Attribute VB_Name = "modMain" Option Explicit '*** Request Informations Public Type RequestInfo strHospNum As String strIDNum As String strPatientName As String strSex As String strAge As String strCivilStatus As String strRoomId As String strRoomClass As String strStationID As String dtRequestDate As Date strPhysician As String strStat As String strRefNum As String strTransplant As String strDialysis As String strORNum As String strCSNum As String strExamName As String strLabSection As String strLabSectionID As String strFormType As String strValueType As String strExamCode As String strPathologist As String strSpecimenId As String strSpecimen As String strPatientType As String strReaderId As String strReader As String strPDPhysician As String strPDPhysicianID As String strSupExamID As String strSupExam As String strAddress As String imgPatientPhoto As Variant End Type Global gblRequestInfo As RequestInfo Global gblResultInfo As ResultInfo Global dbConnection As New ADODB.Connection Global strHospName As String Global strHospAdd As String Global strHospTitle As String Global strServerName As String Global strIDNumber As String Global strHospNumber As String Global strCSNumber As String Global blnDirect As Boolean Global blnAutoprint As Boolean Global strRemarks As String Global strEmployeeName As String Global strEmployeeCode As String Global strMedTechId As String Global strRequestNum As String Global blnClerk As Boolean Global sServerName As String Global sServerUser As String Global sServerPassword As String 'Global GetRequestInfo As New clsGetPatientRequestInfo Global intEntryMode As Integer Global intMode As Integer '0 = Display Crystal 1 = Direct Printing 'Spelling Checker Global oWord As Object Global strSelection As String Public Type ResultInfo Remarks As String LogbookDate As Date SubmittedDate As Date ReportDate As Date AccessionNum As String intEntryMode As Integer Method As String DateFinished As Date InstrumentID As String End Type Public Report As CRAXDRT.Report Public Sub OpenMainReport(ByVal strReportFileName As String, strDatabaseName As String, ParamArray strParameters()) Dim crxParameterField As CRAXDRT.ParameterFieldDefinition Dim intCtr As Integer Dim intTotalParam As Integer Dim crxTable As CRAXDRT.DatabaseTable Dim crxApplication As New CRAXDRT.Application intTotalParam = UBound(strParameters) If Not Report Is Nothing Then Set Report = Nothing Set Report = crxApplication.OpenReport(strReportFileName, 1) Report.ReportTitle = strHospName For Each crxTable In Report.Database.Tables crxTable.Location = strDatabaseName + Mid(crxTable.Location, InStr(1, crxTable.Location, ".")) crxTable.SetLogOnInfo sServerName, strDatabaseName, sServerUser, sServerPassword Next If intTotalParam >= 0 Then For Each crxParameterField In Report.ParameterFields If intTotalParam >= intCtr Then crxParameterField.AddCurrentValue strParameters(intCtr) Else Exit For End If intCtr = intCtr + 1 Next End If Set crxParameterField = Nothing Set crxTable = Nothing Set crxApplication = Nothing End Sub Public Sub OpenSubReport(ByVal strSubReport As String, strDatabaseName As String, ParamArray strParameters()) Dim crxParameterField As CRAXDRT.ParameterFieldDefinition Dim intCtr As Integer Dim intTotalParam As Integer Dim crxTable As CRAXDRT.DatabaseTable Dim crxSubreport As CRAXDRT.Report intTotalParam = UBound(strParameters) Set crxSubreport = Report.OpenSubReport(strSubReport) crxSubreport.ReportTitle = strHospName For Each crxTable In crxSubreport.Database.Tables crxTable.Location = strDatabaseName + Mid(crxTable.Location, InStr(1, crxTable.Location, ".")) crxTable.SetLogOnInfo sServerName, strDatabaseName, sServerUser, sServerPassword Next If intTotalParam >= 0 Then For Each crxParameterField In crxSubreport.ParameterFields If intTotalParam >= intCtr Then crxParameterField.AddCurrentValue strParameters(intCtr) Else Exit For End If intCtr = intCtr + 1 Next End If Set crxParameterField = Nothing Set crxTable = Nothing Set crxSubreport = Nothing End Sub Public Sub ShowReportViewer(Optional blnShowGroupTree As Boolean = False, Optional strCaption As String = "", Optional blnDirectToPrinter As Boolean = False) If blnDirectToPrinter Then Report.DisplayProgressDialog = False Report.PrintOut False Set Report = Nothing Else Dim frmRView As New frmReportViewer With frmRView .ShowGroupTree = blnShowGroupTree .Caption = strCaption .DirectPrint = blnDirectToPrinter .crViewer1.Zoom 1 .Show vbModal End With End If End Sub Public Function GetPatientRequestInfo(RequestNum As String) As Boolean Dim recPatientSearch As New ADODB.RecordSet GetPatientRequestInfo = False With recPatientSearch If .State > 0 Then .Close .CursorLocation = adUseClient .Open "Lab_Get_PatientInformation '" & Trim$(strRequestNum) & "'", dbConnection, adOpenDynamic, adLockReadOnly If .RecordCount > 0 Then GetPatientRequestInfo = True gblRequestInfo.strHospNum = !HospNum gblRequestInfo.strIDNum = !IDNum gblRequestInfo.strPatientName = !PatientName gblRequestInfo.strSex = !Sex gblRequestInfo.strAge = !Age gblRequestInfo.strCivilStatus = !CivilStatus gblRequestInfo.strRoomId = !RoomID gblRequestInfo.strRoomClass = !Class gblRequestInfo.strStationID = !Ward gblRequestInfo.dtRequestDate = !RequestDate gblRequestInfo.strPhysician = !Doctor gblRequestInfo.strStat = !Rush gblRequestInfo.strCSNum = !RefNum gblRequestInfo.strTransplant = !Transplant gblRequestInfo.strDialysis = !Dialysis gblRequestInfo.strORNum = !ORNum gblRequestInfo.strExamName = !ExamName gblRequestInfo.strLabSection = !LabSection gblRequestInfo.strLabSectionID = !SectionId gblRequestInfo.strExamCode = !Code gblRequestInfo.strFormType = !FormType gblRequestInfo.strValueType = !ValueType gblRequestInfo.strPathologist = !Pathologist gblRequestInfo.strSpecimenId = !SpecimenID gblRequestInfo.strSpecimen = !Specimen gblRequestInfo.strReader = !Reader gblRequestInfo.strReaderId = !ReaderID gblRequestInfo.strPDPhysician = !Physician gblRequestInfo.strPDPhysicianID = !PhysicianID gblRequestInfo.strSupExamID = !SupExamID gblRequestInfo.strSupExam = !SupExam gblRequestInfo.strAddress = !Address gblRequestInfo.imgPatientPhoto = !PatientPhoto End If If .State > 0 Then .Close End With Call GeneratePatientPhoto(gblRequestInfo.imgPatientPhoto) End Function Public Sub HighLight() With Screen.ActiveForm If (TypeOf .ActiveControl Is TextBox) Then .ActiveControl.SelStart = 0 .ActiveControl.SelLength = Len(.ActiveControl) End If End With End Sub Public Sub EmbossText(myForm As Form) Dim ctr As Integer For ctr = 1 To 3 Load myForm.lblHeader(ctr) myForm.lblHeader(ctr).Visible = True Next myForm.lblHeader(1).Left = myForm.lblHeader(0).Left - 10 myForm.lblHeader(1).Top = myForm.lblHeader(0).Top - 10 myForm.lblHeader(1).ForeColor = &H80000005 myForm.lblHeader(2).Left = myForm.lblHeader(0).Left + 10 myForm.lblHeader(2).Top = myForm.lblHeader(0).Top + 10 myForm.lblHeader(2).ForeColor = &HC0C0C0 myForm.lblHeader(3).Left = myForm.lblHeader(0).Left + 20 myForm.lblHeader(3).Top = myForm.lblHeader(0).Top + 20 myForm.lblHeader(3).ForeColor = &H80000012 End Sub Function spGetMedTech(strEmployeeCode As String) As String Dim recEmp As New ADODB.RecordSet Dim strFName As String Dim strMName As String Dim strLName As String Dim strTitle As String Dim strPosition As String If recEmp.State > 0 Then recEmp.Close recEmp.CursorLocation = adUseClient recEmp.Open "Laboratory..Lab_GetMedTech '" & strEmployeeCode & "'", _ dbConnection, adOpenDynamic, adLockReadOnly If recEmp.RecordCount > 0 Then spGetMedTech = IIf(IsNull(recEmp!MedTech), "", recEmp!MedTech) Else spGetMedTech = "" End If If recEmp.State > 0 Then recEmp.Close End Function Function MsSpellCheck(strText As String) As String Set oWord = CreateObject("Word.Basic") oWord.AppMinimize MsSpellCheck = strText oWord.FileNewDefault oWord.EditSelectAll oWord.EditCut oWord.Insert strText oWord.StartOfDocument On Error Resume Next oWord.ToolsSpelling On Error GoTo 0 oWord.EditSelectAll strSelection = oWord.Selection$ If Mid(strSelection, Len(strSelection), 1) = Chr(13) Then strSelection = Mid(strSelection, 1, Len(strSelection) - 1) End If If Len(strSelection) > 1 Then MsSpellCheck = strSelection End If oWord.FileCloseAll 2 oWord.AppClose Set oWord = Nothing End Function Function AutoPrint_Results() If intMode = 1 Then blnDirect = True Else blnDirect = False GetPatientRequestInfo strRequestNum Select Case gblRequestInfo.strFormType Case "E" Select Case gblRequestInfo.strValueType Case "1": Draw_HLA_Screening Case "2": Draw_HLA_Specific End Select Case "F": Draw_FlowCytometry Case "G": Draw_Crossmatching Case "H" ' * Hard Coded Exams Select Case gblRequestInfo.strValueType Case "1", "0": Draw_APTT Case "C": Draw_StoolExam Case "F": Draw_SemenAnalysis Case "H": Draw_Histopath Case "L": Draw_BodyFluid Case "P": Draw_Papsmear Case "U": Draw_Urinalysis Case "E", "O": Draw_Fecalysis Case "2": Draw_WithInterpretation Case "S": Draw_Stool Case "4": Draw_AFB Case "K": Draw_GramStain Case "T": Draw_Typhidot Case Else: MsgBox "No printout available for this result.", vbInformation + vbOKOnly, "No Print-Out" End Select Case "P": Select Case gblRequestInfo.strValueType ' Case "1": Draw_NormalValueFormat lvwExams.SelectedItem.SubItems(colAccNum) Case "2", "3", "4", "6": Draw_PreFormats Case "1", "7", "8", "B": Draw_WithNormalValue Case "5", "I": Draw_WithCutOff Case "D": Draw_ShortFormWithRemarks Case Else: MsgBox "No printout available for this result.", vbInformation + vbOKOnly, "No Print-Out" End Select Case "X": Draw_Crossmatching Case "J": Draw_CS Case "2", "3", "4", "6": Draw_PreFormats Case "1", "7", "8", "B": Draw_WithNormalValue Case "5", "I": Draw_WithCutOff Case "D": Draw_ShortFormWithRemarks Case "W": Draw_Widal Case Else: MsgBox "No printout available for this result.", vbInformation + vbOKOnly, "No Print-Out" End Select End Function Public Sub GetResult() Dim recExams As New ADODB.RecordSet If recExams.State > 0 Then recExams.Close recExams.CursorLocation = adUseClient recExams.Open "Lab_FormMaker_GetResult '" & strRequestNum & "'", dbConnection, adOpenDynamic, adLockReadOnly If recExams.RecordCount > 0 Then gblResultInfo.LogbookDate = recExams!lratime gblResultInfo.SubmittedDate = recExams!samplesubmitted gblResultInfo.ReportDate = recExams!ResultDate gblResultInfo.intEntryMode = recExams!EntryMode gblResultInfo.Remarks = recExams!Remarks gblResultInfo.AccessionNum = recExams!AccessionNum gblResultInfo.Method = recExams!Method gblResultInfo.DateFinished = recExams!DateFinished gblResultInfo.InstrumentID = recExams!InstrumentID & "" End If If recExams.State > 0 Then recExams.Close End Sub Public Sub UpdatePrintedStatus(strRequestNum As String) On Error Resume Next dbConnection.Execute "Laboratory..Lab_UpdatePrintedStatus '" & strRequestNum & "'" End Sub Public Sub GeneratePatientPhoto(vPatientPhoto As Variant) On Error Resume Next: Dim strStream As New ADODB.Stream Dim strPhotoPath As String Dim fso As New FileSystemObject strStream.Type = adTypeBinary strStream.Open If IsEmpty(vPatientPhoto) = False Then strPhotoPath = App.Path & "\" & "PatientPhoto.bmp" If fso.FileExists(strPhotoPath) Then Kill (strPhotoPath) End If strStream.Write vPatientPhoto strStream.SaveToFile strPhotoPath, adSaveCreateOverWrite strStream.Close End If Set strStream = Nothing End Sub