Attribute VB_Name = "module1" Option Explicit Global myOPD As New clsOPDMain 'Global Rights As New clsUserRights Global bln_Doctor As Boolean Global clsUserSetting As New clsUserSetting Global blnShow As Boolean Global blnRegFormActive As Boolean Global blnChargeFormActive As Boolean Global strDept_ID As String Global strPatientType As String Global strOPDPatient As String Global strPatientName As String Global recCash As New ADODB.Recordset Public strSpecimenID As String Public strTransplant As String Public strDialysis As String 'Public blnMoreSpecimen As Boolean Public blnStatLab As Boolean Public strTransplantDescription As String Public strDialysisDescription As String 'Public blnIsResultPrint As Boolean Public Const i_spouse_name As Integer = 8 Public Const i_spouse_address As Integer = 4 Public Const i_spouse_telnum As Integer = 3 Public Const i_spouse_EREmail As Integer = 6 Public Const i_spouse_ERName As Integer = 1 Public Const i_spouse_ERAddress As Integer = 2 Public Const i_spouse_ERTelNum As Integer = 5 Public Const i_spouse_ERFax As Integer = 0 Global strRevenueId As String Global strRadiotitle As String Global strDept As String Global strReportHeader As String Global strSectionID As String Global TransactionDate As Date Global dblHospitalBill As Double Global strDischarged As String Global strDischargedTime As String Global strAdmitted As String Global strAdmittedTime As String Global gblCompany As String Global pstrClientName As String Global isReprint As Boolean Global isHMORate As Boolean Global blnWithDiscount As Boolean Global isOPDStatRate As Boolean 'Global dtWeekendStatStart As String 'Global dtWeekendStatEnd As String 'Global dtHolidayStatStart As String 'Global dtHolidayStatEnd As String Global IsShowLabSpecimen As Boolean Global gblSpecimenID As String Global isAllowChargeChangeAmount As Boolean Global isAllowRegisterInpatient As Boolean Global IsAllowOPDCheckLabSection As Boolean Global IsAllowOPDAssessmentRateG As Boolean Global IsAllowJonelta As Boolean Global isAllowOPDSearchBarangay As Boolean Global IsAllowOPDSearchCardNumber As Boolean Global IsAllowOPDMABRate As Boolean Global isWalkinValidate As Boolean Global IsAllowOPDUpdateHMOLOA As Boolean Global IsAllowOPDExportReport As Boolean Global IsAllowOPDSearchDocBySched As Boolean Global IsAllowOPDPatientClass As Boolean Global IsAllowOPDShowDiscount As Boolean Global isAllowOPDPayCode As Boolean Global isAllowSocializeHMORate As Boolean Public blnExport As Boolean Public pubFileName As String Global strControl As String Global strLastName As String Global strFirstName As String Global strMiddleName As String Global strAdmissionDate As String Global strAdmissionTime As String Global strHospnum As String Global strSex As String Global strStatus As String Global strAge As String Global RoomNum As String Global strIDNum As String Global noticedate As String Global noticetime As String Global billupto As String Global dischargeDate As String Global dischargetime As String Global strDoctor As String Global strDiagnosis As String 'Global strremarks As String Global strOperation As String Global strfinalDiagnosis As String Global intRow As Integer Global CurrentUser As String Global strUCode As String Global strUltraExam As String Global strUltraExamCode As String Global blnSearch As Boolean Global strResultCode As String Global strItemId As String Global dbCon As ADODB.Connection 'Public Check As ADODB.Recordset 'Public strMsg As String, strMsg1 As String Public strAdmision As String Public strHospital As String Public Const cvarCode = 0 Public Const cvarDoctor = 0 Public strRoomclass As String Global strAdmDate As String Global strDsdate As String Global strRoom As String Global strPaddress As String Global strTIN As String Global PatientSearch As Object 'New clsPatientSearch Global Upper As Object 'ActiveX100.KeyPress Global uper As Object 'ActiveX100.KeyPress Global Codesearch As Object 'New clsCodeSearch Public Sstationname, SstationID, mServer, mUserid, mPassword As String Global IsGeneric As Boolean Public strLocationID As String Global blnDR As Boolean Public intRowSelect As Integer Global strAddress As String Global strPatientAddress As String Global strAmount As String 'Global recAmount As New ADODB.Recordset Global strStat As String Public strRemarks As String 'Public strProcedureRemarks As String ''Remarks for procedure together with Exam Remarks 'Global sDoc, stor, srtor, SATor, chkTime, sSexCode, sPxPno, sPharCode, SAge As String Global stor, srtor, SATor, chkTime, sSexCode, sPxPno, sPharCode, SAge As String Public strAccount As String 'Public strChecker As String Global Searcher As Object Global strgSectionID As String Global strgSection As String Global strgRevenueID As String Global strgPasswordDeptCode As String Global strgBackgroundImage As String Global strgSuffix As String Global blngBrowseDepartment As Boolean Global Const coCapitalize = 1 Global Const coNumericOnly = 2 Global Const coPositiveNumericOnly = 3 Global blnUltra As Boolean Global blnXray As Boolean Global blnCT As Boolean Global blnRequest As Boolean Global blnClinical As Boolean Global blnLab As Boolean Global blnHeart As Boolean Global blnPT As Boolean Global blnNuclear As Boolean Global blnPulmo As Boolean Global intDays As Integer Global strApelyido As String Global strPangalan As String Global percen Global boxsize Global pictheight Global intScreenRows As Integer Global intUtilityType As Integer Global strHospitalTitle As String Global strHospitalCompany As String Global strHospitalAddress1 As String Global strTinNo As String Global strGlobalUserID As String Global intMode As Integer Global blnAuthenticated As Boolean Global blnFromUtilitiesName As Boolean Global blnFromUtilitiesCompany As Boolean Global blnFromUtilitiesZipcode As Boolean Global blnByPassedNameSearch As Boolean Global Rec As New ADODB.Recordset Global con As New ADODB.Connection 'Global RefNum As String 'Global ORNum As String 'Global CMDept As String Global CMPatientName As String Public Const KC_PASSWORD_KEY = "ROBERTFKAISER" Global intMouseDisabled As Integer Global intMouseEnabled As Integer Public strUserCode_Transaction As String Public strUserName_Transaction As String Type USERTYPE Server As String UserId As String Password As String End Type Public Const cVarAccountCode = 0 Public Const cVarAccountName = 1 Public Const cVarServiceCodeOne = 0 Public Const cVarServiceCodeTwo = 2 Public Const cVarServiceCodeThree = 4 Public Const cVarServiceCodeFour = 6 Public Const cVarServiceCodeFive = 8 Public Const cVarServiceNameOne = 1 Public Const cVarServiceNameTwo = 3 Public Const cVarServiceNameThree = 5 Public Const cVarServiceNameFour = 7 Public Const cVarServiceNameFive = 9 Public Const cVarAllergyCodeOne = 0 Public Const cVarAllergyCodeTwo = 1 Public Const cVarAllergyCodeThree = 2 Public Const cVarAllergyCodeFour = 3 Public Const cVarAllergyCodeFive = 4 Public Const cVarAllergyNameOne = 5 Public Const cVarAllergyNameTwo = 6 Public Const cVarAllergyNameThree = 7 Public Const cVarAllergyNameFour = 8 Public Const cVarAllergyNameFive = 9 Public Const cVarDoctorCodeOne = 0 Public Const cVarDoctorCodeTwo = 2 Public Const cVarDoctorNameOne = 1 Public Const cVarDoctorNameTwo = 3 '----additional dr -------' Public Const cVarDoctorCodeThree = 0 Public Const cVarDoctorCodeFour = 2 Public Const cVarDoctorCodeFive = 4 Public Const cVarDoctorNameThree = 1 Public Const cVarDoctorNameFour = 3 Public Const cVarDoctorNameFive = 5 '----multiple requesting ----' Global isAllowMultipleRequest As Boolean Public Const cVarInformantName = 0 Public Const cVarInformantAddress = 1 Public Const cVarInformantTelNum = 2 Public Const cVarInformantRelation = 3 Public Const cVarEmployerName = 0 Public Const cVarEmployerAddress = 1 Public Const cVarEmployerTelNum = 2 Public Const cvarNationality = 6 Public Const cvarReligion = 7 Public Const cVarGuarantorName = 0 Public Const cVarGuarantorAddress = 1 Public Const cVarGuarantorEmployer = 2 Public Const cVarGuarantorTelNum = 3 Public Const cVarGuarantorEmpAdd = 4 Public Const cvarPediaAge = 14 Public Const cvarSingleAge = 16 Public Const cVarPersonal = 0 Public Const cVarCompany = 1 Public Const cVarInsurance = 2 Public Const cVarWithoutBill = 0 Public Const cVarWithBill = 1 'Civil Status Public Const cvarChild = "0" Public Const cvarSingle = "1" Public Const cvarMarried = "2" Public Const cvarWidow = "3" Public Const cvarSeparated = "4" Public Const cvarDivorced = "5" 'Public blnSendRequest As Boolean Public blnIsAMPickUp As Boolean Public pblnBottonClick As Boolean Public pstrHospitalName As String Public pstrHospitalAddress As String Public pdCurDate As Date Public pstrServerName As String Public pstrHospitalMTS As String Public pubStrHospNum As String Public pubBlnNewRegistration As Boolean Public strPrevious As String 'Public PatientSearch As Object Public pclsCodeSearch As Object Public PCLSUser As Object Public pclsICD As Object 'Public pclsICD As New clsICD Public strHospPlan As String Public strConsType As String Public strLocalAccount As String Public pstrPasswordSetting Public objUser As USERTYPE Global LocalHospNum As String Global LocalOPDNum As String Global vRevenue As New clsRevenueCode Public Report As CRAXDRT.Report Global RSearcher As Object 'Global blnLBDirectCharging As Boolean 'Global blnXRDirectCharging As Boolean 'Global blnUSDirectCharging As Boolean 'Global blnCTDirectCharging As Boolean 'Global blnHSDirectCharging As Boolean 'Global strRequestingDoctorCode As String 'Global strRequestingDoctorNAME As String Global strFormOption As String 'Public strLBChargeSlipNumber As String 'Public strLBRequestNumber As String 'Public strRoomRate As String 'Public strStationName As String 'Public strMembership As String 'Public strADMType As String 'Public objTabularFormat As New clsLaboratoryTabular 'Global gbMasterFileRegistrationOnly As Boolean Global gbAutoDoctorAssignment As Boolean Public gstrPatientPicturePath As String Public pclsMasterSearch As Object Public strAutoSearch As String Public ChildCount As Integer Public pstrEmployeeID As String Public pstrDate As String Public pstrRemarks As String Public pstrLogOutDate As String Public pstrHospitalID As String Public blnValidation As Boolean Public clsUserMenu As New clsUserSetting Public blnLogOut As Boolean ' For SmartCard *************************** Private Declare Function StartDevice Lib "MifareLink.dll" (ByVal port As Integer, ByVal baud As Integer) As Long Private Declare Function StopDevice Lib "MifareLink.dll" () As Integer Private Declare Function CardNumber Lib "MifareLink.dll" (ByRef CardNo As String) As Integer Private Declare Function CheckVersion Lib "MifareLink.dll" (ByRef DLLVersion As String) As Integer Private Declare Function CardRead Lib "MifareLink.dll" (ByVal BlkNo As Integer, ByRef Read As String) As Integer Private Declare Function CardFill Lib "MifareLink.dll" (ByVal StrBlk As Integer, ByVal fill As String) As Integer '-----BIHMI----' Global strPackageID As String Global blnIsPackage As Boolean Global isAllowEndConsultation As Boolean Global isAllowOPFileNumbering As Boolean Global fltDiscountRate As Double '-----LIMSO and CHDC-------' Global isAllowNewOPStatRate As Boolean Global isAllowHolidayRate As Boolean Global intXX As Integer Global blnHolidayRate As Boolean Global blnIsStat As Boolean Global isAllowAfterFivePMRate As Boolean Global isAllowAfterFiveLabChemOnly As Boolean Global isAllowAfterFiveAllRevenues As Boolean Global isAllowWeekendRate As Boolean Global strLabSectionID As String Global dtWeekendStartMarkup As String Global dtWeekendEndMarkup As String Global FirstRate As Double Global isAllowAssessmentDiscount As Boolean Global blnIsAssessment As Boolean Global blnCanGiveDiscountAssessment As Boolean Global isLabAutoMarkUpExam As Boolean Global isAssessmentMarkUp As Boolean Global isPostChargeMarkUp As Boolean Global VerifyRev As String Global isAllowZeroOnHand As Boolean '--rates--' Global OPDStatRAte As Double Global AfterFivePmRate As Double Global HolidayRate As Double Global WeekendRate As Double Global WeekendAfterFive As Double Global HolidayAndWeekend As Double Global HolidayAndAfterFivePmRate As Double Global maxmarkUpRate As Double Global StatAndAfterFivePmRate As Double Global StatAndWeekendRate As Double '------FOR HOLIDAY RATE--------' Global myHolidayGreeting As String Global myHolidayName As String Global isHolidayToday As Boolean '-----Avoid double registration----' Global isAllowCreateNewIDnum As Boolean Global blnIsAutoSearch As Boolean Global strMasterLastName As String '-----For specialized rate -----' Global isAllowSpecializedCompanyRate As Boolean Global strOtherRevenueID As String '----For HomeService Tagging ----' Global isAllowHomeService As Boolean '--added 5/21/2012 Global conBFile As New ADODB.Connection Global blnSeaFarer As Boolean Global blnPrintQueueNo As Boolean Global WshShell As Object Public strFileName As String 'Public blnisAllowRequestChargeOnCashPatient As Boolean 'Public blnisAllowPromptApprovalNumEntry As Boolean 'Public blnAllowCodeIncVitalSigns As Boolean 'Public blnAllowDischargeWithPending As Boolean 'Public blnAllowDoubleClickPxList As Boolean ''Public blnisRequirePhysician As Boolean ''Public blnAllowCF4Entries As Boolean ''Global blnAllowSameExamRequest As Boolean 'Global Patient As Object 'Global PatientSearch As Object 'Global ResultViewer As Object 'Global Drug As Object 'Global Drug As New clsDrug 'Global DrugList As Object 'Global CsrList As Object 'Global objSOA As Object 'Global labViewer As Object 'Global objRequest As Object 'New clsRequest 'Global objResults As Object 'New clsResults 'Global objConfinement As Object 'Global objConfinementResults As Object Dim IX As Integer Public ProcessPerformed As String Public Sub Main() 'MsgBox Mid("isa", 1, 2) 'MsgBox Val("89.9") On Error GoTo ErrTrap pstrDate = Now pstrRemarks = "LogIn:" If blnLogOut = True Then pstrLogOutDate = Now Else pstrLogOutDate = "" End If 'Dim frmAdmission As New frmAdmitPatient Set PCLSUser = DoCreateObject("Medsys_User.clsCurrentUser") PCLSUser.medsysclasses.UseClasses = True PCLSUser.SetExePath = App.Path ' Set labViewer = CreateObject("LabResultViewer.clslabViewer", "") Login If Not PCLSUser.Connected Then End 'Exit Sub End If PCLSUser.medsysclasses.InitWithDB Sstationname = "OPD" SstationID = "OPD Registration" strgRevenueID = "OP" frmSplash.Show DoEvents Set conBFile = PCLSUser.sqlConnection pstrEmployeeID = PCLSUser.EmployeeCode 'conBFile.Execute "patient_data..SP_OPD_UserLogin '" & Get_Sequence & "','" & pstrEmployeeID & "', '" & pstrRemarks & "', '" & pstrDate & "', ''" DoEvents Set Upper = DoCreateObject("ActiveX100.KeyPress") Set uper = DoCreateObject("ActiveX100.KeyPress") Set WshShell = DoCreateObject("WScript.Shell") 'Set pclsICD = DoCreateObject("ICD10.ICDCodeSearch") Set pclsICD = PCLSUser.medsysclasses.clsicd Set PatientSearch = DoCreateObject("MasterSearch.clsPatientSearch") Set RSearcher = DoCreateObject("RadioSearch.clsRadioSearch") 'Set Searcher = DoCreateObject("CodeSearchForm.clsCodeSearch") 'Set Codesearch = DoCreateObject("CodeSearchform.clsCodeSearch") 'Set pclsCodeSearch = DoCreateObject("CodeSearchForm.clsCodeSearch") Set pclsCodeSearch = PCLSUser.medsysclasses.clsSearcher 'Set ResultViewer = DoCreateObject("labresultinquiry.labresultviewer") 'Set Drug = DoCreateObject("prjDrugDLL.clsDrug") 'Set CsrList = DoCreateObject("prjListDrugs.clsListDrugs") 'CreateObject("prjlistcsr.clslistcsr") 'Set objSOA = DoCreateObject("StatementofAccounts.clsSOA") 'Set objWebCam = DoCreateObject("prjMedSysWebCam.ClsMedSysWebCam") 'Set clsMEDSYS = DoCreateObject("MEDSYSClasses.clsMEDSYS") 'Set Barcode = DoCreateObject("prjBarcodeDLL.clsBarcode") AddSplashlog "CF4 Entries" ' Set CF4 = DoCreateObject("CF4.Cf4Entry") ' Set CF4.ActiveConnection = pclsUser.sqlconnection 'ResultViewer.MedsysUser = PCLSUser 'CF4.MedsysUser = PCLSUser 'Set CF4.ActiveConnection = PCLSUser.sqlconnection ' CF4.Connection = pclsUser.sqlconnection 'CF4.ShowEntry 'clsMEDSYS.EXEPath = App.Path PCLSUser.medsysclasses.EXEPath = App.Path AddSplashlog "Setting Webcam." 'objWebCam.SetMedsysUser PCLSUser PCLSUser.sqlConnection.CommandTimeout = 120 pstrServerName = GetServerName(PCLSUser.sqlConnection.ConnectionString) AddSplashlog "Getting Hospital Info." Dim recTemp As New ADODB.Recordset Set recTemp = PCLSUser.sqlConnection.Execute("Select *, GetDate() as CurDate From Patient_Data..tbHospitalInfo") With recTemp pstrHospitalID = !HospitalID pstrHospitalName = !Company pstrHospitalAddress = !Address1 pdCurDate = !CurDate pstrHospitalMTS = !MTSServerName pstrPasswordSetting = !OPDPassword strTIN = !TINNO & "" gstrPatientPicturePath = !PatientPicturePath & "" .Close End With Set recTemp = Nothing AddSplashlog "CodeSearch." ' pclsCodeSearch.MTS_Server = pstrHospitalMTS ' pclsCodeSearch.MTS_Server = "" ' pclsCodeSearch.SearchMode = True ' pclsCodeSearch.Initialize_Classes ' pclsCodeSearch.Connection = PCLSUser.sqlConnection ' pclsCodeSearch.CompanyName = pstrHospitalName Set pclsICD.ActiveConnection = PCLSUser.sqlConnection AddSplashlog "RSearcher." RSearcher.Initialize_Classes Set RSearcher.InitConnection = PCLSUser.sqlConnection RSearcher.Hospital = pstrHospitalName RSearcher.RevenueID = strgRevenueID ' Set Drug = DoCreateObject("prjDrugDLL.clsDrug") ' check if it is By Generic ' If Not IsGeneric Then ' Set DrugList = DoCreateObject("prjListDrugs.clsListDrugs") ' Else ' Set DrugList = DoCreateObject("prjListDrugsByGeneric.clsListGeneric") ' End If ' AddSplashlog "Registration DLL." 'Set Registration = DoCreateObject("Registration.clsRegistration") ' AddSplashlog "Registration DLL Set User." ' pclsuser.medsysclasses.clsregistration.MedsysUser PCLSUser ' Set pclsuser.medsysclasses.clsregistration.MyClassRegistration = Registration AddSplashlog "Setting EXE Path" With PCLSUser.medsysclasses.clsRegistration .EXEPath = App.Path .EXEName = "OPD" .StationN = Sstationname End With PatientSearch.EXEName = "OPD" ' Barcode.EXEPath = App.Path 'AddSplashlog "Drug List." 'Set CsrList = DoCreateObject("prjListDrugs.clsListDrugs") 'CreateObject("prjlistcsr.clslistcsr") AddSplashlog "Nurse Activity." 'Set objRequest = DoCreateObject("Nurse_activity.clsRequest") 'Set objResults = DoCreateObject("Nurse_activity.clsResults") 'Set objConfinementResults = DoCreateObject("Nurse_activity.clsConfinementResults") 'Set objConfinement = DoCreateObject("Nurse_activity.clsConfinement") strGlobalUserID = PCLSUser.EmployeeCode AddSplashlog "Init Patient Search (MasterSearch.dll). " '& pclsUser.sqlconnection If PatientSearch.InitConnection(PCLSUser.sqlConnection, "") Then ' AddSplashlog "Init Drug." ' If Drug.InitConnect(PCLSUser.sqlConnection.ConnectionString) Then ' AddSplashlog "Init Drug List." ' If DrugList.InitConnection(PCLSUser.sqlConnection.ConnectionString) Then ' ' If CsrList.InitConnection(pclsUser.SQLConnection.ConnectionString) Then ' ' CsrList.DrugsORCSR = False ' ' End If ' End If ' End If ' End If End If AddSplashlog "OPD Settings." GetOPDSettings 'LoadOPDSetting ''05.19.16 VBB 'AddSplashlog "Markup Settings." 'Get_MarkUpSettings ' If pstrClientName = "MGH" Then ' OPDStatInfo ' End If strAutoSearch = GetSetting(App.Title, "Search", "AutoSearch") ' clsUserSetting.Initialize_Menu ' clsUserSetting.Load_UserSetting pclsUser.EmployeeCode ' clsUserSetting.Initialize_MenuVisibility ' clsUserSetting.Load_MenuVisibility ' '------------' ' ' If isAllowNewOPStatRate = True And isAllowHolidayRate = True Then ' 'intXX = MsgBox("Is it holiday today?", vbInformation + vbYesNo) ' If isHolidayToday Then '' If intXX = vbYes Then ' blnHolidayRate = True ' End If ' End If 'Unload Me PCLSUser.medsysclasses.clsBilling.RevenueID = "OP" 'Set PCLSUser.medsysclasses.MYclsUserSettingOP = clsUserSetting PCLSUser.medsysclasses.Sstationname = "OPD" PCLSUser.medsysclasses.SstationID = "OPD Registration" frmMain.Show Unload frmSplash If GetSetting(App.Title, "Settings", "OPDLocation", "") = "" Then frmModuleLocation.Show End If 'PCLSUser.MEDSYSClasses.setpatient "120789", "120789", "O" With PCLSUser.medsysclasses .Sstationname = "OPD" .SstationID = "OPD Registration" ' .SetPatient 168815, 553566 ',pattype, showform .ShowUserToolBar True .SearchPatient End With With PCLSUser.medsysclasses.clsBilling .RevenueID = "OP" ' change to youre revenueID ' .CashAssessment ' .PostCharges ' .AssessmentStatus ' .PreviousCharges ' .NursingRequest ' .ShowFinal ' .PharmacyEntry ' .ReceivableCharges ' .ViewResults End With 'strUserCode_Transaction = PCLSUser.ValidateUserID(strUserCode_Transaction) Exit Sub ErrTrap: ' MsgBox "OPD Reg Main..." & Err.Description & ". Check " & ProcessPerformed ' End MsgBox "OPD Registration sub Main " & Err.Description PCLSUser.AddLog Err.Description Resume Next End Sub Public Function ConnectSmartCard() As Boolean Dim port, baud, i As Integer ConnectSmartCard = False port = 3 baud = 9600 i = StartDevice(port, CInt(baud)) If (i <> 0) Then ConnectSmartCard = False Else ConnectSmartCard = True End If End Function Public Sub DisConnectSmartCard() Dim i As Integer i = StopDevice() End Sub Public Function ReadSmartCard() As String Dim BlkNo, data As Integer Dim Read As String ReadSmartCard = "" BlkNo = 0 data = CardRead(BlkNo, Read) ReadSmartCard = Trim$(Read) End Function Public Sub WriteSmartCard(sHospNum As String, sAdmNum As String) Dim data As Integer Dim iHospNum, iAdmNum As Integer Dim recTemp As New ADODB.Recordset iHospNum = 0 iAdmNum = 1 data = CardFill(iHospNum, sHospNum) ' If data = 0 Then ' MsgBox "Writing successful!" ' Else ' MsgBox "Writing failed!" ' End If data = CardFill(iAdmNum, sAdmNum) ' If data = 0 Then ' MsgBox "Writing successful!" ' Else ' MsgBox "Writing failed!" ' End If End Sub ' Smart Card End *************************** Private Function DoCreateObject(ObjectStr As String) As Object On Error GoTo ErrTrap IX = IX + 1 AddSplashlog IX & " " & ObjectStr Set DoCreateObject = CreateObject(ObjectStr, "") Exit Function ErrTrap: ' If MsgBox("Connot create object " & ObjectStr & ". Register this DLL. Do you want to continue?", vbYesNo) = vbNo Then ' End ' End If ' MsgBox "Connot create object " & ObjectStr & ". Register this DLL. " MsgBox "Can not create object " & ObjectStr & ". Register this DLL. " 'End End Function Public Sub Login() PCLSUser.PasswordDeptCode = "18" strDept_ID = PCLSUser.PasswordDeptCode PCLSUser.ShowMain End Sub Private Sub AddSplashlog(LogStr As String) ProcessPerformed = LogStr frmSplash.txtLog = frmSplash.txtLog & vbCrLf & LogStr DoEvents End Sub Public Function IsWholeNumber(Argvalue As String) As Boolean 'Checks whether the passed variable is of numeric value(whole number) Dim intI As Integer Dim blnNumeric As Boolean blnNumeric = True If Len(Argvalue) = 0 Then blnNumeric = False Else For intI = 1 To Len(Argvalue) If IsNumeric(Mid$(Argvalue, intI, 1)) = True Then blnNumeric = False End If Next intI End If IsWholeNumber = blnNumeric End Function Public Function IsAlphabet(Argvalue As String) As Boolean 'Checks whether the passed variable is of numeric value(whole number) Dim intI As Integer Dim blnAlphabet As Boolean blnAlphabet = True If Len(Argvalue) > 0 Then Argvalue = Left$(Argvalue, 1) Else blnAlphabet = False End If If Len(Argvalue) = 0 Then blnAlphabet = False Else For intI = 1 To Len(Argvalue) If Asc(UCase$(Mid$(Argvalue, intI, 1))) < 65 Or Asc(UCase$(Mid$(Argvalue, intI, 1))) > 90 Then blnAlphabet = False End If Next intI End If IsAlphabet = blnAlphabet End Function Public Function LPadWithChar(Argvalue As String, Character As String, Length As Integer) As String 'Left Pad with a certain Character the argvalue to make Length length Dim strTemp As String Dim strChar As String Dim intI As Integer strTemp = Argvalue If Len(Character) > 1 Then Character = Left$(Character, 1) End If If Length > Len(Argvalue) Then strChar = "" For intI = 1 To (Length - Len(Argvalue)) strChar = strChar + Character Next intI strTemp = strChar + Argvalue End If LPadWithChar = strTemp End Function Public Function RPadWithChar(Argvalue As String, Character As String, Length As Integer) As String 'Left Pad with a certain Character the argvalue to make Length length Dim strTemp As String Dim strChar As String Dim intI As Integer strTemp = Argvalue If Len(Character) > 1 Then Character = Left$(Character, 1) End If If Length > Len(Argvalue) Then strChar = "" For intI = 1 To (Length - Len(Argvalue)) strChar = strChar + Character Next intI strTemp = Argvalue + strChar End If RPadWithChar = strTemp End Function Public Function CPadWithChar(Argvalue As String, Character As String, Length As Integer, PadRightSide As Boolean) As String 'Center Pad with a certain Character the argvalue to make Length length Dim strTemp As String Dim strChar As String Dim intI As Integer If Len(Argvalue) > 0 Then If Len(Argvalue) <= Length Then If Length Mod 2 = 1 Then If Len(Argvalue) Mod 2 = 1 Then strChar = "" For intI = 1 To (Length - Len(Argvalue)) \ 2 strChar = strChar + Character Next intI strTemp = strChar + Argvalue If PadRightSide = True Then strChar = "" For intI = 1 To (Length - Len(Argvalue)) \ 2 strChar = strChar + Character Next intI strTemp = strTemp + strChar End If Else strChar = "" For intI = 1 To ((Length - Len(Argvalue)) \ 2) strChar = strChar + Character Next intI strTemp = strChar + Argvalue If PadRightSide = True Then strChar = "" For intI = 1 To ((Length - Len(Argvalue)) \ 2) + 1 strChar = strChar + Character Next intI strTemp = strTemp + strChar End If End If Else If Len(Argvalue) Mod 2 = 0 Then strChar = "" For intI = 1 To (Length - Len(Argvalue)) \ 2 strChar = strChar + Character Next intI strTemp = strChar + Argvalue If PadRightSide = True Then strChar = "" For intI = 1 To (Length - Len(Argvalue)) \ 2 strChar = strChar + Character Next intI strTemp = strTemp + strChar End If Else strChar = "" For intI = 1 To ((Length - Len(Argvalue)) \ 2) strChar = strChar + Character Next intI strTemp = strChar + Argvalue If PadRightSide = True Then strChar = "" For intI = 1 To ((Length - Len(Argvalue)) \ 2) + 1 strChar = strChar + Character Next intI strTemp = strTemp + strChar End If End If End If Else strTemp = Left$(Argvalue, Length) End If Else For intI = 1 To (Length - Len(Argvalue)) \ 2 strChar = strChar + Character strTemp = strChar Next intI End If CPadWithChar = strTemp End Function Public Function HGridFormat(Grid As MSHFlexGrid, Columns As Integer, HeadingsString As String) Dim intI As Integer Dim intJ As Integer Dim intPointer As Integer Dim strHeading As String Grid.RowPosition(0) = 0 Grid.Cols = Columns intPointer = 0 For intI = 1 To Columns - 1 Grid.Col = intI strHeading = "" intPointer = intPointer + 1 For intJ = intPointer To Len(HeadingsString) intPointer = intJ If Mid$(HeadingsString, intPointer, 1) = "?" Then Grid.TextMatrix(0, Grid.Col) = strHeading Exit For Else strHeading = strHeading + Mid$(HeadingsString, intPointer, 1) End If Next intJ Next intI End Function Public Sub AdjustHGrid(Grid As MSHFlexGrid, Columns As Integer, FullScreenRows As Integer) Dim intI As Integer Grid.Width = 0 For intI = 0 To Columns - 1 Grid.Width = Grid.Width + Grid.ColWidth(intI) Next intI If Grid.Rows > FullScreenRows Then Grid.Width = Grid.Width + 310 Else Grid.Width = Grid.Width + 50 End If End Sub 'Public Function FGridFormat(Grid As MSFlexGrid, Columns As Integer, HeadingsString As String) 'Dim intI As Integer 'Dim intJ As Integer 'Dim intPointer As Integer 'Dim strHeading As String ' 'Grid.Row = 0 'Grid.Cols = Columns ' 'intPointer = 0 'For intI = 1 To Columns - 1 ' Grid.Col = intI ' strHeading = "" ' intPointer = intPointer + 1 ' For intJ = intPointer To Len(HeadingsString) ' intPointer = intJ ' If Mid$(HeadingsString, intPointer, 1) = "?" Then ' Grid.TextMatrix(0, Grid.Col) = strHeading ' Exit For ' Else ' strHeading = strHeading + Mid$(HeadingsString, intPointer, 1) ' End If ' Next intJ ' Grid.CellFontBold = True ' 'Next intI ' 'End Function 'Public Sub AdjustFGrid(Grid As MSFlexGrid, Columns As Integer, FullScreenRows As Integer) 'Dim intI As Integer ' 'Grid.Width = 0 'For intI = 0 To Columns - 1 ' Grid.Width = Grid.Width + Grid.ColWidth(intI) 'Next intI ' 'If Grid.Rows > FullScreenRows Then ' Grid.Width = Grid.Width + 360 'Else ' Grid.Width = Grid.Width + 100 'End If 'End Sub Public Sub Focus(TextBoxControl As TextBox) 'Highlight the contents of a text box TextBoxControl.SelStart = 0 TextBoxControl.SelLength = Len(TextBoxControl.Text) Call Change_Color_Got_Focus(TextBoxControl) End Sub 'Public Function Check_PatientsMed(strIDNum As String) As Boolean ' 'Dim recCash As New ADODB.Recordset ' 'recCash.Open "Select Isnull(PatientsMed,0) as PatientsMed from Patient_data..tbPatient2 where IDNum ='" & Trim$(strIDNum) & "'", pclsUser.sqlconnection, adOpenForwardOnly, adLockReadOnly 'If Not recCash.EOF Then ' Check_PatientsMed = recCash!PatientsMed 'Else ' Check_PatientsMed = False 'End If 'recCash.Close 'Set recCash = Nothing 'End Function Public Sub InitConnection() objUser.Server = "mdhserver" objUser.UserId = "sa" objUser.Password = "" con.Open ConnectString("") Rec.CursorLocation = adUseClient 'con.DefaultDatabase = "LMCSERVER" con.DefaultDatabase = "PASSWORD" 'objpclsUser.Server = "psh-ntserver" 'objpclsUser.UserId = "sa" 'objpclsUser.Password = "" 'con.Open ConnectString("") 'rec.CursorLocation = adUseClient 'con.DefaultDatabase = "psh" 'Set objInpatient = CreateObject("Patientclass.clspatient", "kcci") 'Set objPatient = CreateObject("Patient.clsPatient", "") 'Set objMaster = CreateObject("MasterSearch.clsPatientSearch", "") 'objPatient.OpenConnection "Provider=SQLOLEDB;Server=kcci-angelo;UID=sa;Database=mdh" 'Set ObjAdm = objPatient.clsAdmission 'Set ObjMas = objPatient.clsPatientMaster 'Set objOut = objPatient.clsOutPatient End Sub Public Function Alphabet() As String 'Returns the Alphabet String for specific use in filtering keystrokes Alphabet = "ABCDEFGHIJKLMNOPQRSTUVWXYZÑ." End Function Public Function Numerals() As String 'Return the Numerals string for specific use in filtering keystrokes Numerals = "1234567890" End Function Public Function KeyStrokeFilter(ValidKeys As String, KeyAscii As Integer) As Integer 'Returns whether KeyAscii is within ValidKeys Dim intI As Integer Dim blnFound As Boolean 'Indicates whether KeyAscii was found within ValidKeys '-----Lower case alphabet becomes upper case alphabet---------------------------- If KeyAscii >= 97 And KeyAscii <= 122 Then KeyAscii = Asc(UCase$(Chr$(KeyAscii))) End If '-------------------------------------------------------------------------------- '-----Search for Keyascii in ValidKeys------------------------------------------- For intI = 1 To Len(ValidKeys) If Asc(Mid$(ValidKeys, intI, 1)) = KeyAscii Then blnFound = True Exit For End If Next intI '--------------------------------------------------------------------------------- 'You can add here the unprintable keystores, e.g. TAB, ENTER, BACKSPACE, ESCAPE----------- 'so they can also be included----------------------------------------------------- If blnFound = False Then Select Case KeyAscii Case 9, 13, 8, 27 blnFound = True End Select End If '--------------------------------------------------------------------------------- 'If Keyascii is within ValidKeys then pass back keyascii------------------------- 'else keyascii = 0--------------------------------------------------------------- If blnFound = True Then KeyStrokeFilter = KeyAscii Else KeyStrokeFilter = 0 End If '--------------------------------------------------------------------------------- End Function Public Function ConnectString(sdata$) As String With objUser If sdata <> "" Then ConnectString = "Driver={SQL Server};Server=" _ & .Server & ";Database=" & sdata & ";UID=" _ & .UserId & ";PWD=" & .Password & ";" Else ConnectString = "Driver={SQL Server};Server=" _ & .Server & ";UID=" _ & .UserId & ";PWD=" & .Password & ";" End If End With End Function Public Function ToInteger(Argvalue As Variant) As Integer 'Converts a variable to integer data type If IsNumeric(Trim$(Argvalue)) = True Then ToInteger = Val(Trim$(Str$(Argvalue))) Else ToInteger = 0 End If End Function Public Function ToDouble(Argvalue As Variant) As Double 'Converts a variable to double data type If IsNumeric(Trim$(Argvalue)) = True Then ToDouble = Val(Trim$(Str$(Argvalue))) Else ToDouble = 0 End If End Function Public Function IsValidQuantity(Argvalue As Variant, IncludeZero As Boolean, WithMessage As Boolean) As Boolean 'Check if argvalue is valid quantity. If IncludeZero is true, zero quantity is allowed. 'If WithMessage is true then error messages will show. Dim intX As Integer Dim blnValid As Boolean 'Temporary Variable that be assign to the IsValidQuantity blnValid = True '-------Check if argvalue is of numeric format------------------------------------ If IsWholeNumber(Trim$(Str$(Argvalue))) = False Then blnValid = False End If '--------------------------------------------------------------------------------- '------If argvalue is negative then isvalidquantity is false '------If IncludeZero is false and argvalue is zero then isvalidquantity is false If blnValid = True Then If Val(Argvalue) < 0 Then If WithMessage = True Then MsgBox "Negative Numbers are not allowed." End If blnValid = False Else If Argvalue = 0 And IncludeZero = False Then If WithMessage Then intX = MsgBox("The quantity you placed is zero. Do you want to proceed ? ", 52, "Verification") If intX = 7 Then blnValid = False End If Else blnValid = False End If End If End If End If '--------------------------------------------------------------------------------- IsValidQuantity = blnValid End Function Public Function IsValidAmount(Argvalue As Variant, IncludeZero As Boolean, WithMessage As Boolean) As Boolean 'Check if argvalue is valid amount. If IncludeZero is true, zero amount is allowed. 'If WithMessage is true then error messages will show. Dim intX As Integer Dim blnValid As Boolean blnValid = True '-----Check if argvalue is of numeric format-------------------------------------- If IsNumeric(Trim$(Str$(Argvalue))) = False Then blnValid = False End If '--------------------------------------------------------------------------------- '------If argvalue is negative then isvalidamount is false '------If IncludeZero is false and argvalue is zero then isvalidamount is false '------If argvalue is above a million then prompt user if this is correct, if not then isvalidamount is false If blnValid = True Then If Val(Argvalue) < 0 Then If WithMessage = True Then MsgBox "Negative Values are not allowed." End If blnValid = False Else If Val(Argvalue) = 0 Then If IncludeZero = False Then If WithMessage = True Then intX = MsgBox("The amount you placed is zero. Is this correct ? ", 52, "Verification") If intX = 7 Then blnValid = False End If End If End If Else If Argvalue > 1000000 Then If WithMessage = True Then intX = MsgBox("The amount you placed is greater than a million. Is this correct ? ", 52, "Verification") If intX = 7 Then blnValid = False End If End If End If End If End If End If '---------------------------------------------------------------------------------- IsValidAmount = blnValid End Function Public Function NumbertoMonthWord(Argvalue As Integer) As String 'Converts an integer variable to Month Word format Select Case Argvalue Case 1 NumbertoMonthWord = "January" Case 2 NumbertoMonthWord = "February" Case 3 NumbertoMonthWord = "March" Case 4 NumbertoMonthWord = "April" Case 5 NumbertoMonthWord = "May" Case 6 NumbertoMonthWord = "June" Case 7 NumbertoMonthWord = "July" Case 8 NumbertoMonthWord = "August" Case 9 NumbertoMonthWord = "September" Case 10 NumbertoMonthWord = "October" Case 11 NumbertoMonthWord = "November" Case 12 NumbertoMonthWord = "December" End Select End Function Public Function MonthWordToNumber(Argvalue As String) As Integer 'Convert a string variable to month numeric representation Select Case UCase$(Argvalue) Case "JANUARY" MonthWordToNumber = 1 Case "FEBRUARY" MonthWordToNumber = 2 Case "MARCH" MonthWordToNumber = 3 Case "APRIL" MonthWordToNumber = 4 Case "MAY" MonthWordToNumber = 5 Case "JUNE" MonthWordToNumber = 6 Case "JULY" MonthWordToNumber = 7 Case "AUGUST" MonthWordToNumber = 8 Case "SEPTEMBER" MonthWordToNumber = 9 Case "OCTOBER" MonthWordToNumber = 10 Case "NOVEMBER" MonthWordToNumber = 11 Case "DECEMBER" MonthWordToNumber = 12 End Select End Function Public Function IsValidYear(Argvalue As String) As Boolean 'Checks whether passed variable is from Year 1998 to Year 9999 Dim intI As Integer Dim blnValid As Boolean blnValid = True If Len(Argvalue) = 0 Or Len(Argvalue) > 4 Then blnValid = False Else For intI = 1 To Len(Argvalue) If IsNumeric(Mid$(Argvalue, intI, 1)) = False Then blnValid = False Exit For End If Next intI End If If blnValid = True Then If Val(Argvalue) < 1998 Or Val(Argvalue) > 9999 Then blnValid = False End If End If IsValidYear = blnValid End Function Public Function IsValidDay(Argvalue As String) As Boolean 'Checks whether passed variable is a day from 1 to 31 Dim intI As Integer Dim blnValid As Boolean blnValid = True If Len(Argvalue) = 0 Or Len(Argvalue) > 2 Then blnValid = False Else For intI = 1 To Len(Argvalue) If IsNumeric(Mid$(Argvalue, intI, 1)) = False Then blnValid = False Exit For End If Next intI End If If blnValid = True Then If Val(Argvalue) < 1 Or Val(Argvalue) > 31 Then blnValid = False End If End If IsValidDay = blnValid End Function Public Function IsValidMonth(Argvalue As String) As Boolean 'Checks whether passed variable is a month from 1 to 12 Dim intI As Integer Dim blnValid As Boolean blnValid = True If Len(Argvalue) = 0 Or Len(Argvalue) > 2 Then blnValid = False Else For intI = 1 To Len(Argvalue) If IsNumeric(Mid$(Argvalue, intI, 1)) = False Then blnValid = False Exit For End If Next intI End If If blnValid = True Then If Val(Argvalue) < 1 Or Val(Argvalue) > 12 Then blnValid = False End If End If IsValidMonth = blnValid End Function Public Function IsValidDate(Argvalue As String) As Boolean 'Checks whether passed variable conforms to date format: mm/dd/yyyy Dim intI As Integer Dim blnValid As Boolean Dim strMonth As String Dim strDay As String Dim strYear As String Dim blnCase1 As Boolean Dim blnCase2 As Boolean blnValid = True Select Case Len(Argvalue) Case 8 If Mid$(Argvalue, 2, 1) <> "/" Or Mid$(Argvalue, 4, 1) <> "/" Then blnValid = False End If If blnValid = True Then strMonth = Mid$(Argvalue, 1, 1) strDay = Mid$(Argvalue, 3, 1) strYear = Mid$(Argvalue, 5, 4) If IsValidMonth(strMonth) = False Or IsValidDay(strDay) = False Or IsValidYear(strYear) = False Then blnValid = False End If End If Case 9 If Mid$(Argvalue, 2, 1) = "/" And Mid$(Argvalue, 5, 1) = "/" Then blnCase1 = True Else If Mid$(Argvalue, 3, 1) = "/" And Mid$(Argvalue, 5, 1) = "/" Then blnCase2 = True Else blnValid = False End If End If If blnValid = True Then If blnCase1 = True Then strMonth = Mid$(Argvalue, 1, 1) strDay = Mid$(Argvalue, 3, 2) strYear = Mid$(Argvalue, 6, 4) If IsValidMonth(strMonth) = False Or IsValidDay(strDay) = False Or IsValidYear(strYear) = False Then blnValid = False End If Else If blnCase2 = True Then strMonth = Mid$(Argvalue, 1, 2) strDay = Mid$(Argvalue, 4, 1) strYear = Mid$(Argvalue, 6, 4) If IsValidMonth(strMonth) = False Or IsValidDay(strDay) = False Or IsValidYear(strYear) = False Then blnValid = False End If End If End If End If Case 10 If Mid$(Argvalue, 3, 1) <> "/" Or Mid$(Argvalue, 6, 1) <> "/" Then blnValid = False End If If blnValid = True Then strMonth = Mid$(Argvalue, 1, 2) strDay = Mid$(Argvalue, 4, 2) strYear = Mid$(Argvalue, 7, 4) If IsValidMonth(strMonth) = False Or IsValidDay(strDay) = False Or IsValidYear(strYear) = False Then blnValid = False End If End If Case Else blnValid = False End Select IsValidDate = blnValid End Function Public Function IsValidIdnum(Argvalue As String) As Boolean 'Checks whether passed variable is a valid admission number Dim intI As Integer Dim blnValid As Boolean blnValid = True If Len(Argvalue) >= 1 And Len(Argvalue) <= 8 Then If Len(Argvalue) = 1 Then If UCase$(Mid$(Argvalue, 1, 1)) = "W" Then MsgBox "Invalid Idnum." blnValid = False Else If IsWholeNumber(Argvalue) = False Then MsgBox "Invalid Idnum." blnValid = False End If End If Else If UCase$(Mid$(Argvalue, 1, 1)) = "W" Then For intI = 2 To Len(Argvalue) If IsWholeNumber(Mid$(Argvalue, intI, 1)) = False Then MsgBox "Invalid Idnum." blnValid = False Exit For End If Next intI Else For intI = 1 To Len(Argvalue) If IsWholeNumber(Mid$(Argvalue, intI, 1)) = False Then MsgBox "Invalid Idnum." blnValid = False Exit For End If Next intI End If End If Else MsgBox "Invalid Idnum." blnValid = False End If IsValidIdnum = blnValid End Function Public Function IsValidHospnum(Argvalue As String) As Boolean 'Check whether passed variable is a valid hospital number Dim intI As Integer Dim blnValid As Boolean blnValid = True If Len(Argvalue) >= 1 And Len(Argvalue) <= 8 Then For intI = 1 To Len(Argvalue) If IsWholeNumber(Mid$(Argvalue, intI, 1)) = False Then blnValid = False MsgBox "Invalid Hospnum." Exit For End If Next intI Else blnValid = False MsgBox "Invalid Idnum." End If IsValidHospnum = blnValid End Function Public Function HospNumFoundInMasterfile(Argvalue As String) As Boolean Dim blnValid As Boolean blnValid = True Rec.Open "global_searchMasterFile '" & UCase$(Argvalue) & "',4", PCLSUser.sqlConnection, adOpenDynamic, adLockOptimistic If Rec.RecordCount = 0 Then blnValid = False MsgBox "Patient is not in the Master File." End If Rec.Close HospNumFoundInMasterfile = blnValid End Function Public Function PatientIsCurrentlyAdmitted(Argvalue As String) As Boolean Dim blnValid As Boolean Dim blnFound As Boolean blnValid = True Rec.Open "Billing..sp_billing_searchInpatient '" & UCase$(Argvalue) & "','',1", PCLSUser.sqlConnection, adOpenDynamic, adLockOptimistic If Rec.RecordCount = 0 Then Rec.Close Rec.Open "Billing..sp_billing_searchoutpatient '" & UCase$(Argvalue) & "','',1", PCLSUser.sqlConnection, adOpenDynamic, adLockOptimistic If Rec.RecordCount > 0 Then blnFound = True Rec.Close Else blnFound = False Rec.Close End If Else blnFound = True Rec.Close End If If blnFound = False Then blnValid = False MsgBox "Patient is not confined." End If PatientIsCurrentlyAdmitted = True End Function Public Sub Give_Me_Names(Argvalue As String) 'Returns the Last Name(global var. strApelyido) and First Name(global var. strPangalan) Dim intY As Integer strApelyido = "" strPangalan = "" intY = InStr(Argvalue, ",") If intY <= 0 Then strApelyido = Trim$(Argvalue) strPangalan = "" Else strApelyido = Trim$(Left$(Argvalue, intY - 1)) If Len(Argvalue) - intY > 0 Then strPangalan = Trim$(Right$(Argvalue, Len(Argvalue) - intY)) Else strPangalan = "" End If End If strApelyido = UCase$(strApelyido) strPangalan = UCase$(strPangalan) End Sub Public Sub CenterForm(Anyform As Form) 'Centers a Form relative to the screen Anyform.Left = (frmMain.ScaleWidth - Anyform.Width) / 2 Anyform.Top = (frmMain.ScaleHeight - Anyform.Height) / 2 End Sub Public Sub LoadHospitalInfo(intHospitalID As Integer) Dim intX As Integer Rec.Open "global_loadhospitalinfo '" & intHospitalID & "'", PCLSUser.sqlConnection, adOpenDynamic, adLockOptimistic If Rec.RecordCount > 0 Then strHospitalTitle = Rec!Title & "" strHospitalCompany = Rec!Company & "" strHospitalAddress1 = Rec!Address1 & "" strTinNo = Rec!TINNO & "" Rec.Close Else intX = MsgBox("Important file does not exist, call your EDP staff for support.", vbOKOnly, "Notificication") Rec.Close End End If strHospitalTitle = "MANILA DOCTORS HOSPITAL" strHospitalAddress1 = "667 UNITED NATIONS AVENUE, MALATE, MANILA" End Sub Public Function Repl(Character As String, NumberOfTimes As Integer) As String 'Replicates a Character to NumberofTimes times Dim intI As Integer Dim strCh As String For intI = 1 To NumberOfTimes strCh = strCh + Character Next intI Repl = strCh End Function Public Function AdvLeft$(Argvalue As String, Length As Integer) 'Advanced Left$ function that verifies if length of string variable is greater than or less than the trim length If Len(Argvalue) <= Length Then AdvLeft$ = Argvalue Else AdvLeft$ = Left$(Argvalue, Length) End If End Function Public Function Cap(Argvalue As String) As String 'Capitalizes first letter of a string variable Dim strResult As String If Len(Argvalue) > 0 Then strResult = UCase$(Mid$(Argvalue, 1, 1)) If Len(Argvalue) > 1 Then strResult = strResult + LCase$(Mid$(Argvalue, 2, (Len(Argvalue) - 1))) End If End If Cap$ = strResult End Function Public Function UAF(Argvalue As String) As String 'Uppercases All First letters of a word Dim intI As Integer Dim strResult As String For intI = 1 To Len(Argvalue) If intI = 1 Then strResult = Left$(Argvalue, 1) Else If Mid$(Argvalue, intI - 1, 1) = " " Or Mid$(Argvalue, intI - 1, 1) = "-" Or Mid$(Argvalue, intI - 1, 1) = "," Then strResult = strResult + UCase$(Mid$(Argvalue, intI, 1)) Else strResult = strResult + LCase$(Mid$(Argvalue, intI, 1)) End If End If Next intI UAF = strResult End Function 'Public Sub SortFGrid(Grid1 As MSFlexGrid, NumberofRowsToSort As Integer, ColumnNumberToSort As Integer, SortOrder As Integer) 'If Grid1.Rows > 0 Then ' Grid1.Row = 0 ' Grid1.RowSel = Grid1.Rows - 1 ' Grid1.Col = ColumnNumberToSort ' Grid1.ColSel = ColumnNumberToSort ' Grid1.Sort = SortOrder 'End If 'End Sub Public Sub SortHGrid(Grid1 As MSHFlexGrid, NumberofRowsToSort As Integer, ColumnNumberToSort As Integer, SortOrder As Integer) If Grid1.Rows > 0 Then Grid1.Row = 0 Grid1.RowSel = NumberofRowsToSort - 1 'Grid1.Rows - 1 Grid1.Col = ColumnNumberToSort Grid1.ColSel = ColumnNumberToSort Grid1.Sort = SortOrder End If End Sub 'Public Sub MyFormatStringF(Grid1 As MSFlexGrid, FormatString As String) 'Dim intI As Integer 'Dim intJ As Integer ' 'intJ = -1 ' 'For intI = 1 To Len(FormatString) ' Select Case Mid$(FormatString, intI, 1) ' Case ">", "<", "^" ' intJ = intJ + 1 ' If intJ <= Grid1.Cols - 1 Then ' Select Case Mid$(FormatString, intI, 1) ' Case "<" ' Grid1.ColAlignment(intJ) = 1 ' Case ">" ' Grid1.ColAlignment(intJ) = 7 ' Case "^" ' Grid1.ColAlignment(intJ) = 4 ' End Select ' End If ' End Select 'Next intI ' 'End Sub Public Sub MyFormatStringH(Grid1 As MSHFlexGrid, FormatString As String) Dim intI As Integer Dim intJ As Integer intJ = -1 For intI = 1 To Len(FormatString) Select Case Mid$(FormatString, intI, 1) Case ">", "<", "^" intJ = intJ + 1 If intJ <= Grid1.Cols - 1 Then Select Case Mid$(FormatString, intI, 1) Case "<" Grid1.ColAlignment(intJ) = 1 Case ">" Grid1.ColAlignment(intJ) = 7 Case "^" Grid1.ColAlignment(intJ) = 4 End Select End If End Select Next intI End Sub Public Function IsBlank(Argvalue As String) As Boolean If Len(Trim$(Argvalue)) = 0 Then IsBlank = True Else IsBlank = False End If End Function Public Sub ClearAccessDB(AccessDB As data) Dim intI As Integer Dim intTotalData1 As Integer If AccessDB.Recordset.BOF = False Then AccessDB.Recordset.MoveLast End If intTotalData1 = AccessDB.Recordset.RecordCount If AccessDB.Recordset.BOF = False Then AccessDB.Recordset.MoveFirst End If For intI = 0 To intTotalData1 - 1 AccessDB.Recordset.Delete AccessDB.Recordset.MoveNext Next intI End Sub Public Function RFixMe(Argvalue As String, stringLength As Integer) As String If Len(Argvalue) < stringLength Then RFixMe = LPadWithChar(Argvalue, " ", stringLength) Else RFixMe = Left$(Argvalue, stringLength) End If End Function Public Function LFixMe(Argvalue As String, stringLength As Integer) As String If Len(Argvalue) < stringLength Then LFixMe = AdvLeft$(RPadWithChar(Argvalue, " ", stringLength), stringLength) Else LFixMe = Left$(Argvalue, stringLength) End If End Function Public Function DecimalPad(Argvalue As String) As String 'Returns string representation of a numeric value with 2 decimal places Dim intY As Integer Dim strNewValue As String strNewValue = Argvalue intY = InStr(Argvalue, ".") If intY > 0 Then If IsNumeric(Argvalue) = True Then If Mid$(Argvalue, 1, 1) = "." Then Select Case intY Case Len(Argvalue) If Len(Argvalue) = 1 Then strNewValue = "0.00" Else strNewValue = Argvalue + "00" End If Case Len(Argvalue) - 1 strNewValue = "0" + Argvalue + "0" Case Len(Argvalue) - 2 strNewValue = "0" + Argvalue Case Else strNewValue = "0" + Left$(Argvalue, 3) End Select Else Select Case intY Case Len(Argvalue) If Len(Argvalue) = 1 Then strNewValue = "0.00" Else strNewValue = Argvalue + "00" End If Case Len(Argvalue) - 1 strNewValue = Argvalue + "0" Case Else strNewValue = Left$(Argvalue, intY - 1) + "." + Mid$(Argvalue, intY + 1, 2) End Select End If Else strNewValue = "0.00" 'if blank or not all numeric End If Else If IsNumeric(Argvalue) = True Then If Mid$(Argvalue, 1, 1) = "0" Then Select Case Len(Argvalue) Case 1 strNewValue = "0.00" Case 2 strNewValue = "0." + Mid$(Argvalue, 2, 1) + "0" Case Else strNewValue = "0." + Mid$(Argvalue, 2, 2) End Select Else strNewValue = Argvalue + ".00" End If Else strNewValue = "0.00" End If End If DecimalPad = strNewValue End Function Public Sub FadeForm(frm As Form, red%, Green%, blue%) Dim SaveScale%, SaveStyle%, SaveRedraw% Dim j&, X&, Y&, pixels% 'Save current settings. SaveScale = frm.ScaleMode SaveStyle = frm.DrawStyle SaveRedraw = frm.AutoRedraw 'Paint screen. frm.ScaleMode = 3 pixels = Screen.Height / Screen.TwipsPerPixelY X = pixels / 64# + 0.5 frm.DrawStyle = 5 'frm.AutoRedraw = Tr For j = 0 To pixels Step X Y = 240 - 245 * j \ pixels 'can tweak this to preference. If Y < 0 Then Y = 0 'just in case frm.Line (-2, j - 2)-(Screen.Width + 2, j + _ X + 3), RGB(-red * Y, -Green * Y, -blue * Y), BF Next j 'Reset to previous settings. frm.ScaleMode = SaveScale frm.DrawStyle = SaveStyle frm.AutoRedraw = SaveRedraw End Sub Public Sub GivePBRange(ProgressBar As ProgressBar, Minimum As Integer, Maximum As Integer) ProgressBar.Min = 0 ProgressBar.Max = (Maximum - Minimum) + 1 If Maximum - Minimum > 0 Then ProgressBar.Visible = True End If End Sub Public Function ReturnCivilStatus(Argvalue As String) As String Select Case UCase$(Argvalue) Case "0" ReturnCivilStatus = "CHILD" Case "1" ReturnCivilStatus = "SINGLE" Case "2" ReturnCivilStatus = "MARRIED" Case "3" ReturnCivilStatus = "WIDOW" Case "4" ReturnCivilStatus = "SEPARATED" Case "5" ReturnCivilStatus = "DIVORCED" End Select End Function Public Function NumericInputSuppress(Argvalue As String, KeyAscii As Integer, MaxNumber As String) As Integer 'Suppresses the numerals you can put in a textbox up to Max Number and up to 2 decimal places only Dim strNewValue As String Dim intPosition As Integer Dim intNewKeyAscii As Integer intNewKeyAscii = KeyAscii If (KeyAscii >= 48 And KeyAscii <= 57) Or (Chr(KeyAscii) = ".") Then Select Case Chr(KeyAscii) Case "0", "1", "2", "3", "4", "5", "6", "7", "8", "9" strNewValue = Argvalue + Chr(KeyAscii) If IsNumeric(strNewValue) = True Then If Val(strNewValue) > Val(MaxNumber) Then intNewKeyAscii = 0 Else intPosition = InStr(Argvalue, ".") If intPosition > 0 Then If (Len(Argvalue) - intPosition) > 1 Then intNewKeyAscii = 0 End If End If End If Else intNewKeyAscii = 0 End If Case "." If InStr(Argvalue, ".") > 0 Then intNewKeyAscii = 0 End If End Select End If NumericInputSuppress = intNewKeyAscii End Function Public Function NamePunctDelimiter(Argvalue As String, KeyAscii As Integer) As Integer If Len(Trim$(Argvalue)) = 0 Then If Chr$(KeyAscii) = " " Or Chr$(KeyAscii) = "," Then NamePunctDelimiter = 0 Else NamePunctDelimiter = KeyAscii End If Else If InStr(Argvalue, ",") > 0 And Chr$(KeyAscii) = "," Then NamePunctDelimiter = 0 Else NamePunctDelimiter = KeyAscii End If End If End Function Public Sub AddLine(Argvalue As String) 'frmInpatientLedgerNext.data1.Recordset.AddNew 'frmInpatientLedgerNext.data1.Recordset.Fields(0).Value = Argvalue 'frmInpatientLedgerNext.data1.Recordset.Update 'frmBillingMain.Data1.Recordset.AddNew 'frmBillingMain.Data1.Recordset.Fields(0).Value = Argvalue 'frmBillingMain.Data1.Recordset.Update End Sub Public Function SegregateSelTexted(TextBoxControl As TextBox) As String Dim intY As Integer Dim strNewValue As String strNewValue = TextBoxControl.Text If TextBoxControl.SelLength > 0 Then intY = Len(TextBoxControl.Text) - TextBoxControl.SelLength If intY > 0 Then Select Case TextBoxControl.SelStart Case 0 strNewValue = Right$(TextBoxControl.Text, Len(TextBoxControl.Text) - TextBoxControl.SelLength) Case Len(TextBoxControl.Text) - TextBoxControl.SelLength strNewValue = Left$(TextBoxControl.Text, TextBoxControl.SelStart) Case Else strNewValue = Left$(TextBoxControl.Text, TextBoxControl.SelStart) strNewValue = strNewValue + Right$(TextBoxControl.Text, Len(TextBoxControl.Text) - (TextBoxControl.SelStart + TextBoxControl.SelLength)) End Select Else strNewValue = "" End If End If SegregateSelTexted = strNewValue End Function Public Function MoneyFormatWithComma(Argvalue As String) As String MoneyFormatWithComma = Format$(Argvalue, " #,###,##0.00") End Function Public Function Ones(Argvalue As String) As String Select Case Argvalue Case "1" Ones = "one" Case "2" Ones = "two" Case "3" Ones = "three" Case "4" Ones = "four" Case "5" Ones = "five" Case "6" Ones = "six" Case "7" Ones = "seven" Case "8" Ones = "eight" Case "9" Ones = "nine" End Select End Function Public Function Tens(Argvalue As String) As String Select Case Argvalue Case "10" Tens = "ten" Case "11" Tens = "eleven" Case "12" Tens = "twelve" Case "13" Tens = "thirteen" Case "14" Tens = "fourteen" Case "15" Tens = "fifteen" Case "16" Tens = "sixteen" Case "17" Tens = "seventeen" Case "18" Tens = "eighteen" Case "19" Tens = "nineteen" Case "20" Tens = "twenty" Case "30" Tens = "thirty" Case "40" Tens = "forty" Case "50" Tens = "fifty" Case "60" Tens = "sixty" Case "70" Tens = "seventy" Case "80" Tens = "eighty" Case "90" Tens = "ninety" End Select End Function Public Function MoreThanWords(Argvalue As String) As String Dim str1 As String Dim str2 As String Dim str3 As String Select Case Val(Argvalue) Case 1 To 9 MoreThanWords = Ones((Val(Argvalue))) Case 10 To 20 MoreThanWords = Tens((Val(Argvalue))) Case 21 To 99 If Val(Argvalue / 10) = 1 Then MoreThanWords = Tens(Mid$(Argvalue, 1, 1) + "0") Else MoreThanWords = Tens(Mid$(Argvalue, 1, 1) + "0") + " " + Ones(Mid$(Argvalue, 2, 1)) End If Case 100 To 999 Select Case Val(Mid$(Argvalue, 2, 2)) Case 0 MoreThanWords = Ones(Mid$(Argvalue, 1, 1)) + " " + "hundred" Case Else MoreThanWords = Ones(Mid$(Argvalue, 1, 1)) + " " + "hundred" + " " + MoreThanWords((Val(Mid$(Argvalue, 2, 2)))) End Select Case 1000 To 999999 str2 = (Val(Argvalue) \ 1000) str1 = (Val(Argvalue Mod 1000)) MoreThanWords = MoreThanWords((str2)) + " " + "thousand" + " " + MoreThanWords((str1)) Case 1000000 To 999999999 str3 = (Val(Argvalue) \ 1000000) str2 = (Val(Right$(Argvalue, 6)) \ 1000) str1 = (Val(Argvalue Mod 1000)) If Val(str2) = 0 Then MoreThanWords = MoreThanWords((str3)) + " " + "million" + " " + MoreThanWords((str1)) Else MoreThanWords = MoreThanWords((str3)) + " " + "million" + " " + MoreThanWords((str2)) + " " + "thousand" + " " + MoreThanWords((str1)) End If End Select End Function Public Function NumberToWords(Argvalue As String) As String Dim str1 As String Dim str2 As String Dim strTemp As String If InStr(Argvalue, ".") > 0 Then strTemp = Format$(Argvalue, "########0.00") str1 = Mid$(strTemp, 1, Len(strTemp) - 3) str2 = Right$(strTemp, 2) If Val(str2) = 0 Then If Val(str1) = 0 Then NumberToWords = "nothing" Else NumberToWords = MoreThanWords(str1) + " pesos" End If Else If Val(str1) = 0 Then NumberToWords = MoreThanWords(str2) + " centavos" Else NumberToWords = MoreThanWords(str1) + " " + "pesos" + " " + "and" + " " + MoreThanWords(str2) + " " + "centavos" End If End If Else NumberToWords = MoreThanWords(Format$(Argvalue, "#########")) + " pesos" End If End Function Public Function ToDate(Argvalue As Variant) As Date 'Converts a variable to date data type If IsDate(Trim$(Argvalue)) = True Then ToDate = Trim$(Argvalue) Else ToDate = 0 End If End Function Public Function SQLType(AsciiChar As Integer) As Integer Select Case Chr$(AsciiChar) Case "a" To "z" SQLType = Asc(UCase$(Chr$(AsciiChar))) Case "'" SQLType = Asc("`") Case Else SQLType = AsciiChar End Select End Function Public Sub Change_Color_Got_Focus(TextBoxControl As TextBox) TextBoxControl.ForeColor = &H0& TextBoxControl.BackColor = &HFFFFFF End Sub Public Sub Change_Color_Lost_Focus(TextBoxControl As TextBox) TextBoxControl.ForeColor = &H0& TextBoxControl.BackColor = &H80000018 End Sub Public Function Give_My_Age(Argvalue As String) As Integer If IsDate(Argvalue) = True Then If Format$(Argvalue, "yyyy/mm/dd") <= Format$(Date, "yyyy/mm/dd") Then If Format$(Date, "mm/dd") < Format$(Argvalue, "mm/dd") Then Give_My_Age = DateDiff("yyyy", ToDate(Argvalue), Date) - 1 Else Give_My_Age = DateDiff("yyyy", ToDate(Argvalue), Date) End If End If End If End Function Public Function GetServerName(ByVal strServerName As String) As String Dim strTemp As String strTemp = Mid(strServerName, InStr(1, strServerName, "Server", vbTextCompare) + 7) GetServerName = Mid(strTemp, 1, InStr(1, strTemp, ";") - 1) End Function Public Function StringLen(ByVal strVar As String) As Integer StringLen = Len(Trim$(strVar)) End Function Public Function ChkSurname(strName As String, Optional blnAllowBlank As Boolean = False) As Boolean If Len(Trim$(strName)) = 0 Then ChkSurname = blnAllowBlank Else strName = " " + strName + " " If InStr(1, strName, " JR ") > 0 Or InStr(1, strName, " SR ") > 0 Or InStr(1, strName, " II") > 0 Or InStr(1, strName, " IV") > 0 Then MsgBox "Please enter labels like Jr, Sr, II, VI or the like in the patient's firstname...", vbCritical ChkSurname = False Else Dim recTemp As New ADODB.Recordset recTemp.Open "Patient_Data..sp_Adm_ValidateLastName '" + Trim$(strName) + "'", PCLSUser.sqlConnection, adOpenForwardOnly, adLockOptimistic With recTemp If .EOF And .BOF Then If MsgBox("The lastname '" + strName + "' may not be spelled correctly. Select the 'Yes' botton if correct or 'No' botton if not...", vbCritical + vbYesNo) = vbYes Then ChkSurname = True Else ChkSurname = False End If Else ChkSurname = True End If End With Set recTemp = Nothing End If End If End Function 'Public Function CheckService(ByVal cServCode As String, Optional ByVal cSex As String = "", Optional ByVal cAge As String) As Boolean ' Dim nServCode As Integer ' nServCode = Val(cServCode) ' CheckService = True ' If cSex = "M" And (nServCode = 9 Or nServCode = 16) Then ' MsgBox "Cannot use this service for male patient...", vbCritical ' CheckService = False ' ElseIf nServCode = 13 And Val(cAge) > 0 Then ' MsgBox "Patient's age indicates that Newborn is not a valid service...", vbCritical ' CheckService = False ' ElseIf nServCode = 14 And Val(cAge) > 15 Then ' MsgBox "Patient's age indicates that Pediatrics is not a valid service...", vbCritical ' CheckService = False ' ElseIf nServCode = 16 And Val(cAge) < 15 Then ' If MsgBox("Patient's age indicates that this is a Pediatric case. Are you sure this is an obsteric case?", vbQuestion + vbYesNo) = vbNo Then _ ' CheckService = False ' End If 'End Function Public Sub ConvertNameKey(ByRef KeyAscii As Integer) Dim strKey As String KeyAscii = Asc(UCase(Chr$(KeyAscii))) If KeyAscii >= 32 Then strKey = UCase(Chr(KeyAscii)) If strKey Like "[A-Z,--,Ñ, ]" Then _ KeyAscii = Asc(strKey) Else _ KeyAscii = 0 End If 'eyAscii = KeyStrokeFilter(Alphabet + " -", KeyAscii) End Sub Public Sub OpenMainReport1(ByVal strReportFileName 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) Set Report = crxApplication.OpenReport(strReportFileName, 1) For Each crxtable In Report.Database.Tables crxtable.SetLogOnInfo PCLSUser.ServerName, "station", PCLSUser.UserId, PCLSUser.serverpassword 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 OpenMainReport2(ByVal strDatabaseName As String, ByVal strReportFileName 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) Set Report = crxApplication.OpenReport(strReportFileName, 1) 'Report.ReportTitle = pstrHospitalName For Each crxtable In Report.Database.Tables crxtable.Location = strDatabaseName + Mid$(crxtable.Location, InStr(1, crxtable.Location, ".")) crxtable.SetLogOnInfo PCLSUser.ServerName, strDatabaseName, PCLSUser.UserId, PCLSUser.serverpassword Next If intTotalParam >= 0 Then For Each crxParameterField In Report.ParameterFields If intTotalParam >= intCtr Then If crxParameterField.ValueType = crDateField Then crxParameterField.AddCurrentValue CDate(strParameters(intCtr)) ElseIf crxParameterField.ValueType = crDateTimeField Then crxParameterField.AddCurrentValue CDate(strParameters(intCtr)) Else crxParameterField.AddCurrentValue strParameters(intCtr) End If Else Exit For End If intCtr = intCtr + 1 Next End If Set crxParameterField = Nothing Set crxtable = Nothing Set crxApplication = Nothing End Sub Public Sub OpenMainReportExam(ByVal strReportFileName 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) Set Report = crxApplication.OpenReport(strReportFileName, 1) 'Report.ReportTitle = pstrHospitalName For Each crxtable In Report.Database.Tables 'crxtable.Location = "Station" + Mid(crxtable.Location, InStr(1, crxtable.Location, ".")) crxtable.SetLogOnInfo PCLSUser.ServerName, PCLSUser.Database, PCLSUser.UserId, PCLSUser.serverpassword Next If intTotalParam >= 0 Then For Each crxParameterField In Report.ParameterFields If intTotalParam >= intCtr Then If crxParameterField.ValueType = crDateField Then crxParameterField.AddCurrentValue CDate(strParameters(intCtr)) ElseIf crxParameterField.ValueType = crDateTimeField Then crxParameterField.AddCurrentValue CDate(strParameters(intCtr)) Else crxParameterField.AddCurrentValue strParameters(intCtr) End If Else Exit For End If intCtr = intCtr + 1 Next End If Set crxParameterField = Nothing Set crxtable = Nothing Set crxApplication = Nothing End Sub Public Sub OpenMainReport(ByVal strReportFileName As String, ParamArray strParameters()) On Error GoTo ErrTrap Dim crxParameterField As CRAXDRT.ParameterFieldDefinition Dim intCtr As Integer Dim intTotalParam As Integer Dim crxtable As CRAXDRT.DatabaseTable Dim crxApplication As New CRAXDRT.Application Dim strFileName As String intTotalParam = UBound(strParameters) Set Report = crxApplication.OpenReport(strReportFileName, 1) Report.ReportTitle = pstrHospitalName Report.ReportComments = pstrHospitalAddress For Each crxtable In Report.Database.Tables ' crxtable.Location = "Patient_Data" + Mid(crxtable.Location, InStr(1, crxtable.Location, ".")) crxtable.SetLogOnInfo PCLSUser.ServerName, "Patient_Data", PCLSUser.UserId, PCLSUser.serverpassword Next If intTotalParam >= 0 Then For Each crxParameterField In Report.ParameterFields If intTotalParam >= intCtr Then crxParameterField.ClearCurrentValueAndRange crxParameterField.AddCurrentValue strParameters(intCtr) Else Exit For End If intCtr = intCtr + 1 Next End If If IsAllowOPDExportReport And blnExport Then If MsgBox("Do you wish to export the report?", vbYesNo, "Export Report to Disk") = vbYes Then strFileName = pubFileName + " " + Format$(Now, "MMddyyyy") + ".xls" Report.ExportOptions.DiskFileName = strFileName Report.ExportOptions.DestinationType = crEDTDiskFile Report.ExportOptions.FormatType = crEFTExcel80 Report.Export False MsgBox "Report was successfully exported to " + strFileName, vbInformation, "Information" End If End If blnExport = False Set crxParameterField = Nothing Set crxtable = Nothing Set crxApplication = Nothing Exit Sub ErrTrap: MsgBox Err.Description & " " & strReportFileName End Sub Public Sub OpenMainReportSOA(ByVal strReportFileName 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) Set Report = crxApplication.OpenReport(strReportFileName, 1) ' Report.ReportTitle = pstrHospitalName For Each crxtable In Report.Database.Tables ' crxtable.Location = "Patient_Data" + Mid(crxtable.Location, InStr(1, crxtable.Location, ".")) crxtable.SetLogOnInfo PCLSUser.ServerName, "Billing", PCLSUser.UserId, PCLSUser.serverpassword 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 OpenSubReportJoy(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 Dim crxApplication As New CRAXDRT.Application intTotalParam = UBound(strParameters) Set crxSubreport = Report.OpenSubReport(strSubReport) crxSubreport.ReportTitle = pstrHospitalName For Each crxtable In crxSubreport.Database.Tables crxtable.Location = strDatabaseName + Mid(crxtable.Location, InStr(1, crxtable.Location, ".")) crxtable.SetLogOnInfo PCLSUser.ServerName, strDatabaseName, PCLSUser.UserId, PCLSUser.serverpassword 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 OpenMainReportJoy(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 = pstrHospitalName For Each crxtable In Report.Database.Tables 'crxtable.Location = "Station" + Mid(crxtable.Location, InStr(1, crxtable.Location, ".")) crxtable.SetLogOnInfo PCLSUser.ServerName, strDatabaseName, PCLSUser.UserId, PCLSUser.serverpassword Next If intTotalParam >= 0 Then For Each crxParameterField In Report.ParameterFields If intTotalParam >= intCtr Then If crxParameterField.ValueType = crDateField Then crxParameterField.AddCurrentValue CDate(strParameters(intCtr)) ElseIf crxParameterField.ValueType = crDateTimeField Then crxParameterField.AddCurrentValue CDate(strParameters(intCtr)) Else crxParameterField.AddCurrentValue strParameters(intCtr) End If Else Exit For End If intCtr = intCtr + 1 Next End If Set crxParameterField = Nothing Set crxtable = Nothing Set crxApplication = Nothing End Sub Public Sub OpenSubReport2(ByVal strSubReport 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) For Each crxtable In crxSubreport.Database.Tables 'crxtable.Location = "Patient_Data" + Mid(crxtable.Location, InStr(1, crxtable.Location, ".")) crxtable.SetLogOnInfo PCLSUser.ServerName, "Patient_Data", PCLSUser.UserId, PCLSUser.serverpassword 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 OpenSubReport(ByVal strSubReport 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) For Each crxtable In crxSubreport.Database.Tables 'crxtable.Location = "Patient_Data" + Mid(crxtable.Location, InStr(1, crxtable.Location, ".")) crxtable.SetLogOnInfo PCLSUser.ServerName, "Patient_Data", PCLSUser.UserId, PCLSUser.serverpassword 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) Dim frmRView As New frmReportViewer With frmRView .ShowGroupTree = blnShowGroupTree .Caption = strCaption .DirectPrint = blnDirectToPrinter .ExportReportCaption = strCaption .Show vbModal End With End Sub Public Function ValidateDate(ByVal strValue As String, Optional ByVal strStart As String = "", Optional ByVal strEnd As String = "", Optional ByVal blnAllowBlank = True) As Boolean ' If Len(Trim$(strValue)) = 0 Or strValue = " / / " Then ' ValidateDate = IIf(blnAllowBlank, True, False) ' Else ' ValidateDate = False ' If IsDate(strValue) Then ' strValue = Format(strValue, "yyyy/mm/dd") ' strStart = IIf(Len(Trim$(strStart)) > 0 And strStart <> " / / " And IsDate(strStart), Format(strStart, "yyyy/mm/dd"), strValue) ' strEnd = IIf(Len(Trim$(strEnd)) > 0 And Trim$(strEnd) <> " / / " And IsDate(strEnd), Format(strEnd, "yyyy/mm/dd"), strValue) ' If strValue >= strStart And strValue <= strEnd Then ValidateDate = True ' End If ' End If 'If Len(Trim$(strValue)) = 0 Or strValue = " / / " Then ' ValidateDate = IIf(blnAllowBlank, True, False) ' Else If ValidateDate = False Then If IsDate(strValue) Then strValue = Format(strValue, "yyyy/mm/dd") strStart = IIf(Len(Trim$(strStart)) > 0 And strStart <> " / / " And IsDate(strStart), Format(strStart, "yyyy/mm/dd"), strValue) strEnd = IIf(Len(Trim$(strEnd)) > 0 And Trim$(strEnd) <> " / / " And IsDate(strEnd), Format(strEnd, "yyyy/mm/dd"), strValue) If strValue >= strStart And strValue <= strEnd Then ValidateDate = True End If End If End Function Public Function ComputeAge(ByVal strBirth As String, ByVal strNow As String) As Integer Dim intDays As Long ComputeAge = 0 If IsDate(strBirth) And IsDate(strBirth) Then If strBirth <> " / / " Then intDays = DateDiff("d", Format(strBirth, "mm/dd/yyyy"), Format(pdCurDate, "mm/dd/yyyy")) ComputeAge = Int(intDays / 365.25) Else ComputeAge = 0 End If End If End Function 'Public Function Null2Space(vType As Variant) As String ' If IsNull(vType) Then ' vType = " " ' Else ' vType = CStr(vType) ' End If ' Null2Space = vType 'End Function 'Public Sub AddText(Text As String, FontSize As Integer, _ ' FontName As String, FontColor As ColorConstants, Italic As Boolean, Optional xBeginning As Boolean) ' With frmFinal.rtbClinical ' .SelFontName = FontName ' .SelColor = FontColor ' .SelFontSize = FontSize ' .SelItalic = Italic ' If IsEmpty(xBeginning) Or xBeginning = False Then ' .SelText = .SelText + Text ' Else ' .SelText = Text + .SelText ' End If ' End With 'End Sub 'Public Function Pad(sString As String, _ ' iPad As Integer, iAlign As Integer) As String ' ' Const KN_LEFT = 1 ' Const KN_CENTER = 2 ' Const KN_RIGHT = 3 ' Dim sPad As String ' Dim iLen As Integer ' ' sPad = Trim$(sString) ' iLen = Len(sPad) ' Select Case iAlign ' Case KN_LEFT ' If iLen < iPad Then ' Pad = sPad & Space$(iPad - iLen) ' Else ' Pad = sString ' End If ' End Select ' 'End Function Public Sub GetCurrentDateTime() Dim recTemp As New ADODB.Recordset On Error GoTo GetCurrentDateTimeErr Set recTemp = PCLSUser.sqlConnection.Execute("Select GetDate() As CurDate from patient_Data..tbHospitalInfo") With recTemp If .EOF And .BOF Then GoTo GetCurrentDateTimeErr Else pdCurDate = !CurDate End If End With Exit Sub GetCurrentDateTimeErr: pdCurDate = Date End Sub Function spAssess(RefNum As String, _ Name As String, _ ItemID As String, _ RevenueID As String, _ Quantity As String, _ Amount As String) As String ''''''''''' ' Dim strSQL As String Dim strSQL As New ADODB.Recordset ' strSQL = "BILLING..spGlobal_Assess '" + RefNum + "','" + Name + "','" + ItemID + "','" + RevenueID + "','" + _ ' Quantity + "','" + Amount + "','" + strgRevenueID + "','" + pclsUser.EmployeeCode + "'" Set strSQL = New ADODB.Recordset strSQL.Open "BILLING..spGlobal_Assess '" + RefNum + "','" + Name + "','" + ItemID + "','" + RevenueID + "','" + _ Quantity + "','" + Amount + "','" + strgRevenueID + "','" + PCLSUser.EmployeeCode + "'" ' spAssess = strSQL End Function Sub ClearChargeSlip() ' dbCon.Execute "DELETE REPORTS..tbChargeSlip WHERE UserID = '" + pclsUser.EmployeeCode + "'" PCLSUser.sqlConnection.Execute "DELETE REPORTS..tbChargeSlip WHERE UserID = '" + PCLSUser.EmployeeCode + "'" End Sub Public Function SetLogOnInfo(crxtable As CRAXDRT.DatabaseTable, strDatabaseName As String) With PCLSUser crxtable.Location = strDatabaseName + Mid(crxtable.Location, InStr(1, crxtable.Location, ".")) crxtable.SetLogOnInfo .ServerName, strDatabaseName, .UserId, .serverpassword End With End Function Public Function isEmployeesMedsAccount(strHospnum As String) As Boolean Dim recSQL As New ADODB.Recordset Dim strSQL As String strSQL = "Patient_Data..sp_AOPD_CheckPatientsMasterAccount '" & strHospnum & "'" isEmployeesMedsAccount = False With recSQL If .State > 0 Then .Close .CursorLocation = adUseClient .Open strSQL, PCLSUser.sqlConnection, adOpenDynamic, adLockOptimistic If .RecordCount > 0 Then isEmployeesMedsAccount = True End If If .State > 0 Then .Close End With End Function Public Function HolidayGreeting() As String Dim recS As New ADODB.Recordset Dim blnHoliday As Boolean Dim strGreeting As String recS.Open "BUILD_FILE..global_VerifyHoliday", PCLSUser.sqlConnection, adOpenDynamic, adLockOptimistic If recS.EOF Then blnHoliday = False Else blnHoliday = True strGreeting = recS!HolidayGreeting & "" If Len(strGreeting) = 0 Then strGreeting = "Today is " & recS!HolidayName & "." End If End If recS.Close Set recS = Nothing If Not blnHoliday Then If IsSunday Then strGreeting = "Today is Sunday." Else strGreeting = "" End If End If HolidayGreeting = strGreeting End Function Public Function IsSunday() As Boolean Dim recS As New ADODB.Recordset Dim intWeekDay As Integer recS.Open "select datepart(weekday, GETDATE()) as wd", PCLSUser.sqlConnection, adOpenDynamic, adLockOptimistic intWeekDay = recS!WD recS.Close Set recS = Nothing If intWeekDay = 1 Then IsSunday = True Else IsSunday = False End If End Function 'Public Sub SaveInventoryItem(strInventoryCode As String, strHospnum As String, strIDNum As String, strItemId As String, strRefNum As String, _ ' dblQuantity As Double, dblAmount As Double, strRequestedByID As String, strLocationID As String, _ ' strRoomID As String) ' '------ '' Dim A As New prjDrugDLL.clsDrug ' 'DrugInfo ' ' Drug.Drug.AppendStockCard strHospnum, strIDNum, strItemId, Format$(Now, "MM/dd/yyyy hh:mm"), strRefNum, _ ' dblQuantity, 0, dblAmount, PCLSUser.EmployeeCode, "PRN", strRequestedByID, strLocationID, _ ' "", strRoomID, 0, strInventoryCode, strInventoryCode, "", , , , "O" ' 'End Sub 'Public Sub Remove_Profile_List(strExamID As String, ProFileList As MSHFlexGrid) 'Dim intProfile As Integer 'Dim intCount As Integer 'intCount = ProFileList.Rows - 1 'Routine: ' For intProfile = 1 To intCount ' If ProFileList.Rows = 2 And ProFileList.TextMatrix(1, 1) = "" Then ' Else ' If Trim$(ProFileList.TextMatrix(intProfile, 3)) = Trim$(strExamID) Then ' If ProFileList.Rows = 2 And ProFileList.TextMatrix(1, 1) <> "" Then ' ProFileList.TextMatrix(1, 1) = "" ' ProFileList.TextMatrix(1, 2) = "" ' ProFileList.TextMatrix(1, 3) = "" ' ProFileList.TextMatrix(1, 4) = "" ' Else ' ProFileList.RemoveItem (intProfile) ' intCount = ProFileList.Rows - 1 ' GoTo Routine ' End If ' End If ' End If ' Next ' 'End Sub ' 'Public Function Check_ExamRequest(strID As String, strCode As String, strRevenueId As String) As Boolean ''Check supply if requested and status is pending 'Dim recCheckStatus As New ADODB.Recordset 'recCheckStatus.Open "STATION..Nurse_CheckExamStatus '" & Trim$(strID) & "','" & Trim$(strCode) & "','" & Trim$(strRevenueId) & "'", pclsUser.sqlconnection, adOpenDynamic, adLockReadOnly ''---->>oski<<-----' ''--allowing multiple request--' 'If isAllowMultipleRequest Then 'Exit Function ' 'Else 'If Not recCheckStatus.EOF Then ' If MsgBox(strMsg + Trim$(recCheckStatus!Requestdate) + strMsg1, vbOKOnly, "Message ") = vbOK Then ' recCheckStatus.Close ' Set recCheckStatus = Nothing ' Check_ExamRequest = True ' Exit Function ' End If 'Else ' Check_ExamRequest = False 'End If 'End If ' 'recCheckStatus.Close 'Set recCheckStatus = Nothing 'End Function ' ' 'Public Function Check_ExamPosted(strID As String, strCode As String, strRevenueId As String) As Boolean ''Check medicines/supply if requested and status processed 'Dim recCheckStatus As New ADODB.Recordset 'recCheckStatus.Open "STATION..Nurse_CheckExam_Posted '" & Trim$(strID) & "','" & Trim$(strCode) & "','" & Trim$(strRevenueId) & "'", pclsUser.sqlconnection, adOpenDynamic, adLockReadOnly 'If Not recCheckStatus.EOF Then ' If MsgBox("This Request has been PROCCESSED TODAY AT " + Trim$(recCheckStatus!ProcessDate) + "! Do you wish to REPEAT it ?", vbCritical + vbYesNo, "Message ") = vbNo Then ' recCheckStatus.Close ' Set recCheckStatus = Nothing ' Check_ExamPosted = True ' Exit Function ' End If 'Else ' Check_ExamPosted = False 'End If 'recCheckStatus.Close 'Set recCheckStatus = Nothing 'End Function Public Function Get_LabExam_StatID(strExamID As String, frmObject As Object) Dim recCheckStat As New ADODB.Recordset 'Check Exam if StaT recCheckStat.Open "Select isnull(stat,'') AS Stat, datepart(dw,GETDATE()) as DayofWeek, " & _ "case " & _ "When convert(varchar(10),getdate(),101) +' 17:00:00' >= GEtDATE() then 'F' " & _ "When convert(varchar(10),getdate(),101) +' 17:00:00' < GEtDATE() then 'T' " & _ "END AS 'AFter5' from BUILD_FILE..tbcoLabExam Where LabexamID ='" & strExamID & "'", PCLSUser.sqlConnection, adOpenForwardOnly, adLockReadOnly If Not recCheckStat.EOF Then If recCheckStat!Stat = "Y" Then frmObject.Option1(1).Value = True frmObject.Option1(0).Enabled = False frmObject.Option1(1).Enabled = True Else If recCheckStat!Stat = "N" Then frmObject.Option1(0).Value = True frmObject.Option1(1).Enabled = False frmObject.Option1(0).Enabled = True Else frmObject.Option1(0).Enabled = True frmObject.Option1(1).Enabled = True If recCheckStat!DayOfWeek = 7 Or recCheckStat!After5 = "T" Then frmObject.Option1(1).Value = True Else frmObject.Option1(0).Value = True End If End If End If End If recCheckStat.Close Set recCheckStat = Nothing End Function Public Function Get_TransactionDate() As Date Dim recDate As New ADODB.Recordset recDate.Open "select GETDATE() AS Tdate", PCLSUser.sqlConnection, adOpenForwardOnly, adLockReadOnly TransactionDate = recDate!tdate Get_TransactionDate = recDate!tdate recDate.Close 'convert(varchar(10),getdate(),101) Set recDate = Nothing End Function Public Function Check_ProfileExam(strExamID As String, ProFileList As MSHFlexGrid) As Boolean Dim recProfile As New ADODB.Recordset Check_ProfileExam = False 'blnIsProfileExam = False recProfile.Open "STATION..sp_Nurse_Get_ProfileList '" & Trim$(strExamID) & "'", PCLSUser.sqlConnection, adOpenForwardOnly, adLockReadOnly If Not recProfile.EOF Then Check_ProfileExam = True Do While Not recProfile.EOF With ProFileList If .TextMatrix(1, 1) = "" Then .TextMatrix(1, 1) = recProfile!ExamID & "" .TextMatrix(1, 2) = recProfile!ExamName & "" .TextMatrix(1, 3) = recProfile!ProfileID & "" .TextMatrix(1, 4) = recProfile!ProfileName & "" Else .Rows = .Rows + 1 .TextMatrix(.Rows - 1, 1) = recProfile!ExamID & "" .TextMatrix(.Rows - 1, 2) = recProfile!ExamName & "" .TextMatrix(.Rows - 1, 3) = recProfile!ProfileID & "" .TextMatrix(.Rows - 1, 4) = recProfile!ProfileName & "" End If End With recProfile.MoveNext Loop Else Check_ProfileExam = False End If recProfile.Close Set recProfile = Nothing End Function ' 'Public Sub Remove_Profile_OrderList(ProFileList As MSHFlexGrid, OrderList As MSHFlexGrid, intCol As Integer) 'Dim intOrder As Integer 'Dim intProfile As Integer ' 'Routine: 'For intOrder = 1 To OrderList.Rows - 1 ' For intProfile = 1 To ProFileList.Rows - 1 ' If OrderList.Rows = 2 And OrderList.TextMatrix(1, 1) = "" Then ' Else ' If Trim$(ProFileList.TextMatrix(intProfile, 1)) = _ ' Trim$(OrderList.TextMatrix(intOrder, intCol)) Then ' If OrderList.Rows = 2 And OrderList.TextMatrix(1, 1) <> "" Then ' If intCol = 2 Then ' If Not OrderList.TextMatrix(intOrder, 11) = "" Then ' frmFinal.lstListLaboratory.RemoveItem OrderList.TextMatrix(intOrder, 11) ' frmFinal.lstListLaboratory.AddItem OrderList.TextMatrix(intOrder, 10) ' frmFinal.lstListLaboratory.Refresh ' End If ' End If ' OrderList.TextMatrix(1, 1) = "" ' OrderList.TextMatrix(1, 2) = "" ' OrderList.TextMatrix(1, 3) = "" ' OrderList.TextMatrix(1, 4) = "" ' OrderList.TextMatrix(1, 5) = "" ' OrderList.TextMatrix(1, 6) = "" ' OrderList.TextMatrix(1, 7) = "" ' OrderList.TextMatrix(1, 8) = "" ' OrderList.TextMatrix(1, 9) = "" ' OrderList.TextMatrix(1, 10) = "" ' OrderList.TextMatrix(1, 11) = "" ' If OrderList.Cols > 12 Then ' OrderList.TextMatrix(1, 12) = "" ' OrderList.TextMatrix(1, 13) = "" ' OrderList.TextMatrix(1, 14) = "" ' OrderList.TextMatrix(1, 15) = "" ' End If ' Else ' If intCol = 2 Then ' If Not OrderList.TextMatrix(intOrder, 11) = "" Then ' frmFinal.lstListLaboratory.RemoveItem OrderList.TextMatrix(intOrder, 11) ' frmFinal.lstListLaboratory.AddItem OrderList.TextMatrix(intOrder, 10) ' frmFinal.lstListLaboratory.Refresh ' End If ' End If ' OrderList.RemoveItem (intOrder) ' GoTo Routine ' End If ' End If ' End If ' Next 'Next ' 'End Sub Public Function Check_Exam_InProfileList(strExamID As String, ProFileList As MSHFlexGrid) As Boolean Dim intProfile As Integer Check_Exam_InProfileList = False For intProfile = 1 To ProFileList.Rows - 1 If Trim$(ProFileList.TextMatrix(intProfile, 1)) = strExamID Then MsgBox "This Exam " & Trim$(ProFileList.TextMatrix(intProfile, 2)) & " is included in this Profile(" & Trim$(ProFileList.TextMatrix(intProfile, 4)) & ")", vbOKOnly + vbExclamation, "Message" Check_Exam_InProfileList = True Exit Function Else Check_Exam_InProfileList = False End If Next End Function 'Public Function Get_ConfigurationFiles() 'Dim recHospital As ADODB.Recordset ' ' blnIsResultPrint = False ' Set recHospital = New ADODB.Recordset ' recHospital.Open "Select * from PATIENT_DATA..tbHospitalInfo", pclsUser.sqlconnection, adOpenDynamic, adLockReadOnly ' If Not recHospital.EOF Then ' pstrHospitalName = recHospital!Company ' strAddress = recHospital!Address1 ' IsGeneric = recHospital!Bygeneric ' pstrHospitalMTS = recHospital!MTSServerName ' blnIsResultPrint = recHospital!IsNursePrint '' strPhoneNumber = recHospital!PhoneNum ' 'direct charging ' blnLBDirectCharging = recHospital!IsLBDirectCharging ' blnXRDirectCharging = recHospital!IsXRDirectCharging ' blnUSDirectCharging = recHospital!IsUSDirectCharging ' blnCTDirectCharging = recHospital!IsCTDirectCharging ' blnHSDirectCharging = recHospital!IsHSDirectCharging ' ' End If ' recHospital.Close ' Set recHospital = Nothing ' 'End Function 'Public Function Update_Other_Info() ' 'Update other info ' ' pclsUser.sqlconnection.Execute "STATION..sp_Nurse_Update_OtherInfo '" & frmFinal.txtId.Text & _ ' "','" & strTransplant & "','" & strDialysis & "','I'" ' 'End Function 'Public Function Get_Patient_OtherInfo() 'Dim recOther As New ADODB.Recordset ' 'recOther.Open "select * from PATIENT_DATA..tbPatient2 where idnum = '" & frmFinal.txtId.Text & "'", pclsUser.sqlconnection, adOpenForwardOnly, adLockReadOnly 'If Not recOther.EOF Then ' strTransplant = IIf(IsNull(recOther!transplantID), "0", recOther!transplantID) ' strDialysis = IIf(IsNull(recOther!dialysisID), "0", recOther!dialysisID) ' ' Select Case Trim$(strTransplant) ' Case "0" ' strTransplantDescription = "Non_Transplant" ' Case "1" ' strTransplantDescription = "Transplant" ' End Select ' Select Case Trim$(strDialysis) ' Case "0" ' strDialysisDescription = "None" ' Case "1" ' strDialysisDescription = "Pre-Dialysis" ' Case "2" ' strDialysisDescription = "Post-Dialysis" ' End Select 'End If 'recOther.Close 'Set recOther = Nothing 'End Function 'Public Function Get_Lab_Exam_Specimen(strExamID As String) As String 'Dim recSpecimen As New ADODB.Recordset 'recSpecimen.Open "STATION..sp_Nurse_GetLabExam_Specimen '" & Trim$(strExamID) & "'", pclsUser.sqlconnection, adOpenForwardOnly, adLockReadOnly 'If recSpecimen.RecordCount > 1 Then ' blnMoreSpecimen = True 'Else ' blnMoreSpecimen = False 'End If 'If blnMoreSpecimen Then ' strSpecimenID = "" ' Get_Lab_Exam_Specimen = "" 'Else ' If Not recSpecimen.EOF Then ' strSpecimenID = recSpecimen!Code & "" ' Get_Lab_Exam_Specimen = recSpecimen![Description] & "" ' Else ' strSpecimenID = "0" ' Get_Lab_Exam_Specimen = "None" ' ' End If 'End If 'recSpecimen.Close 'Set recSpecimen = Nothing ' 'End Function Public Function Check_OrderList_InProfileList(ProFileList As MSHFlexGrid, OrderList As MSHFlexGrid, intCol As Integer) As Boolean Dim intOrder As Integer Dim intProfile As Integer Check_OrderList_InProfileList = False For intOrder = 1 To OrderList.Rows - 1 For intProfile = 1 To ProFileList.Rows - 1 If Trim$(OrderList.TextMatrix(intOrder, intCol)) = Trim$(ProFileList.TextMatrix(intProfile, 1)) Then MsgBox "The Exam " & Trim$(ProFileList.TextMatrix(intProfile, 2)) & " in the ORDER LIST is included in this Profile(" & Trim$(ProFileList.TextMatrix(intProfile, 4)) & ")", vbOKOnly + vbExclamation, "Message" Check_OrderList_InProfileList = True Exit Function Else Check_OrderList_InProfileList = False End If Next Next End Function Public Sub Get_HospitalBill(strHospnum As String) Dim recOpen As New ADODB.Recordset With recOpen If .State > 0 Then .Close .Open "PATIENT_DATA..sp_Adm_ComputePatientsOldAccounts '" & strHospnum & "'", PCLSUser.sqlConnection, adOpenDynamic, adLockReadOnly If Not .EOF Then If Len(CStr(!Amount & "")) = 0 Or CStr(!Amount) = 0 Then Exit Sub Else MsgBox "The patient has unpaid bill of " + IIf(Len(CStr(!Amount & "")) = 0, "0", CStr(!Amount & "")) & "", vbInformation, "Message" End If End If .Close Set recOpen = Nothing End With End Sub Public Function ValidateDoctorCode(strDocCode As String) As Boolean Dim recSQL As New ADODB.Recordset Dim strSQL As String strSQL = "Select DoctorID from Build_File..tbCoDoctor Where DoctorID = '" & strDocCode & "'" ValidateDoctorCode = False With recSQL If .State > 0 Then .Close .CursorLocation = adUseClient .Open strSQL, PCLSUser.sqlConnection, adOpenDynamic, adLockOptimistic If .RecordCount > 0 Then ValidateDoctorCode = True Else ValidateDoctorCode = False End If If .State > 0 Then .Close End With End Function Public Function UpCase(KeyAscii As Integer) As Integer If KeyAscii = 0 Then UpCase = 0 Else UpCase = Asc(UCase$(Chr$(KeyAscii))) End If End Function ' Moved to MEDSYSClasses 'Public Sub pclsuser.medsysclasses.clsbilling.OpenChargeSlipNew(strRefNum As String, strIDNum As String, strTitle As String, strDiscount As String) ' Dim crxParameterField As CRAXDRT.ParameterFieldDefinition ' Dim intCtr As Integer ' Dim intTotalParam As Integer ' Dim crxtable As CRAXDRT.DatabaseTable ' Dim crxApplication As New CRAXDRT.Application ' Dim strReportFileName As String ' ' If isReprint = False Then ' If strDiscount = "Y" Then ' strReportFileName = App.Path & "\Reports\ChargeSlipNewDiscount.RPT" ' Else ' strReportFileName = App.Path & "\Reports\ChargeSlipNew.RPT" ' End If ' Else ' If blnWithDiscount Then ' strReportFileName = App.Path & "\Reports\ChargeSlipNewDiscount.RPT" ' Else ' strReportFileName = App.Path & "\Reports\ChargeSlipNew_Reprint.RPT" ' End If ' End If ' ' Set Report = crxApplication.OpenReport(strReportFileName, 1) ' ' Report.ReportTitle = pstrHospitalName ' For Each crxtable In Report.Database.Tables ' crxtable.SetLogOnInfo pclsUser.ServerName, "Patient_Data", pclsUser.UserId, pclsUser.serverpassword ' Next ' ' For Each crxParameterField In Report.ParameterFields ' crxParameterField.ClearCurrentValueAndRange ' If crxParameterField.ParameterFieldName = "@RefNum" Then ' crxParameterField.AddCurrentValue strRefNum ' ElseIf crxParameterField.ParameterFieldName = "@IdNum" Then ' crxParameterField.AddCurrentValue strIDNum ' ElseIf crxParameterField.ParameterFieldName = "Title" Then ' crxParameterField.AddCurrentValue strTitle ' ElseIf crxParameterField.ParameterFieldName = "HospName" Then ' crxParameterField.AddCurrentValue pstrHospitalName ' ElseIf crxParameterField.ParameterFieldName = "HospAddress" Then ' crxParameterField.AddCurrentValue pstrHospitalAddress ' Else ' crxParameterField.AddCurrentValue "" ' End If ' Next ' ' Set crxParameterField = Nothing ' Set crxtable = Nothing ' Set crxApplication = Nothing 'End Sub Public Function GetOPDSettings() As String Dim SQL As String SQL = "Select top 1 isnull(ClientName,'') as ClientName, isnull(IsHMORate,0) isHMORate, isnull(IsOPDstatRate,0) IsOPDstatRate, " & _ "isnull(IsAllowOPDShowLabSpecimen,0) IsAllowOPDShowLabSpecimen, isnull(IsAllowOPDChargeChangePrice,0) IsAllowOPDChargeChangePrice, " & _ "isnull(isAllowOPDRegisterInpatient,0) isAllowOPDRegisterInpatient, isnull(IsAllowOPDCheckLabSection,0) IsAllowOPDCheckLabSection, " & _ "isnull(IsAllowOPDAssessmentRateG,0) IsAllowOPDAssessmentRateG, isnull(isAllowJonelta,0) isAllowJonelta, " & _ "isnull(isAllowOPDSearchBarangay,0) isAllowOPDSearchBarangay, Isnull(isAllowOPDSearchCardNumber,0) isAllowOPDSearchCardNumber, " & _ "isnull(IsAllowOPDMABRate,0) IsAllowOPDMABRate, isnull(IsAllowOPDUpdateHMOLOA,0) IsAllowOPDUpdateHMOLOA, " & _ "IsNull(IsAllowOPDExportReport,0) IsAllowOPDExportReport, IsNull(IsAllowOPDSearchDocBySched,0) IsAllowOPDSearchDocBySched, " & _ "IsNull(IsAllowOPDPatientClass,0) IsAllowOPDPatientClass, IsNull(IsAllowOPDShowDiscount,0) IsAllowOPDShowDiscount, isnull(isAllowOPDPayCode,0) isAllowOPDPayCode, " & _ "isnull(isAllowMultipleRequest,0) isAllowMultipleRequest, isnull(allowEndConsultation,0) allowEndConsultation, " & _ "isnull(isAllowOPFileNumbering,0) isAllowOPFileNumbering, isnull(isAllowCreateNewIDnum,0)isAllowCreateNewIDnum, isnull(isAllowSpecializedCompanyRate,0)isAllowSpecializedCompanyRate," & _ "isnull(isAllowAssessmentDiscount, 0)isAllowAssessmentDiscount,isnull(AllowZeroOnHand,0)AllowZeroOnHand from Patient_Data..tbHospitalInfo" With Rec If .State > 0 Then .Close .CursorLocation = adUseClient .Open SQL, PCLSUser.sqlConnection, adOpenDynamic, adLockReadOnly If .RecordCount > 0 Then GetOPDSettings = !ClientName & "" isHMORate = IIf(!isHMORate = 0, False, True) isOPDStatRate = IIf(!isOPDStatRate = 0, False, True) IsShowLabSpecimen = IIf(!IsAllowOPDShowLabSpecimen = 0, False, True) isAllowChargeChangeAmount = IIf(!IsAllowOPDChargeChangePrice = 0, False, True) isAllowRegisterInpatient = IIf(!isAllowOPDRegisterInpatient = 0, False, True) IsAllowOPDCheckLabSection = IIf(!IsAllowOPDCheckLabSection = 0, False, True) IsAllowOPDAssessmentRateG = IIf(!IsAllowOPDAssessmentRateG = 0, False, True) IsAllowJonelta = IIf(!IsAllowJonelta = 0, False, True) isAllowOPDSearchBarangay = IIf(!isAllowOPDSearchBarangay = 0, False, True) IsAllowOPDSearchCardNumber = IIf(!IsAllowOPDSearchCardNumber = 0, False, True) IsAllowOPDMABRate = IIf(!IsAllowOPDMABRate = 0, False, True) isAllowEndConsultation = IIf(!allowEndConsultation = 0, False, True) isAllowOPFileNumbering = IIf(!isAllowOPFileNumbering = 0, False, True) IsAllowOPDUpdateHMOLOA = IIf(!IsAllowOPDUpdateHMOLOA = 0, False, True) IsAllowOPDExportReport = IIf(!IsAllowOPDExportReport = 0, False, True) IsAllowOPDSearchDocBySched = IIf(!IsAllowOPDSearchDocBySched = 0, False, True) IsAllowOPDPatientClass = IIf(!IsAllowOPDPatientClass = 0, False, True) IsAllowOPDShowDiscount = IIf(!IsAllowOPDShowDiscount = 0, False, True) isAllowOPDPayCode = IIf(!isAllowOPDPayCode = 0, False, True) isAllowMultipleRequest = IIf(!isAllowMultipleRequest = 0, False, True) isAllowCreateNewIDnum = IIf(!isAllowCreateNewIDnum = 0, False, True) isAllowSpecializedCompanyRate = IIf(!isAllowSpecializedCompanyRate = 0, False, True) isAllowAssessmentDiscount = IIf(!isAllowAssessmentDiscount = 0, False, True) isAllowZeroOnHand = IIf(!AllowZeroOnHand = 0, False, True) ''08.24.16 VBB If True Check,According to Cost Center Programmers. End If .Close End With pstrClientName = GetOPDSettings End Function Public Sub UnloadMdiForm() Dim intI As Integer intI = 1 Do While intI < Forms.count If Forms(intI).MDIChild = False Then Unload Forms(intI) Else intI = intI + 1 End If Loop ChildCount = 0 End Sub ' moved to billingclass 'Public Sub OPDStatInfo() ' ' Dim SQL As String ' ' SQL = "Select top 1 OPDWeekendStatTimeStart, OPDWeekendStatTimeEnd, OPDHolidayStatTimeStart, OPDHolidayStatTimeEnd from Patient_Data..tbHospitalInfo " ' With Rec ' If .State > 0 Then .Close ' .CursorLocation = adUseClient ' .Open SQL, pclsUser.sqlconnection, adOpenDynamic, adLockReadOnly ' If .RecordCount > 0 Then ' dtWeekendStatStart = !OPDWeekendStatTimeStart ' dtWeekendStatEnd = !OPDWeekendStatTimeEnd ' dtHolidayStatStart = !OPDHolidayStatTimeStart ' dtHolidayStatEnd = !OPDHolidayStatTimeEnd ' End If ' .Close ' End With ' 'End Sub '-----------osk------------' 'codes below where used to validate Markup Rate for Limso and CHDC' Public Function GetLabSectionID(strItemId As String) As String Dim Rec As New ADODB.Recordset Dim SQL As String Dim strSectionID As String SQL = "Select isnull(LabSectionID,'') LabSectionID from Build_File..tbcoLabExam where LabExamID = '" & strItemId & "'" With Rec If .State > 0 Then .Close .CursorLocation = adUseClient .CursorType = adOpenDynamic .LockType = adLockReadOnly .Open SQL, PCLSUser.sqlConnection If Not .EOF Then strSectionID = !LabSectionID & "" End If .Close End With Set Rec = Nothing GetLabSectionID = Trim$(strSectionID) End Function ' Moved to BillingClass 'Public Function get_MarkUpRate() As Double ' Dim recClass As New ADODB.Recordset ' Dim strSQL As String ' Dim dblMarkUpRate As Double ' Dim strType As String ' ' Dim HolidayRate As Double ' Dim AfterFivePmRate As Double ' Dim WeekendRate As Double ' Dim HolidayAndWeekendRate As Double ' Dim HolidayAndAfterFivePmRate As Double ' Dim AfterFiveAndWeekend As Double ' Dim maxmarkUpRate As Double ' ' ' ' strSQL = "Select * from patient_data..tbopd_settings" ' ' With recClass ' If .State > 0 Then .Close ' .CursorLocation = adUseClient ' .Open strSQL, pclsUser.sqlconnection, adOpenDynamic, adLockReadOnly ' ' If .RecordCount > 0 Then ' HolidayRate = !HolidayRate ' AfterFivePmRate = !AfterFivePmRate ' WeekendRate = !WeekendRate ' HolidayAndWeekendRate = !HolidayAndWeekend ' HolidayAndAfterFivePmRate = !HolidayAndAfterFivePmRate ' AfterFiveAndWeekend = !WeekendAfterFive ' maxmarkUpRate = !maxmarkUpRate ' End If ' .Close ' End With ' ' strType = pclsuser.medsysclasses.clsbilling.Get_strType() ' ' Select Case strType ' Case "1" ' dblMarkUpRate = Val(FirstRate) + Val(FirstRate) * (Val(HolidayRate / 100)) ' Case "2" ' dblMarkUpRate = Val(FirstRate) + Val(FirstRate) * (Val(AfterFivePmRate / 100)) ' Case "3" ' dblMarkUpRate = Val(FirstRate) + Val(FirstRate) * (Val(WeekendRate / 100)) ' Case "4" ' dblMarkUpRate = Val(FirstRate) + Val(FirstRate) * (Val(AfterFiveAndWeekend / 100)) ' Case "5" ' dblMarkUpRate = Val(FirstRate) + Val(FirstRate) * (Val(HolidayAndWeekendRate / 100)) ' Case "6" ' dblMarkUpRate = Val(FirstRate) + Val(FirstRate) * (Val(HolidayAndAfterFivePmRate / 100)) ' Case "7" ' dblMarkUpRate = Val(FirstRate) + Val(FirstRate) * (Val(maxmarkUpRate / 100)) ' Case "X" ' dblMarkUpRate = FirstRate ' ' End Select ' Set recClass = Nothing ' ' get_MarkUpRate = dblMarkUpRate ' 'End Function ' Moved to BillingClass 'Public Function pclsuser.medsysclasses.clsbilling.Get_strType() As String 'Dim strType As String ' ' If (Check_ifHoliday = True And NewValidateAfterFivePm = True And NewValidateWeekend = True) Then ' strType = "7" ''Holidayrate and Weekend and after 5pm ' ElseIf (Check_ifHoliday = True And NewValidateAfterFivePm = True) Then ' strType = "6" ''Holiday and after 5pm ' ElseIf (Check_ifHoliday = True And NewValidateWeekend = True) Then ' strType = "5" ''Holiday and Weekend ' ElseIf (NewValidateWeekend = True And NewValidateAfterFivePm = True) Then ' strType = "4" ''Weekend and after 5pm ' ElseIf (NewValidateWeekend = True) Then ' strType = "3" ''Weekend Rate only ' ElseIf (NewValidateAfterFivePm = True) Then ' strType = "2" ''After Five Pm Rate Only ' ElseIf (Check_ifHoliday = True) Then ' strType = "1" ''Holiday Rate only ' Else ' strType = "X" ' End If ' ' pclsuser.medsysclasses.clsbilling.Get_strType = strType ' 'End Function Public Function CheckLabSection(ItemID As String) As Boolean Dim Rec As New ADODB.Recordset Dim SQL As String CheckLabSection = False SQL = "Select * from Build_file..tbcoLabExam where LabExamID = '" & ItemID & "'" With Rec If .State > 0 Then .Close .CursorLocation = adUseClient .Open SQL, PCLSUser.sqlConnection, adOpenDynamic, adLockReadOnly If .RecordCount > 0 Then If !LabSectionID = "2" Then CheckLabSection = True End If End If .Close End With Set Rec = Nothing End Function ' Moved to BillingClass 'Public Function NewValidateWeekend() As Boolean ' Dim recTime As New ADODB.Recordset ' Dim search As String ' ' NewValidateWeekend = False ' ' If isAllowWeekendRate Then ' search = "select getdate()as Time, * from patient_data..tbOPD_settings" ' With recTime ' If .State > 0 Then .Close ' .Open search, pclsUser.sqlconnection, adOpenDynamic, adLockOptimistic ' If Not .EOF Then ' If (isAllowAfterFiveLabChemOnly = True And isLabAutoMarkUpExam = True And (strLabSectionID = "2" Or strLabSectionID = "H")) Then ' If (Format(!Time, "dddd") = "Saturday") Then ' If (Format(!Time, "HH:MM:SS") >= Format(!dtWeekendStartMarkup, "HH:MM:SS") And Format(!Time, "HH:MM:SS") <= Format(!dtWeekendEndMarkup, "HH:MM:SS")) Then ' NewValidateWeekend = True ' Else ' NewValidateWeekend = False ' End If ' ElseIf (Format(!Time, "dddd") = "Sunday") Then ' If (Format(!Time, "HH:MM:SS") >= Format(!dtWeekendStartMarkup2, "HH:MM:SS") And Format(!Time, "HH:MM:SS") <= Format(!dtWeekendEndMarkup2, "HH:MM:SS")) Then ' NewValidateWeekend = True ' Else ' NewValidateWeekend = False ' End If ' Else ' NewValidateWeekend = False ' End If ' ElseIf isAllowAfterFiveAllRevenues Then ' If (Format(!Time, "dddd") = "Saturday") Then ' If (Format(!Time, "HH:MM:SS") >= Format(!dtWeekendStartMarkup, "HH:MM:SS") Or Format(!Time, "HH:MM:SS") <= Format(!dtWeekendEndMarkup, "HH:MM:SS")) Then ' NewValidateWeekend = True ' Else ' NewValidateWeekend = False ' End If ' ElseIf (Format(!Time, "dddd") = "Sunday") Then ' If (Format(!Time, "HH:MM:SS") >= Format(!dtWeekendStartMarkup2, "HH:MM:SS") Or Format(!Time, "HH:MM:SS") <= Format(!dtWeekendEndMarkup2, "HH:MM:SS")) Then ' NewValidateWeekend = True ' Else ' NewValidateWeekend = False ' End If ' Else ' NewValidateWeekend = False ' End If ' End If ' End If ' .Close ' Set recTime = Nothing ' End With ' Else ' NewValidateWeekend = False ' End If 'End Function ' ' Moved to BillingClass 'Public Function NewValidateAfterFivePm() As Boolean ' Dim recTime As New ADODB.Recordset ' Dim search As String ' If isAllowAfterFivePMRate Then ' If isAllowAfterFiveAllRevenues Then ' search = "Select getdate() as Time from patient_data..tbhospitalinfo" ' With recTime ' If .State > 0 Then .Close ' .Open search, pclsUser.sqlconnection, adOpenDynamic, adLockOptimistic ' ' If Not .EOF Then ' If (Format(!Time, "HH:MM:SS") >= "17:00:01") Then ' NewValidateAfterFivePm = True ' Else ' NewValidateAfterFivePm = False ' End If ' End If ' .Close ' ' Set recTime = Nothing ' End With ' ' ElseIf (isAllowAfterFiveLabChemOnly = True And isLabAutoMarkUpExam = True And (strLabSectionID = "2" Or strLabSectionID = "H")) Then ' search = "Select getdate() as Time from patient_data..tbhospitalinfo" ' With recTime ' If .State > 0 Then .Close ' .Open search, pclsUser.sqlconnection, adOpenDynamic, adLockOptimistic ' ' If Not .EOF Then ' If (Format(!Time, "HH:MM:SS") >= "17:00:01") Then ' NewValidateAfterFivePm = True ' Else ' NewValidateAfterFivePm = False ' End If ' End If ' .Close ' ' Set recTime = Nothing ' End With ' Else ' NewValidateAfterFivePm = False ' End If ' Else ' NewValidateAfterFivePm = False ' End If ' 'End Function Public Function blnLabAutomarkUpItem(strItemId As String) Dim search As String Dim recc As New ADODB.Recordset search = "Build_file..spBuild_ValidateLabAutoMarkUp '" & strItemId & "'" With recc If .State > 0 Then .Close .Open search, PCLSUser.sqlConnection, adOpenDynamic, adLockOptimistic If Not .EOF Then If !Automarkup = "Y" Then isLabAutoMarkUpExam = True Else isLabAutoMarkUpExam = False End If .Close End If End With Set recc = Nothing End Function ' Moved to BillingClass 'Public Function Check_ifHoliday() As Boolean 'Dim recQ As New ADODB.Recordset 'Dim mysearch As String ' ' mysearch = "Build_file..Build_GetHolidayToday" ' ' With recQ ' If .State > 0 Then .Close ' .CursorLocation = adUseClient ' .Open mysearch, pclsUser.sqlconnection, adOpenDynamic, adLockReadOnly ' If .RecordCount > 0 Then ' ' isHolidayToday = True ' myHolidayName = !HolidayName ' myHolidayGreeting = !HolidayGreeting ' ' End If ' End With ' Check_ifHoliday = isHolidayToday ' Set recQ = Nothing ' 'End Function Public Function Get_Sequence() 'Dim rec As New ADODB.Recordset ''Dim riv As StringFormatEnum ' With rec ' If .State > 0 Then .Close ' .CursorLocation = adUseClient ' .Open "Select Max(logsequence) + 1 as LogSequence from Patient_Data..tbOPD_UserLogin", pclsUser.SqlConnection, adOpenDynamic, adLockOptimistic ' If .RecordCount > 0 Then ' Get_Sequence = !LogSequence ' End If ' End With ' Set rec = Nothing End Function Public Function UpTrim$(Argvalue As String) 'Returns the upper-cased and trimmed format of a string variable UpTrim$ = UCase$(Trim$(Argvalue)) End Function Public Sub userVerification() 'On Error Resume Next If blnValidation = True Then PCLSUser.EmployeeCode = PCLSUser.ValidateUserID(PCLSUser.EmployeeCode) Else 'blnValidation = False End If End Sub Public Function GetTransactionUser() As Boolean If blnValidation = True Then Dim TranUser As String TranUser = PCLSUser.ValidateUserID(PCLSUser.EmployeeCode) If TranUser = "" Then GetTransactionUser = False Else GetTransactionUser = True End If End If End Function ' moved to patientclass 'Public Function Validate_company(strIDNum As String) As Boolean ' Dim strQ As String ' Dim recc As New ADODB.Recordset ' Dim strSpecial As Integer ' ' ''PatientType 9 = SPecial For PostCharging Cash 03/20/2015 ' strSpecial = "9" ' strQ = "Select AccountNum,isnull(PatientTypeCombo,'0') as PatientTypeCombo, Hospnum from Patient_data..tboutpatient where idnum = '" & strIDNum & "'" ' With recc ' If .State > 0 Then .Close ' .CursorLocation = adUseClient ' .Open strQ, PCLSUser.sqlconnection, adOpenDynamic, adLockReadOnly ' If .RecordCount > 0 Then ' If !AccountNum = !HospNum And !PatientTypeCombo <> strSpecial Then ' Validate_company = False ' ElseIf !AccountNum = !HospNum And !PatientTypeCombo = strSpecial Then ' Validate_company = True ' Else ' Validate_company = True ' End If ' End If ' End With 'End Function 'Public Function Check_OnHand(strItemId As String, strLocationID As String) 'Dim strA As String 'Dim Rec As New ADODB.Recordset 'Dim strStockOnHand As String 'strStockOnHand = 0 ' ' strA = "select isnull(OnHand,0)Onhand from INVENTORY..tbinvent where ItemID = '" & strItemId & "' and LocationID = '" & strLocationID & "'" ' ' With Rec ' If .State > 0 Then .Close ' .CursorLocation = adUseClient ' .Open strA, pclsUser.sqlconnection, adOpenDynamic, adLockOptimistic ' If .RecordCount > 0 Then ' strStockOnHand = !Onhand ' End If ' .Close ' End With ' strStockOnHand = strStockOnHand ' Set Rec = Nothing 'End Function Public Sub OpenMainReportIncome(ByVal strReportFileName 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) Set Report = crxApplication.OpenReport(strReportFileName, 1) ' Report.ReportTitle = pstrHospitalName For Each crxtable In Report.Database.Tables ' crxtable.Location = "Patient_Data" + Mid(crxtable.Location, InStr(1, crxtable.Location, ".")) crxtable.SetLogOnInfo PCLSUser.ServerName, "CLINICAL_AREA", PCLSUser.UserId, PCLSUser.serverpassword 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