frmreport.frm

VB6.0编写的医院影像系统

                                frmOrganTipList.Show , frmMain
                            Case Else
                        End Select
                    End If
                    
                Case "cboClinic"
                    '弹出临床诊断窗体
                    frmClinicDetail.WorkType = "Select"
                    frmClinicDetail.Show vbModal
                    
                Case "txtDescribe"
                    '弹出图象描述窗体
'                    txtDescribe_DblClick
                    '此处改为弹出语句选择窗体
                    If USV.AllowOrganTemplate Then frmOrganIllList.Show , frmMain
                    '如果该版本未赋予此权限,则退出过程
                    
                Case "txtSickNo", "txtSickName"
                    '弹出病人登记窗体
                    frmSickSearch.Show vbModal
                    
                Case Else
                    ComboName = GetComboName(Me.ActiveControl)
                    If ComboName <> vbNullString Then
                        PopItemDetail Me.ActiveControl, ComboName
                    End If
            End Select
                         
        Case US_KEY_POPORGANTEMP
            '如果是弹出"器官模板",则相应弹出该模板
            If (Me.ActiveControl = cboOrganName Or Me.ActiveControl = txtDescribe) And USV.AllowOrganTemplate Then
'               modCommon.PopOrganTemp (cboOrganName.Text)
                Screen.MousePointer = vbHourglass
                modCommon.PopOrganTemp (modCommon.OrganModelNameChosen)
                Screen.MousePointer = vbNormal
            End If
             
        Case US_KEY_NEWREPORT
            '如果是新建报告,则
            frmMain.NewReport
        
        Case US_KEY_SAVEREPORT
            '如果是保存报告,则
            frmMain.SaveReport
             
        Case US_KEY_CANCELREPORT, US_KEY_CANCEL
            '如果取消报告
            Dim Ret
            If Me.Saved = False Then
                'Ret = MsgBox("这将取消当前的报告, 确定吗?", vbYesNo + vbQuestion, "提示")
                'If Ret = vbNo Then
                '    Exit Sub
                'End If
                frmMain.CancelReport
            End If
        
        Case US_KEY_PRINT
            '打印
            Call frmMain.atBarMain_ToolClick(frmMain.atBarMain.Tools("ID_FilePrint"))
            
        Case US_KEY_PRINTPREVIEW
            '打印预览
            Call frmMain.atBarMain_ToolClick(frmMain.atBarMain.Tools("ID_FileHTML"))
            
        Case Else
    End Select
    
    Exit Sub

ErrHandle:
    
End Sub

Private Sub Form_Load()
    
    On Error Resume Next
    
    
    '根据用户类型的不同决定控件是否可以使用
    Select Case Me.WorkType
        Case "Add"
        
        Case "Edit"
        
        Case "Browse"
            '所有的控件都禁止，对于系统管理员和超级管理员，允许“编辑报告选项”。
            Dim ctl As Control
'            If UserType <> "系统管理员" And UserType <> "超级管理员" Then
                DisableEdit
'            End If
            '先禁止“保存菜单”
            frmMain.atBarMain.Tools("ID_USSave").Enabled = False
    End Select
    
    
    '设置一些初试值
    Loading = True
    FoundSick = False
    
    Set rsUSSick = OpenRSClient("SELECT * FROM SICK_INFO", "Data")
    
    '填充下拉列表
    SetComboItems
    
    '显示提示信息
    If USV.AllowOrganTemplate Then
        ShowInfo "[F2]新报告 [F3]保存 [F4]下拉 [F5]代码 [F6]模板 [F7]打印 [F8]预览 [F9]病例 [ESC]=取消"
    Else
        ShowInfo "[F2]新报告 [F3]保存 [F4]下拉 [F5]代码 [F7]打印 [F8]预览 [ESC]=取消"
    End If
    
    '获得新超声序号
    If Me.WorkType = "Add" And (IniUS.GetString("Report", "UserInputUSNO", 0) = 0) Then
        txtUSNo.Text = NewUSNo(cboUSStyle.Text)
    End If
    
    '设置主窗体菜单
    With frmMain.atBarMain
        .Tools("ID_FileHTML").Enabled = True
        .Tools("ID_USViewImage").Enabled = True
        .Tools("ID_USViewVideo").Enabled = True
        .Tools("ID_SysPackDB").Enabled = False
        .Tools("ID_SysBackup").Enabled = False
    End With
    
    '判断是否允许用户编辑超声号
    If IniUS.GetString("Report", "AllowEditUSNO", 0) Then
        txtUSNo.Locked = False
        txtUSNo.TabStop = True
        txtUSNo.BackColor = vbWhite
    End If
    
    '设置状态
    Loaded = True
    Saved = False
    Loading = False
    modCommon.OrganModelNameChosen = ""
    modCommon.OrganModelNameChosenStr = ""

End Sub

Private Sub SetComboItems()
    
    '-------------------------------------------------------
    '从REPORT_ITEM_CLASS和REPORT_ITEM_DETAIL中填充下拉列表
    '-------------------------------------------------------
    
    Dim ctl As Control
    Dim cbo As ComboBox
    Dim ComboName As String
    Dim strSQL As String
    Dim rsTemp As New ADODB.Recordset
    
    '判断每个控件的下拉属性
    For Each ctl In Me.Controls
        If TypeOf ctl Is ComboBox Then
            Set cbo = ctl
            ComboName = GetComboName(ctl)
            If ComboName <> vbNullString Then
                '获取记录集
                strSQL = "SELECT * FROM US_REPORT_ITEM_CLASS WHERE CLASS_NAME = '" & ComboName & "'"
                Set rsTemp = OpenRSClient(strSQL)
                '如果记录数不为0,则
                If rsTemp.RecordCount > 0 Then
                    '如果该控件允许使用预定义的下拉值,则:
                    cbo.Clear
                    If rsTemp!ADJUST_FREQUENCY Then
                        strSQL = "SELECT ITEMDATA FROM US_REPORT_ITEM_DETAIL WHERE CLASS_NAME = '" & ComboName & "' ORDER BY FREQUENCY DESC, ITEMINDEX"
                    Else
                        strSQL = "SELECT ITEMDATA FROM US_REPORT_ITEM_DETAIL WHERE CLASS_NAME = '" & ComboName & "' ORDER BY ITEMINDEX"
                    End If
                    If rsTemp.State = adStateOpen Then rsTemp.Close
                    rsTemp.Open strSQL, ConnUS
                    With rsTemp
                        Do While Not .EOF
                            cbo.AddItem rsTemp!ItemData & vbNullString
                            .MoveNext
                        Loop
                    End With
                    Select Case Me.WorkType
                        Case "Add"
                            cbo.Text = FindValue("SELECT DEFAULT_VALUE FROM US_REPORT_ITEM_CLASS WHERE CLASS_NAME = '" & ComboName & "'")
                        Case "Browse"
                    End Select
                End If
            End If
        End If
        DoEvents
    Next ctl
    
    '填充部位Combo
    Set rsTemp = OpenRSClient("SELECT COMB_NAME FROM US_ORGAN_COMB ORDER BY COMB_FREQUENCY DESC")
    With rsTemp
        cboOrganName.Clear
        Do While Not .EOF
            cboOrganName.AddItem rsTemp!COMB_NAME
            .MoveNext
        Loop
    End With
        
    '填充临床诊断框
    Set rsTemp = OpenRSClient("SELECT CLINIC FROM US_CLINIC_DETAIL ORDER BY FREQUENCY DESC, CLINIC")
    With rsTemp
        cboClinic.Clear
        Do While Not .EOF
            cboClinic.AddItem rsTemp!CLINIC
            .MoveNext
        Loop
    End With
    
    '释放对象
    Set rsTemp = Nothing
    Set cbo = Nothing
    Set ctl = Nothing
    
End Sub

Private Function GetComboName(ctl As Control)
    
    '-----------------------------------------
    '根据控件的名称,返回控件对应的下拉项目名称
    '-----------------------------------------
    
    Select Case ctl.Name
        Case "cboSickType"
            GetComboName = "病人类型"
            
        Case "cboSickSex"
            GetComboName = "病人性别"
            
        Case "cboWard"
            GetComboName = "所在病区"
        
        Case "cboBelongSec"
            GetComboName = "所属科室"
            
        Case "cboSickClass"
            GetComboName = "病人分类"
        
        Case "cboUSStyle"
            GetComboName = "超声类型"
        
        Case "cboDDoctor"
            GetComboName = "诊断医师"
        
        Case "cboHospital"
            GetComboName = "送检医院"
            
        Case "cboSDoctor"
            GetComboName = "送检医师"
            
        Case "cboSSection"
            GetComboName = "送检科室"
        
        Case "cboRecDoctor"
            GetComboName = "记录者"
        
        Case "cboImageQuality"
            GetComboName = "图像质量"
            
        Case "cboAgeUnit"
            GetComboName = "年龄单位"
        
        Case "cboINS_FRE"
            GetComboName = "仪器频率"
        
        Case Else
            GetComboName = vbNullString
        
    End Select
    
End Function
'
'Private Function PopOrganTemp(OrganName As String)
'
'    '------------------------------------
'    '弹出对应该器官组合的模板窗体
'    '------------------------------------
'
'    Dim strSQL As String
'    Dim strTempName As String
'    Dim strTempList() As String
'    Dim strCombList() As String
'    Dim rsTemp As ADODB.Recordset
'    Dim i As Integer
'
'    strSQL = "SELECT COMB_NAME, COMB_STRING, TEMP_NAME FROM US_ORGAN_COMB WHERE COMB_NAME = '" & OrganName & "'"
'    Set rsTemp = OpenRSClient(strSQL)
'
'    If rsTemp.EOF Then
'        '警告没有对应的模板
'        MsgBox "抱歉, 未发现相对应的模板, 请直接在 [图象描述] 和 [超声提示] 中输入检查结果! ", vbOKOnly + vbInformation, "提示"
'        Exit Function
'
'    Else
'        strTempList() = Split(rsTemp!TEMP_NAME, US_STR_TEMPSPLIT)
'        strCombList() = Split(rsTemp!COMB_STRING, US_STR_TEMPSPLIT)
'
'        '依次弹出器官模板
'        For i = 0 To UBound(strTempList())
'
'            strTempName = strTempList(i)
'            gstrCombString = strCombList(i)
'
'            Screen.MousePointer = vbHourglass
'
'            '根据模板的名称决定弹出的窗体名
'            Select Case strTempName
'
'                Case "肝胆胰脾后腹膜"
'                    frmTempL_GB_P_S_BP.Show vbModal
'
'                Case "眼睛"
'                    frmTempEyes.Show vbModal
'
'                Case "透环"
'                    frmTempRing.Show vbModal
'
'                Case "双肾双肾上腺"
'                    frmTempK_A.Show vbModal
'
'                Case "双肾穿刺定位"
'                    frmTempKidneysPuncture.Show vbModal
'
'                Case "乳腺探测"
'                    frmTempMammaryGland.Show vbModal
'
'                Case "甲状腺"
'                    frmTempThyroidGland.Show vbModal
'
'                Case "椎动脉"
'                    frmTempArteriaVertebralis.Show vbModal
'
'                Case "子宫附件"
'                    frmTempWombAdnexa.Show vbModal
'
'                Case "产科"
'                    frmTempFoetus.Show vbModal
'
'                Case "胸腔探测"
'                    frmTempThorax.Show vbModal
'
'                Case "移植肾"
'                    frmTempKidneysTransplant.Show vbModal
'
'                Case "下肢静脉"
'                    frmTempLowerLimbVein.Show vbModal
'
'                Case "阴囊"
'                    frmTempScrotum.Show vbModal
'
'                Case "心脏"
''                    frmTempHeartValue.Show vbModal
''                    frmTempHeartDescribe.Show vbModal
'                    frmTempHeart.Show vbModal
'
'                Case "下肢动脉"
'                    frmTempLowerLimbArtery.Show vbModal
'
'                Case "颈动脉"
'                    frmTempNeckArtery.Show vbModal
'
'                Case "双肾输尿管膀胱前列腺"
'                    frmTempK_U_B_P.Show vbModal
'
'                Case "卵泡检测"
'                    frmTempOvary.txtODiagDay.Text = Date
'                    frmTempOvary.Show vbModal
'
'                Case "肿块"
'                    frmTempTumour.Show vbModal
'
'                Case "腮腺"
'                    frmTempParotid.Show vbModal
'
'                Case "肝穿刺"
'                    frmTempLiverPuncture.Show vbModal
'
'                Case "胃"
'                    frmTempStomach.Show vbModal
'
'                Case "颌下腺"
'                    frmTempJaw.Show vbModal
'
'                Case "半月板"
'                    frmTempMeniscus.Show vbModal
'
'                Case "阑尾"
'                    frmTempAppendix.Show vbModal
'
'                Case "经颅"
'                    frmTempBySkull.Show vbModal
'
'                Case "胸腔心包腹腔"
'                    frmTempChest_HeartP_Abdomen.Show vbModal
'
'                Case Else
'                    Screen.MousePointer = vbNormal
'                    MsgBox "抱歉, 未发现相对应的模板, 请直接在 [图象描述] 和 [超声提示] 中输入检查结果! ", vbOKOnly + vbInformation, "提示"
'
'            End Select
'        Next i
'    End If
'
'End Function

Private Sub Form_Resize()
    On Error Resume Next
    
    '如果是最小化,则退出
    If Me.WindowState = vbMinimized Or frmMain.WindowState = vbMinimized Then Exit Sub
    
    '如果不满足最小条件,则使其符合
    If Me.width < MIN_WIDTH Then Me.width = MIN_WIDTH
    If Me.height < MIN_HEIGHT Then Me.height = MIN_HEIGHT
    
    '设置控件尺寸
    '横向
    Frame1.width = Me.width - Frame1.Left - RIGHT_MARGIN + 345
    Frame2.width = Me.width - Frame2.Left - RIGHT_MARGIN + 345
    cboSickClass.width = Me.width - cboSickClass.Left - RIGHT_MARGIN
    txtSickBirth.width = Me.width - txtSickBirth.Left - RIGHT_MARGIN
    txtUnit.width = Me.width - txtUnit.Left - RIGHT_MARGIN
    txtFamily.width = Me.width - txtFamily.Left - RIGHT_MARGIN
    cboINS_FRE.width = Me.width - cboINS_FRE.Left - RIGHT_MARGIN
    cboSSection.width = Me.width - cboSSection.Left - RIGHT_MARGIN
    txtREC_NO.width = Me.width - txtREC_NO.Left - RIGHT_MARGIN
    cboImageQuality.width = Me.width - cboImageQuality.Left - RIGHT_MARGIN
    txtDescribe.width = Me.width - txtDescribe.Left - RIGHT_MARGIN
    '限制超声描述的最大行宽
'    txtDescribe.width = IIf(txtDescribe.width > 8000, 8000, txtDescribe.width)

    txtUSTip(1).width = Me.width - txtUSTip(1).Left - RIGHT_MARGIN
    txtUSTip(3).width = Me.width - txtUSTip(3).Left - RIGHT_MARGIN
    txtUSTip(5).width = Me.width - txtUSTip(1).Left - RIGHT_MARGIN
    txtUSTip(7).width = Me.width - txtUSTip(3).Left - RIGHT_MARGIN

    '纵向,其中iH为一个行的高度，TextBase是文本框的基数；LableBase是标签的基数。
    Dim iH As Long, TextBase As Long, LableBase As Long

    iH = 390
    TextBase = 795
    LableBase = 735

    lblUSTip(0).Top = Me.height - LableBase - iH * 3
    lblUSTip(1).Top = Me.height - LableBase - iH * 3
    lblUSTip(2).Top = Me.height - LableBase - iH * 2
    lblUSTip(3).Top = Me.height - LableBase - iH * 2
    lblUSTip(4).Top = Me.height - LableBase - iH
    lblUSTip(5).Top = Me.height - LableBase - iH
    lblUSTip(6).Top = Me.height - LableBase
    lblUSTip(7).Top = Me.height - LableBase

    txtUSTip(0).Top = Me.height - TextBase - iH * 3
    txtUSTip(1).Top = Me.height - TextBase - iH * 3
    txtUSTip(2).Top = Me.height - TextBase - iH * 2
    txtUSTip(3).Top = Me.height - TextBase - iH * 2