frmbhhz.frm

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

Dim mintTotal As Integer
Dim mstrBHMC As String
Dim arrGUID()
Dim intHZCount As Integer

Private Sub cmdExit_Click()
    Unload Me
End Sub

Private Sub cmdExport_Click()
    Dim strFileName As String
    
    If CmbTJDW.Text = "" Then
        MsgBox "请选择体检团体", , "提示"
        Exit Sub
    End If

    With CommonDialog1
        .DialogTitle = "另存为"
        .CancelError = True
        .Flags = cdlOFNNoReadOnlyReturn & cdlOFNOverwritePrompt
        .Filter = "文本文档（*.txt）|*.txt"
        .FileName = CmbTJDW.Text & "_病患汇总导出.txt"
        .ShowSave
        If Err.Number <> 0 Then
            '用户单击了取消
'            Exit Sub
            GoTo ExitLab
        Else
            strFileName = .FileName
            
            '检查是否有后缀
            If UCase(Right(strFileName, 4)) <> UCase(".txt") Then
                strFileName = strFileName & ".txt"
            End If
        End If
    End With
    If TxtResult.Text <> "" Then
        If WriteTextFile(strFileName, TxtResult.Text) Then
            '用记事本打开文件
'            Shell "Notepad.exe " & strFileName, vbNormalFocus
            Shell App.Path & "\wordpad.exe " & Chr(34) & strFileName, vbNormalFocus
        End If
    End If
    
ExitLab:
End Sub

Private Sub BHHZtoTxtBHHZ()
    Dim strSQL As String
    Dim rsTemp As ADODB.Recordset
    Dim rsFZ As ADODB.Recordset
    Dim i As Integer
    Dim strResult As String
    Dim tmpCount As Integer
    Dim strTmpHZContent As String
    Dim strBFB As String
    
    If CmbTJDW.Text = "" Then
        MsgBox "请选择体检团体", , "提示"
        Exit Sub
    End If
    
    '首先查出该团体中已体检的共有多少人
'    tmpCount = 0
'    Set rsTemp = New ADODB.Recordset
'    strSQL = "select * from SET_GRXX where YYID='" & arrYYID(CmbTJDW.ListIndex) & "'" _
'            & " and TJRQ>='" & dtpStart.Value & "' and TJRQ<='" & dtpEnd.Value & "'"
'    rsTemp.Open strSQL, GCon, adOpenStatic, adLockReadOnly
'    If rsTemp.RecordCount > 0 Then
'        rsTemp.MoveFirst
'        Do While Not rsTemp.EOF
            Set rsFZ = New ADODB.Recordset
            strSQL = "select count(*) from FZ_FZSJ where (SFTJ=2 or SFTJ=1) and FZID in" _
                    & " (select FZID from FZ_FZSY where YYID='" & arrYYID(CmbTJDW.ListIndex) & "')" _
                    & " and YYID='" & arrYYID(CmbTJDW.ListIndex) & "'"
            rsFZ.Open strSQL, GCon, adOpenStatic, adLockReadOnly
'            If rsFZ.RecordCount > 0 Then
'                rsFZ.MoveFirst
'                Do While Not rsFZ.EOF
'                    If rsTemp("GUID") = rsFZ("GUID") Then
'                        tmpCount = tmpCount + 1
'                    End If
'                    rsFZ.MoveNext
'                Loop
'            End If
'            rsTemp.MoveNext
'        Loop
'    End If
'    mintTotal = tmpCount
    mintTotal = rsFZ(0)
    
    '查询单位名称
    strSQL = "select SET_DW.*,YY_TJDJ.* from SET_DW,YY_TJDJ where SET_DW.DWID=YY_TJDJ.DWID and YYID='" & arrYYID(CmbTJDW.ListIndex) & "'"
    Set rsTemp = New ADODB.Recordset
    rsTemp.Open strSQL, GCon, adOpenStatic, adLockReadOnly
    strResult = strResult & "单位" & rsTemp("DWMC") & "  在" & dtpStart.Value & " 至" & dtpEnd.Value & " 内已体检 " & mintTotal & " 人" & vbCrLf & vbCrLf
    For i = 1 To lvwBH.ListItems.Count
        '如果该病患列入了统计范围
        If lvwBH.ListItems.Item(i).Checked = True Then
            mstrYYID = arrYYID(CmbTJDW.ListIndex)
            mstrJYDMID = Mid(lvwBH.ListItems(i).Key, 2)
            mstrBHMC = lvwBH.ListItems(i)
            strTmpHZContent = getContent(mstrYYID, mstrJYDMID)
            strBFB = Left(CStr((intHZCount / mintTotal) * 100), 4)
            strResult = strResult & "    " & lvwBH.ListItems(i) & " (共" & intHZCount & "人,占已体检总人数的" & strBFB & "%)  名单:" _
                         & vbCrLf & strTmpHZContent & vbCrLf
        End If
    Next i
    TxtResult.Text = strResult
End Sub

Private Sub cmdQuery_Click()
    Me.MousePointer = 11
    TxtResult.Text = ""
    BHHZtoTxtBHHZ
    Me.MousePointer = 0
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
    
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
    If intType = 0 Then         '全部病患
        strSQL = "select * from DM_ZJJY where SFJB=1 or SFCJB=1"
    ElseIf intType = 1 Then     '疾病
        strSQL = "select * from DM_ZJJY where SFJB=1"
    ElseIf intType = 2 Then     '常见病
         strSQL = "select * from DM_ZJJY where SFCJB=1"
    End If
    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 Function getContent(ByVal inYYID As String, ByVal inJYDMID As String) As String
    Dim rsTemp As ADODB.Recordset
    Dim rsZJJL As ADODB.Recordset
    Dim strSQL As String
    Dim tmpResult As String
    Dim rsTmpGRXX As ADODB.Recordset

    intHZCount = 0
    Set rsTemp = New ADODB.Recordset
    strSQL = "select * from SET_GRXX where YYID='" & inYYID & "'" _
            & " and TJRQ>='" & dtpStart.Value & "' and TJRQ<='" & dtpEnd.Value & "'"
    rsTemp.Open strSQL, GCon, adOpenStatic, adLockReadOnly
    
    If rsTemp.RecordCount > 0 Then
        tmpResult = ""
        Set rsZJJL = New ADODB.Recordset
        strSQL = "select DATA_ZJJL.*,SET_GRXX.* from DATA_ZJJL,SET_GRXX where" _
                & " DATA_ZJJL.GUID=SET_GRXX.GUID" _
                & " and DATA_ZJJL.GUID in (select GUID from FZ_FZSJ where FZID in(select FZID from FZ_FZSY where YYID='" & inYYID & "'))" _
                & " and YYID='" & inYYID & "'"
        rsZJJL.Open strSQL, GCon, adOpenStatic, adLockReadOnly
        '组合人员名单
        If rsZJJL.RecordCount > 0 Then
            mintYes = rsZJJL.RecordCount
            rsZJJL.MoveFirst
            Do While Not rsZJJL.EOF
                If InStr(1, rsZJJL("JLValue"), mstrBHMC, vbTextCompare) > 0 Then
                    tmpResult = tmpResult & rsZJJL("YYRXM") & ","
                    intHZCount = intHZCount + 1
                End If
                rsZJJL.MoveNext
            Loop
            '去掉最后的逗号
            If tmpResult <> "" Then
                tmpResult = Mid(tmpResult, 1, Len(tmpResult) - 1)
            End If
        End If
        
    Else
        tmpResult = ""
    End If
    getContent = tmpResult
End Function

Private Sub Form_Unload(Cancel As Integer)
    Set FrmBHHZ = Nothing
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