frmbhtj.frm

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

            End If
        End If
    Next i
    TxtResult.Text = strResult
End Sub

Private Sub cmdQuery_Click()
On Error GoTo ErrMsg
    Dim mintBHCount As Integer          '记录共选中多少病患
    Dim i As Integer
    
    Me.MousePointer = vbHourglass
    
    '年龄是否合理
    If Val(txtDAge.Text) > Val(txtUAge.Text) Then
        MsgBox "年龄下限不能高于上限！", vbInformation, "提示"
        txtDAge.SetFocus
        GoTo ExitLab
    End If
    
    mintBHCount = 0
    For i = 1 To lvwBH.ListItems.Count
        If lvwBH.ListItems(i).Checked = True Then
            mintBHCount = mintBHCount + 1
        End If
    Next i
    If mintBHCount = 0 Then
        '如果没有记录，清空图表控件的显示
        With MSChart1
            .ColumnCount = 1
            .RowCount = 1
'            .RowLabel = "无"
    
            .ShowLegend = False
        End With
        GoTo ExitLab
    End If
    
    '记录查询条件。这个地方的性别记录与实际一致
    If optSMale.Value Then
        mintSex = 1
    ElseIf optSFemale.Value Then
        mintSex = 2
    Else
        mintSex = 0
    End If
    
    '年龄
    mintFromAge = CInt(Val(txtDAge.Text))
    mintToAge = CInt(Val(txtUAge.Text))
    
    '在MsChart1中显示结果
    ShowChart (mintBHCount)
    DoEvents
    
    '在LvwRY中显示人员
    ShowList
    
    GoTo ExitLab
ErrMsg:
    MsgBoxW Err
ExitLab:
    Me.MousePointer = vbDefault
End Sub

Private Sub Form_Load()
    Dim strSQL As String
    Dim rstemp As ADODB.Recordset
    Dim itemX As ListItem
    
    '添加团体
    RefreshTJDW
    OptAll.Value = True
    '添加病患
    OptAll_Click
    
    Me.Width = 11000
    Me.Height = 8000
    
    '设为当天
    dtpStart.Value = Date
    dtpEnd.Value = Date
    
    '显示年龄范围
    updDown_Change
    updUp_Change
End Sub

Private Sub RefreshTJDW()
    Dim strSQL As String
    Dim rstemp As ADODB.Recordset
    Dim i As Integer
    
    strSQL = "select YYID,DWMC" _
            & " 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, adOpenKeyset, adLockOptimistic
    CmbTJDW.Clear
    If rstemp.RecordCount > 0 Then
        CmbTJDW.AddItem "" '首先添加一个空行，便于用户修改
        
        ReDim arrYYID(rstemp.RecordCount)
        
        '添加已经预约过的团体
        rstemp.MoveFirst
        For i = 1 To rstemp.RecordCount
            CmbTJDW.AddItem rstemp("DWMC")
            CmbTJDW.ItemData(CmbTJDW.NewIndex) = i
            arrYYID(i) = rstemp("YYID") 'YYID字段太长，ItemData属性无法存放，只能存入数组
            
            rstemp.MoveNext
        Next
        rstemp.Close
        Set rstemp = Nothing
    End If

End Sub

Private Sub refreshBH(ByVal intType As Integer)
    Dim strSQL As String
    Dim rstemp As ADODB.Recordset
    Dim itemX As ListItem
    
    lvwBH.ListItems.Clear
    
    Set rstemp = New ADODB.Recordset
    strSQL = "select * from DM_ZJJY,SET_KSSZ" _
            & " where DM_ZJJY.KSID=SET_KSSZ.KSID and"
    If intType = 0 Then         '全部病患
        strSQL = strSQL & " (SFJB=1 or SFCJB=1)"
    ElseIf intType = 1 Then     '疾病
        strSQL = strSQL & " SFJB=1"
    ElseIf intType = 2 Then     '常见病
         strSQL = strSQL & " SFCJB=1"
    End If
    '排序
    strSQL = strSQL & " order by SET_KSSZ.SXH,JYMC"
    rstemp.Open strSQL, GCon, adOpenStatic, adLockReadOnly
    If rstemp.RecordCount > 0 Then
        rstemp.MoveFirst
        Do While Not rstemp.EOF
            Set itemX = lvwBH.ListItems.Add(, "W" & rstemp("JYDMID"), rstemp("DMValue"))
            rstemp.MoveNext
        Loop
    End If

End Sub

'在图表中显示汇总结果
Private Sub ShowChart(inIntCount As Integer)
    ReDim arrResult(1 To inIntCount, 1 To 2)
    Dim i, K As Integer
    Dim index1, index2, index3, index4 As Integer
    Dim strTmpHZContent As String
    Dim lngPersonCount As Long
    Dim lngTotal As Long
    Dim strTitle As String
    Dim strResult As String
    
    If CmbTJDW.Text = "" Then
        mstrYYID = ""
        mstrFZID = ""
    Else
        mstrYYID = arrYYID(CmbTJDW.ListIndex)
        If CmbFZ.ListIndex = -1 Then
            mstrFZID = ""
        Else
            mstrFZID = arrFZ(CmbFZ.ListIndex + 1)
        End If
    End If
    
    If CmbTJDW.Text <> "" Then
        strTitle = CmbTJDW.Text & " "
        
        strResult = "单位 " & CmbTJDW.Text & " "
    End If
    strTitle = strTitle & "病患统计结果"
    lngTotal = GetPersonCheckStatus(FINISHED, mstrYYID, _
            CInt(Val(mstrFZID)), dtpStart.Value, dtpEnd.Value & " 23:59:00")
    strResult = strResult & "在 " & CStr(dtpStart.Value) & " 至 " _
            & CStr(dtpEnd.Value) & " " _
            & "已体检 " & CStr(lngTotal) & " 人。"
    
    With MSChart1
        .ChartType = VtChChartType2dBar
        .ColumnCount = inIntCount
        .RowCount = 1
        .RowLabel = "  "
        .Title = strTitle
    End With
    
    K = 1
    For i = 1 To lvwBH.ListItems.Count
        If lvwBH.ListItems(i).Checked = True Then
            arrResult(K, 1) = lvwBH.ListItems(i)
            
            mstrJYDMID = Mid(lvwBH.ListItems(i).Key, 2)
            mstrBHMC = lvwBH.ListItems(i)
            
            strTmpHZContent = GetContent(lngPersonCount, mstrYYID, mstrFZID, mstrJYDMID, _
                    dtpStart.Value, dtpEnd.Value & " 23:59:00", mintSex, mintFromAge, mintToAge)

            arrResult(K, 2) = lngPersonCount
            With MSChart1
                .Row = 1
                .Column = K
                .Plot.SeriesCollection(K).LegendText = mstrBHMC & "(" & lngPersonCount & "人)"
                .Data = arrResult(K, 2)
            End With
            
            If lngPersonCount > 0 Then
                strResult = strResult & vbCrLf & vbCrLf & mstrBHMC & "（共" & lngPersonCount _
                        & "人，占已体检总人数的" & GetRatio(lngPersonCount, lngTotal) & ")" _
                        & "名单：" & vbCrLf & strTmpHZContent
                lngPersonCount = 0
            End If
            
            K = K + 1
        End If
    Next i
    With MSChart1
        MSChart1.ShowLegend = True
        .SelectPart VtChPartTypePlot, index1, index2, _
        index3, index4
        .EditCopy
        .SelectPart VtChPartTypeLegend, index1, _
        index2, index3, index4
        .EditPaste
    End With
    
    TxtResult.Text = strResult
End Sub

'在列表中显示人员
Private Sub ShowList()
    Dim strSQL As String
    Dim rsZJJL As ADODB.Recordset
    Dim i As Integer
    Dim strTmp As String
    Dim itmTemp As ListItem
    
    Me.LvwRY.ListItems.Clear
    
    '构建查询语句
    strSQL = "select DATA_ZJJL.JLValue,SET_GRXX.GUID,SET_GRXX.YYRXM,SET_GRXX.SEX,SET_GRXX.AGE" _
            & " from SET_GRXX,DATA_ZJJL" _
            & " where SET_GRXX.TJRQ between '" & CDate(dtpStart.Value) & "' and '" & CDate(dtpEnd.Value & " 23:59:00") & "'"
    If mstrYYID <> "" Then
        strSQL = strSQL & " and SET_GRXX.YYID='" & mstrYYID & "'"
        If mstrFZID <> "" Then
            strSQL = strSQL & " and SET_GRXX.GUID in(" _
                        & "select GUID from FZ_FZSJ" _
                        & " where YYID='" & mstrYYID & "'" _
                        & " and FZID=" & CInt(Val(mstrFZID)) _
                    & ")"
        End If
    End If
    strSQL = strSQL & " and SET_GRXX.GUID=DATA_ZJJL.GUID"
    
    '性别
    Select Case mintSex
        Case 0
            '
        Case 1
            strSQL = strSQL & " and SET_GRXX.SEX='男'"
        Case 2
            strSQL = strSQL & " and SET_GRXX.SEX='女'"
    End Select
    '年龄
    If mintToAge >= 0 Then
        strSQL = strSQL & " and SET_GRXX.AGE between " & mintFromAge & " and " & mintToAge
    End If
    
    Set rsZJJL = New ADODB.Recordset
    rsZJJL.Open strSQL, GCon, adOpenStatic, adLockReadOnly
    If Not rsZJJL.EOF Then
        Do While Not rsZJJL.EOF
            strTmp = ""
            For i = 1 To lvwBH.ListItems.Count
                If lvwBH.ListItems(i).Checked = True Then
                    If InStr(1, rsZJJL("JLValue"), lvwBH.ListItems(i), vbTextCompare) > 0 Then
                        strTmp = strTmp & lvwBH.ListItems(i) & "，"
                    End If
                End If
            Next i
            '有不正常的项
            If strTmp <> "" Then
                '截掉最后的逗号
                strTmp = Left(strTmp, Len(strTmp) - 1)
                Set itmTemp = LvwRY.ListItems.Add(, "W" & rsZJJL("GUID"), rsZJJL("YYRXM"))
                itmTemp.SubItems(1) = rsZJJL("Sex")
                itmTemp.SubItems(2) = rsZJJL("Age") & ""
                itmTemp.SubItems(3) = CmbTJDW.Text
                itmTemp.SubItems(4) = strTmp
            End If
            
            rsZJJL.MoveNext
        Loop
    End If
End Sub

Private Sub Form_Unload(Cancel As Integer)
    Set FrmBHTJ = Nothing
End Sub

Private Sub LvwRY_ColumnClick(ByVal ColumnHeader As MSComctlLib.ColumnHeader)
    If mintlvPXFC = 1 Then
         mintlvPXFC = 0
         LvwRY.SortOrder = lvwAscending
    Else
        mintlvPXFC = 1
        LvwRY.SortOrder = lvwDescending
    End If
    '单击 ColumnHeader 对象时，将根据
    '那一列的子项目把 ListView 控件排序。
    '设置 SortKey 为 ColumnHeader 的索引值减 1
    LvwRY.SortKey = ColumnHeader.Index - 1
    '设置 Sorted 为 True 以将列表排序。
    LvwRY.Sorted = True

End Sub

'Private Sub MSChart1_DblClick()
'    MSChart1.EditCopy
'End Sub

Private Sub OptAll_Click()
    refreshBH 0
End Sub

Private Sub OptCJB_Click()
    refreshBH 2
End Sub

Private Sub OptJB_Click()
    refreshBH 1
End Sub

Private Sub txtDAge_Change()
On Error Resume Next
    Dim intAge As Integer

    intAge = Int(Val(txtDAge.Text))
    If intAge >= updDown.Min And intAge <= updDown.Max Then
        updDown.Value = intAge
    End If
End Sub

Private Sub txtUAge_Change()
On Error Resume Next
    Dim intAge As Integer

    intAge = Int(Val(txtUAge.Text))
    If intAge >= updUp.Min And intAge <= updUp.Max Then
        updUp.Value = intAge
    End If
End Sub

Private Sub updDown_Change()
    txtDAge.Text = updDown.Value
End Sub

Private Sub updUp_Change()
    txtUAge.Text = updUp.Value
End Sub