formyxhz.frm

本系统可用于医院和专业体检中心的健康体检管理

End
Attribute VB_Name = "FormYXHZ"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Dim arrYYID() As String '团体的预约ID数组

Private Sub cmbDWei_Click()
    If cmbDWei.Text <> "" Then
        ShowXiangMu False, arrYYID(cmbDWei.ItemData(cmbDWei.ListIndex))
        
        cmdExportToExcel.Enabled = True
        cmdExportToText.Enabled = True
        cmdExportToExcelNew.Enabled = True
    Else
        ShowXiangMu True
        
        cmdExportToExcel.Enabled = False
        cmdExportToText.Enabled = False
        cmdExportToExcelNew.Enabled = False
    End If
End Sub

Private Sub cmdExit_Click()
    Unload Me
End Sub

'注：该按钮已经不再使用
Private Sub cmdExportToExcel_Click()

'    Dim Status
'    Dim strSQL As String
'    Dim strTemp As String
'    Dim strSelect As String
'    Dim strTJ As String
'    Dim strCondition As String
'    Dim strKSMC As String
'    Dim rsTemp As ADODB.Recordset
'    Dim rsHZ As ADODB.Recordset
'    Dim nodTemp As Node
'
'    Dim strDXPYSX As String
'    Dim strXXPYSX As String
'    Dim intType As Integer
'    Dim strXMID As String
'    Dim strFileName As String
'    Dim i As Integer, j As Integer, l As Integer
'    Dim arrKSMC() As String
'    Dim blnHave As Boolean
'    Dim blnSel As Boolean
'
'    Me.MousePointer = vbHourglass
'
'    '获取文件名
'On Error Resume Next
'    With CommonDialog1
'        .DialogTitle = "另存为"
'        .CancelError = True
'        .Flags = cdlOFNNoReadOnlyReturn & cdlOFNOverwritePrompt
'        .Filter = "Microsoft Excel 工作簿（*.xls）|*.xls"
'        .FileName = "Book1.xls"
'        .ShowSave
'        If Err.Number <> 0 Then
'            '用户单击了取消
'            GoTo ExitLab
'        Else
'            strFileName = .FileName
'
'            '检查是否有后缀
'            If UCase(Right(strFileName, 4)) <> UCase(".xls") Then
'                strFileName = strFileName & ".xls"
'            End If
'        End If
'    End With

'    '查询当前单位选择的科室
'    blnSel = False
'    l = 0
'    For i = 1 To tvwXMu.Nodes.Count
'        If Len(tvwXMu.Nodes(i).Key) = 3 Then '科室
'            blnHave = False
'            For j = 1 To tvwXMu.Nodes.Count
'                Set nodTemp = tvwXMu.Nodes(j)
'                If Len(nodTemp.Key) = 12 Then '小项
'                    If (nodTemp.Parent.Parent Is tvwXMu.Nodes(i)) And nodTemp.Checked = True Then
'                        blnHave = True
'                        ReDim Preserve arrKSMC(l)
'                        arrKSMC(l) = tvwXMu.Nodes(i).Text
'                    End If
'                End If
'                If blnHave = True Then
'                    l = l + 1
'
'                    blnSel = True
'                    Exit For '跳出第一层循环
'                End If
'            Next j
'        End If
'    Next i
'    If blnSel = False Then
'        MsgBox "请选择要汇总的项目！", vbInformation, "提示"
'        GoTo ExitLab '没有选择科室
'    End If
'
'    '创建临时表
'    strSQL = "CREATE TABLE " & TempTable _
'            & " (GUID bigint primary key,档案号 Varchar(13),姓名 Varchar(20),性别 Varchar(2),年龄 Varchar(5)"
'    For i = LBound(arrKSMC) To UBound(arrKSMC)
'        strSQL = strSQL & "," & arrKSMC(i) & " Varchar(2000)"
'    Next
'    strSQL = strSQL & ")"
'    Call CreateTable(TempTable, True, strSQL)
'
'    '添加所有个人信息
'    strSQL = "insert into " & TempTable _
'            & "(GUID,档案号,姓名,性别,年龄)" _
'            & " select GUID,HealthID,YYRXM,SEX,AGE from SET_GRXX" _
'            & " where YYID='" & arrYYID(cmbDWei.ItemData(cmbDWei.ListIndex)) & "'"
'    GCon.Execute strSQL
'
'    '循环所有选择的项目
'    For i = 1 To tvwXMu.Nodes.Count
'        strXMID = Mid(tvwXMu.Nodes(i).Key, 2)
'
'        strSQL = ""
'        If (Len(strXMID) = 11) And (tvwXMu.Nodes(i).Checked = True) Then '选择了小项
'            strXMID = Right(strXMID, 7)
'            strSQL = "select DXPYSX,XXPYSX,XXType from SET_XX,SET_DX" _
'                    & " where XXID='" & strXMID & "'" _
'                    & " and SET_DX.DXID='" & Mid(tvwXMu.Nodes(i).Parent.Key, 2) & "'"
'            Set rsHZ = New ADODB.Recordset
'            rsHZ.Open strSQL, GCon, adOpenStatic, adLockOptimistic
'            If rsHZ.RecordCount > 0 Then
'                strDXPYSX = rsHZ(0)
'                strXXPYSX = rsHZ(1)
'                intType = rsHZ(2)
'                rsHZ.Close
'
'                '***********************************
'                '以下构建查询语句的Select部分
'                '***********************************
'                strSelect = "select distinct SET_GRXX.GUID as 流水号"
'                strSelect = strSelect & ",[Data_" & strDXPYSX & "].[" & strXXPYSX & "]"
'                strSelect = strSelect & " as [抽查结果]"
'                strSelect = strSelect & ",DW,CKXX,CKSX"
''                strSelect = strSelect & ",NormalVal as 标准值"
'
'                '***********************************
'                '以下构建用户的查询条件
'                '***********************************
'                If intType = 1 Then
'                    '数值型
'                    '小项
'                    strCondition = " and (cast([Data_" & strDXPYSX & "].[" & strXXPYSX & "] as float)<cast(CKXX as float)" _
'                            & " or cast([Data_" & strDXPYSX & "].[" & strXXPYSX & "] as float)>cast(CKSX as float))"
'                Else
'                    '非数值型
'                    '小项
'                    strCondition = " and [Data_" & strDXPYSX & "].[" & strXXPYSX & "]<>NormalVal"
'                End If
'                '设置性别
'                If optMale.Value = True Then
'                    strCondition = strCondition & " and SET_GRXX.SEX='男'"
'                End If
'                If optFemale.Value = True Then
'                    strCondition = strCondition & " and SET_GRXX.SEX='女'"
'                End If
'                '体检日期
'                strCondition = strCondition & " and [DATA_" & strDXPYSX & "].TJRQ>='" & dtpBegin.Value & "'" _
'                        & " and [DATA_" & strDXPYSX & "].TJRQ<='" & dtpStop.Value & " 23:59:59'"
'
'
'                '***********************************
'                '以下根据用户选择决定显示全部还是只显示团检客户
'                '***********************************
'                '团体总是要包括
'                strTJ = " from SET_GRXX,FZ_FZSJ,FZ_FZSY,SET_TJBZDT,[Data_" & strDXPYSX & "]" _
'                        & " where not (SET_GRXX.YYID is null)" _
'                        & " and SET_GRXX.YYID=FZ_FZSJ.YYID" _
'                        & " and SET_GRXX.GUID=FZ_FZSJ.GUID"
'                If cmbDWei.Text <> "" Then
'                    '只有选择团体时才加下一判断
'                    strTJ = strTJ & " and FZ_FZSJ.YYID='" & arrYYID(cmbDWei.ItemData(cmbDWei.ListIndex)) & "'"
'                End If
'                strTJ = strTJ & " and FZ_FZSJ.FZID=FZ_FZSY.FZID" _
'                        & " and FZ_FZSY.BZID=SET_TJBZDT.BZID" _
'                        & " and SET_TJBZDT.XMID='" & strXMID & "'" _
'                        & " and [Data_" & strDXPYSX & "].GUID=SET_GRXX.GUID"
'
'                '***********************************
'                '构建最后的查询语句
'                '***********************************
'                strSQL = strSelect & strTJ & strCondition
'
'                '***********************************
'                '执行查询
'                '***********************************
'                Set rsHZ = New ADODB.Recordset
'                rsHZ.Open strSQL, GCon, adOpenStatic, adLockOptimistic
'                If rsHZ.RecordCount >= 1 Then
'                    '检查当前属于哪个科室
'                    strKSMC = tvwXMu.Nodes(i).Parent.Parent.Text
'
'                    rsHZ.MoveFirst
'                    '循环每个取出的记录集
'                    Do
'                        If Trim(rsHZ("抽查结果")) <> "" Then
'                            strSQL = tvwXMu.Nodes(i).Text & "：" & rsHZ("抽查结果")
'                            If intType = 1 Then
'                                '数值型
'                                strSQL = strSQL & rsHZ("DW")
'                                If Val(rsHZ("抽查结果")) < Val(rsHZ("CKXX")) Then
'                                    strSQL = strSQL & "，偏低"
'                                Else
'                                    strSQL = strSQL & "，偏高"
'                                End If
'                            Else
'                                '说明型
'                                '
'                            End If
'
'                            strTemp = "select " & strKSMC & " from " & TempTable _
'                                    & " where GUID=" & rsHZ("流水号")
'                            Set rsTemp = New ADODB.Recordset
'                            rsTemp.Open strTemp, GCon, adOpenStatic, adLockReadOnly
'                            If IsNull(rsTemp(0)) Then
'                                strTemp = strSQL
'
'                                strTemp = "update " & TempTable & " set " _
'                                        & strKSMC & "='" & strTemp & "'" _
'                                        & " where GUID=" & rsHZ("流水号")
'                            Else
'                                strTemp = "；" & strSQL
'
'                                strTemp = "update " & TempTable & " set " _
'                                        & strKSMC & "=" & strKSMC & "+'" & strTemp & "'" _
'                                        & " where GUID=" & rsHZ("流水号")
'                                rsTemp.Close
'                            End If
'                            GCon.Execute strTemp
'                        End If
'
'                        rsHZ.MoveNext
'                    Loop Until rsHZ.EOF
'
'                    rsHZ.Close
'                End If
'
'            End If
'        End If
'    Next i
'
'    strSQL = "select 档案号,姓名,性别,年龄"
'    For i = LBound(arrKSMC) To UBound(arrKSMC)
'        strSQL = strSQL & "," & arrKSMC(i)
'    Next
'    strSQL = strSQL & " from " & TempTable
'
'    ExportToExcel strSQL, strFileName, cmbDWei.Text
'
'    GoTo ExitLab
'
'ErrMsg:
'    Status = SetError(Err.Number, Err.Description, Err.Source)
'    ErrMsg Status
'ExitLab:
'    Me.MousePointer = vbDefault
End Sub

Private Sub cmdExportToExcelNew_Click()
On Error GoTo ErrMsg
    Dim Status
    Dim strSQL As String
    Dim strYYID As String
    Dim dtmBegin As Date
    Dim dtmStop As Date
    Dim strFileName As String
    Dim strTempTable As String
    
    Me.MousePointer = vbHourglass
    
    '获取起止时间
    dtmBegin = dtpBegin.Value
    dtmStop = dtpStop.Value & " 23:59:00"
    
    '获取文件名
    strFileName = GetFileName(Me.CommonDialog1, "Microsoft Excel 工作簿（*.xls）|*.xls", _
            "另存为", "阳性汇总_" & cmbDWei.Text & ".xls", WRITEFILE)
    If strFileName = "" Then GoTo ExitLab
    
    strYYID = arrYYID(cmbDWei.ItemData(cmbDWei.ListIndex))
    strTempTable = GetYXHZTableOfTT(strYYID)
    If strTempTable = "" Then GoTo ExitLab
    
    '生成Excel文件
    strSQL = "select 项目,名单,人数,[百分比%],提示" _
            & " from " & strTempTable _
            & " order by GUID"
    ExportToExcel strSQL, strFileName, cmbDWei.Text, "阳性汇总名单", "24,30,5.1,8.3,12", 1, 2, 1, 2
    
    GoTo ExitLab
    
ErrMsg:
    Status = SetError(Err.Number, Err.Description, Err.Source)
    ErrMsg Status
ExitLab:
    Me.MousePointer = vbDefault
End Sub

'注：该按钮已经不再使用
Private Sub cmdExportToText_Click()

'    Dim Status
'    Dim strSQL As String
'    Dim strTemp As String
'    Dim strSelect As String
'    Dim strTJ As String
'    Dim strCondition As String
'    Dim strKSMC As String
'    Dim rsTemp As ADODB.Recordset
'    Dim rsHZ As ADODB.Recordset
'    Dim nodTemp As Node
'    Dim strYYID As String
'    Dim intCount As Integer '当前选择单位的总人数
'    Dim strSummary As String '体检综述
'    Dim strSuggest As String '体检建议
'    Dim strTempSuggest As String '某各项目里面的建议
'    Dim strJYMC As String  '要查询的症状
'    Dim intIndex As Integer '当前处理项目的序号
'    Dim f As Integer '文件号
'
'    Dim strDXPYSX As String
'    Dim strXXPYSX As String
'    Dim intType As Integer
'    Dim strXMID As String
'    Dim strXMMC As String '当前处理项目的名称
'    Dim strFileName As String
'    Dim i As Integer, j As Integer, l As Integer
'    Dim arrKSMC() As String
'    Dim blnHave As Boolean
'    Dim blnSel As Boolean
'
'    Me.MousePointer = vbHourglass
'
'    '获取文件名
'On Error Resume Next
'    With CommonDialog1
'        .DialogTitle = "另存为"
'        .CancelError = True
'        .Flags = cdlOFNNoReadOnlyReturn & cdlOFNOverwritePrompt
'        .Filter = "文本文档（*.txt）|*.txt"
'        .FileName = "*.txt"
'        .ShowSave
'        If Err.Number <> 0 Then
'            '用户单击了取消
'            GoTo ExitLab
'        Else
'            strFileName = .FileName
'
'            '检查是否有后缀