frmcheckresult.frm

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

Attribute VB_Name = "frmCheckResult"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
'----------------------------------------------------------------------------------------------------
'文件：frmCheckResult.frm
'作者：冷家锋
'时间：2008-9-24
'说明：获取患者图片和报告
'----------------------------------------------------------------------------------------------------

Option Explicit
Const SECTION_WORKSTATION = "WORKSTATION"
Const KEY_DCM_LOCAL_ROOT = "DCM_LOCAL_ROOT"


'CHECK_LIST表中的ID
Dim m_strCheckListID As String

Dim DEFAULT_FILM_PATH As String


Dim m_strDcmLocalRoot As String

Private Sub Form_Load()
On Error GoTo ErrHandler
    DEFAULT_FILM_PATH = App.Path + "\NoImage.bmp"
    
    Call InitDcm(dcmResult)
    
    
    If dcmResult.LicenseIsOK = False Then
        MsgBox "程序错误, 重新安装可能解决问题.", vbExclamation, "加载"
        Exit Sub
    End If
    
    
    m_strDcmLocalRoot = GetDcmLocalRoot()
    
    Exit Sub
ErrHandler:
    
End Sub


'根据CHECK_LIST表中的ID获取患者的影像和诊断报告
'BY：冷家锋，2008-9-24
'p_strCheckListID<IN>:CHECK_LIST表中的ID
Public Function GetPatientFilmAndReport(ByVal p_strCheckListID As String)
    On Error GoTo ErrHandler
    Dim strErr As String
    Call GetPatientInfo(p_strCheckListID, strErr)
    
    Call GetPatientFilm(p_strCheckListID, strErr)
    
    Call GetPatientReport(p_strCheckListID, strErr)
    
    
    
    Exit Function
ErrHandler:
End Function




'根据CHECK_LIST表中的ID获取患者的影像
'BY：冷家锋，2008-9-24
'p_strCheckListID<IN>:CHECK_LIST表中的ID
'p_strErr<OUT>:输出的错误信息
Private Function GetPatientFilm(ByVal p_strCheckListID As String, ByRef p_strErr As String)
    On Error GoTo ErrHandler
    Dim strSql As String
    Dim strPhotoPath As String
    
    If Trim(p_strCheckListID) = "" Then
        p_strErr = "CHECK_LIST_ID为空."
        Exit Function
    End If
    
    
    strSql = "SELECT PHOTO_PATH FROM CHECK_PART WHERE CHECK_LIST_ID = '" _
        + p_strCheckListID + "' AND ROWNUM<=1 AND PHOTO_PATH IS NOT NULL  "
    
    Dim rsPart As New ADODB.Recordset
    If rsPart.State = adStateOpen Then
        rsPart.Close
    End If
    
    Dim myConn As New ADODB.Connection
    myConn.CursorLocation = adUseClient
    If myConn.State <> adStateOpen Then
        myConn.Open modGlobalDbConnect.GetConnectionString
    End If
    
    rsPart.Open strSql, myConn
    If rsPart.RecordCount <= 0 Then
        p_strErr = "该患者尚未拍片."
        strPhotoPath = ""
    Else
        If Not IsNull(rsPart.Fields("PHOTO_PATH")) Then
            strPhotoPath = rsPart.Fields("PHOTO_PATH")
            
            
            strPhotoPath = GetAbsolutePath(m_strDcmLocalRoot, strPhotoPath)
        End If
    End If
    

    If Trim(strPhotoPath) = "" Or Dir(strPhotoPath, vbArchive) = "" Then
        dcmResult.OpenFile DEFAULT_FILM_PATH
        dcmResult.ImageZoomBestFit = True
    Else
        dcmResult.OpenFileNameByMultiple = strPhotoPath
    End If
    
    dcmResult.ImageZoomBestFit = True
    dcmResult.ImageTool = 14
    
    
    
    
    myConn.Close
    Set myConn = Nothing
    Exit Function
ErrHandler:
    p_strErr = Err.Description
    Debug.Print Err.Description
End Function



'根据CHECK_LIST表中的ID获取患者的报告
'BY：冷家锋，2008-9-24
'p_strCheckListID<IN>:CHECK_LIST表中的ID
'p_strErr<OUT>:输出的错误信息
Private Function GetPatientReport(ByVal p_strCheckListID As String, ByRef p_strErr As String)
    On Error GoTo ErrHandler
    Dim strSql As String
    Dim strPhotoPath As String
    
    If Trim(p_strCheckListID) = "" Then
        p_strErr = "CHECK_LIST_ID为空."
        Exit Function
    End If
    
    
    strSql = "SELECT PHOTO_DESCRIPTION, IMPRESSION FROM CHECK_REPORT WHERE CHECK_LIST_ID = '" _
        + p_strCheckListID + "' AND ROWNUM<=1 ORDER  BY CHECK_DATE  "
    
    Dim rsReport As New ADODB.Recordset
    If rsReport.State = adStateOpen Then
        rsReport.Close
    End If
    
    Dim myConn As New ADODB.Connection
    myConn.CursorLocation = adUseClient
    If myConn.State <> adStateOpen Then
        myConn.Open modGlobalDbConnect.GetConnectionString
    End If
    
    rsReport.Open strSql, myConn
    If rsReport.RecordCount <= 0 Then
        p_strErr = "该患者尚未出报告."
        txtFilmInformation.Text = ""
    Else
        If Not IsNull(rsReport.Fields("PHOTO_DESCRIPTION")) Then
            txtFilmInformation.Text = rsReport.Fields("PHOTO_DESCRIPTION")
        End If
        
        If Not IsNull(rsReport.Fields("IMPRESSION")) Then
            txtDiagnoseResult.Text = rsReport.Fields("IMPRESSION")
        End If
        
    End If
    

    
    
    
    myConn.Close
    Set myConn = Nothing
    Exit Function
ErrHandler:
    p_strErr = Err.Description
    Debug.Print Err.Description
End Function


'根据CHECK_LIST表中的ID获取患者的信息
'BY：冷家锋，2008-9-24
'p_strCheckListID<IN>:CHECK_LIST表中的ID
'p_strErr<OUT>:输出的错误信息
Private Function GetPatientInfo(ByVal p_strCheckListID As String, ByRef p_strErr As String)
On Error GoTo ErrHandler
    '检查编号，姓名，姓名拼音，性别，年龄，
    '出生日期，住院号，病床号，
    '诊断医生
    Dim strSql As String
    strSql = "SELECT ID,PATIENT_ID as 检查编号,PATIENT_NAME as 姓名,PATIENT_NAME_PHONETIC as 姓名拼音, " _
        + " PATIENT_SEX as 性别,to_char(PATIENT_AGE)||AGE_WEIGHT as 年龄," _
        + "PATIENT_BIRTHDAY as 出生日期, HOSPITAL_NUM as 住院号, BED_NUM as 病床号, CHECK_DOCT_ID as 诊断医生," _
        + " MERGEPARTS(id) as 检查部位 " _
        + " FROM CHECK_LIST " _
        + " WHERE ID='" + p_strCheckListID + "'"

    Dim rsPatient As New ADODB.Recordset
    If rsPatient.State = adStateOpen Then
        rsPatient.Close
    End If
    
    Dim myConn As New ADODB.Connection
    myConn.CursorLocation = adUseClient
    If myConn.State <> adStateOpen Then
        myConn.Open modGlobalDbConnect.GetConnectionString
    End If
    rsPatient.Open strSql, myConn

    If rsPatient.RecordCount <= 0 Then
        Exit Function
    End If
    
    If Not IsNull(rsPatient.Fields("检查编号")) Then
        lblCheckNumber.Caption = rsPatient.Fields("检查编号")
    End If
    
    If Not IsNull(rsPatient.Fields("姓名")) Then
        lblName.Caption = rsPatient.Fields("姓名")
    End If
    
    If Not IsNull(rsPatient.Fields("姓名拼音")) Then
        lblNamePhonetic.Caption = rsPatient.Fields("姓名拼音")
    End If
    
    If Not IsNull(rsPatient.Fields("性别")) Then
        lblSex.Caption = rsPatient.Fields("性别")
    End If
    
    If Not IsNull(rsPatient.Fields("年龄")) Then
        lblAge.Caption = rsPatient.Fields("年龄")
    End If
    
    If Not IsNull(rsPatient.Fields("出生日期")) Then
        lblBirthday.Caption = rsPatient.Fields("出生日期")
    End If
    
    If Not IsNull(rsPatient.Fields("住院号")) Then
        lblHospitalNumber.Caption = rsPatient.Fields("住院号")
    End If
    
    
    
    If Not IsNull(rsPatient.Fields("病床号")) Then
        lblBedNumber.Caption = rsPatient.Fields("病床号")
    End If
    
    
    If Not IsNull(rsPatient.Fields("诊断医生")) Then
        lblCheckDoctor.Caption = rsPatient.Fields("诊断医生")
    End If
    
    
    If Not IsNull(rsPatient.Fields("检查部位")) Then
        lblCheckPart.Caption = rsPatient.Fields("检查部位")
    End If


    '检查部位，检查方式，



    Exit Function
ErrHandler:

End Function
    













Private Function GetDcmLocalRoot() As String
On Error GoTo ErrHandler
    '====胶片本地存放根目录============================================================
    Dim strConfigPath As String
    strConfigPath = App.Path + "\" + CONFIG_FILE_NAME
    
    
    GetDcmLocalRoot = Space(256)
    
    Dim nRet As Long
    nRet = GetPrivateProfileString(SECTION_WORKSTATION, KEY_DCM_LOCAL_ROOT, _
        "", GetDcmLocalRoot, 256, strConfigPath)
    GetDcmLocalRoot = Trim(left(GetDcmLocalRoot, nRet))
    GetDcmLocalRoot = DelInvaildChr(GetDcmLocalRoot)

    Exit Function
ErrHandler:
    GetDcmLocalRoot = ""

End Function