frmdwtjbgdc.frm

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

    Erase arrIllPeople
    Erase arrDMValue
    
    If Not (oChart Is Nothing) Then
        oChart.Application.Quit '退出Graph对象
    End If
    Set oChart = Nothing
    Set oShape = Nothing
    Set docTemps = Nothing
    If Not (WordTemps Is Nothing) Then
        WordTemps.Quit '从任务管理器进程列表里面退出Word
    End If
    Set WordTemps = Nothing
    
    Me.MousePointer = vbDefault
End Sub

'获取异常指征、名单、建议等
'参数1：团体编号
'参数2：0表示原始模式：（指征＋名单）＋建议
'       1表示仅有异常指征
'       2表示：（指征＋名单＋建议）
Private Function GetProblem(ByVal strYYID As String, _
        Optional ByVal intFlag As Integer = 0) As String
On Error GoTo ErrMsg
    Dim Status
    Dim strSQL As String
    Dim strTemp As String
    Dim strCondition As String
    Dim strKSMC As String
    Dim rstemp As ADODB.Recordset
    Dim rsHZ As ADODB.Recordset
    Dim intZRS As Integer                       '团体总人数
    Dim intMaleRS, intFemaleRS As Integer       '团体中男性和女性人数
    Dim intYTJRS, intWTJRS As Integer           '已体检人数和未体检人数
    Dim intMaleYTJRS, intFemaleYTJRS As Integer '团体中男性和女性已体检人数
    Dim intNormalRS, intUnnormaleRS As Integer  '团体中完全正常人数和非完全正常人数
    Dim intJBCJBSL As Integer                   '疾病和常见病的数量
    Dim tmpResult()                             '结果数组，存储着每种疾病的名称和人数
    Dim tmpResultName()                         '结果数组，存储着团体中每种疾病患病人姓名名单
    Dim i As Integer
    Dim strTmpResult As String                  '全部疾病名称和患病人员名单的组合串
    Dim strSuggest As String                    '针对该团体存在的疾病的建议的组合串
    Dim strRatio As String                      '比例
    Dim lngPersonCount As Long

    Me.MousePointer = vbHourglass
    
    strTmpResult = ""
    strSuggest = ""

    '查看是否已设置过疾病和常见病
    Set rstemp = New ADODB.Recordset
    strSQL = "select distinct DMValue from DM_ZJJY where SFJB=1 or SFCJB=1"
    rstemp.Open strSQL, GCon, adOpenStatic, adLockReadOnly
    If rstemp.RecordCount = 0 Then
        MsgBox "还未进行疾病和常见病字典的设置，请在体检建议维护中设置", vbInformation, "提示"
        GoTo ExitLab
    End If
    rstemp.Close
    
    '获得该团体总人数
    intZRS = GetDWRS(strYYID)
    If intZRS = 0 Then
        MsgBox "该单位尚未有体检人", vbInformation, "提示"
        GoTo ExitLab
    End If
    DoEvents
    
    '获得该团体男性人数
    strSQL = "select count(*) from FZ_FZSJ,SET_GRXX where" _
            & " SFTJ in (0,1,2)" _
            & " and FZ_FZSJ.GUID=SET_GRXX.GUID" _
            & " and SEX='男'" _
            & " and FZ_FZSJ.YYID='" & strYYID & "'"
    Set rstemp = New ADODB.Recordset
    rstemp.Open strSQL, GCon, adOpenStatic, adLockReadOnly
    intMaleRS = rstemp(0)
    rstemp.Close '关闭记录集
    
    '获得该团体女性人数
    intFemaleRS = intZRS - intMaleRS
    
    '获得该团体已体检人数
    intYTJRS = GetDWYTJRS(strYYID)
    
    '该团体未体检人数
    intWTJRS = intZRS - intYTJRS
    
    '获得该团体男性已体检人数
    strSQL = "select count(*) from FZ_FZSJ,SET_GRXX where" _
            & " (SFTJ=2 or SFTJ=1)" _
            & " and FZ_FZSJ.GUID=SET_GRXX.GUID" _
            & " and SEX='男'" _
            & " and FZ_FZSJ.YYID='" & strYYID & "'"
    Set rstemp = New ADODB.Recordset
    rstemp.Open strSQL, GCon, adOpenStatic, adLockReadOnly
    intMaleYTJRS = rstemp(0)
    rstemp.Close '关闭记录集
    DoEvents
    
    '获得该团体女性已体检人数
    intFemaleYTJRS = intYTJRS - intMaleYTJRS
    
    '获得团体中完全正常的人数
    intNormalRS = GetNormalRS(strYYID, "")
    
    strTmpResult = strTmpResult & "共有 " & intZRS & " 人，其中男性 " _
            & intMaleRS & " 人（" & GetRatio(intMaleRS, intZRS) & "），女性 " _
            & intFemaleRS & " 人（" & GetRatio(intFemaleRS, intZRS) & "）。已体检 " _
            & intYTJRS & " 人（" & GetRatio(intYTJRS, intZRS) & "），其中男性已体检 " _
            & intMaleYTJRS & " 人（" & GetRatio(intMaleYTJRS, intMaleRS) _
            & "），女性已体检 " & intFemaleYTJRS & " 人（" & GetRatio(intFemaleYTJRS, intFemaleRS) _
            & "）。完全正常的有 " & intNormalRS & " 人（" & GetRatio(intNormalRS, intYTJRS) _
            & "），不完全正常的有 " & intYTJRS - intNormalRS & " 人（" _
            & GetRatio(intYTJRS - intNormalRS, intYTJRS) & "）。" & vbCrLf & vbCrLf
    
    '获得疾病和常见病的数量
    intJBCJBSL = GetJBCJBSL("")
    
    '重新定义结果数组
    ReDim tmpResult(1 To intJBCJBSL, 1 To 5)
    
    Set rstemp = New ADODB.Recordset
    strSQL = "select distinct DMValue,JYDMID,JYNR,JYMC,SET_KSSZ.SXH" _
            & " from DM_ZJJY,SET_KSSZ" _
            & " where DM_ZJJY.KSID=SET_KSSZ.KSID" _
            & " order by SET_KSSZ.SXH"
    rstemp.Open strSQL, GCon, adOpenStatic, adLockReadOnly
    '不需进行是否记录数为0的判断，在本过程开始已进行过判断
    '得到统计数据,即每种疾病的患病人数和患病者名单
    rstemp.MoveFirst
    For i = 1 To rstemp.RecordCount
        tmpResult(i, 1) = rstemp("DMValue")
        tmpResult(i, 2) = rstemp("JYMC")
        tmpResult(i, 3) = rstemp("JYNR")
        tmpResult(i, 4) = GetContent(lngPersonCount, strYYID, "", rstemp("JYDMID"), "2000-1-1", Date, 0)
        tmpResult(i, 5) = lngPersonCount
        rstemp.MoveNext
        DoEvents
    Next i
    
    '开始导出
    '将该团体中存在的疾病名称和患病者名单组合后写入strNameList,将该团体存在的疾病的建议的组合串写入strSuggestion
    Select Case intFlag '采用该结构的目的是加快处理速度，虽然代码有一定的冗余
        Case 0 '模式0
            For i = 1 To rstemp.RecordCount
                If tmpResult(i, 5) > 0 Then
                    strTmpResult = strTmpResult & "发现印象 " & tmpResult(i, 1) & " 共有 " _
                            & tmpResult(i, 5) & "人（占已检人数的 " & GetRatio(tmpResult(i, 5), intYTJRS) _
                            & "）, " & "名单如下：" & vbCrLf & tmpResult(i, 4) & vbCrLf
                    strSuggest = strSuggest & tmpResult(i, 2) & vbCrLf & tmpResult(i, 3) & vbCrLf
                End If
            Next i
            GetProblem = strTmpResult & vbCrLf & vbCrLf & strSuggest
        Case 1 '模式1
            For i = 1 To rstemp.RecordCount
                If tmpResult(i, 5) > 0 Then
                    strTmpResult = strTmpResult & "发现印象 " & tmpResult(i, 1) & " 共有 " _
                            & tmpResult(i, 5) & "人（占已检人数的 " & GetRatio(tmpResult(i, 5), intYTJRS) _
                            & "）" & vbCrLf
                End If
            Next i
            GetProblem = strTmpResult
        Case 2 '模式2
            For i = 1 To rstemp.RecordCount
                If tmpResult(i, 5) > 0 Then
                    strTmpResult = strTmpResult & "发现印象 " & tmpResult(i, 1) & " 共有 " _
                            & tmpResult(i, 5) & "人（占已检人数的 " & GetRatio(tmpResult(i, 5), intYTJRS) _
                            & "）, " & "名单如下：" & vbCrLf & tmpResult(i, 4) & vbCrLf _
                            & "建议：" & tmpResult(i, 3) & vbCrLf
                End If
            Next i
            GetProblem = strTmpResult
    End Select
    '释放内存
    Erase tmpResult
    Erase tmpResultName
    
    
    
    GoTo ExitLab

ErrMsg:
    Status = SetError(Err.Number, Err.Description, Err.Source)
    ErrMsg Status
ExitLab:
    Me.MousePointer = vbDefault
End Function

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

    '显示所有预约的团体
    '刷新团体信息
    strSQL = "select YYID,DWMC,TJRQ" _
            & " from YY_TJDJ,SET_DW" _
            & " where YY_TJDJ.DWID=SET_DW.DWID" _
            & " order by YYID desc"
    Set rstemp = New ADODB.Recordset
    rstemp.Open strSQL, GCon, adOpenStatic, adLockReadOnly
    If rstemp.RecordCount > 0 Then
        ReDim arrYYID(1 To rstemp.RecordCount)
                
        '添加已经预约过的团体
        rstemp.MoveFirst
        For i = 1 To rstemp.RecordCount
            Set itmTemp = LvwDWei.ListItems.Add(, HEADER & rstemp("YYID"), rstemp("YYID"))
            itmTemp.Tag = rstemp("YYID")
            itmTemp.SubItems(1) = rstemp("DWMC")
            itmTemp.SubItems(2) = rstemp("TJRQ")
            arrYYID(i) = rstemp("YYID") 'YYID字段太长，ItemData属性无法存放，只能存入数组
            rstemp.MoveNext
        Next
        rstemp.Close
    End If
    If LvwDWei.ListItems.Count > 0 Then
        LvwDWei.ListItems(1).Selected = True '默认选中第一条记录
    End If
    
    '加载所有个人模板
    strSQL = "select MBID,MBMC,MBSM,SFMR from SET_BBMB" _
            & " where MBLX=" & TUANTI
    Set rstemp = New ADODB.Recordset
    rstemp.Open strSQL, GCon, adOpenStatic, adLockOptimistic
    If rstemp.RecordCount >= 1 Then
        rstemp.MoveFirst
        Do
            Set itmTemp = lvwMB.ListItems.Add(, "W" & rstemp("MBID"), rstemp("MBMC"))
            itmTemp.SubItems(1) = rstemp("MBSM")
            '是否默认
            If rstemp("SFMR") = True Then
                Set Me.lvwMB.SelectedItem = itmTemp
            End If
            
            rstemp.MoveNext
        Loop Until rstemp.EOF
        rstemp.Close
        
        '如果没有默认选择，则选择第一个模板
        If lvwMB.SelectedItem Is Nothing Then
            Set Me.lvwMB.SelectedItem = Me.lvwMB.ListItems(1)
        End If
    End If
    
    Call SetCommand
    
    Set rstemp = Nothing
    
    GoTo ExitLab
    
ErrMsg:
    Status = SetError(Err.Number, Err.Description, Err.Source)
    ErrMsg Status
ExitLab:
    Screen.MousePointer = vbDefault
End Sub

'是否启用导出按钮
Private Sub SetCommand()
    If (LvwDWei.SelectedItem Is Nothing) Or (lvwMB.SelectedItem Is Nothing) Then
        cmdExport.Enabled = False
    Else
        cmdExport.Enabled = True
    End If
End Sub

'获得指定健康状况的人数
Private Function GetHealthStatusPersons(ByVal strYYID As String, _
        ByVal intHealthID As Integer) As Long
On Error GoTo ErrMsg
    Dim Status
    Dim strSQL As String
    Dim rstemp As ADODB.Recordset

    strSQL = "select isnull(Count(DATA_HealthStatus.GUID),0) from DATA_HealthStatus" _
            & " where GUID in(" _
                & "select GUID from SET_GRXX" _
                & " where YYID='" & strYYID & "'" _
            & ")" _
            & " and DATA_HealthStatus.HealthStatusID=" & intHealthID
    Set rstemp = New ADODB.Recordset
    rstemp.Open strSQL, GCon, adOpenForwardOnly, adLockReadOnly
    GetHealthStatusPersons = rstemp(0)
    rstemp.Close
    
    GoTo ExitLab
    
ErrMsg:
'    Status = SetError(Err.Number, Err.Description, Err.Source)
'    ErrMsg Status
ExitLab:
    '
End Function