module1.bas

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

                        If strTempJYi <> "" Then
                            strJYi = strJYi & strTempJYi & "；"
                        End If
                        
                        rsData.MoveNext
                    Loop Until rsData.EOF
                    rsData.Close
                    
                    '截掉最后一个逗号
                    If strJYi <> "" Then
                        strJYi = Left(strJYi, Len(strJYi) - 1)
                    End If
                End If
            End If
            
            
            rstemp.MoveNext
        Loop Until rstemp.EOF
        rstemp.Close
        
    End If
    
    GoTo ExitLab
    
    
'获取某一项目的体检结果
GetTJResult:
    strSQL = "select distinct GUID as 流水号"
    If Len(strXMID) = 4 Then
        strSQL = strSQL & ",[" & strDXPYSX & "Value]"
    Else
        strSQL = strSQL & ",[Data_" & strDXPYSX & "].[" & strXXPYSX & "]"
    End If
    strSQL = strSQL & " as [抽查结果]" _
            & "" _
            & " from [Data_" & strDXPYSX & "]" _
            & " where GUID=" & inGUID
'    If intType = 1 Then
'        '数值型
'        If Len(strXMID) = 4 Then
'            '大项
'            strSQL = strSQL & " and (cast([" & strDXPYSX & "Value] as float)<cast(CKXX as float)" _
'                    & " or cast([" & strDXPYSX & "Value] as float)>cast(CKSX as float))"
'        Else
'            '小项
'            strSQL = strSQL & " and (cast([Data_" & strDXPYSX & "].[" & strXXPYSX & "] as float)<cast(CKXX as float)" _
'                    & " or cast([Data_" & strDXPYSX & "].[" & strXXPYSX & "] as float)>cast(CKSX as float))"
'        End If
'    Else
'        '非数值型
'        If Len(strXMID) = 4 Then
'            '大项
'            strSQL = strSQL & " and [" & strDXPYSX & "Value]<>NormalVal"
'        Else
'            '小项
'            strSQL = strSQL & " and [Data_" & strDXPYSX & "].[" & strXXPYSX & "]<>NormalVal"
'        End If
'    End If
    
    '***********************************
    '执行查询
    '***********************************
    Set rsHZ = New ADODB.Recordset
    rsHZ.Open strSQL, GCon, adOpenStatic, adLockOptimistic
    If rsHZ.RecordCount >= 1 Then
        If Trim(rsHZ("抽查结果")) <> "" Then
'            strTemp = strXMMC
'            If intType = 1 Then
'                '数值型
'                strTemp = strTemp
'                strTempJYi = strXMMC
'                If (Val(rsHZ("抽查结果")) < Val(rsHZ("CKXX"))) And (rsHZ("CKXX") <> "") Then
'                    strTemp = strTemp & "偏低(" & rsHZ("抽查结果") & ":" & rsHZ("DW") & ")"
'                    strTempJYi = strTempJYi & "偏低"
'                ElseIf Val(rsHZ("抽查结果")) > Val(rsHZ("CKSX")) And (rsHZ("CKSX") <> "") Then
'                    strTemp = strTemp & "偏高(" & rsHZ("抽查结果") & ":" & rsHZ("DW") & ")"
'                    strTempJYi = strTempJYi & "偏高"
'                Else
'                    strTemp = ""
'                    strTempJYi = ""
'                End If
'            Else
'                '说明型
'                strTemp = strTemp & Trim(rsHZ("抽查结果"))
'                strTempJYi = rsHZ("抽查结果")
'            End If
'            If strTemp <> "" Then
'                strResult = strResult & strTemp & "；"
'            Else
'                strResult = ""
'            End If

        Else        '取回结果为空,说明还未进行该项目的录入
            blXMValueisNull = True
        End If
        
        rsHZ.Close
    Else
        blXMValueisNull = True
    End If
    
    Return
    


    GoTo ExitLab
    
ErrMsg:
    Status = SetError(Err.Number, Err.Description, Err.Source)
    ErrMsg Status
ExitLab:

End Function
'********************20040520加入完 闻**********************************


'********************20040520加入 闻************************************
'判断某人在某科室中某个项目是否已录入值
Public Function CheckXMInput(inGUID As Long, inDXID As String, inXMID As String) As Boolean
    Dim rstemp As ADODB.Recordset
    Dim rsData As ADODB.Recordset
    Dim rsHZ As ADODB.Recordset
    Dim strSQL As String
    Dim strTmpDXPYSX As String
    
    Dim strDXPYSX As String
    Dim strXXPYSX As String
    Dim intType As Integer
    Dim strXMID As String
    Dim strXMMC As String
    
    Dim blXMValueisNull As Boolean
    blXMValueisNull = False      '初始化为false
    
    CheckXMInput = True
    
    Set rstemp = New ADODB.Recordset
    
    If inDXID <> "" Then
'        strSQL = "select * from SET_DX where DXID='" & Left(inXMID, 4) & "'"
        strSQL = "select * from SET_DX where DXID='" & inDXID & "'"
        rstemp.Open strSQL, GCon, adOpenStatic, adLockReadOnly
        strDXPYSX = rstemp("DXPYSX")
        rstemp.Close
    End If
    
    Set rstemp = New ADODB.Recordset
    If inXMID <> "" Then
        Select Case Len(inXMID)
            Case 4      '大项
                strSQL = "select * from SET_DX where DXID='" & inXMID & "'"
                rstemp.Open strSQL, GCon, adOpenStatic, adLockReadOnly
                If rstemp.RecordCount > 0 Then
                    strXMID = inXMID
                    strXMMC = rstemp("DXMC")
    '                intType = rsTemp("DXType")
                    GoSub GetTJResult
                    '如果该项目还未录入，则不能生成小结
                    If blXMValueisNull = True Then
                        CheckXMInput = False
                        GoTo ExitLab
                    End If
                End If
            Case 7      '小项
                strSQL = "select * from SET_XX" _
                        & " where XXID='" & inXMID & "'"
                Set rsData = New ADODB.Recordset
                rsData.Open strSQL, GCon, adOpenStatic, adLockOptimistic
                If rsData.RecordCount >= 1 Then
                    strXMID = inXMID
                    strXMMC = rsData("XXMC")
                    strXXPYSX = rsData("XXPYSX")
    '                intType = rsData("XXType")
                    GoSub GetTJResult
                    '如果该项目还未录入，则不能生成小结
                    If blXMValueisNull = True Then
                        CheckXMInput = False
                        GoTo ExitLab
                    End If
                End If
        End Select
    Else
        strSQL = "select * from SET_DX where DXID='" & inDXID & "'"
        rstemp.Open strSQL, GCon, adOpenStatic, adLockReadOnly
        If rstemp.RecordCount > 0 Then
            strXMID = inDXID
            strXMMC = rstemp("DXMC")
'                intType = rsTemp("DXType")
            GoSub GetTJResult
            '如果该项目还未录入，则不能生成小结
            If blXMValueisNull = True Then
                CheckXMInput = False
                GoTo ExitLab
            End If
        End If
    End If
    GoTo ExitLab
    
GetTJResult:
    strSQL = "select distinct GUID as 流水号"
    If Len(strXMID) = 4 Then
        strSQL = strSQL & ",[" & strDXPYSX & "Value]"
    Else
        strSQL = strSQL & ",[Data_" & strDXPYSX & "].[" & strXXPYSX & "]"
    End If
    strSQL = strSQL & " as [抽查结果]" _
            & "" _
            & " from [Data_" & strDXPYSX & "]" _
            & " where GUID=" & inGUID
    
    '***********************************
    '执行查询
    '***********************************
    Set rsHZ = New ADODB.Recordset
    rsHZ.Open strSQL, GCon, adOpenStatic, adLockOptimistic
    If rsHZ.RecordCount >= 1 Then
'        If Trim(rsHZ("抽查结果")) <> "" Then
        If IsNull(rsHZ("抽查结果")) = False Then
        
        Else        '取回结果为空,说明还未进行该项目的录入
            blXMValueisNull = True
        End If
        
        rsHZ.Close
    Else
        blXMValueisNull = True
    End If
    
    Return
    
ExitLab:
    
End Function
'********************20040520加入完 闻**********************************

Public Function CheckTiJiao(inGUID As Long, inKSID As String) As Boolean
    Dim strSQL As String
    Dim rstemp As ADODB.Recordset
    
    Set rstemp = New ADODB.Recordset
    strSQL = "select * from DATA_KSXJ where GUID='" & inGUID & "' and KSID='" & inKSID & "'"
    rstemp.Open strSQL, GCon, adOpenStatic, adLockReadOnly
    If rstemp.RecordCount > 0 Then
        If rstemp("TiJiao") = 1 Then
            CheckTiJiao = True
            Exit Function
        End If
    End If
    
    CheckTiJiao = False
End Function

'检查inTree的inNode节点是否有子节点
Public Function HaveChild(inTree As TreeView, inNodeKey As String) As Boolean
    Dim i As Integer
    HaveChild = False
    For i = 2 To inTree.Nodes.Count
        If inTree.Nodes(i).Parent.Key = inNodeKey Then
            HaveChild = True
            Exit Function
        End If
    Next
End Function

'检查输入的参数是否是数字
Public Function CheckIfNumber(inString As String) As Boolean
    Dim i As Integer
    CheckIfNumber = True
    If Len(inString) < 6 Then
        For i = 1 To Len(inString)
            If (Asc(Mid(inString, i, 1)) < vbKey0 Or Asc(Mid(inString, i, 1)) > vbKey9) And Asc(Mid(inString, i, 1)) <> 46 Then
                CheckIfNumber = False
                Exit Function
            End If
        Next
    Else
        CheckIfNumber = False
    End If
End Function

'检查某GUID的某个大项是否已检过
Public Function CheckDXSFTJ(inGUID As Long, inDXID As String) As Boolean
    Dim strSQL As String
    Dim rstemp As ADODB.Recordset
    
    Set rstemp = New ADODB.Recordset
    strSQL = "select * from YY_SJDJDX where GUID=" & inGUID & " and DXID='" & inDXID & "'"
    rstemp.Open strSQL, GCon, adOpenStatic, adLockReadOnly
    If rstemp.RecordCount > 0 Then
        If rstemp("SFTJ") >= 1 Then
            CheckDXSFTJ = True
        Else
            CheckDXSFTJ = False
        End If
    Else
        CheckDXSFTJ = False
    End If
End Function

'检查某GUID的所有登记项目是否已检过
Public Function CheckGUIDTJFinish(inGUID As Long) As Boolean
    Dim strSQL As String
    Dim rstemp As ADODB.Recordset
    Dim intSex As Integer
    
    CheckGUIDTJFinish = True
    '首无取得该人的性别
    Set rstemp = New ADODB.Recordset
    rstemp.Open "select * from SET_GRXX where GUID=" & inGUID, GCon, adOpenStatic, adLockReadOnly
    If rstemp.RecordCount > 0 Then
        intSex = IIf(Trim(rstemp("Sex")) = "男", 2, 1)
    End If