frmstatistics.frm

1、以DLL形式提供医生工作站 2、 根据【检查项目】

    MsgBox Err.Description, vbExclamation, "提示"
End Sub


Private Sub Form_Load()
On Error GoTo ErrHandler
    Me.BackColor = mHLSRGB.COLORSET
    
    myConn.CursorLocation = adUseClient
    If myConn.State = 0 Then
        myConn.Open modGlobalDbConnect.GetConnectionString
    End If
    
    Call InitConditions
    Exit Sub
ErrHandler:
    MsgBox "数据库连接失败, 原因:" + Err.Description + " 请与系统管理员联系!", vbExclamation, "提示"
    Unload Me
End Sub

'初始化查询条件
Private Sub InitConditions()
On Error GoTo ErrHandler
    Dim rsResult As New ADODB.Recordset
    Dim strSql As String
'--初始化患者状态-------------------------------------------------------------------------------------------------------------------------
    strSql = "Select State From State "
    If rsResult.State = adStateOpen Then
        rsResult.Close
    End If
    If myConn.State = 0 Then
        myConn.Open modGlobalDbConnect.GetConnectionString
    End If
    rsResult.Open strSql, myConn
    Dim i As Long
    For i = 0 To rsResult.RecordCount - 1
        cmbPatientState.AddItem rsResult.Fields("State").Value
        rsResult.MoveNext
    Next
    rsResult.Close
    Set rsResult = Nothing

'--初始化拍片医生-------------------------------------------------------------------------------------------------------------------------
    strSql = "Select Name From Doctor "
    If myConn.State = 0 Then
        myConn.Open modGlobalDbConnect.GetConnectionString
    End If
    rsResult.Open strSql, myConn
    For i = 0 To rsResult.RecordCount - 1
        cmbPhotoDoctor.AddItem rsResult.Fields("Name").Value
        rsResult.MoveNext
    Next
    rsResult.Close
    Set rsResult = Nothing
    
'--初始化检查医生-------------------------------------------------------------------------------------------------------------------------
    strSql = "Select Name From Doctor "
    If myConn.State = 0 Then
        myConn.Open modGlobalDbConnect.GetConnectionString
    End If
    rsResult.Open strSql, myConn
    For i = 0 To rsResult.RecordCount - 1
        cmbCheckDoctor.AddItem rsResult.Fields("Name").Value
        rsResult.MoveNext
    Next
    rsResult.Close
    Set rsResult = Nothing

    
    
    Exit Sub
ErrHandler:
    MsgBox "查询条件初始化失败, 原因:" + Err.Description + " 请与系统管理员联系!", vbExclamation, "提示"
    'Unload Me
End Sub

Private Sub GetStatisticsResults()
On Error GoTo ErrHandler
    Dim strSql As String
    Dim strWhereCondition As String
    Dim strTables As String
    
    Dim nStart As Long
    Dim nEnd As Long
    Dim strStartDate As String
    Dim strEndDate As String
    Dim strPatientSate As String
    
    nStart = InStr(dtStartDate.Value, " ")
    If nStart <= 0 Then
        MsgBox "日期错误，请与管理员联系", vbExclamation, "提示"
    End If
    
    nEnd = InStr(dtEndDate.Value, " ")
    If nEnd <= 0 Then
        MsgBox "日期错误，请与管理员联系", vbExclamation, "提示"
    End If
    
    strStartDate = Left(dtStartDate.Value, nStart - 1) + CStr(" 00:00:00")
    strEndDate = Left(dtEndDate.Value, nEnd - 1) + CStr(" 23:59:59")
    strWhereCondition = "  WHERE CHECK_DATE >= '" & strStartDate & _
        "'  and CHECK_DATE <= '" + strEndDate + "'"
    
    strTables = "CHECK_LIST"
    If Len(Trim(cmbApplyDepartment.Text)) > 0 Then
        strTables = strTables & " ,  Department "
        strWhereCondition = strWhereCondition & " and  CHECK_LIST.APPLY_DEPT_ID=Department.id  " _
            & " and Department.Name like '%" & Trim(cmbApplyDepartment.Text) & "%'"

    End If
    If Len(Trim(cmbApplyDoctor.Text)) > 0 Or Len(Trim(cmbPhotoDoctor.Text)) > 0 _
        Or Len(Trim(cmbCheckDoctor.Text)) > 0 Then
        strTables = strTables & " , Doctor "
        
        If Len(Trim(cmbApplyDoctor.Text)) > 0 Then
            strWhereCondition = strWhereCondition & " and  CHECK_LIST.APPLY_DOCT_ID = Doctor.NAME " _
                & " and Doctor.Name like '%" & Trim(cmbApplyDoctor.Text) & "%'"
        End If
        
        If Len(Trim(cmbPhotoDoctor.Text)) > 0 Then
            strWhereCondition = strWhereCondition & " and  CHECK_LIST.PHOTO_DOCT_ID = Doctor.NAME " _
                  & " and Doctor.Name = '" & Trim(cmbPhotoDoctor.Text) & "'"
        End If
        
        If Len(Trim(cmbCheckDoctor.Text)) > 0 Then
            strWhereCondition = strWhereCondition & " and  CHECK_LIST.CHECK_DOCT_ID = Doctor.NAME " _
                  & " and Doctor.Name = '" & Trim(cmbCheckDoctor.Text) & "'"
        End If
    End If
        
    If Len(Trim(cmbPatientState.Text)) > 0 Then
        strWhereCondition = strWhereCondition + " and State = '" + Trim(cmbPatientState.Text) + "'"
    End If
    
    strSql = "Select count(*)  as 检查次数 From " + strTables + strWhereCondition
    
    
    Dim rsStatistics As New ADODB.Recordset
    If rsStatistics.State = adStateOpen Then
        rsStatistics.Close
    End If
    If myConn.State = 0 Then
        myConn.Open modGlobalDbConnect.GetConnectionString
    End If
    rsStatistics.Open strSql, myConn
    
    If rsStatistics.RecordCount = 1 And Not IsNull(rsStatistics.Fields("检查次数")) Then
        lblCheckCount.Caption = rsStatistics.Fields("检查次数").Value & " 次"
    Else
        lblCheckCount.Caption = "0 次"
    End If
    
    strSql = "SELECT SUM(to_number(CHECK_FEE) ) as 费用 FROM " + strTables + strWhereCondition
    
    
    If rsStatistics.State = adStateOpen Then
        rsStatistics.Close
    End If
    If myConn.State = 0 Then
        myConn.Open modGlobalDbConnect.GetConnectionString
    End If
    rsStatistics.Open strSql, myConn
    
    lblTotalFee.Caption = "0 元"
    If rsStatistics.RecordCount = 1 Then
        If Not IsNull(rsStatistics.Fields("费用").Value) And Len(Trim(rsStatistics.Fields("费用").Value)) > 0 Then
            lblTotalFee.Caption = rsStatistics.Fields("费用").Value & " 元"
        End If
    End If

    '影像----所照影像
    strSql = "select count(*)  as 影像张数 FROM " + strTables + " , CHECK_PART " + strWhereCondition _
        + " and CHECK_PART.PATIENT_ID = CHECK_LIST.PATIENT_ID and CHECK_LIST.IS_CHECKED = '是' "
    
    If rsStatistics.State = adStateOpen Then
        rsStatistics.Close
    End If
    If myConn.State = 0 Then
        myConn.Open modGlobalDbConnect.GetConnectionString
    End If
    rsStatistics.Open strSql, myConn
    
    If rsStatistics.RecordCount = 1 And Not IsNull(rsStatistics.Fields("影像张数").Value) Then
        lblFilmCount.Caption = rsStatistics.Fields("影像张数").Value & " 幅"
    Else
        lblFilmCount.Caption = "0 幅"
    End If
    
    '胶片----已出胶片
    strSql = "select count(*)  as 影像张数 FROM " + strTables + " , CHECK_PART " + strWhereCondition _
        + " and CHECK_PART.PATIENT_ID = CHECK_LIST.PATIENT_ID and CHECK_LIST.IS_PHOTO_PRINTED = '是' "
    If rsStatistics.State = adStateOpen Then
        rsStatistics.Close
    End If
    If myConn.State = 0 Then
        myConn.Open modGlobalDbConnect.GetConnectionString
    End If
    rsStatistics.Open strSql, myConn
    
    If rsStatistics.RecordCount = 1 And Not IsNull(rsStatistics.Fields("影像张数").Value) Then
        lblFilmPrintedCount.Caption = rsStatistics.Fields("影像张数").Value & " 张"
    Else
        lblFilmPrintedCount.Caption = "0 张"
    End If
    
    Exit Sub
ErrHandler:
    MsgBox "统计失败, 原因:" + Err.Description, vbExclamation, "提示"
End Sub








'初始化申请科室
Private Sub InitApplyDepartment()
On Error GoTo ErrHandler
    Dim strSql As String
    
    cmbApplyDepartment.Clear
    strSql = "select Name from Department where Power >= 1"
    Dim rsDepartment As New ADODB.Recordset
    Dim myConn As New ADODB.Connection
    myConn.CursorLocation = adUseClient
    myConn.Open modGlobalDbConnect.GetConnectionString
    
    rsDepartment.Open strSql, myConn
    If rsDepartment.RecordCount <= 0 Then
        'MsgBox "请您及时添加科室!", vbExclamation, "提示"
    Else

       Do While Not rsDepartment.EOF And Not rsDepartment.BOF
            If Not IsNull(rsDepartment.Fields("Name")) Then
                cmbApplyDepartment.AddItem rsDepartment.Fields("Name")
            Else
                'cmbCheckPart1.AddItem ""
            End If
            rsDepartment.MoveNext
        Loop
        If cmbApplyDepartment.ListCount > 0 Then
            cmbApplyDepartment.ListIndex = 0
        End If
        
    End If
    
    rsDepartment.Close
    Set rsDepartment = Nothing
    myConn.Close
    Set myConn = Nothing
    
    Exit Sub
ErrHandler:
    Dim ErrNumber As Long
    Dim strErrNumber As String
    ErrNumber = Err.Number - vbObjectError
    strErrNumber = ErrNumber
    'MsgBox "错误号:" + strErrNumber + ", 请与系统管理员联系!", vbExclamation, "提示"
    MsgBox Err.Description, vbExclamation, "提示"
   
End Sub



'初始化申请医生
Private Sub InitApplyDoctor(ByVal strApplyDepartment As String)
On Error GoTo ErrHandler

    If Len(Trim(strApplyDepartment)) <= 0 Then
        MsgBox "请选择申请科室!"
        Exit Sub
    End If
    cmbApplyDoctor.Clear
    
    Dim strSql As String
    strSql = "SELECT ID FROM DEPARTMENT WHERE NAME = '" + strApplyDepartment + "'"
    Dim myConn As New ADODB.Connection
    myConn.CursorLocation = adUseClient
    If myConn.State <> adStateOpen Then
        myConn.Open modGlobalDbConnect.GetConnectionString
    End If
    
    Dim rsDepartment As New ADODB.Recordset
    If rsDepartment.State = adStateOpen Then
        rsDepartment.Close
    End If
    rsDepartment.Open strSql, myConn
    
    If rsDepartment.RecordCount <= 0 Or IsNull(rsDepartment.Fields("ID")) Then
        Exit Sub
    End If
    
    
    
    Dim strDeptId As String
    strDeptId = rsDepartment.Fields("ID")
    
    
    strSql = "SELECT NAME FROM DOCTOR WHERE DepartmentID = '" + strDeptId + "'"
    
    
    
    Dim rsDoctors As New ADODB.Recordset
    
    rsDoctors.Open strSql, myConn
    If rsDoctors.RecordCount <= 0 Then
    
    Else
        Dim i As Long
        For i = 0 To rsDoctors.RecordCount - 1
            If Not IsNull(rsDoctors.Fields("NAME")) Then
                cmbApplyDoctor.AddItem rsDoctors.Fields("Name")
            Else
                'cmbCheckPart2.AddItem ""
            End If
            rsDoctors.MoveNext
        Next
        
        If cmbApplyDoctor.ListCount > 0 Then
           cmbApplyDoctor.ListIndex = 0
        End If
        
    End If
    
    rsDoctors.Close
    myConn.Close
    Set myConn = Nothing
  
    
    Exit Sub
ErrHandler:
    Dim ErrNumber As Long
    Dim strErrNumber As String
    ErrNumber = Err.Number - vbObjectError
    strErrNumber = ErrNumber
    'MsgBox "错误号:" + strErrNumber + ", 请与系统管理员联系!", vbExclamation, "提示"
    MsgBox Err.Description, vbExclamation, "提示"

End Sub