frmmdimain.frm

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

'    dg.ColWidth(17) = 4 / 3 * wid
    

    dg.ColWidth(14) = 0 '打印
    dg.ColWidth(15) = 0 '提请审核
    dg.ColWidth(16) = 0 '审核通过
    dg.ColWidth(17) = 0

    dg.ColWidth(18) = 2400 ' 2 * wid
    
    'Me.dgResult.ColWidth(8) = (1 + 1 / 3) * wid
    'Me.dgResult.ColWidth(10) = (1 + 1 / 3) * wid
    
End Sub


'方法--初始化检查项目
'p_strErr<string>[in,out] 错误信息
Private Function InitCheckItems(ByRef p_strErr As String) As Boolean
On Error GoTo ErrHandler
    Dim rsRegister As New ADODB.Recordset
    myConn.CursorLocation = adUseClient
    If myConn.STATE = adStateClosed Then
        myConn.Open modGlobalDbConnect.GetConnectionString
    End If
    
    If myConn.STATE <> adStateOpen Then
        p_strErr = "数据库连接错误,请与系统管理员联系!"
        InitCheckItems = False
        Exit Function
    End If
    
    Dim strSql As String
    strSql = "SELECT ID,NAME FROM DEPARTMENT WHERE POWER='5'"

    If rsRegister.STATE = adStateOpen Then
        rsRegister.Close
    End If
    
    rsRegister.Open strSql, myConn
    If rsRegister.RecordCount > 0 Then
        rsRegister.MoveFirst
        Dim i As Long
        For i = 0 To rsRegister.RecordCount - 1
            If Not IsNull(rsRegister.Fields("ID")) And Not IsNull(rsRegister.Fields("NAME")) Then
                cmbCheckItemID.AddItem Trim(rsRegister.Fields("ID"))
                cmbCheckItemName.AddItem Trim(rsRegister.Fields("NAME"))
                cmbCheckItemName.ListIndex = cmbCheckItemID.ListIndex
            End If
            rsRegister.MoveNext
        Next
        If cmbCheckItemName.ListCount > 0 And cmbCheckItemID.ListCount > 0 Then
            cmbCheckItemName.ListIndex = cmbCheckItemID.ListIndex = 0
        End If
        
    Else
        InitCheckItems = False
        p_strErr = "数据库中未找到相关检查项目!请与系统管理员联系."
        Exit Function
    End If
    
    InitCheckItems = True
    
    Exit Function
ErrHandler:
    InitCheckItems = False
    p_strErr = Err.Description
End Function


'方法---根据检查记录ID，初始化图片列表
'作者：刘辉
'时间：20090202
'p_strCheckListID<string>[in]:患者记录ID
'p_DBConn<ADODB.Connection>[in]:数据库连接
'p_strErr<string>[in,out]:错误信息
'返回值：ture(成功) or false(失败)

Private Function InitFilmList(ByVal p_strCheckListID As String, _
    ByVal p_DBConn As ADODB.Connection, _
    ByRef p_strErr As String) As Boolean
On Error GoTo ErrHandler
    If p_strCheckListID = "" Then
        p_strErr = "p_strCheckListID为空"
        InitFilmList = False
        Exit Function
    End If
    
    If p_DBConn Is Nothing Then
        p_strErr = "数据库连接尚未初始化"
        InitFilmList = False
        Exit Function
    End If
    
    If p_DBConn.STATE <> adStateOpen Then
         p_strErr = "数据库连接尚未初始化"
        InitFilmList = False
        Exit Function
    End If
    
    Dim nCheckPartCount As Long
    Dim strSql As String
    Dim rsGetFilmPath As New ADODB.Recordset
    If rsGetFilmPath.STATE = adStateOpen Then
        rsGetFilmPath.Close
    End If
    
    strSql = "SELECT PHOTO_PATH FROM CHECK_PART WHERE CHECK_LIST_ID='" + p_strCheckListID + "'"
    rsGetFilmPath.Open strSql, p_DBConn
    
    nCheckPartCount = rsGetFilmPath.RecordCount
    Dim i As Long
    For i = 0 To nCheckPartCount - 1
        Load dcmList(i)
        InitDcm (dcmList(i))
        
        dcmList(i).left = picBottom.Width / 5
        dcmList(i).FreeMemory
        dcmList(i).Visible = False
    Next
    
        
        
    If rsGetFilmPath.RecordCount > 0 Then
        rsGetFilmPath.MoveFirst
        For i = 0 To nCheckPartCount - 1
            If Not IsNull(rsGetFilmPath.Fields("PHOTO_PATH")) Then
                dcmList(i).OPENFILENAME = rsGetFilmPath("PHOTO_PATH")
            End If
            rsGetFilmPath.MoveNext
        Next
    Else
        
    End If
    
    InitFilmList = True
    Exit Function
ErrHandler:
    InitFilmList = False
    p_strErr = Err.Description
End Function




'说明：初始化患者部位路径信息
'p_strCheckListID <IN>: CHECKLIST 的ID
'p_strPartPaths    <OUT>: 图像路径数组
'p_nPartPathCount <IN>: 图像路径数组个数
'p_DBConn <IN>: 数据库连接
'p_strError <OUT>: 执行过程中遇到的错误
'Return Value: True if Success, False if Failure
Public Function InitPartsInfo(ByVal p_strCheckListID As String, _
    ByRef p_strPartPaths() As String, ByRef p_nPartPathCount As Long, _
    ByVal p_DBConn As ADODB.Connection, _
    ByRef p_strError As String) As Boolean
On Error GoTo ErrHandler
    If p_strCheckListID = "" Then
        p_strError = ""
        InitPartsInfo = False
        Exit Function
    End If
    
    If p_DBConn Is Nothing Then
        If InitDBConnect(p_DBConn, p_strError) Then
            p_strError = "数据库连接尚未初始化"
            InitPartsInfo = False
        End If
        Exit Function
    End If
    '==============================================================
    
    Dim strSql As String, i As Long
    
    strSql = "SELECT ID ,PHOTO_PATH FROM CHECK_PART  WHERE CHECK_LIST_ID = '" _
        + p_strCheckListID + "' AND IS_PHOTO_DELETED ='否'"
    
    Dim rsPhotoPath As New ADODB.Recordset
    If rsPhotoPath.STATE <> adStateClosed Then
        rsPhotoPath.Close
    End If
    
    If p_DBConn.CursorLocation <> adUseClient Then
        p_DBConn.CursorLocation = adUseClient
    End If
    
    If p_DBConn.STATE <> adStateOpen Then
        p_strError = "数据库连接尚未打开"
        InitPartsInfo = False
        Exit Function
    End If
    
    rsPhotoPath.Open strSql, p_DBConn
    
    Dim strDcmListFileName As String

    p_nPartPathCount = rsPhotoPath.RecordCount
    If p_nPartPathCount <= 0 Then
        p_strError = "患者图像路径数为0(零)"
        ReDim p_strPartPaths(0)
        InitPartsInfo = False
        Exit Function
    End If
    
    ReDim p_strPartPaths(0 To p_nPartPathCount - 1)
    
    For i = 0 To p_nPartPathCount - 1
        If Not IsNull(rsPhotoPath.Fields("PHOTO_PATH")) Then
             p_strPartPaths(i) = GetAbsolutePath(DCM_LOCAL_ROOT, rsPhotoPath.Fields("PHOTO_PATH"))
        End If
        rsPhotoPath.MoveNext
    Next
    
    rsPhotoPath.Close
    Set rsPhotoPath = Nothing
    
    InitPartsInfo = True
    Exit Function
ErrHandler:
    p_strError = "患者图像路径获取失败"
    InitPartsInfo = False
End Function




'说明：初始化数据库连接，
'作者：冷家锋
'时间：2008-11-12 09：35
'p_DBConn   <OUT>:  待初始化的数据库连接
'p_strErr       <OUT>：函数执行过程中的错误信息
Public Function InitDBConnect(ByRef p_DBConn As ADODB.Connection, ByRef p_strErr As String) As Boolean
    On Error GoTo ErrHandler
    If p_DBConn.STATE <> adStateOpen Then
        p_DBConn.Open modGlobalDbConnect.GetConnectionString
    End If
    
    If p_DBConn.STATE <> adStateOpen Then
        p_strErr = "数据库连接失败"
        InitDBConnect = False
        Exit Function
    End If
    
    InitDBConnect = True
    Exit Function
ErrHandler:
    p_strErr = Err.Description
    InitDBConnect = False
End Function






'说明：方法----根据患者拍片路径，初始化DCM控件列表
'p_strPaths <IN>： 图像路径数组
'p_nPathCount <IN>: 图像张数
'p_dcmList <OUT>: DCM控件数组
'p_strError <OUT>: 方法执行过程中的错误信息
'Return Value: True if Success, False if Failure
Private Function InitPatientDcmList(ByRef p_strPaths() As String, _
    ByVal p_nPathCount As Long, _
    ByRef p_strError As String) _
    As Boolean
On Error GoTo ErrHandler
    dcmList(0).FreeMemory
    Dim i As Long
    For i = 1 To dcmList.Count - 1
        dcmList(i).FreeMemory
        Unload dcmList(i)
    Next
    
    If p_nPathCount <= 0 Then
        p_strError = "图像路径数目为0"
        InitPatientDcmList = False
        Exit Function
    End If
    
    If IsNull(p_strPaths) Then
        p_strError = "图像路径数目为0"
        InitPatientDcmList = False
        Exit Function
    End If
    
    If LBound(p_strPaths) < 0 Or UBound(p_strPaths) < 0 Then
        p_strError = "图像路径数目为0"
        InitPatientDcmList = False
        Exit Function
    End If
    
    '判断患者胶片数，如果多于12张，则按CT图片处理只显示一张
    If p_nPathCount > 0 And p_nPathCount <= 12 Then
        For i = 1 To p_nPathCount - 1
            dcmList(0).left = 0
            dcmList(0).Top = 0
            dcmList(0).Width = picBottom.Width / 6
            dcmList(0).Height = picBottom.Height / ((p_nPathCount - 1) \ 6 + 1)
            
            '动态加载DICOM控件
            Load dcmList(i)
            If i Mod 6 = 0 Then
                dcmList(i).left = dcmList(0).left
                dcmList(i).Top = dcmList(0).Top + dcmList(0).Height * i / 6
            Else
                dcmList(i).left = dcmList(i Mod 6 - 1).left + dcmList(i Mod 6 - 1).Width
                dcmList(i).Top = dcmList(i - 1).Top
            End If
                dcmList(i).Width = dcmList(0).Width
                dcmList(i).Height = dcmList(0).Height
            Call InitDcm(dcmList(i))
            dcmList(i).FreeMemory
            dcmList(i).Visible = False
        Next
    Else
        p_nPathCount = 1
    End If
    
    If p_nPathCount = 1 Then
        dcmList(0).left = 0
        dcmList(0).Top = 0
        dcmList(0).Width = picBottom.Width / 6
        dcmList(0).Height = picBottom.Height
    End If
    
    '========================================================================
    
    'For i = LBound(p_strPaths) To UBound(p_strPaths)
    For i = 0 To p_nPathCount - 1
        '如果文件名为空或者路径不正确（可能胶片已保存入光盘），则打开默认的图片
        If p_strPaths(i) = "" Or Dir(p_strPaths(i), vbArchive Or vbHidden Or vbReadOnly Or vbSystem Or vbNormal) = "" Then
            If Dir(DEFAULT_IMAGE, vbArchive Or vbHidden Or vbReadOnly Or vbSystem Or vbNormal) <> "" Then
                dcmList(i).OpenFile DEFAULT_IMAGE
                dcmList(i).ImageTool = 14
                dcmList(i).Visible = True
                dcmList(i).ImageZoomBestFit = True
            End If
        Else
            dcmList(i).OpenFile (p_strPaths(i))
            dcmList(i).ImageTool = 14
            dcmList(i).Visible = True
            dcmList(i).ImageZoomBestFit = True
        End If
    Next


    InitPatientDcmList = True
    Exit Function
ErrHandler:
    p_strError = Err.Description
End Function