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 cvarAttendingDrID = 0
Public Const cvarAdmittingDrID = 1
Public Const cvarConsultantDrID = 2
Public Const cvarReferringDrID = 3
Public Const cvarAttendingDrName = 4
Public Const cvarAdmittingDrName = 5
Public Const cvarConsultantDrName = 6
Public Const cvarReferringDrName = 7

Public Const cvarMale = 0
Public Const cvarFemale = 1

'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 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 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 pblnReload As Boolean
Public pstrServerName As String
Public Report As CRAXDRT.Report

Public Sub Main()

   'On Error GoTo ErrMain:
    
   Set pclsUser = CreateObject("Medsys_User.clsCurrentUser", "")
   Set pclsMasterSearch = CreateObject("MasterSearch.clsPatientSearch", "")
   Set pclsCodeSearch = CreateObject("CodeSearchForm.clsCodeSearch", "")
   Set pclsICD = CreateObject("ICD10.ICDCodeSearch", "")
     
   pclsUser.PasswordDeptCode = "19"
   pclsUser.ShowMain
   
   DoEvents
   
   If pclsUser.Connected Then
      frmWelcom.Show
      frmWelcom.Refresh
   
      pclsUser.SQLConnection.CommandTimeout = 120
      pstrServerName = GetServerName(pclsUser.SQLConnection.ConnectionString)
   
      Dim recMedrec As New ADODB.Recordset
      Set recMedrec = pclsUser.SQLConnection.Execute("Select *, GetDate() as CurDate From Patient_Data..tbHospitalInfo")
      With recMedrec
         pstrHospitalName = !Company
         pstrHospitalAddress = !Address1
         pdCurDate = !CurDate
         pstrRecordOfficer = !RecordOfficer & ""
         pintPediaAgeLimit = IIf(IsNull(!PediaAgeLimit), 14, !PediaAgeLimit)
         pstrNewbornCode = IIf(IsNull(!NewbornServiceID), "13", !NewbornServiceID)
         pstrServerName = !MTSServerName
      End With
      Set recMedrec = Nothing
      
'      pclsCodeSearch.MTS_Server = pstrServerName
      pclsCodeSearch.MTS_Server = ""
      pclsCodeSearch.SearchMode = True
      pclsCodeSearch.Initialize_Classes
      pclsCodeSearch.Connection = pclsUser.SQLConnection
      pclsCodeSearch.CompanyName = pstrHospitalName

   
      Set pclsICD.ActiveConnection = pclsUser.SQLConnection

      'Set pclsMain = New clsPatient
      'Set pclsMain = CreateObject("Patient.clsPatient", "kcci-pdc")
      pstrConnectionString = pclsUser.SQLConnection.ConnectionString
      'pclsMain.OpenConnection pstrConnectionString
'      pclsMasterSearch.InitConnection pstrConnectionString, pstrServerName
      pclsMasterSearch.InitConnection pstrConnectionString, ""
      
      Set pclsMain = pclsMasterSearch.PatientClass
      Set pclsAdmission = pclsMain.clsAdmission
     
      

      Load frmMain
   
      Unload frmWelcom
      frmMain.Show
   Else
      GoTo ErrMain
   End If
   
   Exit Sub
   
ErrMain:
   End

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 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 PrintDataSheet(ByVal strAdmNumber As String)
   Screen.MousePointer = 11
   pclsUser.SQLConnection.Execute "Patient_Data..sp_Adm_PatientData '" + Trim$(strAdmNumber) + "'"
   OpenMainReport App.Path + "\datasheet.rpt", pstrHospitalAddress
   ShowReportViewer False, "Data Sheet"
   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())
   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, "Patient_Data", "sa", ""
   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
      'crxtable.Location = "Patient_Data" + Mid(crxtable.Location, InStr(1, crxtable.Location, "."))
      crxtable.SetLogOnInfo pclsUser.ServerName, "Patient_Data", "sa", ""
   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
   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 FileNum From Patient_Data..tbMaster Where HospNum = '" + Trim$(strPNO) + "'")
   With recTemp
      If .EOF And .BOF Then
         GetFileNumber = ""
      Else
         GetFileNumber = !FileNum & ""
      End If
   End With
   
   GoTo ExitSub
   
GetFileNumberErr:
   MsgBox Err.Description
   GetFileNumber = ""
   
ExitSub:
   Set recTemp = Nothing
End Function