mdldatabase.bas

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

'**********************************************************************
'获取当日最大的体检序号
'输入：日期
'输出：最大编号+1
'注：返回的编号为数字型
'**********************************************************************
Public Function GetMaxSN(ByVal datDate As Date, _
        ByVal enuFromTable As FromTable) As Integer
    Dim strSQL As String
    Dim intMaxSN As Integer
    Dim rstemp As ADODB.Recordset
    Dim conTemp As ADODB.Connection
    Dim strTableName
    
    Screen.MousePointer = vbHourglass
    If ConnectDatabase(conTemp, adUseServer) = False Then GoTo ExitLab
    
    Select Case enuFromTable
        Case AFFIRM_TABLE
            strTableName = "YY_QRXLH"
        Case NOTAFFIRM_TABLE
            strTableName = "YY_XLH"
        Case Else
            MsgBox "GetMaxSN的参数错误！", vbInformation
    End Select
    strSQL = "select * from " & strTableName _
            & " where RiQi='" & datDate & "'"
    Set rstemp = New ADODB.Recordset
    rstemp.CursorLocation = adUseServer
    Select Case enuFromTable
        Case AFFIRM_TABLE
            rstemp.Open strSQL, conTemp, adOpenDynamic, adLockPessimistic
        Case NOTAFFIRM_TABLE
            rstemp.Open strSQL, GCon, adOpenDynamic, adLockPessimistic
        Case Else
            '
    End Select
    If rstemp.EOF Then '无记录
        rstemp.AddNew
        rstemp("RiQi") = datDate
        intMaxSN = 1
    ElseIf IsNull(rstemp("SJYYXLH")) Then '有记录，但所取字段为空
        '该情况存在于表YY_XLH中
        intMaxSN = 1
    Else '有记录，而且所取字段不空
        intMaxSN = rstemp("SJYYXLH") + 1
    End If
    rstemp("SJYYXLH") = intMaxSN
    rstemp.Update
    Set rstemp = Nothing
    Call DisConnectDatabase(conTemp)
    GetMaxSN = intMaxSN
    GoTo ExitLab
ExitLab:
    Screen.MousePointer = vbDefault
End Function

'获取指定日期的确认序列号和健康档案号
'返回值：HealthID（后四位为序列号）
Public Function GetMaxHealthID(ByVal dtmDate As Date, _
        ByVal enuFromTable As FromTable) As String
    Dim strHealthID As String
    
    strHealthID = Format(dtmDate, "yyyymmdd") '构造HealthID的前半部分
    strHealthID = strHealthID & LongToString(CLng(GetMaxSN(dtmDate, enuFromTable)), 4)

    '现在的业务逻辑这样理解：
    '如果用户档案号没有确认标记，则从确认序号表里面从新生成
    '否则采用原来的序号。
    GetMaxHealthID = strHealthID
    
    GoTo ExitLab
ExitLab:
    '
End Function

'**********************************************************************
'获取编号最大的字段
'参数1：表名
'参数2：编号对应的字段名
'参数3：缺省返回值
'参数4：可选。是否要更新表，即在相应字段插入一条空记录。
'返回值：最大编号+1
'注：返回的编号为字符串
'**********************************************************************
Public Function GetMaxID(ByVal strTable As String, ByVal strField As String, _
        ByVal strDefaultValue As String, Optional ByVal blnUpdate As Boolean = False) As String
On Error GoTo ErrMsg
    Dim Status
    Dim strSQL As String
    Dim rstemp As New ADODB.Recordset
    Dim conTemp As ADODB.Connection  '为保证唯一性，用服务器端游标打开数据库
    Dim strMaxID As String
    
    '打开连接
    If ConnectDatabase(conTemp, adUseServer) = False Then GoTo ExitLab
    
    strSQL = "select top 1 [" & strField & "] from [" & strTable & "]" _
            & " order by [" & strField & "] desc"
    rstemp.Open strSQL, conTemp, adOpenKeyset, adLockPessimistic
    If rstemp.EOF Then
        strMaxID = strDefaultValue
    Else
        strMaxID = rstemp(0)
        strMaxID = LongToString(Val(strMaxID) + 1, Len(strMaxID))
'        rsTemp.Close
    End If
    '是否要写入一条新记录
    If blnUpdate Then
        rstemp.AddNew
        rstemp(strField) = strMaxID
        rstemp.Update
    End If
    
    Set rstemp = Nothing
    Call DisConnectDatabase(conTemp)
    GetMaxID = strMaxID
    
    GoTo ExitLab
ErrMsg:
    GetMaxID = ""
ExitLab:
    '
End Function

'**********************************************************************
'获取保存或打开的文件名
'参数1：通用对话框
'参数2：过滤设置
'参数3：对话框标题
'参数4：缺省文件名
'参数5：读写标识
'返回值：取得的文件名
'**********************************************************************
Public Function GetFileName(ByRef CommonDialog1 As CommonDialog, ByVal strFilter As String, _
        Optional ByVal strDialogTitle As String, Optional ByVal strDefaultFile As String, _
        Optional ByVal enuDirection As OpenDirection = READFILE) As String
On Error Resume Next
    With CommonDialog1
        If strDialogTitle <> "" Then
            .DialogTitle = strDialogTitle
        End If
        .Filter = strFilter
        .CancelError = True
        .FileName = strDefaultFile
        If enuDirection = WRITEFILE Then
            .Flags = cdlOFNNoReadOnlyReturn & cdlOFNOverwritePrompt
            .ShowSave
        Else
            .ShowOpen
        End If
        If Err.Number = 0 Then
            GetFileName = .FileName
        End If
    End With
End Function

'刷新树形控件
Public Function RefreshTree(ByRef tvwTreeView As TreeView, _
        ByVal strTableName As String, ByVal strNodeID As String, _
        ByVal strNodeName As String, ByVal strNodeParent As String) As Boolean
On Error GoTo ErrMsg
    Dim Status
    Dim strSQL As String
    Dim strText As String
    Dim blnFirst As Boolean
    Dim rstemp As ADODB.Recordset
    
    Screen.MousePointer = vbArrowHourglass
    RefreshTree = False
    tvwTreeView.Nodes.Clear
    '首先获取根结点
    Set rstemp = New ADODB.Recordset
    strSQL = "select * from " & strTableName & " where " & strNodeParent & " is null order by " & strNodeID
    rstemp.Open strSQL, gstrConString, adOpenStatic, adLockReadOnly
'    If ErrTrue(Status) Then
'        If Status(0) <> NoRecord Then
'            ErrMsg Status
'        End If
'        Exit Function
'    End If
    
    If rstemp.RecordCount = 0 Then
        Screen.MousePointer = vbDefault
        Exit Function
    End If
    
    blnFirst = True
'    Set rsTemp = RS
'    CloseRS
    rstemp.MoveFirst
    
    tvwTreeView.Nodes.Clear
    Do Until rstemp.EOF
        If blnFirst = True Then
            tvwTreeView.Nodes.Add , , "W" & rstemp(strNodeID), rstemp(strNodeName), 2
            blnFirst = False
        Else
            tvwTreeView.Nodes.Add strText, tvwNext, "W" & rstemp(strNodeID), rstemp(strNodeName), 2
        End If
        RansackTree tvwTreeView, strTableName, strNodeID, strNodeName, strNodeParent, rstemp(strNodeID)
        strText = "W" & rstemp(strNodeID)
        rstemp.MoveNext
    Loop
    rstemp.Close
    Set rstemp = Nothing
    
    Screen.MousePointer = vbDefault
    Exit Function
ErrMsg:
    Screen.MousePointer = vbDefault
    Status = SetError(Err.Number, Err.Description, Err.Source)
    ErrMsg Status
End Function

'根据父结点遍历所有子结点
Private Sub RansackTree(ByRef tvwTreeView As TreeView, ByVal strTableName As String, _
        ByVal strNodeID As String, ByVal strNodeName As String, _
        ByVal strNodeParent As String, ByVal strParentIDValue As String)
On Error GoTo ErrMsg
    Dim Status
    Dim strSQL As String
    Dim blnFirst As Boolean
    Dim rstemp As ADODB.Recordset
    Dim tempNode As Node
    
    Set rstemp = New ADODB.Recordset
    strSQL = "select * from " & strTableName & " where " & strNodeParent & "='" & strParentIDValue & "'"
    rstemp.Open strSQL, gstrConString, adOpenStatic, adLockReadOnly
    If rstemp.RecordCount = 0 Then Exit Sub
    
'    Status = GetRows(strSQL)
'    If ErrMsg(Status) Then
'        If Status(0) <> NoRecord Then
'            ErrMsg Status
'        End If
'        Exit Sub
'    End If
    
    blnFirst = True
'    Set rsTemp = RS
'    CloseRS
    rstemp.MoveFirst
    
    Do Until rstemp.EOF
        Set tempNode = tvwTreeView.Nodes.Add("W" & strParentIDValue, tvwChild, "W" & rstemp(strNodeID), rstemp(strNodeName), 1)
        tempNode.EnsureVisible
        RansackTree tvwTreeView, strTableName, strNodeID, strNodeName, strNodeParent, rstemp(strNodeID)
        rstemp.MoveNext
    Loop
    rstemp.Close
    Set rstemp = Nothing
    Exit Sub
ErrMsg:
    Status = SetError(Err.Number, Err.Description, Err.Source)
    ErrMsg Status
End Sub

'根据客户选择的项目显示树型结构
'参数1：GUID
'参数2：跟数据库相反的性别编号
'参数3：树型控件
'参数4：是否显示历时数据
'返回值：当前客户的体检标准编号
'该函数不能脱离当前的数据库结构运行（DHTJ）
Public Function SetSelXMu(ByVal lngGUID As Long, ByVal intSex As Integer, _
        ByRef tvwTreeView As TreeView, _
        Optional ByVal blnShowHistory As Boolean = True) As Integer
On Error GoTo ErrMsg
    Dim Status
    Dim strSQL As String
    Dim strTJBZ As String
    Dim strTemp As String
    Dim rsKS As ADODB.Recordset
    Dim rsDX As ADODB.Recordset
    Dim strYYID As String
    Dim intFZID As Integer '分组ID
    Dim intBZID As Integer '标准ID
    Dim rstemp As ADODB.Recordset
    Dim nodTemp As MSComctlLib.Node
    
    Screen.MousePointer = vbArrowHourglass
    SetSelXMu = -1 '出错时的返回值
    
    '清空树型控件里面的节点
    tvwTreeView.Nodes.Clear
    
    '判断来自团体还是个人
    strSQL = "select YYID from SET_GRXX" _
            & " where GUID=" & lngGUID
    Set rstemp = New ADODB.Recordset
    rstemp.Open strSQL, GCon, adOpenKeyset, adLockReadOnly
    If IsNull(rstemp("YYID")) Or rstemp("YYID") = "" Then
        strYYID = ""
    Else
        '来自团体
        strYYID = rstemp("YYID")
        rstemp.Close
        
        '首先获取分组id号
        strTemp = "select FZID from FZ_FZSJ" _
                & " where YYID='" & strYYID & "'" _
                & " and GUID=" & lngGUID
        Set rstemp = New ADODB.Recordset
        rstemp.Open strTemp, GCon, adOpenForwardOnly, adLockReadOnly
        If rstemp.RecordCount < 1 Then
            MsgBox "该人员尚未参与分组，无法进行终检录入！", vbInformation, "提示"
            GoTo ExitLab
        End If
        intFZID = rstemp("FZID")
        rstemp.Close
    End If
    
    If strYYID = "" Then
        '个人
        '获取该用户的体检标准id
        strTJBZ = "select BZID from YY_SJDJ" _
                & " where GUID=" & lngGUID
    Else
        '团体客户
        '获取该用户的体检标准id，每个分组公用一个体检标准
        strTJBZ = "select BZID from FZ_FZSY" _
                & " where YYID='" & strYYID & "'" _
                & " and FZID=" & intFZID
    End If
    
    '获取体检标准
    Set rstemp = New ADODB.Recordset
    rstemp.Open strTJBZ, GCon, adOpenStatic, adLockOptimistic
    If Not IsNull(rstemp(0)) Then
        intBZID = rstemp(0)
        intBZID = g_intEnableBZID '重新设置为默认体检标准
        rstemp.Close
    Else
        MsgBox "当前用户尚未选择体检标准，无法进行体检，请到“登记”处选择体检标准！", vbInformation, "提示"
        GoTo ExitLab
    End If
    
    '显示根节点
    '关键字长度：1=1
    Set nodTemp = tvwTreeView.Nodes.Add(, , "W", "所有科室")
    nodTemp.Expanded = True
            
    '*********************************************************************
    '                           以下显示历史数据
    '*********************************************************************
    '是否需要显示历史数据
    If blnShowHistory Then
        strSQL = "select GUID,TJRQ from SET_GRXX" _
                & " where HealthID in (" _
                    & "select HealthID from SET_GRXX" _
                    & " where GUID=" & lngGUID _
                & ")" _
                & " and GUID<" & lngGUID
        Set rstemp = New ADODB.Recordset
        rstemp.Open strSQL, GCon, adOpenStatic, adLockOptimistic
        If rstemp.RecordCount > 0 Then
            '循环显示历史数据
            With tvwTreeView
                '关键字长度：2＝2
                Set nodTemp = .Nodes.Add("W", tvwChild, "H", "历史数据")
                nodTemp.Expanded = False
                rstemp.MoveFirst
                Do
                    '关键字长度：2＋未知>2
                    .Nodes.Add "H", tvwChild, "H" & rstemp("GUID"), rstemp("TJRQ")
                    rstemp.MoveNext
                Loop Until rstemp.EOF
                rstemp.Close
            End With
        End If
    End If
    '*********************************************************************
    '                           历史数据显示完毕
    '*********************************************************************
    
    '以下显示当前用户有选择的科室
    strSQL = "select KSID,KSMC from SET_KSSZ"
    strSQL = strSQL & " where KSID in (" _
            & "select distinct left(DXID,2) from YY_SJDJDX" _
            & " where GUID=" & lngGUID & ")"
    '加载有选择的科室
    strSQL = strSQL & " order by SET_KSSZ.SXH"
    Set rsKS = New ADODB.Recordset
    rsKS.Open strSQL, GCon, adOpenKeyset, adLockOptimistic
    If rsKS.RecordCount >= 1 Then
        With tvwTreeView