mdldatabase.bas

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

    
    'display the error information
'    AddLog Status(0), Status(1), ErrorLog, Status(2)
'    If gblnAuto = False Then
        MsgBox strErr, vbInformation, "提示"
'    Else
'        ShowDialog strErr
'    End If
    
    '是否网络连接被断开
    If (CStr(Status(0)) = "-2147467259") Or (CStr(Status(0)) = "3709") Then
        If MsgBox("到服务器的连接被断开，要尝试重新打开连接吗？", vbQuestion + vbYesNo + vbDefaultButton1) = vbYes Then
            On Error Resume Next
            GCon.Close
            If Err.Number <> 0 Then Err.Clear
            
            If Not CheckConnection(GCon) Then
'                MsgBox "连接失败，请检查数据库服务器是否已经启动！", vbExclamation
            End If
        End If
    End If
End Sub

'Purpose:  确保记录集空的
Private Sub SetNewRS()
    If rs Is Nothing Then
        Set rs = New ADODB.Recordset
    ElseIf rs.State = adStateOpen Then
        rs.Close
    End If
End Sub

'Purpose:   Close and destoy rs
Public Sub CloseRS()
On Error Resume Next
    'close the Recordset
    rs.Close
    'and destroy then Recordset Object
    Set rs = Nothing
End Sub


'//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
'以下代码可设计为一个通用的组件clsDatabase: 执行SQL命令

Public Function GetRows(ByVal strSQL As String) '返回记录集（二维）或错误集（一维）
    'handle all errors locally
On Error GoTo GetRows_Err
    
    'dimension local variables
    Dim Status
'    Dim ConnStr As String
'
'    'create an ADO Connection Recordset Object
    Dim ADOConn As ADODB.Connection
'
    Status = NoError
'
'    'access your data source
'    ConnStr = gstrConString
'
'    'open a static Recordset specified by strSQL
    SetNewRS
    rs.Open strSQL, GCon, adOpenStatic, adLockReadOnly
    GoSub GetRows_CheckStatus
    
    'check errors
    If Status(0) <> 0 Then
        GetRows = Status
    ElseIf rs.RecordCount <> 0 Then
        'retrieve the rows as a variant array
'        GetRows = rs.GetRows
        GoSub GetRows_CheckStatus
    Else
        GetRows = SetError(NoRecord, "Record Not Found", "GetRows")
    End If
    
GetRows_Cont:
    'all done
    Exit Function
    
GetRows_Err:
    'pass it back
    With Err
        GetRows = SetError(.Number, .Description, .Source)
    End With
    
    'all done
    Resume GetRows_Cont
    
GetRows_CheckStatus:
    'check the ADO Errors collection for any error
    'greater than zero
    Set ADOConn = GCon
    If ADOConn.Errors.Count > 0 Then
        With ADOConn.Errors(0)
            If .Number > 0 Then
                'assign error information
                Status = SetError(.Number, .Description, .Source)
            End If
            'pass it back
            GetRows = Status
        End With
    End If
    
    'done checking
    Set ADOConn = Nothing
    
    Return
End Function

Public Function Execute(ByVal strSQL As String)
    'handle all errors locally
    On Error GoTo Execute_Err
    
    'dimension our local variables
    Dim Status
'    Dim ConnStr As String
    Status = NoError
    Execute = NoError
    
'    'create an ADO Connection Object
'    Dim ADO As ADODB.Connection
'    Set ADO = New ADODB.Connection
'
'    'specify then connection
'    ConnStr = gstrConString
'
'    'open the connection
'    ADO.Open ConnStr
'    GoSub Execute_CheckStatus
'    If Status(0) = 0 Then
        'execute the command
        GCon.Execute strSQL
'        GoSub Execute_CheckStatus
'    End If
    
'    'close the connection
'    ADO.Close
'
'    'and destroy the Connection Object
'    Set ADO = Nothing
    
Execute_Cont:
    Execute = Status
    
    'all done
    Exit Function
    
Execute_Err:
    'pass it back
    With Err
        'Debug.Print strSQL
        Status = SetError(.Number, .Description, .Source)
    End With
    
    'all done
    Resume Execute_Cont
    
Execute_CheckStatus:
    'check the ADO Errors collection for any error
    'greater than zero
    If GCon.Errors.Count > 0 Then
        With GCon.Errors(0)
            If .Number > 0 Then
                'assign error information
                Status = SetError(.Number, .Description, .Source)
            End If
        End With
    End If
    
    'done checking
    Return
End Function

'//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
'类中使用的错误结构示例
Public Function Update()
    'handle all errors locally
    On Error GoTo Update_Err
    
    '
    '功能代码略
    '
    '
    
Update_Cont:
    'Destroy your object
    
    
    'all done
    Exit Function
    
Update_Err:
    'if an error occurs then pass back then error variant
    With Err
        Update = SetError(.Number, .Description, .Source)
    End With
    
    'Reset then Err object and exit then function
    Resume Update_Cont
End Function

'//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
'在客户端，可以检测是否有错误。比如
Private Sub cmdUpdate_Click()
    'handle all errors locally
    On Error GoTo cmdUpdate_Err
    
'    Dim clsDB As clsDatabase
    Dim Status 'the local error variant
    '
    '功能代码略
    '
    '
'    Status = clsDB.Update
'    Set clsDB = Nothing
    
    'if an error occurred then
    If ErrTrue(Status) Then
        'display the error information
'        ErrMsg Status, Caption
    Else
        '
        '
    End If
    
cmdUpdate_Cont:
    '
    '
    '
    
cmdUpdate_Err:
    '
    '
    '
    
End Sub

'wxw add 20050709
'将人员的体检大项写入LIS接口表


'参数1：GUID
'参数2：跟数据库相反的性别编号
'该函数不能脱离当前的数据库结构运行（DHTJ）
Public Function AddInterface(ByVal lngGUID As Long, ByVal intSex As Integer) 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
    
    Dim rs As ADODB.Recordset
    Set rs = GCon.Execute("select * from sysobjects where name='interface_grxx' ")
    If rs.RecordCount <= 0 Then
    Dim str As String
    str = "CREATE TABLE [dbo].[Interface_Grxx] ("
    str = str & " [tj_Date] [smalldatetime] NULL ,"
    str = str & " [Id] [char] (10) COLLATE Chinese_PRC_CI_AS NULL ,"
    str = str & " [XM] [char] (20) COLLATE Chinese_PRC_CI_AS NULL ,"
    str = str & " [XB] [char] (10) COLLATE Chinese_PRC_CI_AS NULL ,"
    str = str & " [NL] [int] NULL ,"
    str = str & " [tj_ItemId] [char] (20) COLLATE Chinese_PRC_CI_AS NULL ,"
    str = str & " [JYZL] [char] (20) COLLATE Chinese_PRC_CI_AS NULL"
    str = str & ") ON [PRIMARY]"
    GCon.Execute str


    End If
    
    
    '判断来自团体还是个人
    strSQL = "select YYID ,* from SET_GRXX" _
            & " where GUID=" & lngGUID
    Set rstemp = New ADODB.Recordset
    rstemp.Open strSQL, GCon, adOpenKeyset, adLockReadOnly
    
    GCon.Execute "delete from interface_grxx where tj_date='" & rstemp("tjrq") & "' and id='" & rstemp("selfbh") & "'"

    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
    
    strSQL = "select * from SET_GRXX" _
            & " where GUID=" & lngGUID
    Set rstemp = New ADODB.Recordset
    rstemp.Open strSQL, GCon, adOpenKeyset, adLockReadOnly
    '以下显示当前用户有选择的科室
    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
         While Not rsKS.EOF
'            rsKS.MoveFirst
                '根据性别显示大项
                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
                        GCon.Execute "insert into interface_grxx values('" & rstemp("tjrq") & "','" & rstemp("selfbh") & "','" & rstemp("YYRXM") & "','" & rstemp("SEX") & "'," & IIf(IsNull(rstemp("AGE")), 0, rstemp("AGE")) & ",'" & Trim(rsDX("DXID")) & "','" & rsDX("DXMC") & "')"
                        rsDX.MoveNext
                    Loop Until rsDX.EOF
                    rsDX.Close
                End If
                
                rsKS.MoveNext
         Wend
         rsKS.Close
    End If
    Set rsKS = Nothing
    Set rsDX = Nothing
    
    GoTo ExitLab
    
ErrMsg:
    Status = SetError(Err.Number, Err.Description, Err.Source)
    ErrMsg Status
ExitLab:
    Screen.MousePointer = vbDefault
End Function