frmdwbhhzdc.frm

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

    '循环所有选择的项目
    intIndex = 0
    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) & "'"
            strXMMC = tvwXMu.Nodes(i).Text
            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 流水号,SET_GRXX.YYRXM 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>='" & "2000-1-1" & "'" _
                        & " and [DATA_" & strDXPYSX & "].TJRQ<='" & Date & "'"
                '加上体检标准的性别判断
                strCondition = strCondition & " and ((SET_GRXX.SEX='男' and SET_TJBZDT.SEX<>2) or (SET_GRXX.SEX='女' and SET_TJBZDT.SEX<>1))"
                
                '***********************************
                '以下根据用户选择决定显示全部还是只显示团检客户
                '***********************************
                '团体总是要包括
                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 lvwDWei.SelectedItem.SubItems(1) <> "" Then
                    '只有选择团体时才加下一判断
                    strTJ = strTJ & " and FZ_FZSJ.YYID='" & strYYID & "'"
                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
                
                intIndex = intIndex + 1
                strSummary = strSummary & intIndex & "、" & strXMMC & vbCrLf & "    "
                strSuggest = strSuggest & intIndex & "、" & strXMMC & vbCrLf & "    "
                strTempSuggest = ""
                If rsHZ.RecordCount < 1 Then
                    '全部体检通过
                    strSummary = strSummary & "（无）"
                    strSuggest = strSuggest & "（全体通过）"
                Else
                    '**************************************************
                    '有客户未通过体检
                    '**************************************************
                    intUnnormalCount = 0
                    rsHZ.MoveFirst
                    '循环每个取出的记录集
                    blnHave = False
                    Do
                        If Trim(rsHZ("抽查结果")) <> "" Then
                            blnHave = True
                            intUnnormalCount = intUnnormalCount + 1
                            If intType = 1 Then
                                '数值型
                                strSummary = strSummary & rsHZ("姓名")
                                
                                If Val(rsHZ("抽查结果")) < Val(rsHZ("CKXX")) Then
                                    strJYMC = strXMMC & "偏低"
                                Else
                                    strJYMC = strXMMC & "偏高"
                                End If
                            Else
                                '说明型
                                strSummary = strSummary & rsHZ("姓名")
                                
                                '判断是否阴阳型
                                If rsHZ("抽查结果") = "阳性" Then
                                    strJYMC = strXMMC & "阳性"
                                Else
                                    strJYMC = rsHZ("抽查结果")
                                End If
                            End If
                            strSQL = "select JYNR from DM_ZJJY" _
                                    & " where JYMC='" & strJYMC & "'"
                            
                            '姓名后面跟一个逗号
                            strSummary = strSummary & "，"
                            
                            '检查是否有建议
                            Set rsTemp = New ADODB.Recordset
                            rsTemp.Open strSQL, GCon, adOpenStatic, adLockOptimistic
                            If rsTemp.RecordCount > 0 Then
                                If Not IsNull(rsTemp(0)) Then
                                    If InStr(1, strTempSuggest, rsTemp(0)) < 1 Then
                                        strTempSuggest = strTempSuggest & strJYMC & "：" & rsTemp(0) & vbCrLf
                                    End If
                                End If
                            End If
                        End If
                        
                        rsHZ.MoveNext
                    Loop Until rsHZ.EOF

                    rsHZ.Close
                    If blnHave = True Then
                        '截掉最后一个逗号
                        strSummary = Left(strSummary, Len(strSummary) - 1)
                        strSuggest = strSuggest & "本次体检“" & strXMMC & "”不正常者共 " _
                                & intUnnormalCount & " 人，占单位体检人数的" _
                                & Format(intUnnormalCount * 100 / intCount, "##.#") & "%。" _
                                & vbCrLf _
                                & "建议：" _
                                & vbCrLf & "    "
                    End If
                    
                    If strTempSuggest <> "" Then
                        strSuggest = strSuggest & strTempSuggest
                    End If
                End If
                
                '每个项目后面跟一个回车换行
                strSummary = strSummary & vbCrLf
                strSuggest = strSuggest & vbCrLf
                
                '不要让系统呈现死机状态
                DoEvents
            End If
        End If
    Next i
    
    '判断是否有记录
    If strSummary = "" Then
        MsgBox "没有记录！", vbInformation, "提示"
        GoTo ExitLab
    End If
    
    '最后写入文件
    If WriteTextFile(strFileName, strSummary & vbCrLf & strSuggest) Then
        '用记事本打开文件
'        Shell "Notepad.exe " & strFileName, vbNormalFocus
        Call Shell(gstrCurrPath & "wordpad.exe " & Chr(34) & strFileName, vbNormalFocus)
    End If
    
    GoTo ExitLab
    
ErrMsg:
    Status = SetError(Err.Number, Err.Description, Err.Source)
    ErrMsg Status
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 = vbArrowHourglass
    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
        ShowXiangMu False, lvwDWei.SelectedItem.Text
        
        CmdOK.Enabled = True
    Else
        CmdOK.Enabled = False
    End If
    GoTo ExitLab
    
ErrMsg:
    Status = SetError(Err.Number, Err.Description, Err.Source)
    ErrMsg Status
ExitLab:
    Screen.MousePointer = vbDefault
End Sub

'显示所有项目（对团检和散检），部分项目（对团检）
Private Sub ShowXiangMu(ByVal blnAll As Boolean, Optional ByVal strYYID As String)
On Error GoTo ErrMsg
    Dim Status
    Dim strSQL As String
    Dim nodTemp As Node
    Dim nodRoot As MSComctlLib.Node
    Dim rsKShi As ADODB.Recordset
    Dim rsDX As ADODB.Recordset
    Dim rsXX As ADODB.Recordset
    Dim i As Integer
    
    Me.MousePointer = vbHourglass