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 strPDResidentId As String strPDResident As String blnResultVerified As Boolean strBloodType As String BirthDate As String End Type Public Type ResultInfo Remarks As String LogbookDate As Date SubmittedDate As Date ReportDate As Date AccessionNum As String intEntryMode As Integer End Type Global gblRequestInfo As RequestInfo Global gblResultInfo As ResultInfo Global LSearch As Object '***Remarks, LogbookDate/Time, SubmittedDate/Time, ReportDate/TIme 'Global strRemarks As String 'Global LogbookDate As Date 'Global SubmittedDate As Date 'Global ReportDate As Date 'Global AccessionNum As String Global dbConnection As New ADODB.Connection Global strHospName As String Global strHospAdd As String Global strHospTitle As String Global strServerName As String Global blnEditMode As Boolean Global blnVerifyMode As Boolean Global blnCancelled As Boolean Global blnResultVerified As Boolean Global blnPrintResult As Boolean 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 strSupervisorId As String 'Global Searcher As Object Global conStr As New ConnSettings Global strFaxPath As String 'Spelling Check Public oWord As Object Public strSelection As String Public blnFaxResult As Boolean Public blnEmailResult As Boolean Public Report As CRAXDRT.Report Public frmSearchVal As String Sub Main() End Sub 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, Optional blnWithVerification As Boolean = False) If blnDirectToPrinter Then Report.DisplayProgressDialog = False Report.PrintOut False Set Report = Nothing Else Dim frmRView As New frmReportViewer With frmRView .WithVerification = blnWithVerification .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.strPDResidentId = !ResidentId gblRequestInfo.strPDResident = !Resident gblRequestInfo.blnResultVerified = !ResultVerified gblRequestInfo.strBloodType = !BloodType gblRequestInfo.BirthDate = !BirthDate ' gblRequestInfo.strPatientType = !PatientType End If If .State > 0 Then .Close Set recPatientSearch = Nothing End With End Function Public Sub HighLight() On Error Resume Next With Screen.ActiveForm If (TypeOf .ActiveControl Is TextBox) Then .ActiveControl.SelStart = 0 .ActiveControl.SelLength = Len(.ActiveControl) End If End With End Sub Public Function ValiText(KeyIn As Integer, ValidateString As String, _ Editable As Boolean) As Integer Dim ValidateList As String Dim KeyOut As Integer If Editable = True Then ValidateList = UCase(ValidateString) & Chr(8) Else ValidateList = UCase(ValidateString) End If If InStr(1, ValidateList, UCase(Chr(KeyIn)), 1) > 0 Then KeyOut = KeyIn Else KeyOut = 0 Beep End If ValiText = KeyOut End Function Public Sub MT_Rights(myform As Form, Optional blnHistopath As Boolean = False) If blnClerk = False Then 'Med Tech myform.fraMedTech.Enabled = True If gblRequestInfo.blnResultVerified Then myform.cmdSave.Enabled = False Else If blnEditMode And Not blnHistopath And gblRequestInfo.blnResultVerified Then myform.cmdSave.Enabled = False myform.fraMedTech.Enabled = False End If End Sub Public Function Search_Donors(strLastName As String) As Boolean Dim Com As New ADODB.Command Dim rec As New ADODB.Recordset Search_Donors = False With Com .ActiveConnection = dbConnection .CommandText = "Laboratory.dbo.Search_Donor_Or_Recipient_By_LastName" .CommandType = adCmdStoredProc .Parameters.Append .CreateParameter("LastName", adVarChar, adParamInput, 20, strLastName) Set rec = .Execute() If Not rec.EOF Then Search_Donors = True End If rec.Close Set rec = Nothing Set Com = Nothing End With End Function 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 Public Sub EnableFormButtons(myform As Form, Enable As Boolean) myform.cmdPrint.Enabled = Enable myform.cmdVerify.Enabled = Enable myform.cmdSave.Enabled = Enable End Sub 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 End If If recExams.State > 0 Then recExams.Close End Sub 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 Public Function VerifyResult() As Boolean Dim recVerify As New ADODB.Recordset VerifyResult = False If recVerify.State > 0 Then recVerify.Close recVerify.Open "select * from laboratory..tblablogbook where requestnum = '" & strRequestNum & "'", _ dbConnection, adOpenDynamic, adLockReadOnly If Not recVerify.EOF Then dbConnection.Execute "laboratory..LAB_Save_VerifyResults '" & strRequestNum & "','" & strEmployeeCode & "', '" & strSupervisorId & "'" VerifyResult = True If blnEmailResult = True Then Report.ExportOptions.DestinationType = crEDTDiskFile Report.ExportOptions.DiskFileName = strFaxPath + "\" + strRequestNum + ".pdf" Report.ExportOptions.FormatType = crEFTPortableDocFormat Report.Export False MsgBox "Result is now ready for Email." + vbCrLf + _ "Already exported in drive " + strFaxPath, vbInformation ElseIf blnFaxResult = True Then Report.ExportOptions.DestinationType = crEDTDiskFile Report.ExportOptions.DiskFileName = strFaxPath + "\" + strRequestNum + ".pdf" Report.ExportOptions.FormatType = crEFTPortableDocFormat Report.Export False 'ConvertToTIFF strFaxPath + "\" + strRequestNum + ".pdf", strFaxPath + "\" + strRequestNum MsgBox "Result is now ready for Fax." + vbCrLf + _ "Report is already exported in drive " + strFaxPath, vbInformation End If End If recVerify.Close Set recVerify = Nothing End Function Public Sub Check_FaxResult() Dim recFax As New ADODB.Recordset blnFaxResult = False blnEmailResult = False If recFax.State > 0 Then recFax.Close recFax.Open "Select RequestNum, FaxResult, EmailResult From Laboratory..tbLabMaster Where RequestNum = '" & strRequestNum & "'", _ dbConnection, adOpenDynamic, adLockReadOnly If Not recFax.EOF Then If Trim$(recFax!FaxResult & "") = "Y" Then blnFaxResult = True ElseIf Trim$(recFax!emailResult & "") = "Y" Then blnEmailResult = True End If End If recFax.Close Set recFax = Nothing End Sub Public Function showSampleSearch(mResultDate As String, mInstrumentID As String, Optional mInstrumentName As String, Optional mSearchString As String) As String With frmSampleSearch frmSearchVal = "" .wResultDate = Format(mResultDate, "MM/dd/yyyy") .wInstrumentID = mInstrumentID .wSearchString = mSearchString On Error GoTo errFound .Show 1 showSampleSearch = frmSearchVal End With errFound: If Err = 364 Then MsgBox "No Result(s) Found for " & mInstrumentName, vbInformation, "Results" ElseIf Err > 0 Then MsgBox "Error: " & Err.Description End If End Function