frmdwyxhzdc.frm

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

    Dim strUnnormal As String
    Dim strColTitle As String
    Dim lngGUID As Long
    
    '获取文件名
    strFileName = GetFileName(Me.CommonDialog1, "Microsoft Excel 工作簿（*.xls）|*.xls", "另存为", _
            lvwDWei.SelectedItem.SubItems(1) & " 阳性汇总导出.xls", WRITEFILE)
    If strFileName = "" Then GoTo ExitLab
    
    Me.MousePointer = vbHourglass
    
    '记录是否以科室模式
    blnKShi = optKShi.Value
    
    '查询当前单位选择的科室
    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
                        
                        If Not blnKShi Then
                            '按项目导出时的列名
                            ReDim Preserve arrXXTitle(intXXIndex)
                            arrXXTitle(intXXIndex) = nodTemp.Parent.Parent.Text & "_" _
                                    & nodTemp.Parent.Text & "_" _
                                    & nodTemp.Text
                        Else
                            '科室名称
                            ReDim Preserve arrKSMC_XX(intXXIndex)
                            arrKSMC_XX(intXXIndex) = nodTemp.Parent.Parent.Text
                        End If
                        
                        '小项ID
                        ReDim Preserve arrXXID(intXXIndex)
                        arrXXID(intXXIndex) = Right(nodTemp.Key, 7)
                        '检索当前小项的信息
                        strSQL = "select XXID,XXMC,XXPYSX,XXType from SET_XX" _
                                & " where XXID='" & arrXXID(intXXIndex) & "'"
                        Set rstemp = New ADODB.Recordset
                        rstemp.Open strSQL, GCon, adOpenForwardOnly, adLockReadOnly
                        '小项名称
                        ReDim Preserve arrXXMC(intXXIndex)
                        arrXXMC(intXXIndex) = nodTemp.Text
                        '小项拼音缩写
                        ReDim Preserve arrXXPYSX(intXXIndex)
                        arrXXPYSX(intXXIndex) = rstemp("XXPYSX")
                        '小项类型
                        ReDim Preserve arrXXType(intXXIndex)
                        arrXXType(intXXIndex) = rstemp("XXType")
                        rstemp.Close
                        
                        '获取当前大项的拼音缩写
                        strSQL = "select DXPYSX from SET_DX" _
                                & " where SET_DX.DXID='" & Mid(nodTemp.Parent.Key, 2) & "'"
                        Set rstemp = New ADODB.Recordset
                        rstemp.Open strSQL, GCon, adOpenForwardOnly, adLockReadOnly
                        ReDim Preserve arrDXPYSX(intXXIndex)
                        arrDXPYSX(intXXIndex) = rstemp("DXPYSX")
                        rstemp.Close
                        
                        intXXIndex = intXXIndex + 1
                    End If
                End If
                
            Next j
            
            '当前科室是否有选择
            If blnHave Then
                blnSel = True
                
                ReDim Preserve arrKSMC(l)
                arrKSMC(l) = tvwXMu.Nodes(i).Text
                l = l + 1
            End If
        End If
    Next i
    
    blnExportZJJL = IIf(ChkDCZJJL.Value = vbChecked, True, False)
    blnExportZJJY = IIf(ChkDCZJJY.Value = vbChecked, True, False)
    If (Not blnSel) And (Not blnExportZJJL) And (Not blnExportZJJY) Then
        MsgBox "请选择要汇总的项目！", vbInformation, "提示"
        GoTo ExitLab '没有选择科室
    End If
    DoEvents
    
    '生成临时表的sql语句
    strSQL = "CREATE TABLE " & TempTable _
            & " ([GUID] bigint primary key,档案号 Varchar(20),姓名 Varchar(20),性别 Varchar(2),年龄 Varchar(5)"
    If blnSel = True Then
        If blnKShi Then
            '按科室方式
            For i = LBound(arrKSMC) To UBound(arrKSMC)
                strSQL = strSQL & ",[" & arrKSMC(i) & "] Varchar(4000)"
            Next
        Else
            '按项目方式
            For i = LBound(arrXXTitle) To UBound(arrXXTitle)
                strSQL = strSQL & ",[" & arrXXTitle(i) & "] Varchar(200)"
            Next
        End If
    End If
    
    '如果导出总检结论
    If blnExportZJJL Then
        strSQL = strSQL & "," & "总检结论" & " Varchar(4000)"
    End If
    '如果导出总检建议
    If blnExportZJJY Then
        strSQL = strSQL & "," & "总检建议" & " Varchar(4000)"
    End If
    strSQL = strSQL & ")"
    '创建临时表
    If CreateTable(TempTable, True, strSQL) = False Then GoTo ExitLab
    
    strYYID = lvwDWei.SelectedItem.Text
    '添加所有个人信息
    strSQL = "insert into " & TempTable _
            & "(GUID,档案号,姓名,性别,年龄)" _
            & " select GUID,"
    If Not g_blnSelfID Then
        strSQL = strSQL & "HealthID"
    Else
        strSQL = strSQL & "SelfBH"
    End If
    strSQL = strSQL & ",YYRXM,SEX,AGE from SET_GRXX" _
            & " where YYID='" & strYYID & "'"
    GCon.Execute strSQL
    
    '循环每个人
    If blnSel Then
        strSQL = "select GUID from SET_GRXX" _
                & " where YYID='" & strYYID & "'"
        Set rsPerson = New ADODB.Recordset
        rsPerson.Open strSQL, GCon, adOpenStatic, adLockReadOnly
        If rsPerson.EOF Then GoTo ExitLab
    
        For i = 1 To rsPerson.RecordCount
            lngGUID = rsPerson("GUID")
            '循环所选择的每个项目
            '在没有选择任何项目的时候，运行下一条语句会报错（下表越界）
            '所以在前面进入循环之前加了判断
            strOldColumn = ""
            For intXXIndex = LBound(arrXXID) To UBound(arrXXID)
                strUnnormal = GetUnnormalResult(lngGUID, arrDXPYSX(intXXIndex), _
                        arrXXID(intXXIndex), arrXXPYSX(intXXIndex), arrXXMC(intXXIndex), _
                        arrXXType(intXXIndex), blnKShi)
                If strUnnormal <> "" Then
                    If blnKShi Then
                        '按科室方式
                        strColTitle = arrKSMC_XX(intXXIndex)
                        If strOldColumn <> strColTitle Then
                            strOldColumn = strColTitle '记录旧列名
                            strSQL = "update " & TempTable & " set" _
                                & " [" & strColTitle & "]=" & "'" & strUnnormal & "'" _
                                & " where GUID=" & lngGUID
                        Else
                            strSQL = "update " & TempTable & " set" _
                                & " [" & strColTitle & "]=[" & strColTitle & "]+'" _
                                & vbCrLf & strUnnormal & vbCrLf & "'" _
                                & " where GUID=" & lngGUID
                        End If
                    Else
                        strColTitle = arrXXTitle(intXXIndex)
                        '按项目方式
                        strSQL = "update " & TempTable & " set" _
                                & " [" & strColTitle & "]=" & "'" & strUnnormal & "'" _
                                & " where GUID=" & lngGUID
                    End If
                    
                    '写入临时表
                    GCon.Execute strSQL
                    
                End If
            Next intXXIndex
            If i Mod 5 = 0 Then
                '没处理5个人刷新一次
                DoEvents
            End If
            
            rsPerson.MoveNext
        Next i
    End If
    
    GoSub InsertJLJY '写入总检建议和结论
    
    strSQL = "select 档案号,姓名,性别,年龄"
    If blnSel = True Then
        If blnKShi Then
            For i = LBound(arrKSMC) To UBound(arrKSMC)
                strSQL = strSQL & ",[" & arrKSMC(i) & "]"
            Next
        Else
            For i = LBound(arrXXTitle) To UBound(arrXXTitle)
                strSQL = strSQL & ",[" & arrXXTitle(i) & "] as [" & arrXXMC(i) & "]"
            Next i
        End If
    End If
    If blnExportZJJL Then
        strSQL = strSQL & ",总检结论"
    End If
    If blnExportZJJY Then
        strSQL = strSQL & ",总检建议"
    End If
    strSQL = strSQL & " from " & TempTable
    
    ExportToExcel strSQL, strFileName, lvwDWei.SelectedItem.SubItems(1)
    
    GoTo ExitLab
    
InsertJLJY:
    '导出总检结论
    If blnExportZJJL Then
        strTemp = "update " & TempTable & " set " _
                & TempTable & ".总检结论=DATA_ZJJL.JLValue" _
                & " from " & TempTable & ",DATA_ZJJL" _
                & " where " & TempTable & ".GUID=DATA_ZJJL.GUID"
        GCon.Execute strTemp
    End If
    '导出总检建议
    If blnExportZJJY Then
        strTemp = "update " & TempTable & " set " _
                & TempTable & ".总检建议=DATA_ZJJY.JYValue" _
                & " from " & TempTable & ",DATA_ZJJY" _
                & " where " & TempTable & ".GUID=DATA_ZJJY.GUID"
        GCon.Execute strTemp
    End If
    Return
    
ErrMsg:
    Status = SetError(Err.Number, Err.Description, Err.Source)
    ErrMsg Status
'    If Err.Number = VARCHAR_TO_FLOAT_ERROR Then
''        GoTo ErrorResume
'    End If
    Resume Next
ExitLab:
    Me.MousePointer = vbDefault
End Sub

Private Sub Form_Load()
On Error GoTo ErrMsg
    Dim Status
    Dim strSQL As String
    Dim rstemp As ADODB.Recordset
    Dim i As Integer
    Dim itmTemp As ListItem
    
    Screen.MousePointer = vbHourglass
    Me.Top = 2000
    Me.Left = 2000
    '选中项目树中所有节点
    SelectNodeAll
    
    lvwDWei.View = lvwReport
    lvwDWei.FullRowSelect = True
    lvwDWei.LabelEdit = lvwManual

    '显示所有预约的团体
    '刷新团体信息
'    strSQL = "select YYID,DWMC,TJRQ" _
'            & " from YY_TJDJ,SET_DW" _
'            & " where YY_TJDJ.DWID=SET_DW.DWID" _
'            & " and SFTJ=2" _
'            & " order by JLRQ desc"
    strSQL = "select YYID,DWMC,TJRQ" _
            & " from YY_TJDJ,SET_DW" _
            & " where YY_TJDJ.DWID=SET_DW.DWID" _
            & " order by JLRQ desc"

    Set rstemp = New ADODB.Recordset
    rstemp.Open strSQL, GCon, adOpenStatic, adLockReadOnly
    If rstemp.RecordCount > 0 Then
        ReDim arrYYID(rstemp.RecordCount)
                
        '添加已经预约过的团体
        rstemp.MoveFirst
        For i = 1 To rstemp.RecordCount
            Set itmTemp = lvwDWei.ListItems.Add(, , rstemp("YYID"))
            itmTemp.SubItems(1) = rstemp("DWMC")
            itmTemp.SubItems(2) = rstemp("TJRQ")
            arrYYID(i) = rstemp("YYID") 'YYID字段太长，ItemData属性无法存放，只能存入数组
            rstemp.MoveNext
        Next
        rstemp.Close
        Set rstemp = Nothing
    End If
    If lvwDWei.ListItems.Count > 0 Then
        lvwDWei.ListItems(1).Selected = True