module1.bas

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

    '根据性别查该人应该记录的大项是否已记录
    strSQL = "select DXID,DXMC from SET_DX" _
        & " where  DXNNTY<>" & intSex
    strSQL = strSQL & " and DXID in (select DXID from YY_SJDJDX" _
            & " where GUID=" & inGUID & ")"
    
    Set rstemp = New ADODB.Recordset
    rstemp.Open strSQL, GCon, adOpenStatic, adLockReadOnly
    If rstemp.RecordCount > 0 Then
        rstemp.MoveFirst
        Do While Not rstemp.EOF
            If CheckDXSFTJ(inGUID, rstemp("DXID")) = False Then
                CheckGUIDTJFinish = False
                Exit Function
            End If
            rstemp.MoveNext
        Loop
    End If
    
End Function

'**********************************************************************
'根据当前的过滤设置，返回过滤后的字符串
'参数1：被过滤的字符串
'返回值：过滤后的字符串
'**********************************************************************
Public Function GetFilterString(ByVal strFiltered As String) As String
    '过滤“未见异常”
    If GFilterSet.WJYC_FILTER Then
        If InStr(1, strFiltered, GFilterString.WJYC_FILTER) >= 1 Then
            strFiltered = ""
            GoTo ExitLab
        End If
    End If
    
    '过滤“未见明显异常”
    If GFilterSet.WJMXYC_FILTER Then
        If InStr(1, strFiltered, GFilterString.WJMXYC_FILTER) >= 1 Then
            strFiltered = ""
            GoTo ExitLab
        End If
    End If
    
    '过滤“正常”
    If GFilterSet.ZC_FILTER Then
        If InStr(1, strFiltered, GFilterString.ZC_FILTER) >= 1 Then
            strFiltered = ""
        End If
    End If
    
    '过滤空值
    If GFilterSet.NULL_FILTER Then
'        strFiltered = ""
    End If
    
ExitLab:
    GetFilterString = strFiltered
End Function

'根据某人（GUID）各科室的科室小结形成总检结论
Public Function MakeZJJL(strGUID As String) As String
On Error GoTo ErrMsg
    Dim Status
    Dim strSQL As String
    Dim rstemp As ADODB.Recordset
    Dim strZJJL As String
    Dim strTmpZJJL As String
    Dim rsKSXJ As ADODB.Recordset
    Dim lngGUID As Long
    Dim intCount As Integer
    
    Screen.MousePointer = vbArrowHourglass
    lngGUID = CLng(Val(strGUID))
    If lngGUID < 1 Then GoTo ExitLab
    strTmpZJJL = ""
    
    '找出当前客户有选择项目的科室
    Set rstemp = New ADODB.Recordset
    strSQL = "select KSID,KSMC from SET_KSSZ" _
            & " where KSID in(" _
                & "select left(DXID,2) from YY_SJDJDX" _
                & " where GUID=" & lngGUID _
            & ")" _
            & " order by SXH"
    rstemp.Open strSQL, GCon, adOpenStatic, adLockReadOnly
    If Not rstemp.EOF Then
        intCount = 1
        rstemp.MoveFirst
        Do While Not rstemp.EOF
            strTmpZJJL = "" '清空临时变量
            
            '找出该人在某一科室中的小结
            Set rsKSXJ = New ADODB.Recordset
            strSQL = "select XJValue from DATA_KSXJ" _
                    & " where GUID=" & lngGUID _
                    & " and KSID='" & rstemp("KSID") & "'"
            rsKSXJ.Open strSQL, GCon, adLockReadOnly, adLockReadOnly
            If Not rsKSXJ.EOF Then
                strTmpZJJL = rsKSXJ("XJValue") & ""
                strTmpZJJL = GetFilterString(strTmpZJJL)
                
                rsKSXJ.Close
            End If
            
            If strTmpZJJL <> "" Then
                If intCount > 1 Then
                    '不是第一个科室
                    strZJJL = strZJJL & vbCrLf
                End If
                strZJJL = strZJJL & CStr(intCount) & "   " & rstemp("KSMC") & "：" & strTmpZJJL
                
                intCount = intCount + 1
            End If
                
            rstemp.MoveNext
        Loop

    End If
    MakeZJJL = strZJJL
    
    GoTo ExitLab
ErrMsg:
    Status = SetError(Err.Number, Err.Description, Err.Source)
    ErrMsg Status
ExitLab:
    Screen.MousePointer = vbDefault
End Function

'将某YYID的某分组的人员的所有人员加入某大项
Public Sub InsertDXtoFZRY(inYYID As String, inFZID As Integer, inDXID As String)
    Dim rstemp As ADODB.Recordset
    Dim strSQL As String
    Dim cmdTemp As ADODB.Command
    Dim rsDX As ADODB.Recordset
    
    Set cmdTemp = New ADODB.Command
    Set cmdTemp.ActiveConnection = GCon

    '找出该分组中所有人员
    Set rstemp = New ADODB.Recordset
    strSQL = "select GUID from FZ_FZSJ where YYID='" & inYYID & "' and FZID=" & inFZID
    rstemp.Open strSQL, GCon, adOpenStatic, adLockReadOnly
    If rstemp.RecordCount > 0 Then
        rstemp.MoveFirst
        '将该分组中所有人员均加入该大项
        Do While Not rstemp.EOF
            Set rsDX = New ADODB.Recordset
            strSQL = "select * from YY_SJDJDX where GUID=" & rstemp("GUID") _
                    & " and DXID='" & inDXID & "'"
            rsDX.Open strSQL, GCon, adOpenStatic, adLockReadOnly
            '如果该人还未选择该大项，则加入
            If rsDX.RecordCount = 0 Then
                 strSQL = "insert into YY_SJDJDX(GUID,DXID,SFTJ) VALUES(" _
                        & rstemp("GUID") & ",'" & inDXID & "',0)"
                 cmdTemp.CommandText = strSQL
                 cmdTemp.Execute
            End If
            rstemp.MoveNext
        Loop
    End If
    
End Sub

'在inForm的inCmbBox控件中显示所有已预约和登记的单位名称,每条的KEY属性存储其YYID
Public Sub ShowDW(ByRef inForm As Form, ByRef inCmbBox As ComboBox)
On Error GoTo ErrMsg
    Dim rstemp As ADODB.Recordset
    Dim strSQL As String
    Dim i As Integer
    Dim Status
    
    Set rstemp = New ADODB.Recordset
    
    '刷新团体信息
    strSQL = "select YYID,DWMC" _
            & " from YY_TJDJ,SET_DW" _
            & " where YY_TJDJ.DWID=SET_DW.DWID" _
            & " order by JLRQ desc"
    rstemp.Open strSQL, GCon, adOpenKeyset, adLockOptimistic
    inCmbBox.Clear
    If rstemp.RecordCount > 0 Then
        inCmbBox.AddItem "" '首先添加一个空行，便于用户修改
        ReDim garrYYID(rstemp.RecordCount)
        
        '添加已经预约过的团体
        rstemp.MoveFirst
        For i = 1 To rstemp.RecordCount
            inCmbBox.AddItem rstemp("DWMC")
            
            inCmbBox.ItemData(inCmbBox.NewIndex) = i
            garrYYID(i) = rstemp("YYID") 'YYID字段太长，ItemData属性无法存放，只能存入数组
            
            rstemp.MoveNext
        Next
        Set rstemp = Nothing
    End If
    
    Exit Sub
ErrMsg:
    Status = SetError(Err.Number, Err.Description, Err.Source)
    ErrMsg Status
End Sub

'在相应窗体和组合框中添加相应的字典内容
Public Sub ShowZD(ByRef inForm As Form, ByRef inCmbBox As ComboBox, ByVal instrType As String)
On Error GoTo ErrMsg
    Dim rstemp As ADODB.Recordset
    Dim strSQL As String
    Dim i As Integer
    Dim Status
    
    Set rstemp = New ADODB.Recordset
    
    '刷新信息
    strSQL = "select * from DM_ZYSZYBS where Type='" & instrType & "'"
    rstemp.Open strSQL, GCon, adOpenKeyset, adLockOptimistic
    inCmbBox.Clear
    If rstemp.RecordCount > 0 Then
        inCmbBox.AddItem "" '首先添加一个空行，便于用户修改
        
        '添加已经预约过的团体
        rstemp.MoveFirst
        For i = 1 To rstemp.RecordCount
            inCmbBox.AddItem rstemp("Content")
            inCmbBox.ItemData(inCmbBox.NewIndex) = i
            
            rstemp.MoveNext
        Next
        Set rstemp = Nothing
    End If
    
    Exit Sub
ErrMsg:
    Status = SetError(Err.Number, Err.Description, Err.Source)
    ErrMsg Status
End Sub

'获得某团体中已体检的人数
Public Function GetDWYTJRS(inYYID As String) As Integer
    Dim rstemp As ADODB.Recordset
    Dim strSQL As String
    
    Set rstemp = New ADODB.Recordset
    strSQL = "select count(*) from FZ_FZSJ" _
            & " where (SFTJ=2 or SFTJ=1)" _
            & " and YYID='" & inYYID & "'"
    rstemp.Open strSQL, GCon, adOpenStatic, adLockReadOnly
    GetDWYTJRS = rstemp(0)
    rstemp.Close
    Set rstemp = Nothing
End Function

Public Function GetDWRS(inYYID As String) As Integer
    Dim rstemp As ADODB.Recordset
    Dim strSQL As String
    
    Set rstemp = New ADODB.Recordset
    strSQL = "select count(*) from FZ_FZSJ where SFTJ in (0,1,2)" _
            & " and YYID='" & inYYID & "'"
    Set rstemp = New ADODB.Recordset
    rstemp.Open strSQL, GCon, adOpenStatic, adLockReadOnly
    GetDWRS = rstemp(0)
    rstemp.Close
    Set rstemp = Nothing
End Function

'获得团体中体检结果完全正常的人数，inSex表示性别
Public Function GetNormalRS(ByVal inYYID As String, ByVal inSEX As String, _
        Optional ByVal strField As String, Optional ByVal strValue As String) As Integer
On Error GoTo ErrMsg
    Dim rstemp As ADODB.Recordset
    Dim rsJBCJB As ADODB.Recordset
    Dim strSQL As String
    Dim i, j As Integer
    Dim intTmpZCRS, intTmpFZCRS As Integer   '正常人数和非正常人数
    Dim Status
    
    '查出所有疾病和常见病
    Set rsJBCJB = New ADODB.Recordset
    strSQL = "select DMValue from DM_ZJJY where (SFJB=1 or SFCJB=1)"
    If strField <> "" Then
        strSQL = strSQL & " and " & strField & "='" & strValue & "'"
    End If
    rsJBCJB.Open strSQL, GCon, adOpenStatic, adLockReadOnly
    If rsJBCJB.RecordCount = 0 Then
        If strField = "" Then '
            MsgBox "还未进行疾病和常见病字典的设置，请在体检建议维护中设置", vbInformation, "提示"
        End If
        GoTo ExitLab
    End If
    
    '查出该团体中所有人的体检结论
    'DATA_ZJJL.*,SET_GRXX.*
    strSQL = "select JLValue from DATA_ZJJL,SET_GRXX" _
            & " where DATA_ZJJL.GUID=SET_GRXX.GUID" _
            & " and SET_GRXX.YYID='" & inYYID & "'"
    If inSEX <> "" Then
        strSQL = strSQL & " and SEX='" & inSEX & "'"
    End If
    Set rstemp = New ADODB.Recordset
    rstemp.Open strSQL, GCon, adOpenStatic, adLockReadOnly
    If rstemp.RecordCount = 0 Then
        If strField = "" Then
            MsgBox "该单位尚未有人存在总检结论,请先生成总检结论", vbInformation, "提示"
        End If
        GoTo ExitLab
    End If
    rstemp.MoveFirst
    
    rsJBCJB.MoveFirst
    intTmpZCRS = 0
    intTmpFZCRS = 0
    '每个人