frmmain.frm.bak

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

    
    If Not IsNull(myDgCheckList.TextMatrix(myDgCheckList.Row, 1)) Then
        m_strCurList_ID = Trim(myDgCheckList.TextMatrix(myDgCheckList.Row, 1))
        
        Dim strSql As String
        strSql = "SELECT ID FROM CHECK_REPORT WHERE CHECK_LIST_ID = '" + Trim(m_strCurList_ID) + "'"
        If GetRecordNumber(strSql) > 0 Then
            modReportEdit.g_bModifyReport = True
        Else
            modReportEdit.g_bModifyReport = False
        End If
    Else
        Exit Sub
    End If
    
    '加载报告编辑================================
    Load frmReportEdit
    Dim strError As String, myConn As New ADODB.Connection
    myConn.CursorLocation = adUseClient
    If myConn.STATE <> adStateOpen Then
        myConn.Open modGlobalDbConnect.GetConnectionString
    End If
    
    If myConn.STATE = adStateOpen Then
        If False = frmReportEdit.InitReportEditDynamicInfo(m_strCurList_ID, myConn, strError) Then
            MsgBox strError, vbExclamation, "报告编辑信息初始化"
        End If
    End If
    frmReportEdit.Show
    'END OF 加载报告编辑================================
    
    Exit Sub
ErrHandler:
    MsgBox Err.Description, vbExclamation, "提示"
End Sub

Private Sub cmbCheckItemName_Click()
On Error GoTo ErrHandler
    If cmbCheckItemID.ListCount >= cmbCheckItemName.ListIndex Then
        cmbCheckItemID.ListIndex = cmbCheckItemName.ListIndex
    End If
    Exit Sub
ErrHandler:
    MsgBox Err.Description, vbExclamation, "提示"
End Sub

'双击事件---显示胶片编辑
Private Sub dcmList_OnDblClick(Index As Integer)
On Error GoTo ErrHandler
    Dim strErr As String
    Load frmPhoto
    Debug.Print dcmList(Index).OPENFILENAME
    If frmPhoto.InitPhoto(dcmList(Index).OPENFILENAME, strErr) = False Then
        MsgBox "胶片显示错误!" + strErr, vbExclamation, "提示"
        Exit Sub
    End If
    frmPhoto.Show
    Exit Sub
ErrHandler:
    MsgBox Err.Description, vbExclamation, "提示"
End Sub





Private Sub myDgCheckList_Click()
    txtFilmDescription.Text = ""
    txtFilmDescription.Text = myDgCheckList.TextMatrix(myDgCheckList.Row, 6)
    txtFilmImpression.Text = myDgCheckList.TextMatrix(myDgCheckList.Row, 7)
End Sub

'双击事件----动态MSHFlexGrid
Private Sub myDgCheckList_DblClick()
On Error GoTo ErrHandler
    If myDgCheckList.Row < 1 Then
        Exit Sub
    End If
    
    If Not IsNull(myDgCheckList.TextMatrix(myDgCheckList.Row, 1)) Then
        m_strCurList_ID = myDgCheckList.TextMatrix(myDgCheckList.Row, 1)
        
        'curCheckNumber = myDgCheckList.TextMatrix(myDgCheckList.Row, 2)
        'curPatientName = myDgCheckList.TextMatrix(myDgCheckList.Row, 4)
    Else
        Exit Sub
    End If
    
    myConn.CursorLocation = adUseClient
    If myConn.STATE = adStateClosed Then
        myConn.Open modGlobalDbConnect.GetConnectionString
    End If
    
    Dim strErr As String
    If False = InitPartsInfo(m_strCurList_ID, m_strCheckPartsPaths, m_nCheckPartsCount, myConn, strErr) Then
        strErr = strErr + "<患者部位信息初始化>"
        Exit Sub
    Else
        If False = InitPatientDcmList(m_strCheckPartsPaths, m_nCheckPartsCount, strErr) Then
            strErr = strErr + "<DCM图像列表初始化>"
            Exit Sub
'        Else
'            If False = InitDcmEdit(dcmList(0).OPENFILENAME, DEFAULT_IMAGE, dcmEdit(0), strErr) Then
'                p_strErr = strErr + "<DCM图像加载>"
'                InitFilmEditDynamicInfo = False
'                Exit Function
'            End If
        End If
    End If
    
    'Load frmPhoto
    'frmPhoto.Show vbModal
    'Call frmCheckResult.GetPatientFilmAndReport(CStr(m_strCurList_ID))
    
    
    Exit Sub
ErrHandler:
     MsgBox Err.Description + strErr, vbExclamation, "提示"
End Sub

'双击事件---记录列表
Private Sub dgResult_Click()
On Error GoTo ErrHandler
    If dgResult.Rows > 0 Then
        Exit Sub
    End If
    Exit Sub
ErrHandler:
    MsgBox Err.Description, vbExclamation, "提示"
End Sub

Private Sub Form_Activate2()
On Error GoTo ErrHandler
    Dim strSql As String
    If cmbCheckItemID.Text <> "" Then
        strSql = DEFAULT_CHECK_LIST + " AND PHOTO_DEPT_ID='" + Trim(cmbCheckItemID.Text) + "'"
    End If
    strSql = strSql + CHECK_LIST_ORDER
    Call Activate(strSql)
   
    Exit Sub
ErrHandler:
    MsgBox Err.Description, vbExclamation, "提示"
End Sub

Private Sub Form_Load()
On Error GoTo ErrHandler
    Call ThisResize
    '控件位置及大小调整==========================
'    picMdi.Top = picTop.Top + picTop.Height
'    picMdi.left = picTop.left
'    picMdi.Width = picTop.Width + 100
'    picMdi.Height = Me.Height - picMdi.Top - picBottom.Height + 350
'
    dgResult.Width = picMdi.Width
    dgResult.Height = picMdi.Height - dgResult.Top - 50
    
    
    
    '一些初始化动作==========================
    
    Set myDgCheckList = Controls.Add("MSHierarchicalFlexGridLib.MSHFlexGrid", "mydgCreate", picMdi)
    myDgCheckList.Visible = True
    myDgCheckList.SelectionMode = flexSelectionByRow
    
    dtRegisterStart.Value = Now - 7
    dtRegisterEnd.Value = Now
    
    
    DEFAULT_IMAGE = App.Path & "\" & "NoImage.bmp"
    
    
    
    Exit Sub
ErrHandler:
    MsgBox Err.Description, vbExclamation, "提示"
    
End Sub



Private Function MachineConfig()
On Error GoTo ErrHandler
    Dim strConfigFilePath As String
    strConfigFilePath = App.Path + "\" + CONFIG_FILE_NAME
    Dim nRet As Long
    
    Dim strStationName As String
    strStationName = Space(256)
    
    nRet = GetPrivateProfileString("WORKSTATION", "STATION_NAME", "", _
        strStationName, 256, strConfigFilePath)

    If nRet > 0 Then
        strStationName = left(strStationName, nRet)
    End If

    Exit Function
ErrHandler:
    
    
End Function


'获取检查结果
Public Sub Activate(strSql As String)
    On Error GoTo ErrHandler
    
    MsgBox "执行患者列表初始化"
    Dim rsRegister As New ADODB.Recordset
    If rsRegister.STATE = 1 Then
        rsRegister.Close
    End If
    If myConn.STATE = adStateClosed Then
        myConn.Open modGlobalDbConnect.GetConnectionString
    End If
        
    If myConn.STATE = adStateClosed Then
        MsgBox "数据库连接错误，请查看网络状态！", vbExclamation, "提示"
        tmrCheckPart.Enabled = False
        Exit Sub
    End If
    
    rsRegister.Open strSql, myConn
    Set myDgCheckList.DataSource = rsRegister
    
    Call AdjustDgResult(myDgCheckList)
   
    Exit Sub
ErrHandler:
    MsgBox "检查结果获取失败, 原因:" + Err.Description, vbExclamation, "提示"

End Sub


'设置患者列表中列的宽度
Private Sub AdjustDgResult(dg As MSHFlexGrid)
On Error Resume Next
    Dim i As Integer
    Dim colcount As Integer
    Dim wid As Long
    
    dg.Font.Size = 11
    dg.FontFixed.Size = 11
    dg.left = dgResult.left
    dg.Top = dgResult.Top
    dg.Width = dgResult.Width
    dg.Height = dgResult.Height
    
    colcount = dg.Cols
    
    '1 ID,2 编号，3设备检查序号，4 姓名，5姓名拼音，6 性别，7 年龄，8 拍片部位，9 状态，
    '10 住院号，11 登记日期，12 检查医生，13 已写报告 ，14 已出打印,15 提请审核报告 ，16 已审核报告,17 审核医生 ，18检查日期。
    'wid = (dg.Width) / (colcount - 1)
'    wid = 800
'    For i = 1 To colcount - 1
'        dg.ColWidth(i) = wid
'    Next
'    dg.ColWidth(0) = 200
'    dg.ColWidth(1) = 0
'
'    '编号
''    dg.ColWidth(2) = 2 * wid
'    dg.ColWidth(2) = 0
'    '设备检查序号
'    dg.ColWidth(3) = 2 * wid + 400
'    '姓名
'    dg.ColWidth(4) = 2 * wid
'    '姓名拼音
'    'dg.ColWidth(5) = 5 / 3 * wid
'    dg.ColWidth(5) = 0
'    '性别
'    'Me.dgResult.ColWidth(3) = 2 / 3 * wid
'    dg.ColWidth(6) = 2 / 3 * wid + 400
'    '年龄
'    'Me.dgResult.ColWidth(4) = 2 / 3 * wid
'    dg.ColWidth(7) = wid
'    'Me.dgResult.ColWidth(5) = 2 / 3 * wid
'
'    '拍片部位
'    dg.ColWidth(8) = wid * 4
'    '状态
'    dg.ColWidth(9) = 2 / 3 * wid + 400
'
'    '住院号
'    dg.ColWidth(10) = 5 / 3 * wid
'
'    dg.ColWidth(11) = 2400 '2 * wid
'
'    dg.ColWidth(12) = 4 / 3 * wid
'    dg.ColWidth(13) = 4 / 3 * wid
'
''    dg.ColWidth(14) = 4 / 3 * wid '打印
''    dg.ColWidth(15) = 4 / 3 * wid '提请审核
''    dg.ColWidth(16) = 4 / 3 * wid '审核通过
''    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