mdldatabase.bas

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

    End If
    Set rstemp = New ADODB.Recordset
    rstemp.Open strSQL, GCon, adOpenStatic, adLockOptimistic
    If rstemp.RecordCount < 1 Then GoTo ExitLab
    
    '循环处理取得的所有大项数据表
    rstemp.MoveFirst
    Do
        strDXPYSX = rstemp("DXPYSX")
        strSQL = "select [" & strXXPYSX & "] from [DATA_" & strDXPYSX & "]" _
            & " where GUID=" & lngGUID
        Set rsResult = New ADODB.Recordset
        rsResult.Open strSQL, GCon, adOpenStatic, adLockReadOnly
        If rsResult.RecordCount > 0 Then
            If Not IsNull(rsResult(0)) Then
                If rsResult(0) <> "" Then
                    strResult = rsResult(0)
                    Exit Do
                End If
            End If
            
            rsResult.Close
        End If
        
        rstemp.MoveNext
    Loop Until rstemp.EOF
    rstemp.Close
    
    GoTo ExitLab
ErrMsg:
    Status = SetError(Err.Number, Err.Description, Err.Source)
    ErrMsg Status
ExitLab:
    GetExistResult = strResult
    Screen.MousePointer = vbDefault
End Function

'*********************20040327 封闭***********************************
'根据健康档案号和序列号更新标识字段SFTJ
'Public Function SetSFTJ(ByVal lngGUID As Long) As Boolean

'    Dim Status
'    Dim strSQL As String
'    Dim strTemp As String
'    Dim rsTemp As ADODB.Recordset
'    Dim Cmd1 As ADODB.Command
'
'    '检查是团体还是散检客户
'    strSQL = "select YYID from SET_GRXX" _
'            & " where GUID=" & lngGUID
'    Set rsTemp = New ADODB.Recordset
'    Set Cmd1 = New ADODB.Command
'    Set Cmd1.ActiveConnection = GCon
'
'    rsTemp.Open strSQL, GCon, adOpenStatic, adLockOptimistic
'    If IsNull(rsTemp(0)) Then
'        '散检客户
'        strSQL = "update YY_SJDJ set" _
'                & " SFTJ=2" _
'                & " where GUID=" & lngGUID
'    Else
'        If rsTemp(0) = "" Then
'            '散检客户
'            strSQL = "update YY_SJDJ set" _
'                    & " SFTJ=2" _
'                    & " where GUID=" & lngGUID
'        Else
'            '团体客户
'            strSQL = "update YY_TJDJ set" _
'                    & " SFTJ=2" _
'                    & " where YYID='" & rsTemp(0) & "'"
'
'            strTemp = "update FZ_FZSJ set" _
'                    & " SFTJ=2" _
'                    & " where GUID=" & lngGUID
'        End If
'    End If
'    rsTemp.Close
'    Cmd1.CommandText = strSQL
'    Cmd1.Execute
'    If strTemp <> "" Then
'        Cmd1.CommandText = strTemp
'        Cmd1.Execute
'    End If
'
'    SetSFTJ = True
'    Exit Function
'
'ErrMsg:
'    Status = SetError(Err.Number, Err.Description, Err.Source)
'    ErrMsg Status
'    SetSFTJ = False
'ExitLab:
'
'End Function
'*********************20040327 封闭完***********************************

'*********************20040327 加入 闻***********************************
'根据健康档案号和序列号更新标识字段SFTJ
Public Function SetSFTJ(ByVal lngGUID As Long, ByVal intResult As Integer) As Boolean
On Error GoTo ErrMsg
    Dim Status
    Dim strSQL As String
    Dim strTemp As String
    Dim rstemp As ADODB.Recordset
    
    '检查是团体还是散检客户
    strSQL = "select YYID from SET_GRXX" _
            & " where GUID=" & lngGUID
    Set rstemp = New ADODB.Recordset
    rstemp.Open strSQL, GCon, adOpenStatic, adLockOptimistic
    If IsNull(rstemp(0)) Then
        '散检客户
        strSQL = "update YY_SJDJ set" _
                & " SFTJ=" & intResult _
                & " where GUID=" & lngGUID
    Else
        If rstemp(0) = "" Then
            '散检客户
            strSQL = "update YY_SJDJ set" _
                    & " SFTJ=" & intResult _
                    & " where GUID=" & lngGUID
        Else
            '团体客户
            strSQL = "update YY_TJDJ set" _
                    & " SFTJ=" & intResult _
                    & " where YYID='" & rstemp(0) & "'"
            
            strTemp = "update FZ_FZSJ set" _
                    & " SFTJ= " & intResult _
                    & " where GUID=" & lngGUID
        End If
    End If
    rstemp.Close
    GCon.Execute strSQL
    If strTemp <> "" Then
        GCon.Execute strTemp
    End If
    
    '更新确认登记标识
    If intResult > 1 Then intResult = 1 '确认登记标识只有0，1两种状态
    strSQL = "update SET_GRXX set" _
            & " QRDJ=" & intResult _
            & " where GUID=" & lngGUID
    GCon.Execute strSQL
    '修复错误记录
    strSQL = "update SET_GRXX set" _
            & " QRDJ=1" _
            & " where QRDJ=2"
    GCon.Execute strSQL
    
    SetSFTJ = True
    Exit Function
    
ErrMsg:
    Status = SetError(Err.Number, Err.Description, Err.Source)
    ErrMsg Status
    SetSFTJ = False
ExitLab:
    
End Function
'*********************20040327 加入完 闻***********************************

'写入健康状况
Public Sub WritePersonHealthStatus(ByVal lngGUID As Long, ByRef cmbHealthStatus As ComboBox, _
        ByRef txtHealthResult As TextBox, ByRef txtJYiContent As TextBox)
On Error Resume Next
    Dim Status
    Dim strSQL As String
    Dim rstemp As ADODB.Recordset
    Dim intHealthID As Integer
    
    If Not gblnIsSpy Then GoTo ExitLab
    
    If cmbHealthStatus.Text = "" Then GoTo ExitLab
    intHealthID = CInt(Val(cmbHealthStatus.ItemData(cmbHealthStatus.ListIndex)))
    
    strSQL = "if not exists(select * from DATA_HealthStatus where GUID=" & lngGUID & ")" _
            & vbCrLf _
            & " insert into DATA_HealthStatus(GUID,TJRQ) values(" _
            & lngGUID & ",'" & Date & "')"
    GCon.Execute strSQL
    
    strSQL = "update DATA_HealthStatus set" _
            & " HealthStatusID=" & intHealthID _
            & ",HealthResult='" & txtHealthResult.Text & "'" _
            & ",JYContent='" & txtJYiContent.Text & "'" _
            & " where GUID=" & lngGUID
    GCon.Execute strSQL
    
    GoTo ExitLab
    
ErrMsg:
    Status = SetError(Err.Number, Err.Description, Err.Source)
    ErrMsg Status
ExitLab:
    '
End Sub

'读出健康状况
Public Sub GetPersonHealthStatus(ByVal lngGUID As Long, ByRef cmbHealthStatus As ComboBox, _
        ByRef txtHealthResult As TextBox, ByRef txtJYiContent As TextBox)
On Error Resume Next
    Dim Status
    Dim strSQL As String
    Dim rstemp As ADODB.Recordset
    Dim i As Integer
    
    If Not gblnIsSpy Then GoTo ExitLab
    
    cmbHealthStatus.ListIndex = 0
    txtHealthResult.Text = ""
    txtJYiContent.Text = ""
    
    strSQL = "select * from DATA_HealthStatus" _
            & " where GUID=" & lngGUID
    Set rstemp = New ADODB.Recordset
    rstemp.Open strSQL, GCon, adOpenForwardOnly, adLockReadOnly
    If Not rstemp.EOF Then
        With cmbHealthStatus
            For i = 0 To .ListCount - 1
                If CInt(Val(.ItemData(i))) = rstemp("HealthStatusID") Then
                    .ListIndex = i
                    Exit For
                End If
            Next
        End With
        
        txtHealthResult.Text = rstemp("HealthResult")
        txtJYiContent.Text = rstemp("JYContent")
        
        rstemp.Close
    End If
    
    GoTo ExitLab
    
ErrMsg:
    Status = SetError(Err.Number, Err.Description, Err.Source)
    ErrMsg Status
ExitLab:
    '
End Sub

'根据一个字符串返回其对应的汉字简码
Public Function GetPYJM(ByVal strChina As String) As String
On Error GoTo ErrMsg
    Dim Status
    Dim i As Integer
    Dim strSQL As String
    Dim strRet As String
    Dim rstemp As ADODB.Recordset
    
    If strChina = "" Then Exit Function
    
    For i = 1 To Len(strChina)
        If Asc(Mid(strChina, i, 1)) < 0 Then
            strSQL = "select PYJM from SET_HZJM" _
                    & " where HZNM='" & Mid(strChina, i, 1) & "'"
            Set rstemp = New ADODB.Recordset
            rstemp.Open strSQL, GCon, adOpenStatic, adLockReadOnly
            If Not rstemp.EOF Then
                strRet = strRet & rstemp(0)
            End If
        Else
            strRet = strRet & Mid(strChina, i, 1)
        End If
    Next
    
    GoTo ExitLab
    
ErrMsg:
    Status = SetError(Err.Number, Err.Description, Err.Source)
    ErrMsg Status
    strRet = ""
ExitLab:
    GetPYJM = strRet
End Function

'局域网里搜索SQL服务器
'可以列出局域网内注册或未注册的SQL服务器
'参数：用于显示服务器名的组合框
Public Function GetLocalSQLServer(ByRef cmbServer As ComboBox) As Boolean
    Dim oSQLServerDMOApp   As SQLDMO.Application
    Dim oServerGroup   As SQLDMO.ServerGroup
    Dim oRegisteredServer   As SQLDMO.RegisteredServer
    Dim i   As Integer, j   As Integer
    Dim namX   As NameList
    Dim blnEquate As Boolean
    
    Screen.MousePointer = vbArrowHourglass
    
    Set oSQLServerDMOApp = New SQLDMO.Application
    
    cmbServer.Clear
    '首先显示的是注册了的数据库
    '处理所有服务器组
    For Each oServerGroup In oSQLServerDMOApp.ServerGroups
        '处理每个注册了的服务器
        For Each oRegisteredServer In oServerGroup.RegisteredServers
            '添加每个名字到  combobox
            cmbServer.AddItem oRegisteredServer.name
        Next
    Next
    Set oRegisteredServer = Nothing
    Set oServerGroup = Nothing

    '接下来显示尚未注册的数据库
    Set namX = oSQLServerDMOApp.ListAvailableSQLServers
    For i = 1 To namX.Count
        blnEquate = False
        '检查该服务器是否已经被列出来
        For j = 0 To cmbServer.ListCount - 1
            If cmbServer.List(j) = namX.item(i) Then
                blnEquate = True
                Exit For '退出内圈循环
            End If
        Next j
        If blnEquate = False Then
            cmbServer.AddItem namX.item(i)
        End If
    Next i
    
    '显示第一个服务器
    If cmbServer.ListCount > 0 Then
        cmbServer.ListIndex = 0
    End If
    
    Set namX = Nothing
    Set oSQLServerDMOApp = Nothing
    
    Screen.MousePointer = vbDefault
End Function

'存储照片文件到数据库
Public Function WriteToDB(ByRef col As ADODB.Field, ByVal FileName As String) As Boolean
On Error GoTo ErrMsg
    Dim mStream As ADODB.Stream
    Set mStream = New ADODB.Stream
    
    WriteToDB = False
    mStream.Type = adTypeBinary
    mStream.Open
    mStream.LoadFromFile FileName
    col.Value = mStream.Read
    
    mStream.Close
    Set mStream = Nothing
    WriteToDB = True
    Exit Function
ErrMsg:
    MsgBox "存储照片到数据库时出现错误．" & vbCrLf & Err.Description, vbExclamation, "提示"
End Function

'设置临时照片文件
Public Function ReadDB(col As ADODB.Field, ByRef imgFile As String) As Boolean
On Error GoTo ErrRead
    Dim mStream As New ADODB.Stream
    ReadDB = False
    
    If col.ActualSize < 200 Then Exit Function
    
    mStream.Type = adTypeBinary
    mStream.Open
    mStream.Write col.Value
    mStream.SaveToFile imgFile, adSaveCreateOverWrite
    ReadDB = True
    Exit Function
ErrRead:
     MsgBox "设置临时照片文件时出现错误:" & vbCrLf & Err.Description, vbInformation, "提示"
     ReadDB = False
End Function

'//////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
'创建一个标准执行模块，命名modErrorMsg，用于显示出错信息：
Public Sub ErrMsg(Status)
'The Status parameter should be passed as a variant array
'of 3 elements as listed"
' 0-Error Number
' 1-Error Description
' 2-Error Source

    'define local variables
    Dim strErr As String
    
    If Status(0) = 0 Then Exit Sub
    'Build the error information
    strErr = "Error " & Trim(CStr(Status(0))) & " In " & Status(2) & ":" & vbCrLf & Status(1)