frmreport.frm

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

    txtUSTip(4).Top = Me.height - TextBase - iH
    txtUSTip(5).Top = Me.height - TextBase - iH
    txtUSTip(6).Top = Me.height - TextBase
    txtUSTip(7).Top = Me.height - TextBase

    txtDescribe.height = Me.height - TextBase - iH * 4 + txtUSTip(0).height - txtDescribe.Top

End Sub

Private Sub Form_Unload(Cancel As Integer)
    Dim Ret As Integer
    Dim i As Integer
    
    
    '-------------------------------
    '在窗体卸载时,可以加入一些判断
    '-------------------------------
    
    '如果是在浏览状态下,则不管,直接可以退出
    If Me.WorkType = "Browse" Then
        '设置主窗体的工具栏
        With frmMain.atBarMain
            .Tools("ID_FileHTML").Enabled = False
            .Tools("ID_FilePrint").Enabled = False
            .Tools("ID_USSave").Enabled = False
            .Tools("ID_USDelete").Enabled = False
            .Tools("ID_USAdd").Enabled = True
            .Tools("ID_FileHTML").Enabled = False
            .Tools("ID_USViewImage").Enabled = False
            .Tools("ID_USViewVideo").Enabled = False
            .Tools("ID_SysPackDB").Enabled = True
            .Tools("ID_SysBackup").Enabled = True
        End With
        Me.Loaded = False
        Exit Sub
    End If
    
    '判断是否已经保存过,如果未保存,则提示是否当前的报告
    If Me.Saved = False Then
        Ret = MsgBox("这将取消当前的报告, 确定吗?", vbYesNo + vbQuestion, "取消报告")
        If Ret = vbNo Then Cancel = True: Exit Sub
    End If
        
    ShowInfo "[F2]=新建报告  [F9]=病例"
    
    '设置主窗体的工具栏
    With frmMain.atBarMain
        .Tools("ID_FileHTML").Enabled = False
        .Tools("ID_FilePrint").Enabled = False
        .Tools("ID_USSave").Enabled = False
        .Tools("ID_USDelete").Enabled = False
        .Tools("ID_USAdd").Enabled = True
        .Tools("ID_FileHTML").Enabled = False
        .Tools("ID_USViewImage").Enabled = False
        .Tools("ID_USViewVideo").Enabled = False
        .Tools("ID_SysPackDB").Enabled = True
        .Tools("ID_SysBackup").Enabled = True
    End With
    
    '设置加载为否，清空初试信息
    Set Me.IFs = Nothing
    Set Me.VFs = Nothing
    Me.Loaded = False
    Me.Saved = False
    Me.VideoFileName = vbNullString
    Me.VideoSoundFileName = vbNullString
    
    '为避免与下一条记录混淆,先卸载视频捕捉窗体
    Unload frmVideoCapture
    
    '清空数组
    For i = 0 To 199
        modOrganDescribe.OrganChosen(i) = 0
    Next i
    For i = 0 To 19
        modCommon.TempLoadFlag(i) = False
        modCommon.OldTempLoadFlag(i) = False
    Next i
    
End Sub



Private Sub txtDescribe_DblClick()
    
    '---------------
    '弹出器官模板
    '---------------
    
    
    If USV.AllowOrganTemplate = False Then Exit Sub     '如果该版本未赋予此权限,则退出过程
    If txtDescribe.Locked Then Exit Sub                 '如果在禁止状态下，则不弹出器官模版
    
    
    Screen.MousePointer = vbHourglass
    modCommon.PopOrganTemp (modCommon.OrganModelNameChosen)
    Screen.MousePointer = vbNormal
    
End Sub

Private Sub txtDescribe_LostFocus()
    If frmOrganIllList.Loaded = True And frmReport.ActiveControl.Name <> "txtDescribe" Then
        Unload frmOrganIllList
    End If
End Sub

Private Sub txtDescribe_Validate(Cancel As Boolean)
    
    '-------------
    '验证
    '-------------
    
    Cancel = ValidateNullString(txtDescribe)
    
End Sub

Private Sub txtSickName_LostFocus()
    
    '-----------
    '查找病人
    '-----------
    
'    On Error GoTo ErrHandle
'
'    If Trim(txtSickName.Text) <> vbNullString And Not FoundSick Then
'        With rsUSSick
'            .Filter = "SICK_NAME = '" & txtSickName.Text & "'"
'            Select Case .RecordCount
'                Case 0
'
'                Case 1
'                    FillSickInfo
'
'                Case Is > 1
'                    With frmSelSick
'                        .Show vbModal
'                        If .Cancel = False Then
'                            FillSickInfo
'                        End If
'                    End With
'            End Select
'        End With
'    End If
'    Exit Sub
'
'ErrHandle:
'    ShowError
        
End Sub

Private Sub txtSickName_Validate(Cancel As Boolean)
    '----------
    '验证
    '----------
    Cancel = ValidateNullString(txtSickName)
End Sub

Private Sub txtSickNo_LostFocus()
    Dim Ret As Integer
    
    '----------
    '查找病人
    '----------
    
    If Trim(txtSickNo.Text) <> vbNullString Then
        With rsUSSick
            .Requery
            .Filter = "SICK_NO = '" & txtSickNo.Text & "'"
            If .RecordCount > 0 Then
                Me.blnNewSick = False
                '如果找到记录,则填写过程
                FillSickInfo
                txtSickBirth_LostFocus
            Else
                Me.blnNewSick = True
                '新的版本中，如果没有查到相应的记录，则不提示是否添加记录，因此，以下的代码先屏蔽掉(2001-3-10)
                '如果没找到记录,则提问是否添加记录
'                Ret = MsgBox("您输入了一个数据库中没有的病人号码, 要将此病人记录登录到数据库中吗?", vbYesNo + vbQuestion, "提示")
'                If Ret = vbYes Then
'                    frmSickSearch.txtSearchNo.Text = txtSickNo.Text
'                    frmSickSearch.Show vbModal
'                Else
'                    Exit Sub
'                End If
            End If
        End With
    End If
    
End Sub

Private Sub FillSickInfo()
    
    '-----------------------------
    '如果找到病人信息,用本过程填写
    '-----------------------------
    
    FoundSick = True
    With rsUSSick
        txtSickNo.Text = !SICK_NO & vbNullString
        txtSickName.Text = !SICK_NAME & vbNullString
        cboSickSex.Text = !SICK_SEX & vbNullString
        txtSickBirth.Value = !SICK_BIRTH & vbNullString
        cboSickClass.Text = !SICK_CLASS & vbNullString
        txtUnit.Text = !SICK_UNIT & vbNullString
        txtFamily = !SICK_FAMILY & vbNullString
    End With
    
End Sub
    

Private Sub txtSickNo_Validate(Cancel As Boolean)
    '验证
    Cancel = ValidateNullString(txtSickNo)
End Sub

Private Sub txtUSNo_LostFocus()
    
    Dim rsTemp As ADODB.Recordset
    Dim Ret As Integer
    Dim strFind As String
    
    '如果字符为空，或者没有变化，则退出
    If txtUSNo.Text = vbNullString Then Exit Sub
    
    '不在添加模式下，也退出
    If Me.WorkType <> "Add" Then Exit Sub
    
    '检查是否存在当前的超声号，并提示用户是否修改已经存在的超声报告
    Set rsTemp = OpenRSClient("SELECT * FROM US_REPORT WHERE US_NO = '" & txtUSNo.Text & "'", "Data")
    '找到了当前记录
    If rsTemp.RecordCount > 0 And frmReport.Saved <> True Then
        If UserType = "系统管理员" Or UserType = "超级管理员" Or UserType = "一般用户" Then '胡斌晖改7月20号，增加条件 UserType = "一般用户"
            Ret = MsgBox("您输入了一个已经存在的超声报告序号，是否开始编辑这条超声报告？", vbYesNo + vbQuestion, "编辑已有记录")
            Select Case Ret
                Case vbYes
                    '将查询记录集重新定位,并更新显示
                    strFind = "US_NO='" & txtUSNo.Text & "'"
                    rsUS_ReportSick.Find strFind, , adSearchForward, 1
                    Report_Index = rsUS_ReportSick!SERIAL_ID
                    Me.WorkType = "Edit"
                    Me.txtUSNo.Enabled = False
                    ShowReport
                    
                Case vbNo
                    txtUSNo.SetFocus
                    txtUSNo.SelStart = 0
                    txtUSNo.SelLength = Len(txtUSNo.Text)
            End Select
        Else
            MsgBox "对不起，此超声报告已存在，您无权修改。请重新输入一个新的超声号。", vbOKOnly + vbInformation
            txtUSNo.SetFocus
            txtUSNo.Text = vbNullString
        End If
    Else
        Me.blnNewSick = True
    End If

End Sub

Private Sub txtUSNo_Validate(Cancel As Boolean)
    '验证
    Cancel = ValidateNullString(txtUSNo)
End Sub

Private Sub cboSickSex_Validate(Cancel As Boolean)
    '验证
    Cancel = ValidateNullString(cboSickSex)
End Sub

Private Sub cboOrganName_Validate(Cancel As Boolean)
    '验证
    Cancel = ValidateNullString(cboOrganName)
End Sub

Private Sub cboUSStyle_Validate(Cancel As Boolean)
    '验证
    Cancel = ValidateNullString(cboUSStyle)
End Sub

Private Sub cboDDoctor_Validate(Cancel As Boolean)
    '验证
    Cancel = ValidateNullString(cboDDoctor)
End Sub

Public Sub EnableReport(bEnable As Boolean)
    
    '--------------------
    '允许显示"打印"等按钮
    '--------------------
    
    With frmMain.atBarMain
        .Tools("ID_FileHTML").Enabled = bEnable
        .Tools("ID_FilePrint").Enabled = bEnable
    End With
    
End Sub


Public Sub ViewVideo()
    
    '------------------
    '察看报告视频
    '------------------
    
    Dim rsTemp As ADODB.Recordset
    Dim strFile As String
    Dim itmX As ListItem
    Dim cIF As ImageFile
    
    '如果已经保存,则调用数据库中的记录;否则调用cVFs中的对应文件
    If Me.WorkType = "Browse" Or (Me.WorkType = "Add" And Me.Saved) Then
        Set rsTemp = OpenRSClient("SELECT * FROM US_MEDIA WHERE FILE_TYPE = 'VIDEO' AND US_NO = '" & Me.txtUSNo & "'", "Data")
        If rsTemp.RecordCount > 0 Then
             With frmViewReportVideo
                Do While Not rsTemp.EOF
                    strFile = rsTemp!FILE_NAME
                    If FSO.FileExists(strFile) Then
                        Set itmX = .lvwVideo.ListItems.Add(, , strFile, , "Video")
                        itmX.ToolTipText = strFile
                        itmX.Tag = strFile
                        itmX.SubItems(1) = Format(FileSize(strFile), "###,###,###,###,###")
                    End If
                    
                    If USV.AllowAudio Then
                        strFile = rsTemp!SOUND_FILE_NAME & vbNullString
                        itmX.SubItems(3) = vbNullString
                        If strFile <> vbNullString Then
                            itmX.ListSubItems(3).ReportIcon = "Sound"
                            itmX.ListSubItems(3).ToolTipText = strFile
                            itmX.ListSubItems(3).Tag = strFile
                        End If
                    End If
                    rsTemp.MoveNext
                Loop
                If USV.AllowAudio Then
                    If frmViewReportVideo.lvwVideo.SelectedItem.ListSubItems(3).Tag = "" Then frmViewReportVideo.cmdSound.Enabled = False
                End If
                frmViewReportVideo.Show vbModal
             End With
        End If
    Else
        With frmViewReportVideo
            For Each cIF In Me.VFs
                strFile = cIF.FileFullName
                If FSO.FileExists(strFile) Then
                    Set itmX = .lvwVideo.ListItems.Add(, , strFile, , "Video")
                    itmX.Tag = strFile
                    itmX.SubItems(1) = Format(FileSize(strFile), "###,###,###,###,###")
                    itmX.SubItems(3) = vbNullString
                End If
                
                If USV.AllowAudio Then
                    strFile = cIF.SoundFile
                    If strFile <> vbNullString Then
                        itmX.ListSubItems(3).ReportIcon = "Sound"
                        itmX.ListSubItems(3).ToolTipText = strFile
                        itmX.ListSubItems(3).Tag = strFile
                    End If
                End If
                    
            Next cIF
            If Me.VFs.Count > 0 Then frmViewReportVideo.Show vbModal

        End With
    End If
    
    '释放对象
    Set rsTemp = Nothing
    
End Sub

Public Sub DisableEdit()
    
    '------------------------
    '禁止所有的编辑控件,对于
    'txtDescribe,是切换Locked属性
    '------------------------
    
    Dim ctl As Control
    
    For Each ctl In Me
        If TypeOf ctl Is TextBox Or TypeOf ctl Is ComboBox Or TypeOf ctl Is DTPicker Then
            If ctl Is txtDescribe Then
                ctl.Locked = True
            Else
                ctl.Enabled = False
            End If
        End If
    Next ctl

End Sub

Public Sub EnableEdit(Optional AllowEditUSNO As Boolean = False)
    
    '-----------------------
    '允许所有的可编辑的编辑控件
    '-----------------------
    
    Dim ctl As Control
    
    For Each ctl In Me
        If TypeOf ctl Is TextBox Or TypeOf ctl Is ComboBox Or TypeOf ctl Is DTPicker Then
            Select Case ctl.Name
                Case "cboOrganName", "txtUSTip"
                    ctl.Enabled = True
                Case "txtDescribe"
                    ctl.Locked = False
                Case Else
            End Select
'            If Ctl.Name <> "txtUSNO" Then
'                Ctl.Enabled = True
'            Else
'                Ctl.Enabled = AllowEditUSNO Or Ctl.Enabled
'            End If
        End If
    Next ctl

End Sub

Private Sub txtSickAge_LostFocus()
    If frmReport.cboAgeUnit.Text <> "" And frmReport.txtSickAge.Text <> "" Then
        frmReport.txtSickBirth.Value = Account_BirthDay(frmReport.txtSickAge.Text, frmReport.cboAgeUnit.Text)
    End If
End Sub

Private Sub cboAgeUnit_LostFocus()
    If frmReport.cboAgeUnit.Text <> "" And frmReport.txtSickAge.Text <> "" Then
        frmReport.txtSickBirth.Value = Account_BirthDay(frmReport.txtSickAge.Text, frmReport.cboAgeUnit.Text)
    End If
End Sub

Private Sub txtSickBirth_LostFocus()
    If IsDate(frmReport.txtSickBirth.Value) = True Then
        frmReport.txtSickAge.Text = Account_Age(frmReport.txtSickBirth.Value, frmReport.txtDiagDay.Value)
    End If
End Sub

Private Sub txtUSTip_DblClick(Index As Integer)
    If USV.AllowOrganTemplate Then
        '弹出超声提示窗体
        Select Case IniUS.GetString("Report", "TipMode")
            Case 0
                frmTipDetail.WorkType = "Select"
                frmTipDetail.Show , frmMain
            Case 1
                frmOrganTipList.Show , frmMain
            Case Else
        End Select
    End If
End Sub

Private Sub txtUSTip_LostFocus(Index As Integer)
    If frmOrganTipList.Loaded = True And frmReport.ActiveControl.Name <> "txtUSTip" Then
        Unload frmOrganTipList
    End If
End Sub