Attribute VB_Name = "modAdmitPatient"
Option Explicit
Public Const cvarPediaAge = 14
Public Const cvarHouseStreet = 1
Public Const cvarBarangay = 3
Public Const cvarTown = 4
Public Const cvarName = 0
Public Const cvarAddress = 1
Public Const cvarLastName = 0
Public Const cvarFirstName = 1
Public Const cvarMiddleName = 2
Public Const cvarTelNum = 5
Public Const cvarCode = 0
Public Const cvarDesc = 1
Public Const cvarTelNumber = 2
Public Const cvarAttendingDrID = 0
Public Const cvarAdmittingDrID = 1
Public Const cvarConsultantDrID = 2
Public Const cvarReferringDrID = 3
Public Const cvarAttendingDr5 = 4
Public Const cvarAttendingDr6 = 5
Public Const cvarAttendingDr7 = 6
Public Const cvarAttendingDr8 = 7
Public Const cvarAttendingDr9 = 8
Public Const cvarAttendingDr10 = 9
Public Const cvarAttendingDrName = 10
Public Const cvarAdmittingDrName = 11
Public Const cvarConsultantDrName = 12
Public Const cvarReferringDrName = 13
Public Const cvarAttendingDrName5 = 14
Public Const cvarAttendingDrName6 = 15
Public Const cvarAttendingDrName7 = 16
Public Const cvarAttendingDrName8 = 17
Public Const cvarAttendingDrName9 = 18
Public Const cvarAttendingDrName10 = 19
Public Const KC_PASSWORD_KEY = "ROBERTFKAISER"
Public Const cvarMale = 0
Public Const cvarFemale = 1
Public Const cvarOccupation = 0
Public Const cvarNationality = 6
'Hospitalization Plan
Public Const cVarPersonal = "P"
Public Const cVarCompany = "C"
Public Const cVarInsurance = "I"
Public Const cvarOthers = "O"
'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"
'Disposition
Public Const cvarDischarged = "1"
Public Const cvarTransfered = "2"
Public Const cvarAbsconded = "3"
Public Const cvarAutopsied = "4"
Public Const cvarHAMA = "5"
Public Const cvarHPR = "6"
'Result
Public Const cvarRecovered = "1"
Public Const cvarImproved = "2"
Public Const cvarUnimproved = "3"
Public Const cvarDied = "4"
Public Const cvarDiagOnly = "5"
Public Const cvarDAMAHAMA = "6"
'Public pclsMasterSearch As New clsPatientSearch
'Public pclsCodeSearch As New clsCodeSearch
'Public pclsUser As New clsCurrentUser
'Public pclsICD As New ICDCodeSearch
Public pclsMasterSearch As Object
Public pclsCodeSearch As Object
Public pclsUser As Object
Public pclsICD As Object
Public pclsMain As Object
Public pclsAdmission As Object
Public pstrConnectionString As String
Public pubstrHospNum As String
Public pubstrIDNum As String
Public pubblnSelected As Boolean
Public strIDNum As String
Public pubstrServerDate As String
Public pubClientName As String
Public clsUserSetting As New clsUserSetting
Public pblnBottonClick As Boolean
Public pblnPatient As Boolean
Public pstrHospitalName As String
Public pstrHospitalAddress As String
Public pdCurDate As Date
Public pstrNewbornCode As String
Public pstrRecordOfficer As String
Public pintPediaAgeLimit As Integer
Public pstrZipcode As String
Public ReportNameOnViewer As String
Public pblnReload As Boolean
Public pstrServerName As String
Public Report As CRAXDRT.Report
Public glngHospitalID As HospitalTypeEnum
Public Enum HospitalTypeEnum
cHospTypeCebuDoctors = 0
cHospTypeSeamens = 4
cHospTypeAUF = 2
cHospTypeStaRosa = 3
End Enum
'User log
Global recFile As New ADODB.Connection
Public clsUserLog As New clsLogFile
Public pstrEmployeeID As String
Public pstrRemarks As String
Public pstrDate As String
'From OPD
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 strHospPlan As String
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
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 cvarReligion = 7
Public Const cVarGuarantorName = 0
Public Const cVarGuarantorAddress = 1
Public Const cVarGuarantorEmployer = 2
Public Const cVarGuarantorTelNum = 3
Public Const cVarGuarantorEmpAdd = 4
Public Const cvarSingleAge = 16
Public Const cVarWithoutBill = 0
Public Const cVarWithBill = 1
Public Const cVarAccountCode = 0
Global strResultCode As String
Global gbAutoDoctorAssignment As Boolean
Global gbMasterFileRegistrationOnly As Boolean
Public blnExport As Boolean
Public strFileName As String
Public clsAuditTrail As New clsAuditTrail
Public clsAuditLog As New clsAuditLog
'for User Setting
Public blnAdmission As Boolean
Public blnUpdateAdmission As Boolean
Public blnAdmRecord As Boolean
Public blnPrintCertificate As Boolean
Public blnPrintCertification As Boolean
Public blnAdmissionDataSheet As Boolean
Public blnBirthCertificate As Boolean
Public blnMedicoLegal As Boolean
Public blnDeathCertificate As Boolean
Public blnClinicalSummary As Boolean
Public blnBirthCertification As Boolean
Public blnAssessment As Boolean
Public blnPrintCertificateOld As Boolean
Public blnClinicalSummaryLab As Boolean
Public blnFileOpen As Boolean
Public blnPxAdmDcrInfo As Boolean
Public blnPxOtherInfo As Boolean
Public blnPxFinalDxWithICD As Boolean
Public blnPxOperationWithICP As Boolean
Public blnPxOtherInfoII As Boolean
Public blnAuditTrail As Boolean
'For MedRec SetUp
Public blnAllowAuditTrail As Boolean
Public blnAllowRefNum As Boolean
Public blnAllowDrNameWithSpecialization As Boolean
Public blnAllowPatientDiseases As Boolean
Public blnAllowAnesthesiaInfo As Boolean
Public blnAllowObstetrical As Boolean
Public blnAllowLockedICDDesc As Boolean
Public blnAllowCertificateResidentDr As Boolean
Public blnAllowRepAdmissionLogbookNew As Boolean
Public blnAllowRepMorbidityNew As Boolean
Public blnAllowRepMortalityNew As Boolean
Public blnAllowUpdateFileNumber As Boolean
Public blnAllowCertificateRequest As Boolean
Public blnAllowCertificateNum As Boolean
Public blnAllowRepClinicalSummaryNew As Boolean
Public blnAllowDataSheetNew As Boolean
Public blnAllowExportReport As Boolean
Public blnAllowBirthCareOf As Boolean
Public blnAllowDeathCemetryInfo As Boolean
Public blnAllowCheckIfAdmitted As Boolean
Public blnAllowBirthFetal As Boolean
Public blnAllowBirthEthnic As Boolean
Public blnAllowDemographics As Boolean
Public blnAllowShowNewResult As Boolean
Public blnAllowFatherResidence As Boolean
Public blnOldBirthCertFormat As Boolean
Public blnOldDeathCertFormat As Boolean
Public pStrAssessRevCode As String
Public blnAllowConfirmationCode As Boolean
Public blnAllowDemographyByProvince As Boolean
Public blnLiveBirthCertificateOLDSeperateNameFormat As Boolean
'Public blnisGetRemarksToNurseDischargeNotice As Boolean
Public blnPediaToLT18 As Boolean
Public blnBorrowRecordwithDoctors As Boolean
Public blnConfinementRec As Boolean
Public blnPatientInquiry As Boolean
Public blnDOHReport As Boolean
Public blnAllowCF4 As Boolean
Public blnAllowWidePatientIndex As Boolean
Public blnAllowedUserCf4 As Boolean
Public blnAllowResidentDoctors As Boolean
Public blnAllowWidePatientIndexForUser As Boolean
Public blnAllowPatientClassID As Boolean
Public blnAllowOtherDeathFields As Boolean
Public blnAllowNurseNotes As Boolean
Public blnAllowMedCertShowRequestForm As Boolean
Public blnSetAgeByAdmission As Boolean
Public blnSetAgeByAdmission_IncludeNonNumeric As Boolean
Public blnSetAgeCurrent As Boolean
Public blnAllowNewSuffix As Boolean
Public blnAllowDisableICDValidation As Boolean
Public blnLoadParentsWithClearEntries As Boolean
Public blnAllowDoctorOnAssessment As Boolean
Public blnAllowCourseInTheWardDisplay As Boolean
Public blnAllowPhysicalExaminationDisplay As Boolean
Public blnAllowPhicCaseRateBtn As Boolean
Public blnIsAllowDcrDateValidation As Boolean
'INDEXES REPORT
Public blnIndexReport2Entries As Boolean
Global crxReport As New CrystalReport1
'Fetal Death Reference Number
Public PubFDNum As String
Public PubBlnNewRecord As Boolean
'Build path for excel export
Global fs As Object
'For Mothers List
Public PubAdmDate As Date
Public PubDcrDate As Date
Public Registration As Object
'Public clsMEDSYS As Object
Public blnSeaFarer As Boolean
Global WshShell As Object
Public clsCF4 As Object 'CLASS DECLARATION AS OBJECT
Global User As Object
'Admitting Label Setup
Public strLabelLastName As String
Public strLabelFirstName As String
Public strLabelMiddleName As String
Public strLabelTitle As String
Public strLabelBirth As String
Public strLabelGender As String
Public strLabelBirthPlace As String
Public strLabelBarangay As String
Public strLabelTownProvince As String
Public strLabelForeignAddress As String
Public strLabelCountry As String
Public strLabelOccupation As String
Public strLabelGuarantor As String
Public strLabelOtherGuarantor As String
Public strLabelHospitalizationPlan As String
Private Sub CreateOBJ(OBJ As Object, strClass As String)
On Error GoTo ErrTrap
Set OBJ = CreateObject(strClass, "")
Exit Sub
ErrTrap:
MsgBox Err.Description & " please register:" & strClass
End Sub
Public Sub Main()
'Flag to determine Hospital Type compilation
'glngHospitalID = cHospTypeAUF
'glngHospitalID = cHospTypeStaRosa
'
On Error GoTo Main_Err
'
100 glngHospitalID = 0
'Set pclsUser = CreateObject("Medsys_User.clsCurrentUser", "")
'Set pclsMasterSearch = CreateObject("MasterSearch.clsPatientSearch", "")
'Set pclsCodeSearch = CreateObject("CodeSearchForm.clsCodeSearch", "")
'Set pclsICD = CreateObject("ICD10.ICDCodeSearch", "")
'Set Registration = DoCreateObject("Registration.clsRegistration")
'Set clsMEDSYS = CreateObject("MEDSYSClasses.clsMEDSYS")
102 CreateOBJ pclsUser, "Medsys_User.clsCurrentUser"
104 CreateOBJ pclsMasterSearch, "MasterSearch.clsPatientSearch"
106 CreateOBJ pclsCodeSearch, "CodeSearchForm.clsCodeSearch"
108 CreateOBJ pclsICD, "ICD10.ICDCodeSearch"
110 CreateOBJ Registration, "Registration.clsRegistration"
'112 CreateOBJ clsMEDSYS, "MEDSYSClasses.clsMEDSYS"
'/ NEW MEDSYSCLASSES REPORT EXPORTER - MARCH 30 2018 /'
' Set medClass = CreateObject("MEDSYSClasses.clsMEDSYS")
' medClass.EXEPath = App.Path
' medClass.MedsysUser = pclsUser
'/--------------------END CODE------------------------/'
pclsUser.MEDSYSClasses.useclasses = True
114 pclsUser.PasswordDeptCode = "19"
116 pclsUser.ShowMain
118 pstrRemarks = "LogIn: "
120 DoEvents
Dim ErrPart As String
122 If pclsUser.Connected Then
pclsUser.MEDSYSClasses.initwithdb
124 pstrEmployeeID = pclsUser.EmployeeCode
126 Set recFile = pclsUser.sqlconnection
128 frmWelcom.Show
130 frmWelcom.Refresh
132 pclsUser.sqlconnection.CommandTimeout = 120
134 pstrServerName = GetServerName(pclsUser.sqlconnection.ConnectionString)
Dim recMedrec As New ADODB.Recordset
136 Set recMedrec = pclsUser.sqlconnection.Execute("Select *, GetDate() as CurDate From Patient_Data..tbHospitalInfo")
138 With recMedrec
140 pstrHospitalName = !Company
142 pstrHospitalAddress = !Address1
144 pdCurDate = !CurDate
146 pstrRecordOfficer = !RecordOfficer & ""
148 pintPediaAgeLimit = IIf(IsNull(!PediaAgeLimit), 14, !PediaAgeLimit)
150 pstrNewbornCode = IIf(IsNull(!NewbornServiceID), "13", !NewbornServiceID)
152 pstrZipcode = !ZipCode
'pstrServerName = !MTSServerName
End With
154 Set recMedrec = Nothing
' pclsCodeSearch.MTS_Server = pstrServerName
' pclsCodeSearch.MTS_Server = ""
156 'pclsCodeSearch.SearchMode = True
158 'pclsCodeSearch.Initialize_Classes
160 'pclsCodeSearch.Connection = pclsUser.sqlconnection
162 'pclsCodeSearch.CompanyName = pstrHospitalName
'164 If blnAllowCF4 Then
'166 'CreateOBJ clsCF4, "CF4.CF4Entry"
' Set clsCF4 = CreateObject("CF4.CF4Entry")
'168 Set clsCF4.ActiveConnection = pclsUser.sqlconnection
' End If
170 Set pclsICD.ActiveConnection = pclsUser.sqlconnection
'Set pclsMain = New clsPatient
'Set pclsMain = CreateObject("Patient.clsPatient", "kcci-pdc")
172 pstrConnectionString = pclsUser.sqlconnection.ConnectionString
174 ErrPart = "MasterSearch.dll"
'pclsMain.OpenConnection pstrConnectionString
' pclsMasterSearch.InitConnection pstrConnectionString, pstrServerName
176 pclsMasterSearch.InitConnection pstrConnectionString, ""
178 Set pclsMain = pclsMasterSearch.patientclass
180 Set pclsAdmission = pclsMain.clsAdmission
182 ErrPart = "Registration.dll"
184 Registration.MedsysUser pclsUser
186 Set Registration.MyClassRegistration = Registration
188 Registration.EXEName = App.EXEName
190 pclsMasterSearch.EXEName = App.EXEName
192 Registration.EXEPath = App.Path
194 ErrPart = ""
196 'clsMEDSYS.EXEPath = App.Path
pclsUser.MEDSYSClasses.EXEPath = App.Path
198 pstrDate = Format(Now, "MM/DD/YYYY HH:MM:SS")
200 Get_ServerDate
202 Get_ClientName
204 LoadSetUp
206 clsUserSetting.Initialize_Menu
208 clsUserSetting.Load_UserSetting pstrEmployeeID
210 recFile.Execute "Patient_Data..SP_Medrec_UserLogin '" & Get_Sequence & "','" & pstrEmployeeID & "', '" & pstrRemarks & "', '" & pstrDate & "', ''"
212 clsUserSetting.Initialize_MenuVisibility
214 clsUserSetting.Load_MenuVisibility
215 If blnAllowCF4 Then
Set clsCF4 = CreateObject("CF4.CF4Entry") 'SET AS OBJECT
clsCF4.MedsysUser = pclsUser
Set clsCF4.ActiveConnection = pclsUser.sqlconnection
End If
'DOH REPORT
216 If frmMain.mnuNewDOH.Visible = True Then
218 clsUserSetting.Load_DOHReportMenuVisibility
220 clsUserSetting.Load_DOHReportMenu
End If
'FOR NKTI CUSTOMIZED DISCHARGED REPORT VISIBILITY
222 If pubClientName = "NKTI" Then
224 With frmMain
226 .mnuFetalDeath.Visible = False
228 .mnuReportRegisterDischarge.Visible = False
230 .mnuReportRegisterDischargeNKTI.Visible = True
232 .mnuReportRegisterDischargeNKTIOld.Visible = True
End With
Else
End If
'NURSE NOTES VISIBILITY
234 frmMain.tbToolBar.Buttons(11).Enabled = False
236 If Not blnAllowNurseNotes Then
238 frmMain.tbToolBar.Buttons(11).Visible = False
End If
240 Set WshShell = CreateObject("WScript.Shell")
242 Load frmMain
244 Unload frmWelcom
' frmCons.Show
246 frmMain.Show
Else
'GoTo ErrMain
End If
'
Exit Sub
Main_Err:
MsgBox Err.Description & vbCrLf & _
"in MedRec.modAdmitPatient.Main " & _
"at line " & Erl, _
vbExclamation + vbOKOnly, "Application Error"
Resume Next
'
End Sub
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
ChkSurname = True
'End If
End If
End Function
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
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", strBirth, strNow)
ComputeAge = Int(intDays / 365)
Else
ComputeAge = 0
End If
End If
End Function
Public Function ConvertToDate(StrYear As String, strMonth As String, strDay As String) As String
Dim intTemp As Integer
Dim strDate As String
strDate = Trim(StrYear)
intTemp = Val(strMonth)
If intTemp >= 1 And intTemp <= 12 Then
strDate = strDate + "." + IIf(intTemp < 10, "0", "") + Trim(strMonth)
intTemp = Val(strDay)
If intTemp >= 1 And intTemp <= 31 Then
strDate = strDate + "." + IIf(intTemp < 10, "0", "") + Trim(strDay)
End If
End If
ConvertToDate = strDate
End Function
Public Sub ConvertNameKey(ByRef KeyAscii As Integer)
Dim strKey As String
If KeyAscii >= 32 Then
strKey = UCase(Chr(KeyAscii))
If strKey Like "[A-Z,--,Ñ,' ]" Then _
KeyAscii = Asc(strKey) Else _
KeyAscii = 0
End If
End Sub
Public Function StringLen(ByVal strVar As String) As Integer
StringLen = Len(Trim$(strVar))
End Function
Public Function ValidateCode(ByRef objTextBox As TextBox, ByVal strSearchType As String, Optional ByVal strSearch As String = "", Optional ByVal blnAllowBlank As Boolean = True) As Boolean
'Dim recLookup As New ADODB.Recordset
' If StringLen(strSearch) = 0 And blnAllowBlank Then
' ValidateCode = True
' Exit Function
' End If
' Select Case strSearchType
' Case "Address"
' Set recLookup = pclsMain.ExecuteCommand("Patient_Data..sp_adm_LoadZipCode '" + strSearch + "'")
' Case "Nationality"
' Set recLookup = pclsMain.ExecuteCommand("Patient_Data..sp_adm_LoadNationality '" + strSearch + "'")
' Case "Religion"
' Set recLookup = pclsMain.ExecuteCommand("Patient_Data..sp_adm_LoadReligion '" + strSearch + "'")
' Case "Company"
' Set recLookup = pclsMain.ExecuteCommand("Patient_Data..sp_adm_LoadAccount '" + strSearch + "'")
' Case "Service"
' Set recLookup = pclsMain.ExecuteCommand("Patient_Data..sp_adm_LoadService '" + strSearch + "'")
' Case "Doctor"
' Set recLookup = pclsMain.ExecuteCommand("Patient_Data..sp_adm_LoadDoctor '" + strSearch + "'")
'
' End Select
' If Not (recLookup.EOF And recLookup.BOF) Then
' ValidateCode = True
' Else
' With frmLookup
' .LookupType = strSearchType
' .LookupReturn = objTextBox
' .SearchString = strSearch
' .Show vbModal
' End With
' ValidateCode = pubblnSelected
' End If
'
' Set recLookup = Nothing
End Function
Public Function ValidateRoom() As Boolean
ValidateRoom = True
If pclsMasterSearch.Room.BedsLeft <= 0 And _
pclsAdmission.Room.RoomID <> pclsMasterSearch.Room.RoomID Then
If Not MsgBox("Warning! The room is fully occupied. Do you want to conitnue?", vbQuestion + vbYesNo) = vbYes Then
ValidateRoom = False
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 blnPediaToLT18 Then '----FOR UCMED SETUP----'
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) > 18 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
Else '---DEFAULT---'
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 If
End Function
Public Sub PrintDataSheet(ByVal strAdmNumber As String, ByVal strAge As String)
Screen.MousePointer = 11
pclsUser.sqlconnection.Execute "Patient_Data..sp_Adm_PatientData '" + Trim$(strAdmNumber) + "', '" + strAge + "'"
' If pubClientName <> "LMC" Then --Removed By Raymund Tacuban 02.01.2010
' If blnAllowDataSheetNew Then
strFileName = App.Path + "\Customized\DataSheet.rpt"
If File_Exists(strFileName) = False Then
strFileName = App.Path + "\Reports\DataSheet.rpt"
End If
' If pubClientName = "NDCH" Then
' OpenMainReport strFileName, pstrHospitalAddress, pclsUser.employeename
' Else
If pubClientName = "NKTI" Then
OpenMainReport strFileName, pstrHospitalAddress, strAdmNumber, strAge
ShowReportViewer False, "Data Sheet"
Else
OpenMainReport strFileName, pstrHospitalAddress
ShowReportViewer False, "Data Sheet"
End If
' End If
' Else
' frmCrViewer.Show vbModal
' End If
Screen.MousePointer = 0
End Sub
Private 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 Sub ExtractName(ByVal strName As String, ByRef strLastName As String, ByRef strFirstName As String, ByRef strMiddleName As String)
Dim intpos As Integer
intpos = InStr(1, strName, ",", vbTextCompare)
If intpos > 0 Then
strLastName = Trim$(Mid$(strName, 1, intpos - 1))
strName = Trim$(Mid$(strName, intpos + 1))
intpos = InStr(1, strName, ",", vbTextCompare)
If intpos > 0 Then
strFirstName = Trim$(Mid$(strName, 1, intpos - 1))
strMiddleName = Trim$(Mid$(strName, intpos + 1))
Else
strFirstName = strName
strMiddleName = ""
End If
Else
strLastName = Trim$(strName)
strFirstName = ""
strMiddleName = ""
End If
End Sub
Public Sub OpenMainReport(ByVal strReportFileName As String, ParamArray strParameters())
On Error GoTo ReportError
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
Report.ReportComments = pstrHospitalAddress
Report.ReportAuthor = pclsUser.employeename
For Each crxtable In Report.Database.Tables
If frmReportPeriod.strReportType = "OR Census" Then
crxtable.Location = "Station" + Mid(crxtable.Location, InStr(1, crxtable.Location, "."))
crxtable.SetLogOnInfo pclsUser.ServerName, "Patient_Data", pclsUser.UserId, pclsUser.serverpassword
ElseIf frmReportPeriod.strReportType = "HEMO Census" Then
crxtable.Location = "Hemodialysis" + Mid(crxtable.Location, InStr(1, crxtable.Location, "."))
crxtable.SetLogOnInfo pclsUser.ServerName, "Hemodialysis", pclsUser.UserId, pclsUser.serverpassword
ElseIf frmPHICMandatoryReport.strReportName = "PHICMandatoryReport" Then
crxtable.Location = "Medicare" + Mid(crxtable.Location, InStr(1, crxtable.Location, "."))
crxtable.SetLogOnInfo pclsUser.ServerName, "Medicare", pclsUser.UserId, pclsUser.serverpassword
ElseIf frmMain.strReportType = "NurseNotesReports" Then
crxtable.Location = "Station" + Mid(crxtable.Location, InStr(1, crxtable.Location, "."))
crxtable.SetLogOnInfo pclsUser.ServerName, "Station", pclsUser.UserId, pclsUser.serverpassword
Else
crxtable.Location = "Patient_Data" + Mid(crxtable.Location, InStr(1, crxtable.Location, "."))
crxtable.SetLogOnInfo pclsUser.ServerName, "Patient_Data", pclsUser.UserId, pclsUser.serverpassword
End If
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
' If pubClientName = "BOLMSH" And blnExport Then --Removed By Raymund Tacuban 02.01.2010
If blnAllowExportReport And blnExport Then
If MsgBox("Do you wish to export the report?", vbYesNo, "Export Report to Disk") = vbYes Then
strFileName = "Logbook " + 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
ReportError:
MsgBox Err.Description
Resume Next
End Sub
Public Sub OpenMainReportForAUFMedicalCertificate(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
Dim strTable As String
Dim strDatabase As String
intTotalParam = UBound(strParameters)
Set Report = crxApplication.OpenReport(strReportFileName, 1)
Report.ReportTitle = pstrHospitalName
For Each crxtable In Report.Database.Tables
strDatabase = "Patient_Data"
strTable = Mid(crxtable.Location, InStr(1, crxtable.Location, "."))
If InStr(1, UCase(strTable), "TBCO") > 0 Then
strDatabase = "Build_File"
End If
crxtable.Location = strDatabase + Mid(crxtable.Location, InStr(1, crxtable.Location, "."))
crxtable.SetLogOnInfo pclsUser.ServerName, strDatabase, 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 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
If frmReportPeriod.strReportType = "HEMO Census" Then
crxtable.Location = "Hemodialysis" + Mid(crxtable.Location, InStr(1, crxtable.Location, "."))
crxtable.SetLogOnInfo pclsUser.ServerName, "Patient_Data", pclsUser.UserId, pclsUser.serverpassword
ElseIf frmPHICMandatoryReport.strReportName = "PHICMandatoryReport" Then
crxtable.Location = "Medicare" + Mid(crxtable.Location, InStr(1, crxtable.Location, "."))
crxtable.SetLogOnInfo pclsUser.ServerName, "Medicare", pclsUser.UserId, pclsUser.serverpassword
Else
crxtable.Location = "Patient_data" + Mid(crxtable.Location, InStr(1, crxtable.Location, "."))
crxtable.SetLogOnInfo pclsUser.ServerName, "Patient_Data", pclsUser.UserId, pclsUser.serverpassword
End If
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
.Show 1
End With
End Sub
Public Sub ShowReportViewerModal(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
.Show
End With
End Sub
Public Function GetFileNumber(ByVal strPNO As String) As String
Dim recTemp As New ADODB.Recordset
On Error GoTo GetFileNumberErr
Set recTemp = pclsUser.sqlconnection.Execute("Select isnull(FileNum,'') as FileNum From Patient_Data..tbMaster Where HospNum = '" + Trim$(strPNO) + "'")
With recTemp
If .EOF And .BOF Then
GetFileNumber = ""
Else
GetFileNumber = IIf(IsNull(!FileNum), "", !FileNum & "")
End If
End With
GoTo ExitSub
GetFileNumberErr:
MsgBox Err.Description
GetFileNumber = ""
ExitSub:
Set recTemp = Nothing
End Function
Public Function DoctorName(code As String) As String
Dim recDoctor As New ADODB.Recordset
On Error GoTo DoctorNameErr
If Len(Trim$(code)) > 0 Then
Set recDoctor = pclsUser.sqlconnection.Execute("Patient_Data..sp_Adm_LoadDoctor '" + code + "'")
With recDoctor
If .EOF And .BOF Then
DoctorName = ""
Else
DoctorName = Trim$(!LastName & "") + ", " + Trim$(!FirstName & "") + IIf(Len(Trim$(!MiddleName & "")) > 0, ", " + !MiddleName & "", "")
End If
.Close
End With
Else
DoctorName = ""
End If
Exit Function
DoctorNameErr:
DoctorName = ""
End Function
Public Function IsBlank(Argvalue As String) As Boolean
If Len(Trim$(Argvalue)) = 0 Then
IsBlank = True
Else
IsBlank = False
End If
End Function
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 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 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 Alphabet() As String
'Returns the Alphabet String for specific use in filtering keystrokes
Alphabet = "ABCDEFGHIJKLMNOPQRSTUVWXYZÑ"
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 Sub OpenReportClinical(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
Report.ReportComments = pstrHospitalAddress
Report.ReportAuthor = pclsUser.employeename
For Each crxtable In Report.Database.Tables
crxtable.Location = "Station" + Mid(crxtable.Location, InStr(1, crxtable.Location, "."))
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 OpenForm3Report(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 = User.Database + Mid(crxtable.Location, InStr(1, crxtable.Location, "."))
' crxtable.SetLogOnInfo pclsUser.ServerName, pclsUser.Database, "sa", pclsUser.serverpassword
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
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 OpenSubForm3Report(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 = User.Database + Mid(crxtable.Location, InStr(1, crxtable.Location, "."))
' crxtable.SetLogOnInfo pclsUser.ServerName, pclsUser.Database, "sa", pclsUser.serverpassword
crxtable.SetLogOnInfo pclsUser.ServerName, pclsUser.Database, 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 ShowReportViewerForm3(Optional blnShowGroupTree As Boolean = False, Optional strCaption As String = "", Optional blnDirectToPrinter As Boolean = False)
Dim frmView1 As New frmReportViewer
If blnDirectToPrinter Then
Report.DisplayProgressDialog = False
Report.PrintOut False
Set Report = Nothing
Else
With frmView1
.ShowGroupTree = blnShowGroupTree
.Caption = strCaption
.DirectPrint = blnDirectToPrinter
.Show 'vbModal
End With
End If
End Sub
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..tbMedRec_UserLogin", pclsUser.sqlconnection, adOpenDynamic, adLockOptimistic
If .RecordCount > 0 Then
Get_Sequence = !LogSequence
End If
End With
Set Rec = Nothing
End Function
Public Function Get_ClientName() As String
Dim Rec As New ADODB.Recordset
Dim SQL As String
With Rec
SQL = "Select top 1 ClientName,Seafarer from Patient_Data..tbHospitalInfo"
If .State > 0 Then .Close
.CursorLocation = adUseClient
.Open SQL, pclsUser.sqlconnection, adOpenDynamic, adLockReadOnly
If .RecordCount = 1 Then
Get_ClientName = !clientname
blnSeaFarer = !Seafarer
End If
.Close
End With
Set Rec = Nothing
pubClientName = Get_ClientName & ""
End Function
Public Function Get_ServerDate() As String
Dim Rec As New ADODB.Recordset
Dim SQL As String
With Rec
SQL = "Select getdate() as ServerDate"
If .State > 0 Then .Close
.CursorLocation = adUseClient
.Open SQL, pclsUser.sqlconnection, adOpenDynamic, adLockReadOnly
If .RecordCount = 1 Then
Get_ServerDate = !ServerDate
End If
.Close
End With
Set Rec = Nothing
pubstrServerDate = Get_ServerDate
End Function
Public Function Crypt(Action As String, Key As String, Src As String) As String
'E encrypts, D decrypts, Key is a unique string needed to en/decrypt
'(either hardcode or
'setup something for the user to enter. Src is the string to be en/decrypted.
Dim count As Integer, KeyPos As Integer, KeyLen As Integer, SrcAsc As Integer
Dim Dest As String, Offset As Integer, TmpSrcAsc, SrcPos As Integer
Const KN_OFFSET = 91
KeyLen = Len(Key)
If Action = "E" Then
'Randomize
'Offset = (Rnd * 10000 Mod 255) + 1 'Modified by randy gadingan
Offset = KN_OFFSET
Dest = Hex$(Offset)
For SrcPos = 1 To Len(Src)
SrcAsc = (Asc(Mid$(Src, SrcPos, 1)) + Offset) Mod 255
If KeyPos < KeyLen Then KeyPos = KeyPos + 1 Else KeyPos = 1
'Fill Dest$ with HEX representation of Encrypted field
'Hex used to keep nasties such as eof or lf from mangling stream
'Use format$ to make Hex$ return " 0" instead of "0" when the same
'values are Xor'ed together (Null) - keeps placeholder for decrypt
SrcAsc = SrcAsc Xor Asc(Mid$(Key, KeyPos, 1))
Dest = Dest + Format$(Hex$(SrcAsc), "@@")
Offset = SrcAsc
Next
ElseIf Action = "D" Then
Offset = Val("&H" + Left$(Src, 2))
For SrcPos = 3 To Len(Src) Step 2
SrcAsc = Val("&H" + Trim(Mid$(Src, SrcPos, 2)))
If KeyPos < KeyLen Then KeyPos = KeyPos + 1 Else KeyPos = 1
TmpSrcAsc = SrcAsc Xor Asc(Mid$(Key, KeyPos, 1))
If TmpSrcAsc <= Offset Then
TmpSrcAsc = 255 + TmpSrcAsc - Offset
Else
TmpSrcAsc = TmpSrcAsc - Offset
End If
Dest = Dest + Chr(TmpSrcAsc)
Offset = SrcAsc
Next
End If
Crypt = Dest
End Function
Public Function ValidateICDCode(strICD As String) As Boolean
Dim Rec As New ADODB.Recordset
Dim SQL As String
SQL = "Select isnull(isNotifiable, 'Y') isNotifiable from Build_File..tbIcdDiagMain where Code = '" & strICD & "'"
ValidateICDCode = False
With Rec
If .State > 0 Then .Close
.CursorLocation = adUseClient
.Open SQL, pclsUser.sqlconnection, adOpenDynamic, adLockReadOnly
If Not .EOF Then
If !isNotifiable = "Y" Then
ValidateICDCode = True
Else
ValidateICDCode = False
End If
End If
.Close
End With
Set Rec = Nothing
End Function
Public Function GetDiseaseName(strDiseaseID As String, intType As Integer) As String
Dim Rec As New ADODB.Recordset
Dim SQL As String
If intType = 1 Then
SQL = "Select isnull(Disease, '') Disease from Patient_Data..tbMedrecDisease where DiseaseID = '" & Trim$(strDiseaseID) & "'"
Else
SQL = "Select isnull(DiseaseDiagnosis, '') Disease from Patient_Data..tbMedrecDiseaseDiagnosis where DiseaseDiagnosisID = '" & Trim$(strDiseaseID) & "'"
End If
With Rec
If .State > 0 Then .Close
.CursorLocation = adUseClient
.Open SQL, pclsUser.sqlconnection, adOpenDynamic, adLockReadOnly
If Not .EOF Then
GetDiseaseName = !Disease
End If
.Close
End With
Set Rec = Nothing
End Function
Public Function GetDiagnosisRemarks(strDxRemarksID As String, strDxID As String) As String
Dim Rec As New ADODB.Recordset
Dim SQL As String
SQL = "Select isnull(DiagnosisType, '') DiagnosisType from Patient_Data..tbMedrecDiagnosisType where DiseaseDiagnosisID = '" & Trim$(strDxID) & "' and DiagnosisTypeID = '" & Trim$(strDxRemarksID) & "'"
With Rec
If .State > 0 Then .Close
.CursorLocation = adUseClient
.Open SQL, pclsUser.sqlconnection, adOpenDynamic, adLockReadOnly
If Not .EOF Then
GetDiagnosisRemarks = !DiagnosisType
End If
.Close
End With
Set Rec = Nothing
End Function
Public Function CheckIfAlreadyBilled(IdNum As String) As Boolean
Dim Rec As New ADODB.Recordset
Dim SQL As String
CheckIfAlreadyBilled = False
SQL = "Select BillingDate from Patient_Data..tbOutPatient where IDNum = '" & IdNum & "'"
With Rec
If .State > 0 Then .Close
.CursorLocation = adUseClient
.Open SQL, pclsUser.sqlconnection, adOpenDynamic, adLockReadOnly
If Not .EOF Then
If IsNull(!BillingDate) = False Then
CheckIfAlreadyBilled = True
End If
End If
.Close
End With
Set Rec = Nothing
End Function
Public Function DrSpecialization(strCode As String) As String
Dim Rec As New ADODB.Recordset
Dim SQL As String
DrSpecialization = ""
SQL = "Build_File..global_SearchDoctor_by_Specialization '" & Trim$(strCode) & "', '8'"
With Rec
If .State > 0 Then .Close
.CursorLocation = adUseClient
.CursorType = adOpenDynamic
.LockType = adLockOptimistic
.Open SQL, pclsUser.sqlconnection
If .RecordCount > 0 Then
DrSpecialization = "(" & !Specialization & ")"
End If
.Close
End With
Set Rec = Nothing
End Function
Public Function File_Exists(FileName As String) As Boolean
Dim fs As Object
Dim blnResult As Boolean
On Error GoTo errHandle
Set fs = CreateObject("Scripting.FileSystemObject")
blnResult = fs.FileExists(FileName)
Set fs = Nothing
File_Exists = blnResult
Exit Function
errHandle:
File_Exists = True
End Function
Private Sub LoadSetUp()
'
On Error GoTo LoadSetUp_Err
'
Dim SQL As String
Dim Rec As New ADODB.Recordset
100 SQL = "Select * From Patient_Data..tbMedRecSetUp"
102 With Rec
104 If .State > 0 Then .Close
106 '.CursorLocation = adUseClient
108 .CursorType = adOpenDynamic
110 .LockType = adLockOptimistic
112 .Open SQL, pclsUser.sqlconnection
'On Error GoTo LoadSetupFailErr
114 'If .RecordCount > 0 Then
If .EOF = False Then
'116 blnAllowAuditTrail = !IsAllowAuditTrail
'118 blnAllowRefNum = !IsAllowRefNum
'120 blnAllowDrNameWithSpecialization = !IsAllowDrNameWithSpecialization
'122 blnAllowPatientDiseases = !IsAllowPatientDiseases
'124 blnAllowAnesthesiaInfo = !IsAllowAnesthesiaInfo
'126 blnAllowObstetrical = !IsAllowObstetrical
'128 blnAllowLockedICDDesc = !IsAllowLockedICDDesc
'130 blnAllowCertificateResidentDr = !IsAllowCertificateResidentDr
'132 blnAllowRepAdmissionLogbookNew = !IsAllowRepAdmissionLogbookNew
'134 blnAllowRepMorbidityNew = !IsAllowRepMorbidityNew
'136 blnAllowRepMortalityNew = !IsAllowRepMortalityNew
'138 blnAllowUpdateFileNumber = !IsAllowUpdateFileNumber
'140 blnAllowCertificateRequest = !IsAllowCertificateRequest
'142 blnAllowCertificateNum = !IsAllowCertificateNum
'144 blnAllowRepClinicalSummaryNew = !IsAllowRepClinicalSummaryNew
'146 blnAllowDataSheetNew = !IsAllowDataSheetNew
'148 blnAllowExportReport = !IsAllowExportReport
'150 blnAllowBirthCareOf = !IsAllowBirthCareOf
'152 blnAllowDeathCemetryInfo = !IsAllowDeathCemetryInfo
'154 blnAllowCheckIfAdmitted = !IsAllowCheckIfAdmitted
'156 blnAllowBirthFetal = !IsAllowBirthFetal
'158 blnAllowBirthEthnic = !IsAllowBirthEthnic
'160 blnAllowDemographics = !IsAllowDemographics
'162 blnAllowShowNewResult = !IsAllowShowNewResult
'164 blnAllowFatherResidence = !AllowFatherResidence
'166 blnOldBirthCertFormat = !AllowOldBirthCertFormat
'168 blnOldDeathCertFormat = !AllowOldDeathCertFormat
'170 pStrAssessRevCode = !RevenueCode
' 'blnAllowConfirmationCode = !AllowConfirmationCode
'172 blnAllowConfirmationCode = !isAllowConfirmationCode
'174 blnAllowDemographyByProvince = !IsAllowDemographyByProvince
'176 blnLiveBirthCertificateOLDSeperateNameFormat = !IsAllowLiveBirthCertificateOldSeperateNameFormat
' ' blnisGetRemarksToNurseDischargeNotice = !isAllowisGetRemarksToNurseDischargeNotice
'178 blnPediaToLT18 = !isAllowPediaToLT18
'180 blnBorrowRecordwithDoctors = !isAllowBorrowerLogbookWithDr
'182 blnConfinementRec = !isAllowConfinementRec
'184 blnPatientInquiry = !isAllowPatientInquiry
'186 blnDOHReport = !isAllowDOHReport
'188 blnIndexReport2Entries = !isAllowIndexReport2Entries
'190 blnAllowResidentDoctors = !isAllowResidentDoctors
'192 blnAllowMedCertShowRequestForm = !isAllowMedCertShowRequestForm
'197 blnSetAgeByAdmission = !IsAllowPatientIndexAgeByAdmission
'198 blnSetAgeByAdmission_IncludeNonNumeric = !IsAllowPatientIndexAgeByAdmission_IncludeNonNumeric
'199 blnSetAgeCurrent = !IsAllowPatientIndexAgeCurrent
'200 blnAllowNewSuffix = !IsAllowNewSuffix
'201 blnAllowDisableICDValidation = !IsAllowDisableICDValidation
'202 blnLoadParentsWithClearEntries = !isAllowLoadParentsWithClearEntries
'203 blnAllowDoctorOnAssessment = !isAllowDoctorOnAssessment
' blnAllowCourseInTheWardDisplay = !isAllowCourseInTheWardDisplay
' blnAllowPhysicalExaminationDisplay = !isAllowPhysicalExaminationDisplay
' blnAllowPhicCaseRateBtn = !isAllowPhicCaseRateBtn
' blnIsAllowDcrDateValidation = !isAllowDcrDateValidation
116 blnAllowAuditTrail = GetField(Rec, "IsAllowAuditTrail")
118 blnAllowRefNum = GetField(Rec, "IsAllowRefNum")
120 blnAllowDrNameWithSpecialization = GetField(Rec, "IsAllowDrNameWithSpecialization")
122 blnAllowPatientDiseases = GetField(Rec, "IsAllowPatientDiseases")
124 blnAllowAnesthesiaInfo = GetField(Rec, "IsAllowAnesthesiaInfo")
126 blnAllowObstetrical = GetField(Rec, "IsAllowObstetrical")
128 blnAllowLockedICDDesc = GetField(Rec, "IsAllowLockedICDDesc")
130 blnAllowCertificateResidentDr = GetField(Rec, "IsAllowCertificateResidentDr")
132 blnAllowRepAdmissionLogbookNew = GetField(Rec, "IsAllowRepAdmissionLogbookNew")
134 blnAllowRepMorbidityNew = GetField(Rec, "IsAllowRepMorbidityNew")
136 blnAllowRepMortalityNew = GetField(Rec, "IsAllowRepMortalityNew")
138 blnAllowUpdateFileNumber = GetField(Rec, "IsAllowUpdateFileNumber")
140 blnAllowCertificateRequest = GetField(Rec, "IsAllowCertificateRequest")
142 blnAllowCertificateNum = GetField(Rec, "IsAllowCertificateNum")
144 blnAllowRepClinicalSummaryNew = GetField(Rec, "IsAllowRepClinicalSummaryNew")
146 blnAllowDataSheetNew = GetField(Rec, "IsAllowDataSheetNew")
148 blnAllowExportReport = GetField(Rec, "IsAllowExportReport")
150 blnAllowBirthCareOf = GetField(Rec, "IsAllowBirthCareOf")
152 blnAllowDeathCemetryInfo = GetField(Rec, "IsAllowDeathCemetryInfo")
154 blnAllowCheckIfAdmitted = GetField(Rec, "IsAllowCheckIfAdmitted")
156 blnAllowBirthFetal = GetField(Rec, "IsAllowBirthFetal")
158 blnAllowBirthEthnic = GetField(Rec, "IsAllowBirthEthnic")
160 blnAllowDemographics = GetField(Rec, "IsAllowDemographics")
162 blnAllowShowNewResult = GetField(Rec, "IsAllowShowNewResult")
164 blnAllowFatherResidence = GetField(Rec, "AllowFatherResidence")
166 blnOldBirthCertFormat = GetField(Rec, "AllowOldBirthCertFormat")
168 blnOldDeathCertFormat = GetField(Rec, "AllowOldDeathCertFormat")
170
'blnAllowConfirmationCode = GetField(Rec,"AllowConfirmationCode
172 blnAllowConfirmationCode = GetField(Rec, "isAllowConfirmationCode")
174 blnAllowDemographyByProvince = GetField(Rec, "IsAllowDemographyByProvince")
176 blnLiveBirthCertificateOLDSeperateNameFormat = GetField(Rec, "IsAllowLiveBirthCertificateOldSeperateNameFormat")
' blnisGetRemarksToNurseDischargeNotice = GetField(Rec,"isAllowisGetRemarksToNurseDischargeNotice
178 blnPediaToLT18 = GetField(Rec, "isAllowPediaToLT18")
180 blnBorrowRecordwithDoctors = GetField(Rec, "isAllowBorrowerLogbookWithDr")
182 blnConfinementRec = GetField(Rec, "isAllowConfinementRec")
184 blnPatientInquiry = GetField(Rec, "isAllowPatientInquiry")
186 blnDOHReport = GetField(Rec, "isAllowDOHReport")
188 blnIndexReport2Entries = GetField(Rec, "isAllowIndexReport2Entries")
190 blnAllowResidentDoctors = GetField(Rec, "isAllowResidentDoctors")
192 blnAllowMedCertShowRequestForm = GetField(Rec, "isAllowMedCertShowRequestForm")
197 blnSetAgeByAdmission = GetField(Rec, "IsAllowPatientIndexAgeByAdmission")
198 blnSetAgeByAdmission_IncludeNonNumeric = GetField(Rec, "IsAllowPatientIndexAgeByAdmission_IncludeNonNumeric")
199 blnSetAgeCurrent = GetField(Rec, "IsAllowPatientIndexAgeCurrent")
200 blnAllowNewSuffix = GetField(Rec, "IsAllowNewSuffix")
201 blnAllowDisableICDValidation = GetField(Rec, "IsAllowDisableICDValidation")
202 blnLoadParentsWithClearEntries = GetField(Rec, "isAllowLoadParentsWithClearEntries")
203 blnAllowDoctorOnAssessment = GetField(Rec, "isAllowDoctorOnAssessment")
blnAllowCourseInTheWardDisplay = GetField(Rec, "isAllowCourseInTheWardDisplay")
blnAllowPhysicalExaminationDisplay = GetField(Rec, "isAllowPhysicalExaminationDisplay")
blnAllowPhicCaseRateBtn = GetField(Rec, "isAllowPhicCaseRateBtn")
blnIsAllowDcrDateValidation = GetField(Rec, "isAllowDcrDateValidation")
pStrAssessRevCode = !RevenueCode
End If
' End If
204 .Close
End With
205 Set Rec = Nothing
Exit Sub
'LoadSetupFailErr:
'
Exit Sub
LoadSetUp_Err:
MsgBox Err.Description & vbCrLf & _
"in MedRec.modAdmitPatient.LoadSetUp " & _
"at line " & Erl, _
vbExclamation + vbOKOnly, "Application Error"
Resume Next
'
End Sub
Private Function GetField(Rec As ADODB.Recordset, FName As String) As Boolean
On Error GoTo ErrTrap
GetField = Rec.Fields(FName)
Exit Function
ErrTrap:
MsgBox Err.Description
On Error Resume Next
pclsUser.sqlconnection.Execute "ALTER TABLE Patient_Data..tbMedRecSetUp ADD " & FName & " [BIT] NOT NULL DEFAULT ((0)) "
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
Public Function GetNewFDNum() As Boolean
On Error GoTo GetNewFDNumErr
Dim comTemp As New ADODB.Command
Dim parTemp As New ADODB.Parameter
With comTemp
.ActiveConnection = pclsUser.sqlconnection
.CommandType = adCmdStoredProc
.CommandText = "Patient_Data..sp_adm_GetNewFDNum"
Set parTemp = .CreateParameter("@FDNum", adVarChar, adParamOutput, 10, "")
.Parameters.Append parTemp
.Execute
End With
PubFDNum = comTemp.Parameters(0).Value
'If Len(PubFDNum) = 0 Or PubFDNum = "" Then
' GetNewFDNum = False
' GoTo GetNewFDNumErr
'End If
' GetNewFDNum = True
Set comTemp = Nothing
Set parTemp = Nothing
Exit Function
GetNewFDNumErr:
GetNewFDNum = False
MsgBox "Unable to assign a new Reference Number", vbOKOnly + vbCritical, "Error"
End Function
Private Function DoCreateObject(ObjectStr As String) As Object
On Error GoTo ErrTrap
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. "
End
End Function
Private Sub CheckSwitchFeature()
End Sub
Public Sub Load_RegistrationLabelEntries()
Dim Rec As New ADODB.Recordset
Dim SQL As String
SQL = "Select * from Patient_Data..tbAdmLabelEntrySettings where status= 1"
With Rec
If .State > 0 Then .Close
.CursorLocation = adUseClient
.CursorType = adOpenDynamic
.LockType = adLockOptimistic
.Open SQL, pclsUser.sqlconnection
If .RecordCount > 0 Then
Do While Not .EOF
If !EntryID = "1" Then
strLabelLastName = !InUseLabel
ElseIf !EntryID = "2" Then
strLabelFirstName = !InUseLabel
ElseIf !EntryID = "3" Then
strLabelMiddleName = !InUseLabel
ElseIf !EntryID = "4" Then
strLabelTitle = !InUseLabel
ElseIf !EntryID = "5" Then
strLabelBirth = !InUseLabel
ElseIf !EntryID = "6" Then
strLabelGender = !InUseLabel
ElseIf !EntryID = "7" Then
strLabelBirthPlace = !InUseLabel
ElseIf !EntryID = "8" Then
strLabelBarangay = !InUseLabel
ElseIf !EntryID = "9" Then
strLabelTownProvince = !InUseLabel
ElseIf !EntryID = "10" Then
strLabelForeignAddress = !InUseLabel
ElseIf !EntryID = "11" Then
strLabelCountry = !InUseLabel
ElseIf !EntryID = "12" Then
strLabelOccupation = !InUseLabel
ElseIf !EntryID = "13" Then
strLabelGuarantor = !InUseLabel
ElseIf !EntryID = "14" Then
strLabelOtherGuarantor = !InUseLabel
ElseIf !EntryID = "15" Then
strLabelHospitalizationPlan = !InUseLabel
End If
.MoveNext
Loop
End If
.Close
End With
Set Rec = Nothing
End Sub
'Public Sub Remove_Profile_List(strIDNum 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
'