modcommon.bas

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

Public Function ExistRecordUSData(TableName As String, FieldName As String, Value As String, Optional OtherCondition As String = vbNullString) As Boolean

    '-----------------------------------------------------
    '判断指定表中是否存在FieldName字段值为Value的记录
    '-----------------------------------------------------

    Dim strSQL As String
    Dim rsTemp As New ADODB.Recordset
    
    strSQL = "SELECT " & FieldName & " FROM " & TableName & " WHERE " & FieldName & " = '" & Value & "' " & OtherCondition
    rsTemp.Open strSQL, ConnData
    
    If Not rsTemp.EOF Then
        ExistRecordUSData = True
    Else
        ExistRecordUSData = False
    End If
    
    Set rsTemp = Nothing

End Function

Public Function FindValue(ByVal strSQL As String, Optional FieldName As String = vbNullString)
'----------------------------------
'寻找某个条件满足的记录的字段值
'----------------------------------
Dim rsTemp As New ADODB.Recordset
    
    rsTemp.Open strSQL, GDB, adOpenForwardOnly, adLockReadOnly
        
    If Not rsTemp.EOF Then
        If FieldName = vbNullString Then FieldName = rsTemp(0).Name
        FindValue = rsTemp(FieldName).Value & vbNullString
    Else
        FindValue = vbNullString
    End If
    
End Function

Public Function ShowError()
    
    '-----------------
    '显示出现错误
    '-----------------
    
    MsgBox Err.Source & " 发生以下错误:" & vbCrLf & vbCrLf & "错误代码: " & Err.Number & vbCrLf & vbCrLf & "错误描述: " & Err.Description, vbOKOnly + vbInformation, "错误"
    
End Function

Public Function LstTextToIndex(LstBox As ListBox, ListText As String) As Integer
    
    '-----------------------------------------------
    '对于指定的ListBox控件,返回ListText对应的Index
    '-----------------------------------------------
    Dim i As Integer
    With LstBox
        For i = 0 To .ListCount - 1
            If .List(i) = ListText Then
                LstTextToIndex = i
                Exit Function
            End If
        Next i
    End With
    
    LstTextToIndex = -1
    
End Function

Public Sub ShowInfo(InfoString As String, Optional InfoKey As String = "Info")
    
    '------------------
    '显示信息
    '------------------
    
    frmMain.sbrMain.Panels(InfoKey).Text = InfoString
    
End Sub

Public Sub RebindForm(frm As Form)
    
'    '-----------------------------
'    '将窗体的数据绑定控件重新绑定
'    '-----------------------------
'    Dim Ctl As Control
'    For Each Ctl In frm
'        If TypeOf Ctl Is TextBox Or TypeOf Ctl Is ComboBox Or TypeOf Ctl Is CheckBox Then
'            If Ctl.DataMember <> vbNullString Then
'                Set Ctl.DataSource = deUS
'                Ctl.DataMember = Ctl.DataMember
'            End If
'        End If
'    Next Ctl
    
End Sub

Public Sub UpdateFrequency()
        
    '--------------------
    '刷新超声报告的频率
    '--------------------
        
    On Error GoTo ErrHandle
        
    '1.刷新一般选项的内容
    Dim rsTemp As ADODB.Recordset
    Dim strField As String
    Dim strSQL As String
    
    frmMain.sbrMain.style = sbrSimple
    
    Set rsTemp = OpenRSClient("SELECT * FROM US_REPORT_ITEM_DETAIL")
    With rsTemp
        .MoveFirst
        Do While Not .EOF
            Select Case rsTemp!CLASS_NAME
                '根据控件的名称,返回控件对应的下拉项目名称
                Case "病人类型"
                    strField = "US_REPORT.SICK_TYPE"
'                Case "病人性别"                        '男女比例大致相等，应不用刷新（徐升，2000-11-27）
'                    strField = "SICK_INFO.SICK_SEX"
                Case "所属科室"
                    strField = "US_REPORT.SICK_BELONG_SEC"
                Case "病人分类"
                    strField = "SICK_INFO.SICK_CLASS"
                Case "超声类型"
                    strField = "US_REPORT.US_TYPE"
                Case "诊断医师"
                    strField = "US_REPORT.DIAG_DOCTOR"
                Case "送检医院"
                    strField = "US_REPORT.SEND_HOSPITAL"
                Case "送检科室"
                    strField = "US_REPORT.SEND_SECTION"
                Case Else
                
            End Select
            
            frmMain.sbrMain.SimpleText = "正在更新 [" & !CLASS_NAME & "] 中 [" & !ItemData & "] 的数据"
            strSQL = "SELECT COUNT(" & strField & ") AS FREQ FROM US_REPORT RIGHT JOIN SICK_INFO ON US_REPORT.SICK_NO=SICK_INFO.SICK_NO WHERE " & strField & " = '" & rsTemp!ItemData & "'"
            !FREQUENCY = Val(FindValue(strSQL, "FREQ", "ConnData"))
            
            rsTemp.Update
            .MoveNext
            DoEvents
        Loop
    End With
    
    '2.刷新临床诊断的频率
    Set rsTemp = OpenRS("SELECT * FROM US_CLINIC_DETAIL")
    With rsTemp
        Do While Not .EOF
            frmMain.sbrMain.SimpleText = "正在更新 [临床诊断] 中 [" & !CLINIC & "] 的数据"
            strSQL = "SELECT COUNT(CLINIC) AS FREQ FROM US_REPORT WHERE CLINIC = '" & rsTemp!CLINIC & "'"
            !FREQUENCY = Val(FindValue(strSQL, "FREQ", "ConnData"))
            .MoveNext
            DoEvents
        Loop
    End With
    
    '3.刷新部位
    Set rsTemp = OpenRS("SELECT * FROM US_ORGAN_COMB")
    With rsTemp
        Do While Not .EOF
            frmMain.sbrMain.SimpleText = "正在更新 [检查部位] 中 [" & !COMB_NAME & "] 的数据"
            strSQL = "SELECT COUNT(ORGAN_NAME) AS FREQ FROM US_REPORT WHERE ORGAN_NAME = '" & rsTemp!COMB_NAME & "'"
            !COMB_FREQUENCY = Val(FindValue(strSQL, "FREQ", "ConnData"))
            .MoveNext
            DoEvents
        Loop
    End With

    '4.刷新超声提示
    Set rsTemp = OpenRS("SELECT * FROM US_TIP_DETAIL")
    With rsTemp
        Do While Not .EOF
            frmMain.sbrMain.SimpleText = "正在更新 [超声提示] 中 [" & !TIP & "] 的数据"
            strSQL = "SELECT COUNT(US_NO) AS FREQ FROM US_REPORT WHERE US_TIP1 = '" & rsTemp!TIP & _
                "' OR US_TIP2 = '" & rsTemp!TIP & "' OR US_TIP3 = '" & rsTemp!TIP & "' OR US_TIP4 = '" & _
                rsTemp!TIP & "' OR US_TIP5 = '" & rsTemp!TIP & "' OR US_TIP6 = '" & "' OR US_TIP7 = '" & rsTemp!TIP _
                & "' OR US_TIP8 = '" & rsTemp!TIP & "'"
            !TIP_FREQUENCY = Val(FindValue(strSQL, "FREQ", "ConnData"))
            .MoveNext
            DoEvents
        Loop
    End With
    
    frmMain.sbrMain.style = sbrNormal
    
    Exit Sub

ErrHandle:

    ShowError
    Resume Next
    
End Sub

Public Sub TempletINI(frmTemplet As Form)
    
    
    '------------------------------
    '初始化模板文件的各选项
    '------------------------------
    
    Dim CboList() As String
    Dim i As Integer
    Dim cbo As Control
    Dim Ctn As Object
    Dim strSQL As String
    Dim rstTemp As New ADODB.Recordset
    Dim strError As String
    
    On Error GoTo ErrorHandler
    
    CboList = Split(gstrCombString, US_STR_COMBSPLIT)
    
    With frmTemplet
        '设置frame enabled属性
        For Each cbo In .Controls
            If TypeOf cbo Is Frame Then
                cbo.Enabled = False
                For i = 0 To UBound(CboList)
                    If CboList(i) = Trim$(cbo.Caption) Then cbo.Enabled = True          'frame caption
                Next
            End If
            If TypeOf cbo Is TextBox Or TypeOf cbo Is ComboBox Then cbo.Text = ""
        Next
        
        DoEvents                                                                        'show form

        For Each cbo In .Controls
            
            Set Ctn = cbo.Container
            
            If TypeOf Ctn Is Frame Then                         '容器为frame
            
                If Ctn.Enabled Then                             'frame enabled
                    If TypeOf cbo Is ComboBox Then
                        strSQL = "SELECT ITEM_DETAIL FROM qryUS_ORGAN_DETAIL WHERE ORGAN_NAME = '" & _
                            Trim$(Ctn.Caption) & "' AND ORGAN_ITEM = '" & Trim$(cbo.Tag) & _
                            "' ORDER BY ITEM_DETAIL_INDEX"                              'frame caption,cbo tag
                        Set rstTemp = OpenRS(strSQL)
                        'rstTemp.Open strSQL, ConnUS, adOpenForwardOnly, adLockReadOnly, adCmdText
                        If rstTemp Is Nothing Then
                            MsgBox "打开数据库出错!", vbOKOnly + vbExclamation, "警告"
                            Exit Sub
                        End If
                        With rstTemp
                            If Not .EOF Then
                                cbo.Clear
                                Do While Not .EOF
                                    cbo.AddItem rstTemp("item_detail") & ""
                                    .MoveNext
                                Loop
                            End If
                        End With
                        rstTemp.Close
                    End If
                Else
                    cbo.Enabled = False
                End If
                
            ElseIf TypeOf Ctn Is PictureBox Then
            
                If TypeOf cbo Is ComboBox Then
                    strSQL = "SELECT ITEM_DETAIL FROM qryUS_ORGAN_DETAIL WHERE ORGAN_NAME = '" & _
                        Trim$(Ctn.Tag) & "' AND ORGAN_ITEM = '" & Trim$(cbo.Tag) & _
                        "' ORDER BY ITEM_DETAIL_INDEX"                                  'picturebox tag, cbo tag
                    Set rstTemp = OpenRS(strSQL)
                    'rstTemp.Open strSQL, ConnUS, adOpenForwardOnly, adLockReadOnly, adCmdText
                    If rstTemp Is Nothing Then
                        MsgBox "打开数据库出错!", vbOKOnly + vbExclamation, "警告"
                        Exit Sub
                    End If
                    With rstTemp
                        If Not .EOF Then
                            cbo.Clear
                            Do While Not .EOF
                                cbo.AddItem rstTemp("item_detail") & ""
                                .MoveNext
                            Loop
                        End If
                    End With
                    rstTemp.Close
                End If
                
            End If
            
        Next
        
    End With
    
    Set rstTemp = Nothing
    
    Exit Sub
    
ErrorHandler:
    
    strError = "发生如下错误: " & vbCrLf & _
        "    错误号: " & Err.Number & vbCrLf & _
        "    错误描述: " & Err.Description & vbCrLf & _
        "    错误源名: " & Err.Source & vbCrLf & vbCrLf
    MsgBox strError, vbOKOnly + vbExclamation, "警告"
    
End Sub

Public Sub ExecWait(strCommand As String)
    Dim SA As SECURITY_ATTRIBUTES
    Dim SI As STARTUPINFO
    Dim PI As PROCESS_INFORMATION
    Dim sNull As String
    
    Dim lp As Long
    
    '-----------------------------
    '执行并等待一个进程的结束
    '-----------------------------
    
    sNull = vbNullString
    lp = CreateProcess(strCommand, sNull, SA, SA, 0, 0, 0, sNull, SI, PI)
    
    WaitForSingleObject lp, 20
    
End Sub

Public Function NewUSNo(USStyle As String) As String
    
    '----------------------
    '生成一个新的超声序号
    '----------------------
    Dim strYear As String
    Dim strStyle As String
    Dim strSQL As String
    Dim strNo As String
    Dim Id As String
    
    strYear = Year(Date)
    
'    Select Case USStyle
'        Case "黑白超声"
'            strStyle = "A"
'        Case "彩超"
'            strStyle = "B"
'        Case "心超"
'            strStyle = "C"
'        Case Else
'            strStyle = "D"
'    End Select
    
    '从US_TYPE_CODE表中读取对应的编码
    strStyle = FindValue("SELECT CODE FROM US_TYPE_CODE WHERE US_TYPE = '" & USStyle & "'")
    If strStyle = vbNullString Then strStyle = "_"
    
    
    '检索数据库,并生成新的超声号
    strSQL = "SELECT MAX(RIGHT(US_NO,6)) AS MAXNO FROM US_REPORT WHERE LEFT(US_NO,5)= " & SingleQuote(Year(Date) & strStyle)
    'strSQL = "SELECT MAX(VAL(MID(US_NO,6))) AS MAXNO FROM US_REPORT WHERE MID(US_NO,5,1) = '" & strStyle & "'"     '此句注释是因为要配合SQL Server作统一的语句。
    strNo = FindValue(strSQL, "MAXNO", "ConnData")
    Id = Format(Val(strNo) + 1, "000000")
    
    NewUSNo = strYear & strStyle & Id
    
End Function

Public Function EditImage(FileName As String)

    '-------------------
    '对图像进行编辑
    '-------------------
    
    On Error Resume Next
    
    With frmImageEdit
        .FileName = FileName
        .Show , frmMain
        .SetFocus
    End With
    
'    With frmImageKnifeEdit
'        .FileName = FileName
'        .Show , frmMain
'    End With
    
    
End Function


Public Function ShowReport()
    
    '----------------------
    '将记录显示到报告窗体
    '----------------------
    
    On Error Resume Next
    
    Dim rsTemp As ADODB.Recordset
    Dim rsRPT As ADODB.Recordset
    Dim strSQL As String
    
    '获取该条记录
    strSQL = "SELECT * FROM US_REPORT WHERE US_NO = '" & rsUS_ReportSick!US_NO & "'"
    Set rsRPT = OpenRS(strSQL, "Data")
    
    
    '首先显示主报告内容
    With frmReport
        .cboSickType.Text = rsRPT!SICK_TYPE & vbNullString
        .cboBelongSec.Text = rsRPT!SICK_BELONG_SEC & vbNullString
        .cboWard.Text = rsRPT!SICK_WARD & vbNullString
        .txtBedNo.Text = rsRPT!SICK_BEDNO & vbNullString
        .txtSickNo.Text = rsRPT!SICK_NO & vbNullString
        .txtUSNo.Text = rsRPT!US_NO & vbNullString
        .cboUSStyle.Text = rsRPT!US_TYPE & vbNullString
        .cboClinic.Text = rsRPT!CLINIC & vbNullString
        .cboOrganName.Text = rsRPT!Organ_Name & vbNullString
        .txtOrganNum.Text = rsRPT!ORGAN_NUM & vbNullString
        .txtCharge.Text = rsRPT!CHARGE & vbNullString
        .cboDDoctor.Text = rsRPT!DIAG_DOCTOR & vbNullString
        .cboRecDoctor.Text = rsRPT!REC_DOCTOR & vbNullString
        .txtDiagDay.Value = rsRPT!diag_day & vbNullString