frmsearch.frm

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

        If .BOF And .EOF Then Exit Sub      '如果记录集为空,则退出过程
        If .EOF Then .MoveLast
        If .BOF Then .MoveFirst
    End With
    
    Screen.MousePointer = vbHourglass
    DoEvents
    
    '如果记录查询窗体已经加载,则这将刷新报告的显示
    If frmSearch.Loaded Then
        ShowReport
    End If

    If frmImageResult.Loaded Then
        ShowReportImage
    End If

    '设置主窗体的“报告编辑”功能的状态，为了慎重，每条记录都要重复“允许编辑”->“保存”的过程。
    If frmSearch.Loaded And AdminUser Then
        With frmMain.atBarMain
            .Tools("ID_USSave").Enabled = False
            .Tools("ID_USEdit").Enabled = True
            If frmReport.Loaded Then
                frmReport.DisableEdit
            End If
        End With
    End If
    
    Screen.MousePointer = vbNormal

End Sub

Private Sub ssBarSearch_ComboCloseUp(ByVal Tool As ActiveToolBars.SSTool)
    
    Dim rsTemp As ADODB.Recordset
    Dim strSQL As String
    
    Screen.MousePointer = vbHourglass
    
    Select Case Tool.ComboBox.Text
        '数值、日期型
        Case "诊断日期", "出生日期", "诊断费用", "器官数目"
            Me.ssBarSearch.Tools("ID_SearchCondition").ComboBox.Clear
            Me.ssBarSearch.Tools("ID_SearchCondition").ComboBox.AddItem "="
            Me.ssBarSearch.Tools("ID_SearchCondition").ComboBox.AddItem ">"
            Me.ssBarSearch.Tools("ID_SearchCondition").ComboBox.AddItem "<"
            Me.ssBarSearch.Tools("ID_SearchCondition").ComboBox.AddItem ">="
            Me.ssBarSearch.Tools("ID_SearchCondition").ComboBox.AddItem "<="
'            Me.ssBarSearch.Tools("ID_SearchCondition").ComboBox.AddItem "<>"
        '文本
        Case "诊断医师", "检查部位", "病人姓名", "临床诊断", "送检医师", "送检医院", "送检科室", "病人类型", "病人单位", "病人分类"
            Me.ssBarSearch.Tools("ID_SearchCondition").ComboBox.Clear
            Me.ssBarSearch.Tools("ID_SearchCondition").ComboBox.AddItem "="
'            Me.ssBarSearch.Tools("ID_SearchCondition").ComboBox.AddItem "<>"
            Me.ssBarSearch.Tools("ID_SearchCondition").ComboBox.AddItem "包含"
        '文本特殊
        Case "超声号", "病人号", "所属病区", "病人床号"
            Me.ssBarSearch.Tools("ID_SearchCondition").ComboBox.Clear
            Me.ssBarSearch.Tools("ID_SearchCondition").ComboBox.AddItem "="
            Me.ssBarSearch.Tools("ID_SearchCondition").ComboBox.AddItem ">"
            Me.ssBarSearch.Tools("ID_SearchCondition").ComboBox.AddItem "<"
            Me.ssBarSearch.Tools("ID_SearchCondition").ComboBox.AddItem ">="
            Me.ssBarSearch.Tools("ID_SearchCondition").ComboBox.AddItem "<="
'            Me.ssBarSearch.Tools("ID_SearchCondition").ComboBox.AddItem "<>"
            Me.ssBarSearch.Tools("ID_SearchCondition").ComboBox.AddItem "包含"
        '男女
        Case "病人性别"
            Me.ssBarSearch.Tools("ID_SearchCondition").ComboBox.Clear
            Me.ssBarSearch.Tools("ID_SearchCondition").ComboBox.AddItem "="
'            Me.ssBarSearch.Tools("ID_SearchCondition").ComboBox.AddItem "<>"
        '超声提示、图像描述
        Case "超声提示", "图象描述"
            Me.ssBarSearch.Tools("ID_SearchCondition").ComboBox.Clear
            Me.ssBarSearch.Tools("ID_SearchCondition").ComboBox.AddItem "包含"
        Case Else
    End Select
    
    Select Case Tool.Id
        Case "ID_SearchItem"
            '当选择一个项目时,要填充下拉框
            ssBarSearch.Tools("ID_SearchValue").ComboBox.Clear
            If Tool.ComboBox.Text = vbNullString Then Exit Sub
            
            '先查看是否在标准的项目中
            strSQL = "SELECT * FROM US_REPORT_ITEM_DETAIL WHERE CLASS_NAME = '" & Tool.ComboBox.Text & "' ORDER BY FREQUENCY DESC"
            Set rsTemp = OpenRSClient(strSQL)
            If rsTemp.RecordCount > 1 Then
                With rsTemp
                    Do While Not .EOF
                        ssBarSearch.Tools("ID_SearchValue").ComboBox.AddItem rsTemp!ItemData
                        .MoveNext
                    Loop
                End With
                GoTo PEnd
            End If
            
            Select Case Tool.ComboBox.Text
                '如果是临床诊断
                Case "临床诊断"
                    strSQL = "SELECT CLINIC FROM US_CLINIC_DETAIL ORDER BY FREQUENCY DESC"
                    Set rsTemp = OpenRSClient(strSQL)
                    If rsTemp.RecordCount > 1 Then
                        With rsTemp
                            Do While Not .EOF
                                ssBarSearch.Tools("ID_SearchValue").ComboBox.AddItem rsTemp!CLINIC
                                .MoveNext
                            Loop
                        End With
                        GoTo PEnd
                    End If
            
                Case "检查部位"
                    '如果是检查部位
                    strSQL = "SELECT COMB_NAME FROM US_ORGAN_COMB ORDER BY COMB_FREQUENCY DESC"
                    Set rsTemp = OpenRSClient(strSQL)
                    If rsTemp.RecordCount > 1 Then
                        With rsTemp
                            Do While Not .EOF
                                ssBarSearch.Tools("ID_SearchValue").ComboBox.AddItem rsTemp!COMB_NAME
                                .MoveNext
                            Loop
                        End With
                        GoTo PEnd
                    End If
                
            End Select
            
    End Select
    
PEnd:

    Screen.MousePointer = vbNormal
    
End Sub

Private Sub ssBarSearch_ToolClick(ByVal Tool As ActiveToolBars.SSTool)

    Dim strItem As String
    Dim FLG_SPLIT As String
    Dim i As Integer
    
    FLG_SPLIT = Chr(9)
    
    Select Case Tool.Id
        Case "ID_Search"
            BeginSearch
            
        Case "ID_ViewSearch"
            ViewResult False
            
        Case "ID_MoveFirst", "ID_MovePrevious", "ID_MoveNext", "ID_MoveLast"
            MoveRecord Tool.Id
        
        Case "ID_ViewResult"
            ViewResult True
            SearchTip = False
            TipAtSerial = 0
            '将查询条件清空
            For i = 1 To flgSearch.Rows - 1
                flgSearch.TextMatrix(i, 0) = vbNullString
                flgSearch.TextMatrix(i, 1) = vbNullString
                flgSearch.TextMatrix(i, 2) = vbNullString
                flgSearch.Refresh
            Next i
            
        Case "ID_Shrink"
            Me.height = 1140
        
        Case "ID_UnShrink"
            Me.height = 4890
            
        Case "ID_SearchAdd"
            '加入一个查询条件
            With Me.ssBarSearch
                If Trim(.Tools("ID_SearchItem").ComboBox.Text) = vbNullString Or Trim(.Tools("ID_SearchCondition").ComboBox.Text) = vbNullString Or Trim(.Tools("ID_SearchValue").ComboBox.Text) = vbNullString Then Exit Sub
                    
                    '针对某些特殊类型作过滤和转换
                    Select Case (.Tools("ID_SearchItem").ComboBox.Text)
                        Case "出生日期", "诊断日期"
                            '如果是日期类型数据
                            .Tools("ID_SearchValue").ComboBox.Text = SetDate(.Tools("ID_SearchValue").ComboBox.Text)
                        Case "超声提示"
                            If SearchTip = False Then
                                SearchTip = True
                            Else
                                MsgBox "用超声提示进行查询时只能用一条超声提示条件!", vbOKOnly, "提示"
                                Exit Sub
                            End If
                        Case Else
                        
                    End Select
                
                For i = 1 To flgSearch.Rows - 1
                    If flgSearch.TextMatrix(i, 0) = vbNullString Then
                        flgSearch.TextMatrix(i, 0) = .Tools("ID_SearchItem").ComboBox.Text
                        flgSearch.TextMatrix(i, 1) = .Tools("ID_SearchCondition").ComboBox.Text
                        flgSearch.TextMatrix(i, 2) = .Tools("ID_SearchValue").ComboBox.Text
                        flgSearch.Refresh
                        If flgSearch.TextMatrix(i, 0) = "超声提示" Then TipAtSerial = i
                        Exit Sub
                    End If
                Next i
            End With
            MsgBox "已达到最大查询条件限制!", vbOKOnly, "提示"
            Exit Sub
        
        Case "ID_SearchDelete"
            '删除一个查询条件
            With flgSearch
                If .Rows > 2 Then
                    i = .Row
                    .TextMatrix(i, 0) = vbNullString
                    .TextMatrix(i, 1) = vbNullString
                    .TextMatrix(i, 2) = vbNullString
                End If
                
            End With
    End Select
    
End Sub

Private Sub MoveRecord(KeyString As String)
    
    On Error GoTo ErrHandle
    
    '移动报告记录
    With rsUS_ReportSick
        If .BOF And .EOF Then Exit Sub      '如果为空记录则退出移动函数
    
        Select Case KeyString
            Case "ID_MoveFirst"
                .MoveFirst
            Case "ID_MovePrevious"
                .MovePrevious
                If .BOF Then .MoveFirst
            Case "ID_MoveNext"
                .MoveNext
                If .EOF Then .MoveLast
            Case "ID_MoveLast"
                .MoveLast
        End Select
        
    End With
    
    Exit Sub

ErrHandle:

    ShowError
    Exit Sub
    
End Sub

Private Sub ViewResult(bViewResult As Boolean)
    
    '设置显示查询结果
    flgSearch.Visible = Not bViewResult
    picResult.Visible = bViewResult
    
    Dim cTool As SSTool
    For Each cTool In Me.ssBarSearch.Tools
        If cTool.Category = "Move" Then cTool.Enabled = bViewResult
        If cTool.Category = "Search" Then cTool.Enabled = Not bViewResult
    Next cTool
    
End Sub

Private Sub BeginSearch()
    
    On Error GoTo ErrHandle
    
    '--------------
    '开始搜索
    '--------------
    
    Dim strSQL As String
    Dim i As Integer
    Dim RT As ReportItem
    Dim SqlStr As String
    
    Screen.MousePointer = vbHourglass
    
    '生成SQL语句用于过滤记录
    strSQL = vbNullString
    With flgSearch
        For i = 1 To .Rows - 1
            If .TextMatrix(i, 0) <> vbNullString Then
                Set RT = RTFromCName(.TextMatrix(i, 0))
                strSQL = strSQL & RT.GenFilter(.TextMatrix(i, 1), .TextMatrix(i, 2), i - 1)
                '如果因为某种原因,导致SQL的开始是"AND",则删除此"AND"
                If Left(strSQL, 4) = " AND" Then strSQL = Mid(strSQL, 5)
            End If
        Next i
        If SearchTip Then
            If strSQL = "" Then
                For i = 1 To 8
                    strSQL = strSQL & " OR US_TIP" & i & " LIKE '*" & flgSearch.TextMatrix(TipAtSerial, 2) & "*'"
                Next
                If Left(strSQL, 3) = " OR " Then strSQL = Mid(strSQL, 4)
            Else
                For i = 1 To 8
                    SqlStr = SqlStr & " OR (" & strSQL & " AND US_TIP" & i & " LIKE '*" & flgSearch.TextMatrix(TipAtSerial, 2) & "*')"
                Next
                If Left(SqlStr, 3) = " OR " Then strSQL = Mid(SqlStr, 4)
            End If
            SqlStr = ""
        End If
        If strSQL = vbNullString Then strSQL = "SERIAL_ID > 0": GoTo SearchNow
    End With
    
SearchNow:

    rsUS_ReportSick.Filter = strSQL
    rsUS_ReportSick.Sort = "DIAG_DAY DESC, US_NO DESC"
    dtgResult.Refresh
    Me.sbrSearch.Panels("Info").Text = "共查找到: " & rsUS_ReportSick.RecordCount & " 条记录。"
    Me.ssBarSearch.Tools("ID_ViewResult").State = ssChecked
    
    '显示"报告"窗体
    If rsUS_ReportSick.RecordCount > 0 Then
        
        frmReport.Show
        frmReport.Saved = True
        
        Dim O_H As Single
        
        '根据版本决定是否显示图像窗体
        If USV.AllowShowImage Then
            With frmReport
                '试图将Report窗体缩到最小,以给图像显示腾出空间
                .Move 0, 0, 1000, 1000
                .Move 0, frmMain.ScaleHeight - .height, frmMain.ScaleWidth
                .Move 0, 0, frmMain.ScaleWidth
                frmImageResult.Show
                frmImageResult.Move 0, .height, frmMain.ScaleWidth, frmMain.ScaleHeight - .height
            End With
        Else
            frmReport.Move 0, 0, frmMain.ScaleWidth, frmMain.ScaleHeight
        End If
        
       '设置工具条
        With frmMain.atBarMain
'            .Tools("ID_USAdd").Enabled = False
            .Tools("ID_FileHTML").Enabled = True
            .Tools("ID_FilePrint").Enabled = True
            If UserType = "系统管理员" Or UserType = "超级管理员" Then
                .Tools("ID_USDelete").Enabled = True
            End If
        End With
        
    Else
        '设置工具条
        With frmMain.atBarMain
            .Tools("ID_FileHTML").Enabled = False
            .Tools("ID_FilePrint").Enabled = False
            .Tools("ID_USDelete").Enabled = False
        End With
    End If
    
    '如果有记录则移动到第一条，
    If rsUS_ReportSick.RecordCount > 0 Then
        rsUS_ReportSick.MoveFirst
        '如果用户是系统管理员或超级管理员，则允许编辑
        If UserType = "系统管理员" Or UserType = "超级管理员" Then
            frmMain.atBarMain.Tools("ID_USEdit").Enabled = True
        End If
    End If

    Screen.MousePointer = vbNormal
    Exit Sub

ErrHandle:
    Screen.MousePointer = vbNormal
    ShowError
    Resume Next
End Sub