modreportedit.bas

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

        If Not IsNull(rsPatient.Fields("检查方式")) Then
            p_PatientInfo.METHOD = rsPatient.Fields("检查方式")
        Else
            p_PatientInfo.METHOD = ""
        End If
        
    rsPatient.Close
    Set rsPatient = Nothing
    
    InitPatientInfo = True
    Exit Function
ErrHandler:
    p_strError = Err.Description
    InitPatientInfo = False
    Debug.Print Err.Description
End Function





'作者：冷家锋
'时间：2008-11-11-10-52
'说明: 初始化性别下拉框，常规为"男","女","未知"
'p_Sex<OUT>:性别下拉框
'p_strError<OUT>：函数执行过程中的错误信息
'返回值：患者信息初始化正确，返回TRUE，否则返回FALSE
Public Function InitCmbSex(ByRef p_Sex As ComboBox, ByRef p_strError As String) As Boolean
    On Error GoTo ErrHandler
    Const STR_MALE = "男"
    Const STR_FEMALE = "女"
    Const STR_UNKNOWN = "未知"
    p_Sex.Clear
    p_Sex.AddItem STR_MALE
    p_Sex.AddItem STR_FEMALE
    p_Sex.AddItem STR_UNKNOWN
    
    InitCmbSex = True
    Exit Function
ErrHandler:
    p_strError = Err.Description
    InitCmbSex = False
End Function


'作者：冷家锋
'时间：2008-11-11-10-52
'说明: 初始化年龄单位下拉框，常规为"岁","月","天","未知"
'p_AgeWeight<OUT>:年龄单位下拉框
'p_strError<OUT>：函数执行过程中的错误信息
'返回值：患者信息初始化正确，返回TRUE，否则返回FALSE
Public Function InitCmbAgeWeight(ByRef p_AgeWeight As ComboBox, ByRef p_strError As String) As Boolean
    On Error GoTo ErrHandler
    Const STR_YEAR = "岁"
    Const STR_MONTH = "月"
    Const STR_DAY = "天"
    Const STR_UNKNOWN = "未知"
    p_AgeWeight.Clear
    p_AgeWeight.AddItem STR_YEAR
    p_AgeWeight.AddItem STR_MONTH
    p_AgeWeight.AddItem STR_DAY
    p_AgeWeight.AddItem STR_UNKNOWN
    
    InitCmbAgeWeight = True
    Exit Function
ErrHandler:
    p_strError = Err.Description
    InitCmbAgeWeight = False
End Function


'作者：冷家锋
'时间：2008-11-11-10-52
'说明: 根据影像科室ID初始化申请科室
'p_FilmDeptID<IN>:影像科室ID, 将来的数据库拟将申请科室放置于一个独立的表，以影像科ID作为筛选依据
'p_strApplyDept<OUT>:申请科室数组, 为2维STRING数组：申请科室ID，申请科室名称
'p_nApplyDeptCount<IN>：申请科室记录条数
'p_DBConn<IN>:数据库连接
'p_strError<OUT>：函数执行过程中的错误信息
'返回值：患者信息初始化正确，返回TRUE，否则返回FALSE
Public Function InitApplyDept(ByVal p_FilmDeptID As String, _
    ByRef p_ApplyDept() As DeptInfo, _
    ByRef p_nApplyDeptCount As Long, _
    ByVal p_DBConn As ADODB.Connection, _
    ByRef p_strError As String) As Boolean
On Error GoTo ErrHandler
    If p_DBConn Is Nothing Then
        p_strError = "数据库连接尚未初始化"
        InitApplyDept = False
        Exit Function
    End If
        
    If p_DBConn.STATE <> adStateOpen Then
         p_strError = "数据库连接尚未打开"
        InitApplyDept = False
        Exit Function
    End If
    
    If p_DBConn.CursorLocation <> adUseClient Then
        p_DBConn.CursorLocation = adUseClient
    End If
'=========================================================================]
    


    Dim strSql As String
    strSql = "SELECT ID ,Name FROM Department WHERE ORDER_KEY IS NOT NULL  ORDER BY ORDER_KEY "
    Dim rsDepartment As New ADODB.Recordset
    
    
    
    Dim i As Long
    i = 0
    p_nApplyDeptCount = 0
    If rsDepartment.STATE <> adStateClosed Then
        rsDepartment.Close
    End If
    
    rsDepartment.Open strSql, p_DBConn
    If rsDepartment.RecordCount <= 0 Then
        ReDim p_ApplyDept(0)
        p_strError = "该影像科室没有对应的<申请科室>"
        InitApplyDept = False
        Exit Function
    Else
        ReDim p_ApplyDept(0 To rsDepartment.RecordCount - 1)
        Do While Not rsDepartment.EOF And Not rsDepartment.BOF
             If Not IsNull(rsDepartment.Fields("Name")) Or Not IsNull(rsDepartment.Fields("ID")) Then
                 p_ApplyDept(i).DEPT_ID = rsDepartment.Fields("ID")
                 p_ApplyDept(i).DEPT_NAME = rsDepartment.Fields("Name")
                 i = i + 1
                 p_nApplyDeptCount = i
             End If
             rsDepartment.MoveNext
         Loop
    End If
        
    rsDepartment.Close
    Set rsDepartment = Nothing
    
    InitApplyDept = True
    Exit Function
ErrHandler:
    ReDim p_ApplyDept(0)
    p_strError = Err.Description
    InitApplyDept = False
End Function
    
'作者：冷家锋
'时间：2008-11-11-12:34
'说明: 根据影像科室ID初始化申请科室
'p_FilmDeptID<IN>:影像科室ID, 将来的数据库拟将申请科室放置于一个独立的表，以影像科ID作为筛选依据
'p_strApplyDept<OUT>:申请科室数组, 为2维STRING数组：申请科室ID，申请科室名称
'p_nApplyDeptCount<IN>：申请科室记录条数
'p_DBConn<IN>:数据库连接
'p_strError<OUT>：函数执行过程中的错误信息
'返回值：患者信息初始化正确，返回TRUE，否则返回FALSE
Public Function GetApplyDocts(ByVal p_ApplyDeptID As String, _
    ByRef p_CmbApplyDoct As ComboBox, _
    ByVal p_DBConn As ADODB.Connection, _
    ByRef p_strError As String) As Boolean
    
    On Error GoTo ErrHandler
    If Trim(p_ApplyDeptID) = "" Then
        p_strError = "申请科室ID为空"
        GetApplyDocts = False
        Exit Function
    End If
    
    
    
     If p_DBConn Is Nothing Then
        p_strError = "数据库连接尚未初始化"
        GetApplyDocts = False
        Exit Function
    End If
        
    If p_DBConn.STATE <> adStateOpen Then
         p_strError = "数据库连接尚未打开"
        GetApplyDocts = False
        Exit Function
    End If
    
    If p_DBConn.CursorLocation <> adUseClient Then
        p_DBConn.CursorLocation = adUseClient
    End If
'=========================================================================]
    p_CmbApplyDoct.Clear
        
    Dim strSql As String
    strSql = "SELECT  NAME FROM DOCTOR WHERE DepartmentID = '" _
        + Trim(p_ApplyDeptID) + "'"
    
    
    Dim rsDoctors As New ADODB.Recordset
    If rsDoctors.STATE <> adStateClosed Then
        rsDoctors.Close
    End If
    
    rsDoctors.Open strSql, p_DBConn
    If rsDoctors.RecordCount <= 0 Then
        p_strError = "该<科室>尚未添加申请医生"
        GetApplyDocts = False
        Exit Function
    Else
        Do While Not rsDoctors.EOF And Not rsDoctors.BOF
            If Not IsNull(rsDoctors.Fields("Name")) Then
                p_CmbApplyDoct.AddItem rsDoctors.Fields("Name")
            End If
            rsDoctors.MoveNext
        Loop
    End If
    
    rsDoctors.Close
    Set rsDoctors = Nothing
    GetApplyDocts = True
    Exit Function
ErrHandler:
    p_strError = Err.Description
    GetApplyDocts = False
End Function


'作者：冷家锋
'时间：2008-11-11-10-52
'说明: 初始化年龄单位下拉框，常规为"岁","月","天","未知"
'p_AgeWeight<OUT>:年龄单位下拉框
'p_strError<OUT>：函数执行过程中的错误信息
'返回值：患者信息初始化正确，返回TRUE，否则返回FALSE
Public Function InitPatientState( _
    ByRef p_CmbState As ComboBox, _
    ByVal p_DBConn As ADODB.Connection, _
    ByRef p_strError As String) As Boolean
    On Error GoTo ErrHandler
     If p_DBConn Is Nothing Then
        p_strError = "数据库连接尚未初始化"
        InitPatientState = False
        Exit Function
    End If
        
    If p_DBConn.STATE <> adStateOpen Then
         p_strError = "数据库连接尚未打开"
        InitPatientState = False
        Exit Function
    End If
    
    If p_DBConn.CursorLocation <> adUseClient Then
        p_DBConn.CursorLocation = adUseClient
    End If
'=========================================================================]
    Dim strSql As String
    strSql = "SELECT STATE FROM STATE"
    Dim rsState As New ADODB.Recordset
    If rsState.STATE <> adStateClosed Then
        rsState.Close
    End If
    
    rsState.Open strSql, p_DBConn
    If rsState.RecordCount <= 0 Then
        InitPatientState = False
        Exit Function
    End If
    
    p_CmbState.Clear
    While Not rsState.EOF And Not rsState.BOF
        If Not IsNull(rsState.Fields("STATE")) Then
            p_CmbState.AddItem rsState.Fields("STATE")
        End If
        
        rsState.MoveNext
    Wend
    
    rsState.Close
    Set rsState = Nothing
    
    InitPatientState = True
    Exit Function
ErrHandler:
    p_strError = Err.Description
    InitPatientState = False
End Function





'作者：冷家锋
'时间：2008-11-11-10-52
'说明: 初始化<检查词库>
'p_DeptID<IN>:影像科室ID, 将来的数据库拟将申请科室放置于一个独立的表，以影像科ID作为筛选依据
'p_lvCheckDictionary<OUT>:词库ListView
'p_DBConn<IN>:数据库连接
'p_strError<OUT>：函数执行过程中的错误信息
'返回值：患者信息初始化正确，返回TRUE，否则返回FALSE
Public Function InitCheckDictionary( _
    ByVal p_DeptID As String, _
    ByRef p_lvCheckDictionary As ListView, _
    ByVal p_DBConn As ADODB.Connection, _
    ByRef p_strError As String) As Boolean
    On Error GoTo ErrHandler
     
     If Trim(p_DeptID) = "" Then
        p_strError = "影像科室ID为空"
        InitCheckDictionary = False
        Exit Function
     End If
     
     If p_DBConn Is Nothing Then
        p_strError = "数据库连接尚未初始化"
        InitCheckDictionary = False
        Exit Function
    End If
        
        
    If p_DBConn.STATE <> adStateOpen Then
         p_strError = "数据库连接尚未打开"
        InitCheckDictionary = False
        Exit Function
    End If
    
    If p_DBConn.CursorLocation <> adUseClient Then
        p_DBConn.CursorLocation = adUseClient
    End If
'=========================================================================]
    Dim strSql As String
    Dim rsLsv As New ADODB.Recordset
    
    strSql = "SELECT ID,CONTENT AS 词库 FROM WORD_STOREROOM WHERE DEPT_ID='" + p_DeptID + "' ORDER BY ORDER_KEY"
    
  
    If rsLsv.STATE = adStateOpen Then
        rsLsv.Close
    End If
    
    rsLsv.Open strSql, p_DBConn
    Dim i As Integer
    Dim j As Integer
    
    p_lvCheckDictionary.View = lvwReport
    p_lvCheckDictionary.ListItems.Clear
    p_lvCheckDictionary.ColumnHeaders.Clear
    
    p_lvCheckDictionary.ColumnHeaders.Add , , rsLsv.Fields(0).Name, 0
    p_lvCheckDictionary.ColumnHeaders.Add , , rsLsv.Fields(1).Name, p_lvCheckDictionary.Width - 60

    
    If rsLsv.RecordCount <= 0 Then
        p_strError = "尚未添加<词库>信息"
        InitCheckDictionary = False
    Else
        rsLsv.MoveFirst
        For i = 0 To rsLsv.RecordCount - 1
            If Not IsNull(rsLsv.Fields("ID")) Then
                p_lvCheckDictionary.ListItems.Add , , rsLsv(0).Value
                For j = 1 To rsLsv.Fields.Count - 1
                    If IsNull(rsLsv(j).Value) = False Then
                        p_lvCheckDictionary.ListItems(i + 1).SubItems(j) = rsLsv(j).Value
                    End If
                Next
            End If
            rsLsv.MoveNext