frmstat.frm

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

    Dim i As Long
    
    Dim rsStat As ADODB.Recordset
    Dim rsTotal As ADODB.Recordset
    
    Dim cTR As New TextReplace
    Dim ctrCont As New TextReplace
    Dim ts As TextStream
    
    Dim cmd As ADODB.Command
    Dim fld As ADODB.Field
     
    Dim strOrg_Arr As String
    Dim strOrg As Integer
    Dim strOrg_Name As String
         
    '检查日期的合法性
    If dtpStart.Value > dtpEnd.Value Then
        MsgBox "开始时间不能晚于结束时间! 请重新输入。", vbOKOnly + vbExclamation, "日期"
    End If

    If icbRegion.Text = "全部" Or icbRegion.Text = vbNullString Then
        strOrgan = vbNullString
    Else
'        strOrgan = "AND ORGAN_NAME = " & SingleQuote(icbRegion.Text) & " "   '等于选定部位
'        strOrgan = "AND ORGAN_NAME LIKE '%" & icbRegion.Text & "%'"          '包括选定部位
'''''''包括选定部位列表
        strOrg_Arr = icbRegion.Text
        While InStr(1, strOrg_Arr, ";") <> 0
            strOrg = InStr(1, strOrg_Arr, ";")
            strOrg_Name = Left(strOrg_Arr, strOrg - 1)
            strOrg_Arr = Right(strOrg_Arr, Len(strOrg_Arr) - strOrg)
            If strOrg_Name <> "" Then strOrgan = strOrgan & "AND ORGAN_NAME LIKE '%" & strOrg_Name & "%' "
        Wend
        If strOrg_Arr <> "" Then strOrgan = strOrgan & "AND ORGAN_NAME LIKE '%" & strOrg_Arr & "%'"
'''''''包括选定部位列表
    End If
    
    '是否选择了特定的统计部位
    Select Case True
        Case optReportType(0).Value '综合统计
'           '是否选择了特定的统计部位
'           If icbRegion.Text = "全部" Or icbRegion.Text = vbNullString Then
'               strOrgan = vbNullString
'           Else
'               strOrgan = " AND ORGAN_NAME = " & SingleQuote(icbRegion.Text) & " "
'           End If
           
           '根据选择的报告类型设置
           Select Case True
              
               Case optType(0).Value
                   '按超声方式分
                   strStat = "SELECT US_TYPE , COUNT(US_NO) AS SICK_COUNT, SUM(ORGAN_NUM) AS ORGAN_COUNT, SUM(CHARGE) AS CHARGE_COUNT From US_REPORT Where DIAG_DAY >= [START_DATE] And DIAG_DAY <= [END_DATE] " & strOrgan & " GROUP BY US_TYPE"
                   strTotal = "SELECT COUNT(US_NO) AS TOTAL_SICK_COUNT, SUM(ORGAN_NUM) AS TOTAL_ORGAN_COUNT, SUM(CHARGE) AS TOTAL_CHARGE_COUNT From US_REPORT Where DIAG_DAY >= [START_DATE] And DIAG_DAY <= [END_DATE] " & strOrgan
                   strTempFile = "ReportStatByUSType.htm"
                   strStatType = "按超声类型统计"
               
               Case optType(1).Value
                   '按医师划分
                   strStat = "SELECT DIAG_DOCTOR , COUNT(US_NO) AS SICK_COUNT, SUM(ORGAN_NUM) AS ORGAN_COUNT, SUM(CHARGE) AS CHARGE_COUNT From US_REPORT Where DIAG_DAY >= [START_DATE] And DIAG_DAY <= [END_DATE] " & strOrgan & " GROUP BY DIAG_DOCTOR"
                   strTotal = "SELECT COUNT(US_NO) AS TOTAL_SICK_COUNT, SUM(ORGAN_NUM) AS TOTAL_ORGAN_COUNT, SUM(CHARGE) AS TOTAL_CHARGE_COUNT From US_REPORT Where DIAG_DAY >= [START_DATE] And DIAG_DAY <= [END_DATE]" & strOrgan
                   strTempFile = "ReportStatByDDoctor.htm"
                   strStatType = "按医师统计"
        
               Case optType(2).Value
                   '按病人类型
                   strStat = "SELECT SICK_TYPE , COUNT(US_NO) AS SICK_COUNT, SUM(ORGAN_NUM) AS ORGAN_COUNT, SUM(CHARGE) AS CHARGE_COUNT From US_REPORT Where DIAG_DAY >= [START_DATE] And DIAG_DAY <= [END_DATE] " & strOrgan & " GROUP BY SICK_TYPE"
                   strTotal = "SELECT COUNT(US_NO) AS TOTAL_SICK_COUNT, SUM(ORGAN_NUM) AS TOTAL_ORGAN_COUNT, SUM(CHARGE) AS TOTAL_CHARGE_COUNT From US_REPORT Where DIAG_DAY >= [START_DATE] And DIAG_DAY <= [END_DATE]" & strOrgan
                   strTempFile = "ReportStatBySickType.htm"
                   strStatType = "按病人类型统计"
                   
               Case optType(3).Value
                   '按送检医师划分
                   strStat = "SELECT SEND_DOCTOR , COUNT(US_NO) AS SICK_COUNT, SUM(ORGAN_NUM) AS ORGAN_COUNT, SUM(CHARGE) AS CHARGE_COUNT From US_REPORT Where DIAG_DAY >= [START_DATE] And DIAG_DAY <= [END_DATE] " & strOrgan & " GROUP BY SEND_DOCTOR"
                   strTotal = "SELECT COUNT(US_NO) AS TOTAL_SICK_COUNT, SUM(ORGAN_NUM) AS TOTAL_ORGAN_COUNT, SUM(CHARGE) AS TOTAL_CHARGE_COUNT From US_REPORT Where DIAG_DAY >= [START_DATE] And DIAG_DAY <= [END_DATE]" & strOrgan
                   strTempFile = "ReportStatBySDoctor.htm"
                   strStatType = "按送检医师统计"
                   
           End Select
                    
        Case optReportType(1).Value '工作量明细
'            '是否选择了特定的统计部位
'            If icbRegion.Text = "全部" Or icbRegion.Text = vbNullString Then
'                strOrgan = vbNullString
'            Else
'                strOrgan = " AND ORGAN_NAME = " & SingleQuote(icbRegion.Text) & " "
'            End If

            strStat = "SELECT US_REPORT.* FROM US_REPORT Where DIAG_DAY >= [START_DATE] And DIAG_DAY <= [END_DATE] " & strOrgan & " ORDER BY US_REPORT.US_NO, US_REPORT.ORGAN_NAME"
            strTotal = "SELECT COUNT(US_NO) AS TOTAL_SICK_COUNT, SUM(ORGAN_NUM) AS TOTAL_ORGAN_COUNT, SUM(CHARGE) AS TOTAL_CHARGE_COUNT From US_REPORT Where DIAG_DAY >= [START_DATE] And DIAG_DAY <= [END_DATE]" & strOrgan
            strTempFile = "ReportStatDetail.htm"
                    
    End Select
                   
    '查询统计时间段的选择类型，用于"STAT_DATE_TYPE"的替换
    For i = 0 To optTime.UBound
        If optTime(i).Value = True Then
            strStatDateType = optTime(i).Tag
            Exit For
        End If
    Next i
                   
    '替换SQL语句中的起始时间和结束时间
    With cTR
        .Text = strStat
        .Replace "START_DATE", MakeSQLDateString(dtpStart.Value)
        .Replace "END_DATE", MakeSQLDateString(dtpEnd.Value)
        strStat = .Text
        .Text = strTotal
        .Replace "START_DATE", MakeSQLDateString(dtpStart.Value)
        .Replace "END_DATE", MakeSQLDateString(dtpEnd.Value)
        strTotal = .Text
        
    End With
    
    Set rsStat = OpenRSClient(strStat, "Data")
    Set rsTotal = OpenRSClient(strTotal, "Data")
    
    '替换报告模板的内容
    With cTR
        Set ts = FSO.OpenTextFile(App.Path & "\REPORT\TEMPLATE\" & strTempFile, ForReading)
        .Text = ts.ReadAll
        .Replace "START_DATE", dtpStart.Value
        .Replace "END_DATE", dtpEnd.Value
        .Replace "PRINT_DATE", Date
        .Replace "STAT_TYPE", strStatType
        .Replace "STAT_DATE_TYPE", strStatDateType
        .Replace "STAT_ORGAN_NAME", icbRegion.Text
        For Each fld In rsTotal.Fields
            str = fld.Value & vbNullString
            If str = vbNullString Then str = "　"
            .Replace fld.Name, str
        Next fld
        strContTemp = .FindTag("<CONT_START>", "<CONT_END>")
    End With
    
    '替换连续的内容
    If rsStat.RecordCount = 0 Then
        strCont = vbNullString
    Else
        With rsStat
            strCont = vbNullString
            Do While Not .EOF
                ctrCont.Text = strContTemp
                For Each fld In .Fields
                    str = fld.Value & vbNullString
                    If str = vbNullString Then str = "　"
                    ctrCont.Replace fld.Name, str
                Next fld
                If optReportType(1).Value Then      '只在日工作量统计时使用此替换，否则在综合统计中会出错。
                    ctrCont.Replace "SICK_AGE", Year(!diag_day) - Year(!SICK_BIRTH)
                End If
                strCont = strCont & ctrCont.Text
            .MoveNext
            Loop
        End With
    End If
    cTR.Replace strContTemp, strCont, False
    
    '写文件
    Set ts = FSO.CreateTextFile(App.Path & "\REPORT\" & strTempFile, True)
    ts.Write cTR.Text
    ts.Close
    Do While Not FSO.FileExists(App.Path & "\REPORT\" & strTempFile)
        DoEvents
    Loop
    
    
    '显示打印预览
    frmReportPreview.FileName = App.Path & "\REPORT\" & strTempFile
    frmReportPreview.Caption = "打印预览 - 超声检查统计报表"
    frmReportPreview.Show vbModal
    
    '释放对象
    Set rsStat = Nothing
    Set rsTotal = Nothing
    Set ts = Nothing
    Set cTR = Nothing
    Set ctrCont = Nothing
    
    
End Sub

Private Sub Form_Load()
    
    '-------------
    '初始化
    '-------------
    
    dtpStart.Value = Date
    dtpEnd.Value = Date
    
    '填充部位Combo
    Dim rsTemp As ADODB.Recordset
    Set rsTemp = OpenRSClient("SELECT COMB_NAME FROM US_ORGAN_COMB ORDER BY COMB_FREQUENCY DESC")
    With rsTemp
        icbRegion.ComboItems.Clear
        icbRegion.ComboItems.Add , , "全部"
        Do While Not .EOF
            icbRegion.ComboItems.Add , , rsTemp!COMB_NAME
            .MoveNext
        Loop
        icbRegion.Text = "全部"
        icbRegion.Refresh
    End With
    
End Sub

Private Sub optReportType_Click(Index As Integer)
    
    '选择时要切换不同的允需状态
    
    Dim i As Integer
    
    Select Case True
        Case optReportType(0).Value     '综合统计
            fraRegion.Enabled = True
            fraType.Enabled = True
            For i = 0 To 3
                optType(i).Enabled = True
            Next
            
        Case optReportType(1).Value     '工作量明细
            fraType.Enabled = False
            For i = 0 To 3
                optType(i).Enabled = False
            Next
            
    End Select
End Sub

Private Sub optTime_Click(Index As Integer)
    
    '--------------------
    '根据所选择的不同决定
    '起始时间
    '--------------------
    
    Dim EndDay As Integer
    
    Select Case Index
        Case 0
            '本年度
            dtpStart.Day = 1
            'dtpEnd.Day = 1
            dtpStart.Year = Year(Date)
            dtpStart.Month = 1
            dtpStart.Day = 1
            dtpEnd.Value = Date
            'dtpEnd.Year = Year(Date)
            'dtpEnd.Month = 12
            'dtpEnd.Day = 31
        
        Case 1
            '本月
            dtpStart.Day = 1
            'dtpEnd.Day = 1
            dtpStart.Month = Month(Date)
            dtpStart.Day = 1
            dtpEnd.Month = Month(Date)
            dtpEnd.Value = Date
            'EndDay = 31
            'For EndDay = 31 To 28 Step -1
            '    If IsDate(dtpEnd.Year & "-" & dtpEnd.Month & "-" & EndDay) Then Exit For
            'Next EndDay
            'dtpEnd.Day = EndDay
            
        Case 2
            '本周
            dtpStart.Value = Date - Weekday(Date, vbMonday) + 1
            dtpEnd.Value = Date
            'dtpEnd.Value = Date + 7 - Weekday(Date, vbMonday)

            
        Case 3
            '当天
            dtpStart.Value = Date
            dtpEnd.Value = Date
            'dtpEnd.Value = Date
            
        Case 4
        
    End Select
    
    '如果不是“自定义”，则禁止修改时间
    If Index <> 4 Then
        dtpStart.Enabled = False
        dtpEnd.Enabled = False
    Else
        dtpStart.Enabled = True
        dtpEnd.Enabled = True
    End If
    
End Sub