vb808.tmp

1、以DLL形式提供医生工作站 2、 根据【检查项目】

Private Sub Form_Resize()
'================================================================
    Me.Left = RIGHT_WINDOW_LEFT
    Me.Top = RIGHT_WINDOW_TOP
    Me.Width = RIGHT_WINDOW_WIDTH
    Me.Height = RIGHT_WINDOW_HEIGHT
    
'================================================================
    Me.tabMaintain.Width = Me.Width - 2 * Me.tabMaintain.Left
    Me.tabMaintain.Height = Me.Height - 2 * Me.tabMaintain.Top
    
'================================================================
    'Me.picMainPart.Width = Me.tabMaintain.Width - Me.picMainPart.left * 2
    'Me.picMainPart.Height = Me.tabMaintain.Height - Me.picMainPart.top * 2
    
    'picCheckMethod.Width = Me.picMainPart.Width
    'picCheckMethod.Height = Me.picMainPart.Height
    
    
    'Me.picCheckPart.Width = Me.tabMaintain.Width - Me.picCheckPart.left * 2
    'Me.picCheckPart.Height = Me.tabMaintain.Height - Me.picCheckPart.top
    '
    'Me.picCheckMethod.left = Me.picCheckPart.left
    'Me.picCheckMethod.Width = Me.picCheckPart.Width
    'Me.picCheckMethod.Height = Me.picCheckPart.Height
    '
    'Me.picState.left = Me.picState.left
    'Me.picState.Width = Me.picCheckPart.Width
    'Me.picState.Height = Me.picCheckPart.Height
End Sub





'检查部位----初始化主部位
Private Function InitMainParts() As Boolean
    On Error GoTo ErrHandler
    Dim strSql As String
    strSql = "SELECT  Name  FROM CheckMainPart "
    Dim rsMainPart As New ADODB.Recordset
    If rsMainPart.State = adStateOpen Then
        rsMainPart.Close
    End If
    If myConn.State <> adStateClosed Then
        myConn.Close
    End If
    myConn.Open modGlobalDbConnect.GetConnectionString
    rsMainPart.Open strSql, myConn
    
    
    lstPartMainPart.Clear
    Dim i As Long
    For i = 0 To rsMainPart.RecordCount - 1
        If Not IsNull(rsMainPart.Fields("Name")) Then
            lstPartMainPart.AddItem rsMainPart.Fields("Name")
        End If
        rsMainPart.MoveNext
    Next
    
    InitMainParts = True
    Exit Function
ErrHandler:
    InitMainParts = False
End Function




'检查部位----初始化子部位
Private Function InitSubParts(ByVal strMainPart As String) As Boolean
On Error GoTo ErrHandler
    Dim strSql As String
    
    
    lstSubNumber.Clear
    lstSubPart.Clear
    If Trim(strMainPart) = "" Then
        InitSubParts = False
        Exit Function
    End If
    
    
    strSql = "SELECT ID FROM CHECKMAINPART WHERE rownum<=1 AND  NAME='" _
        + strMainPart + "'"
    Dim rsMainPart As New ADODB.Recordset
    If rsMainPart.State = adStateOpen Then
        rsMainPart.Close
    End If
    
    
    Dim myConn As New ADODB.Connection
    myConn.CursorLocation = adUseClient
    If myConn.State <> adStateOpen Then
        myConn.Open modGlobalDbConnect.GetConnectionString
    End If
    
    rsMainPart.Open strSql, myConn
    
    If rsMainPart.RecordCount <> 1 Or IsNull(rsMainPart.Fields("ID")) Then
        InitSubParts = False
        Exit Function
    End If
    Dim strMainPartId As String
    strMainPartId = CStr(rsMainPart.Fields("ID"))
    
    If strMainPartId = "" Then
        InitSubParts = False
        Exit Function
    End If
    
    
    strSql = "SELECT DISTINCT ID AS 序号, Name as 子部位名称 FROM CheckSubPart " _
        + " WHERE CheckMainPartId = '" + CStr(strMainPartId) + "'"
    
    Dim rsSubPart As New ADODB.Recordset
    If rsSubPart.State = adStateOpen Then
        rsSubPart.Close
    End If
    
    rsSubPart.Open strSql, myConn
    Dim i As Integer
    
    If rsSubPart.RecordCount <= 0 Then
        'MsgBox "尚未添加子部位, 请及时添加!", vbExclamation, "提示"
        Exit Function
    End If
    For i = 0 To rsSubPart.RecordCount - 1
        If Not IsNull(rsSubPart.Fields("序号")) And Not IsNull(rsSubPart.Fields("子部位名称")) Then
            lstSubNumber.AddItem rsSubPart.Fields("序号")
            lstSubPart.AddItem rsSubPart.Fields("子部位名称")
        End If
        rsSubPart.MoveNext
    Next
    
    InitSubParts = True
    Exit Function
ErrHandler:
    InitSubParts = False
    MsgBox Err.Description, vbExclamation, "提示"
End Function






Private Sub lstCheckMethod_Click()
    On Error GoTo ErrHandler
    lstMethodNumber.ListIndex = lstCheckMethod.ListIndex
    txtMethod.Text = lstCheckMethod.Text
    Exit Sub
ErrHandler:
    Debug.Print Err.Description
End Sub



'检查部位----主部位
Private Sub lstPartMainPart_Click()
    On Error GoTo ErrHandler
    
    txtMainPart.Text = ""
    txtSubPart.Text = ""
    
    
    If lstPartMainPart.ListCount <= 0 Or Trim(lstPartMainPart.Text) = "" Then
        Exit Sub
    End If
    
    Call InitSubParts(lstPartMainPart.Text)
    
    '检查部位
    txtMainPart.Text = Trim(lstPartMainPart.Text)
    
    Exit Sub
ErrHandler:
    MsgBox Err.Description, vbExclamation, "提示"
End Sub

Private Sub lstPatientState_Click()
    On Error GoTo ErrHandler
    lstPatientStateId.ListIndex = lstPatientState.ListIndex
    txtPatientState.Text = lstPatientState.Text
    
    
    Exit Sub
ErrHandler:
    MsgBox "赋值错误, 原因:" + Err.Description, vbExclamation, "提示"
End Sub

Private Sub lstSubPart_Click()
    On Error GoTo ErrHandler
    lstSubNumber.ListIndex = lstSubPart.ListIndex
    txtSubPart.Text = lstSubPart.Text
    Exit Sub
ErrHandler:
    Debug.Print Err.Description
End Sub




'初始化 检查方式 中的主部位下拉框
Private Function InitMethodMainPart() As Boolean
    On Error GoTo ErrHandler
    Dim strSql As String
    strSql = "SELECT ID AS 序号, Name as 主部位名称 FROM CheckMainPart "
    Dim rsMethodMainPart As New ADODB.Recordset
    If rsMethodMainPart.State = adStateOpen Then
        rsMethodMainPart.Close
    End If
    
    If myConn.State <> adStateClosed Then
        myConn.Close
    End If
    myConn.Open modGlobalDbConnect.GetConnectionString
    rsMethodMainPart.Open strSql, myConn
    Dim i As Integer
    cmbMainPart.Clear
    cmbMainPartId.Clear
    For i = 0 To rsMethodMainPart.RecordCount - 1
        If Not IsNull(rsMethodMainPart.Fields("主部位名称").Value) Then
            cmbMainPart.AddItem rsMethodMainPart.Fields("主部位名称").Value
        End If
        
        If Not IsNull(rsMethodMainPart.Fields("序号")) Then
            cmbMainPartId.AddItem rsMethodMainPart.Fields("序号")
        End If
        rsMethodMainPart.MoveNext
    Next
    If cmbMainPart.ListCount > 0 Then
        cmbMainPart.ListIndex = 0
    End If
    
    InitMethodMainPart = True
    Exit Function
ErrHandler:
    Debug.Print Err.Description
    InitMethodMainPart = False
End Function









'初始化 检查方式 中的子部位下拉框
Private Function InitMethodSubParts(ByVal nMainPartId As Long) As Boolean
On Error GoTo ErrHandler

    
    Dim strSql As String
    strSql = "SELECT DISTINCT ID AS 序号, Name as 子部位名称 FROM CheckSubPart " _
        + " WHERE CheckMainPartId = '" + CStr(nMainPartId) + "'"
    
    Dim rsMethodSubPart As New ADODB.Recordset
    If rsMethodSubPart.State = adStateOpen Then
        rsMethodSubPart.Close
    End If
    
    If myConn.State <> adStateClosed Then
        myConn.Close
    End If
    myConn.Open modGlobalDbConnect.GetConnectionString
    rsMethodSubPart.Open strSql, myConn

    Dim i As Integer
    If rsMethodSubPart.RecordCount <= 0 Then
        MsgBox "尚未添加子部位, 请及时添加!", vbExclamation, "提示"
    End If
    
    
    cmbSubPart.Clear
    cmbSubPartId.Clear
    For i = 0 To rsMethodSubPart.RecordCount - 1
        
        If Not IsNull(rsMethodSubPart.Fields("子部位名称")) And Not IsNull(rsMethodSubPart.Fields("序号")) Then
            cmbSubPart.AddItem rsMethodSubPart.Fields("子部位名称")
            cmbSubPartId.AddItem rsMethodSubPart.Fields("序号")
        End If
        
        rsMethodSubPart.MoveNext
    Next
    
    InitMethodSubParts = True
    Exit Function
ErrHandler:
    InitMethodSubParts = False
End Function





'检查方式--检查方式
Private Function InitMethodMethods(ByVal nSubPartId As Long) As Boolean
On Error GoTo ErrHandler
    Dim strSql As String
    strSql = "SELECT DISTINCT ID AS 序号, Name as 检查方法 FROM CheckMethod " _
        + " WHERE CheckSubPartId = '" + CStr(nSubPartId) + "'"
    
    Dim rsMethodMethods As New ADODB.Recordset
    If rsMethodMethods.State = adStateOpen Then
        rsMethodMethods.Close
    End If
    
    If myConn.State <> adStateClosed Then
        myConn.Close
    End If
    myConn.Open modGlobalDbConnect.GetConnectionString
    rsMethodMethods.Open strSql, myConn

    Dim i As Integer
    If rsMethodMethods.RecordCount <= 0 Then
        'MsgBox "尚未添加检查方式, 请及时添加!", vbExclamation, "提示"
        Exit Function
    End If
    
    lstCheckMethod.Clear
    lstMethodNumber.Clear
    For i = 0 To rsMethodMethods.RecordCount - 1
        lstCheckMethod.AddItem rsMethodMethods.Fields("检查方法")
        lstMethodNumber.AddItem rsMethodMethods.Fields("序号")
        
        rsMethodMethods.MoveNext
    Next
    
    InitMethodMethods = True
    Exit Function
ErrHandler:
    InitMethodMethods = False
End Function




'初始化 患者 状态
Private Function InitPatientStates() As Boolean
    On Error GoTo ErrHandler
    Dim strSql As String
    strSql = "SELECT ID AS 序号, State as 状态 FROM State "
    Dim rsPatientStates As New ADODB.Recordset
    If rsPatientStates.State = adStateOpen Then
        rsPatientStates.Close
    End If
    
    If myConn.State <> adStateClosed Then
        myConn.Close
    End If
    myConn.Open modGlobalDbConnect.GetConnectionString
    rsPatientStates.Open strSql, myConn
    
    lstPatientState.Clear
    lstPatientStateId.Clear
    Dim i As Integer
    For i = 0 To rsPatientStates.RecordCount - 1
        lstPatientState.AddItem rsPatientStates.Fields("状态")
        lstPatientStateId.AddItem rsPatientStates.Fields("序号")
        rsPatientStates.MoveNext
    Next
    
    InitPatientStates = True
    Exit Function
ErrHandler:
    InitPatientStates = False
    
End Function