formbzb_yxhz.frm

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

        
        ShowXiangMu True
    End If
End Sub

Private Sub cmdExit_Click()
    Unload Me
End Sub

Private Sub cmdExportToExcel_Click()
On Error GoTo ErrMsg
    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 = 11
    
    '获取文件名
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
On Error GoTo ErrMsg
    '查询当前单位选择的科室
    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) = 5 Then '大项
                    If (nodTemp.Parent Is tvwXMu.Nodes(i)) And nodTemp.Checked = True Then
                        blnHave = True
                        ReDim Preserve arrKSMC(l)
                        arrKSMC(l) = tvwXMu.Nodes(i).Text
                    End If
                ElseIf 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 & ")"
    If CreateTable(TempTable, strSQL) = False Then GoTo ExitLab
    
    '添加所有个人信息
    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 SET_XX.XXID='" & strXMID & "'" _
                    & " and SET_DX.DXID='" & Mid(tvwXMu.Nodes(i).Parent.Key, 2) & "'"
        End If
        If strSQL <> "" Then
            Set rsHZ = New ADODB.Recordset
            rsHZ.Open strSQL, GCon, adOpenStatic, adLockOptimistic
            If rsHZ.RecordCount > 0 Then
                If Len(strXMID) = 4 Then
                    strDXPYSX = rsHZ(0)
                    intType = rsHZ(1)
                Else
                    strDXPYSX = rsHZ(0)
                    strXXPYSX = rsHZ(1)
                    intType = rsHZ(2)
                End If
                rsHZ.Close
                
                '***********************************
                '以下构建查询语句的Select部分
                '***********************************
                strSelect = "select distinct SET_GRXX.GUID as 流水号"
                If Len(strXMID) = 4 Then
                    strSelect = strSelect & ",[" & strDXPYSX & "Value]"
                Else
                    strSelect = strSelect & ",[Data_" & strDXPYSX & "].[" & strXXPYSX & "]"
                End If
                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 = 0
End Sub

Private Sub cmdExportToText_Click()
On Error GoTo ErrMsg
    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 = 11
    
    '获取文件名
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
            
            '检查是否有后缀
            If UCase(Right(strFileName, 4)) <> UCase(".txt") Then
                strFileName = strFileName & ".txt"
            End If
        End If
    End With
On Error GoTo ErrMsg
    
    '查询当前单位选择的科室
    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