mdldatabase.bas

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

            rsKS.MoveFirst
            Do
                '关键字长度：1+2=3
                Set nodTemp = .Nodes.Add("W", tvwChild, "W" & rsKS("KSID"), rsKS("KSMC"))
                nodTemp.Expanded = True
                '加载大项
                '根据性别显示大项
                strSQL = "select DXID,DXMC from SET_DX" _
                        & " where KSID='" & rsKS("KSID") & "'" _
                        & " and DXNNTY<>" & intSex
'                If strYYID = "" Then
                    '个人
                    strSQL = strSQL & " and DXID in (select DXID from YY_SJDJDX" _
                            & " where GUID=" & lngGUID & ")"
'                Else
'                    '团体客户
'                    strSQL = strSQL & " and DXID in (select DXID from YY_TJDJDX" _
'                            & " where YYID='" & strYYID & "'" _
'                            & " and FZID=" & intFZID _
'                            & ")"
'                End If
                
                '按顺序号排序
                strSQL = strSQL & " order by SXH"
                Set rsDX = New ADODB.Recordset
                rsDX.Open strSQL, GCon, adOpenStatic, adLockOptimistic
                If rsDX.RecordCount >= 1 Then
                    rsDX.MoveFirst
                    Do
                        '关键字长度：1+4=5
                        Set nodTemp = .Nodes.Add("W" & rsKS("KSID"), tvwChild, "W" & rsDX("DXID"), rsDX("DXMC"))
'''                        If gstrClassifyID = GManager.SysTemCJYS And InStr(1, gstrKSID, rsKS("KSID")) > 0 Then
'''                        nodTemp.ForeColor = vbRed
'''                        End If
                        rsDX.MoveNext
                    Loop Until rsDX.EOF
                    rsDX.Close
                End If
                
                rsKS.MoveNext
            Loop Until rsKS.EOF
            rsKS.Close
        End With
    End If
    Set rsKS = Nothing
    Set rsDX = Nothing
    
    intBZID = g_intEnableBZID '重新设置为默认体检标准
    SetSelXMu = intBZID
    GoTo ExitLab
    
ErrMsg:
    Status = SetError(Err.Number, Err.Description, Err.Source)
    ErrMsg Status
ExitLab:
    Screen.MousePointer = vbDefault
End Function

'功能：把指定客户尚未检查的项目放到目标ListView中
'传入参数：  客户的唯一编号，
'           源树型控件，
'           目标ListView
'返回值：布尔型变量
Public Function GetNotTJDX(ByVal lngGUID As Long, ByRef tvwSource As TreeView, _
        ByRef lvwDestination As ListView) As Boolean
On Error GoTo ErrMsg
    Dim Status
    Dim strSQL As String
    Dim rsDX As ADODB.Recordset
    Dim rstemp As ADODB.Recordset
    Dim i As Integer
    Dim strDXID As String
    
    Screen.MousePointer = vbArrowHourglass
    GetNotTJDX = False '出错时的返回值
    
    lvwDestination.ListItems.Clear
    
    With tvwSource
        For i = 1 To .Nodes.Count
            If Left(.Nodes(i).Key, 1) = "W" Then
                strDXID = Mid(.Nodes(i).Key, 2)
                If Len(strDXID) = 4 Then
                    '说明是大项，需要检查
                    strSQL = "select DXMC,DXPYSX from SET_DX" _
                            & " where DXID='" & strDXID & "'"
                    Set rsDX = New ADODB.Recordset
                    rsDX.Open strSQL, GCon, adOpenStatic, adLockReadOnly
                    
                    '用取得的大项拼音缩写检索数据表
                    '*************************************************************
                    '显示当前客户是否体检过当前项目
                    '*************************************************************
                    '检查该项目用户是否体检过
                    strSQL = "select count(*) from [DATA_" & rsDX("DXPYSX") & "]" _
                            & " where GUID=" & lngGUID
                    Set rstemp = New ADODB.Recordset
                    rstemp.Open strSQL, GCon, adOpenStatic, adLockOptimistic
                    If rstemp(0) < 1 Then
                        lvwDestination.ListItems.Add , "W" & strDXID, rsDX("DXMC")
                    End If
                    rstemp.Close
                    '*************************************************************
                    '检查完毕
                    '*************************************************************
                    rsDX.Close
                End If
            End If
        Next
    End With
    GetNotTJDX = True
    
    GoTo ExitLab
ErrMsg:
    Status = SetError(Err.Number, Err.Description, Err.Source)
    ErrMsg Status
ExitLab:
    Screen.MousePointer = vbDefault
End Function

'******************************************************************
'根据用户输入的数字显示相应天数内的记录
'******************************************************************
Public Function ShowRecord(ByRef frmParent As Form, ByVal strCondition As String, _
        ByRef mshGrid As mshFlexGrid, Optional ByVal blnIncludeZJ As Boolean = False) As Boolean
On Error GoTo ErrMsg
    Dim Status
    Dim strSQL As String
    Dim dtmOver As Date
    Dim rstemp As ADODB.Recordset
    Dim i As Long, j As Long, K As Long
    Dim strShowHealthID() As String
    Dim lngIndex As Long
    Dim blnHave As Boolean
    
    Screen.MousePointer = vbArrowHourglass
    
    '只显示在当前科室有登记的客户
    '***********************************************************
    '首先显示散检客户
    '***********************************************************
    strSQL = "select distinct SET_GRXX.GUID as 流水号,HealthID as " & g_strSystemIDTitle _
            & ",SET_GRXX.SelfBH as " & g_strSelfIDTitle _
            & ",TJSerialNum as 序号,YYRXM as 姓名,SET_GRXX.TJRQ as 登记日期" _
            & " from SET_GRXX,YY_SJDJ,DATA_ZJJL" _
            & " where (YYID is null or YYID='')" _
            & " and QRDJ>0" _
            & " and SET_GRXX.GUID=YY_SJDJ.GUID"
    If Not blnIncludeZJ Then
         strSQL = strSQL & " and SET_GRXX.GUID not in (" _
                    & " select GUID from DATA_ZJJL" _
                & ")"
    End If

    If gstrClassifyID = GManager.SystemKSYS Then
        '科室医生只可以看到本科室的人员
        strSQL = strSQL & " and SET_GRXX.GUID in(" _
                & "select distinct GUID from YY_SJDJDX" _
                & " where Left(DXID,2)='" & gstrKSID & "')"
    Else
        '系统管理员可以看到所有人员
    End If
    
    '连上传入的查询条件
    strSQL = strSQL & strCondition
    
    '***********************************************************
    '以下提取团体中的客户
    '***********************************************************
    strSQL = strSQL & " union "
    strSQL = strSQL & "select distinct SET_GRXX.GUID as 流水号,HealthID as " & g_strSystemIDTitle _
            & ",SET_GRXX.SelfBH as " & g_strSelfIDTitle & ",TJSerialNum as 序号,YYRXM as 姓名,SET_GRXX.TJRQ as 登记日期" _
            & " from SET_GRXX,YY_TJDJ,FZ_FZSJ,DATA_ZJJL" _
            & " where not (SET_GRXX.YYID is null or SET_GRXX.YYID='')" _
            & " and YY_TJDJ.SFTJ in (0,1,2)" _
            & " and SET_GRXX.YYID=YY_TJDJ.YYID" _
            & " and SET_GRXX.GUID=FZ_FZSJ.GUID" _
            & " and QRDJ>0"
    If Not blnIncludeZJ Then
         strSQL = strSQL & " and SET_GRXX.GUID not in (" _
                    & " select GUID from DATA_ZJJL" _
                & ")"
    End If

    If gstrClassifyID = GManager.SystemKSYS Then
        '科室医生只可以看到本科室的人员
        strSQL = strSQL & " and SET_GRXX.GUID in(" _
                & "select distinct GUID from YY_SJDJDX" _
                & " where Left(DXID,2)='" & gstrKSID & "')"
    Else
        '系统管理员可以看到所有人员
    End If
    
    '连上传入的查询条件
    strSQL = strSQL & strCondition
    
    '按日期排序
    strSQL = strSQL & " order by 登记日期 desc,序号"
    
    '隐藏流水号
    mshGrid.ColWidth(0) = 0
    Call SetObjectTitleAndWidth(mshGrid, 1, 2)
    
    DoEvents
    '显示
    Set rstemp = New ADODB.Recordset
    rstemp.Open strSQL, GCon, adOpenStatic, adLockPessimistic
    
    mshGrid.Clear
    mshGrid.Rows = 2
    mshGrid.Refresh
'    frmParent.MousePointer = vbDefault
    If Not rstemp.EOF Then
        mshGrid.FixedCols = 0
        
        With mshGrid
            .Cols = rstemp.Fields.Count
            For j = 0 To rstemp.Fields.Count - 1
                .TextMatrix(0, j) = rstemp.Fields(j).name
            Next j
            For i = 1 To rstemp.RecordCount
                blnHave = False
                '检查HealthID是否已经显示过
                If lngIndex < 1 Then
                    lngIndex = 1
                    ReDim strShowHealthID(1 To 1)
                    strShowHealthID(1) = rstemp(g_strSystemIDTitle)
                Else
                    For K = LBound(strShowHealthID) To UBound(strShowHealthID)
                        If rstemp(g_strSystemIDTitle) = strShowHealthID(K) Then
                            blnHave = True
                            Exit For
                        End If
                    Next K
                    If Not blnHave Then
                        lngIndex = lngIndex + 1
                        ReDim Preserve strShowHealthID(1 To lngIndex)
                        strShowHealthID(lngIndex) = rstemp(g_strSystemIDTitle)
                    End If
                End If
                
                If Not blnHave Then
'                    If .TextMatrix(1, 1) <> "" Then
                        .Rows = lngIndex + 1
'                    End If
                    
                    For j = 0 To rstemp.Fields.Count - 1
                        .TextMatrix(lngIndex, j) = rstemp(j) & ""
                    Next j
                End If
                
                If i Mod 100 = 0 Then DoEvents
                
                rstemp.MoveNext
            Next i
        End With
    End If
    
'    If blnSort Then
        mshGrid.col = gintPXFC
        mshGrid.Sort = 5
'    End If
    
    DoEvents
    
    With mshGrid
        .Row = 1
        .col = 0
        If .TextMatrix(1, 0) <> "" Then
            .ColSel = .Cols - 1
        End If
    End With
    
    GoTo ExitLab
ErrMsg:
    Status = SetError(Err.Number, Err.Description, Err.Source)
    ErrMsg Status
ExitLab:
    Screen.MousePointer = vbDefault
End Function

'******************************************************************
'根据拼音缩写，返回指定项目的正常值
'参数1：大项ID
'参数2：项目拼音缩写
'参数3：标准ID
'参数4：标准所适用的相反性别。如果为男士，传入女士性别编号；反之亦然
'返回值：获取的正常值（字符型）
'******************************************************************
Public Function GetNormalValue(ByVal strDXID As String, ByVal strPYSX As String, _
        ByVal intBZID As Integer, ByVal intSex As Integer) As String
On Error GoTo ErrMsg
    Dim Status
    Dim strSQL As String
    Dim rstemp As ADODB.Recordset
    Dim blnHaveChild As Boolean '是否有子项
    Dim strXMID As String
    
    Screen.MousePointer = vbArrowHourglass
    
    '检查该大项是否有子项
    strSQL = "select DXSFYZX from SET_DX" _
            & " where DXID='" & strDXID & "'"
    Set rstemp = New ADODB.Recordset
    rstemp.Open strSQL, GCon, adOpenStatic, adLockReadOnly
    blnHaveChild = rstemp(0)
    rstemp.Close
    
    If blnHaveChild Then '有子项
        '获取小项id
        strSQL = "select * from SET_XX" _
                & " where XXID='" & strPYSX & "'"
    Else '无子项
        '获取大项id
        strSQL = "select DXID from SET_DX where DXPYSX='" & strPYSX & "'"
    End If
    Set rstemp = New ADODB.Recordset
    rstemp.Open strSQL, GCon, adOpenStatic, adLockReadOnly
    strXMID = rstemp(0)
    rstemp.Close
    
    '获取正常值
    strSQL = "select NormalVal from SET_TJBZDT" _
            & " where BZID=" & intBZID _
            & " and XMID='" & strXMID & "'" _
            & " and SEX<>" & intSex
    Set rstemp = New ADODB.Recordset
    rstemp.Open strSQL, GCon, adOpenStatic, adLockReadOnly
    If rstemp.RecordCount > 0 Then
        GetNormalValue = rstemp("NormalVal") & ""
        
        rstemp.Close
    End If
    
    GoTo ExitLab
ErrMsg:
    Status = SetError(Err.Number, Err.Description, Err.Source)
    ErrMsg Status
ExitLab:
    Screen.MousePointer = vbDefault
End Function

'******************************************************************
'根据拼音缩写，返回指定用户不在当前小项的体检值（如果存在）
'参数1：GUID
'参数2：项目组合ID
'参数3：小项拼音缩写
'参数4：返回值是否包含当前大项（默认为False）
'返回值：获取的体检值（字符型）
'******************************************************************
Public Function GetExistResult(ByVal lngGUID As Long, ByVal strDXID As String, _
        ByVal strXXPYSX As String, ByVal strXXID As String, Optional ByVal blnInclude As Boolean = False) As String
On Error GoTo ErrMsg
    Dim Status
    Dim strSQL As String
    Dim rstemp As ADODB.Recordset
    Dim rsResult As ADODB.Recordset
    Dim strResult As String
    Dim strDXPYSX As String
    
    Screen.MousePointer = vbArrowHourglass
    strResult = ""
    
    '取得当前小项所属组合，要求不是当前组合，并且已被当前用户选择
'    strSQL = "select DXPYSX from SET_DX" _
'            & " where DXID in (" _
'                & "select DXID from SET_ZH_Data" _
'                & " where XXID in (" _
'                    & "select XXID from SET_XX" _
'                    & " where XXPYSX='" & strXXPYSX & "'" _
'                & ")" _
'            & ")" _
'            & " and DXID in (" _
'                & "select DXID from YY_SJDJDX" _
'                & " where GUID=" & lngGUID _
'            & ")"
    strSQL = "select DXPYSX from SET_DX" _
            & " where DXID in (" _
                & "select DXID from SET_ZH_Data" _
                & " where XXID='" & strXXID & "'" _
            & ")" _
            & " and DXID in (" _
                & "select DXID from YY_SJDJDX" _
                & " where GUID=" & lngGUID _
            & ")"
    If Not blnInclude Then
         strSQL = strSQL & " and DXID<>'" & strDXID & "'"