Attribute VB_Name = "modMain"
Option Explicit

Public MyclsRegistreation As clsRegistration

Public blnLoadSearcher As Boolean


Public IsInitialized As Boolean
Public pclsUser As Object
Public clsMEDSYS As Object
Public objWebCam As Object
Global Searcher As Object
'Public pclsCodeSearch As Object
Global PatientSearch As Object
'Public MEDSYSClassesService As Object
'Public MEDSYSClassesclsSearch As Object
'Public MEDSYSClassesclsAllergy As Object
'Public MEDSYSClassesclsDoctor As Object
Public CF4 As Object

'--for validation
Public pstrEmployeeID As String
Public pstrEmployeePassword As String
Global gbMasterFileRegistrationOnly As Boolean

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

'tbOPD_settings setup 1/15/2020
Global isAllowPackageID As Boolean
Global isAllowNoBalanceBillingTag As Boolean
Global isAllowSetDefaultValues As Boolean
Global isAllowNewSuffix As Boolean

Global isAllowHomeService As Boolean

Global isAllowEndConsultation  As Boolean
Global isAllowOPFileNumbering As Boolean

Public pblnBottonClick As Boolean
Public pdCurDate As Date

Global isHMORate As Boolean
Global isOPDStatRate As Boolean

Global IsShowLabSpecimen As Boolean
Global isAllowMultipleRequest As Boolean

Global gbAutoDoctorAssignment 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

Global isAllowAssessmentDiscount As Boolean
 

Public strRoomclass As String
Global strAdmDate As String
Global strDsdate As String
Global strRoom As String

Global FSO As Object

Public ChildCount As Integer
Public strHospPlan As String

Public pstrClientName As String
Global Rec As New ADODB.Recordset

Public NewPatientSelected As Boolean
Public HospNumSelected As String
Global strFormElips As String
Global strFormName As String
Global strFormType As String
Global strEvent As String
Public ProgEXEPath As String
Public ProgEXEName As String
Public intPediaAgeLimit As String
Public pclsICD As Object
Global WshShell As Object
Public blnReqLastName As Boolean
Public blnReqFirstName As Boolean
Public blnReqMiddleName As Boolean
Public blnReqPatientClass As Boolean
Public blnReqPatientType As Boolean
Public blnReqServices As Boolean
Public blnReqCausesOfConsultation As Boolean
Public blnReqRequestingPhysician As Boolean
Public blnReqAllergies As Boolean
Public blnReqChiefComplaints As Boolean
Public blnReqInitialDiagnosis As Boolean
Public blnReqOPDPayCode As Boolean
Public blnReqVitalSignsTab As Boolean

Public blnReqHouseStreet As Boolean
Public blnReqBarangay As Boolean
Public blnReqOccupation As Boolean
Public blnReqMobileNumber As Boolean
Public blnReqWhomToNotifyInCaseOfEmergency As Boolean

Public clsRegistration As New clsRegistration
Public blnAllowHMOTagging As Boolean
Public blnAllowCF4Entries As Boolean
Public blnAllowCF4OnRegistration As Boolean
Public StationName As String

Public blnIsAllowWalkInPatientBypassReqEntry As Boolean

Public blnTagHemoPatient As Boolean
Public blnTagChemo As Boolean
Public blnTagRTPatient As Boolean
Public blnTagDOTS As Boolean
Public blnTagForDeposit As Boolean
Public blnTagWithFollowUp As Boolean
Public blnTagPAD As Boolean
Public blnTagCPClearance As Boolean
Public blnTagWithMedico As Boolean
Public blnTagWomensCare As Boolean
Public blnTagHomeCarePatient As Boolean
Public blnTagHomeOfficeService As Boolean
Public blnTagPEME As Boolean
Public blnTagWalkIn As Boolean

Global RecPayCode As New ADODB.Recordset
Global RecCivilStatus As New ADODB.Recordset
Global PatientType As New ADODB.Recordset
Global recPatientClass As New ADODB.Recordset
Global recSeaFarerSetup As New ADODB.Recordset
Global recSeamanDepartment As New ADODB.Recordset
Global recHemoPxType As New ADODB.Recordset
'Public prjOPDRegistration As Object

Global blnSeaFarer As Boolean
Global txtDoctor0 As String
Global txtDoctor2 As String

Global txtAddDoctor0 As String
Global txtAddDoctor2 As String
Global txtAddDoctor4 As String

Public Sub InitClass()

    On Error GoTo ErrTrap
    
    If IsInitialized = True Then
        Exit Sub
    End If
    
    Set FSO = CreateObject("Scripting.FileSystemObject")
    
    Set objWebCam = CreateObject("prjMedSysWebCam.ClsMedSysWebCam")
    objWebCam.SetMedsysUser pclsUser

    Set clsMEDSYS = CreateObject("MEDSYSClasses.clsMEDSYS")
    clsMEDSYS.MedsysUser = pclsUser
    
    'pclsUser.MEDSYSClasses.CourseintheWard
    
    'Set Searcher = CreateObject("CodeSearchForm.clsCodeSearch")
    'Set pclsCodeSearch = CreateObject("CodeSearchForm.clsCodeSearch")
    'Set pclsCodeSearch = pclsUser.medsysclasses.clsSearcher
    
    
'    pclsUser.medsysclasses.clsSearcher.SearchMode = True
'    pclsUser.medsysclasses.clsSearcher.Initialize_Classes
'    pclsUser.medsysclasses.clsSearcher.Connection = pclsUser.sqlconnection
'    pclsUser.medsysclasses.clsSearcher.CompanyName = pclsUser.CompanyName
    
    Set PatientSearch = CreateObject("MasterSearch.clsPatientSearch")
    Set pclsICD = CreateObject("ICD10.ICDCodeSearch", "")
'    Set MEDSYSClassesService = CreateObject("MEDSYSClasses.clsService")
'    Set MEDSYSClassesclsSearch = CreateObject("MEDSYSClasses.clsSearch")
'    Set MEDSYSClassesclsAllergy = CreateObject("MEDSYSClasses.clsAllergy")
'    Set MEDSYSClassesclsDoctor = CreateObject("MEDSYSClasses.clsDoctor")
    
    If PatientSearch.InitConnection(pclsUser.SQLConnection, "") Then
    End If
    
'    Set prjOPDRegistration = CreateObject("clsOPDMain.modFunctions")
    
    pstrEmployeeID = pclsUser.employeecode
    '--added 5/28/2012
    pstrEmployeePassword = pclsUser.Password

    InitOptions
    AdditionalOPD_Setup
    Load_OPDTaggingSetup
    IsInitialized = True

    Set WshShell = CreateObject("WScript.Shell")
    Set CF4 = CreateObject("CF4.Cf4Entry")
'    WshShell.SendKeys "1{+}"
    clsRegistration.Load_RegistrationReqEntries
    
    Exit Sub
ErrTrap:
    
    MsgBox "Registration InitClass " & Err.Description
    Resume Next
End Sub


Public Sub InitOptions()

    Dim Rec As New ADODB.Recordset
    
    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,PediaAgeLimit from Patient_Data..tbHospitalInfo"
          
    With Rec
        If .State > 0 Then .Close
        .CursorLocation = adUseClient
        .Open SQL, pclsUser.SQLConnection, adOpenDynamic, adLockReadOnly
        If .RecordCount > 0 Then
            pstrClientName = !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)
            intPediaAgeLimit = !PediaAgeLimit
            
            
        End If
        .Close
    End With
    
    'pstrClientName = GetClientName
    
End Sub

Public Sub AdditionalOPD_Setup()

    Dim Rec As New ADODB.Recordset
    
    Dim SQL As String

    SQL = "Select top 1 ISNULL(IsAllowPackageID,0) IsAllowPackageID, ISNULL(isAllowNoBalanceBillingTag,0) isAllowNoBalanceBillingTag , ISNULL(isAllowSetDefaultValues,0) isAllowSetDefaultValues,ISNULL(isAllowNewSuffix,0) isAllowNewSuffix, ISNULL(IsAllowWalkInPatientBypassReqEntry,0) IsAllowWalkInPatientBypassReqEntry " & _
          "from Patient_Data..tbOPD_Settings"
          
    With Rec
        If .State > 0 Then .Close
        .CursorLocation = adUseClient
        .Open SQL, pclsUser.SQLConnection, adOpenDynamic, adLockReadOnly
        If .RecordCount > 0 Then
            isAllowPackageID = !isAllowPackageID
            isAllowNoBalanceBillingTag = !isAllowNoBalanceBillingTag
            isAllowSetDefaultValues = !isAllowSetDefaultValues
            isAllowNewSuffix = !isAllowNewSuffix
            blnIsAllowWalkInPatientBypassReqEntry = !IsAllowWalkInPatientBypassReqEntry
        End If
        .Close
    End With
    
    'pstrClientName = GetClientName
    
End Sub
Public Function StringLen(ByVal strVar As String) As Integer
   StringLen = Len(Trim$(strVar))
End Function





Public Function CheckHMOAccount(strAccountNum As String) As Boolean
   Dim Rec As New ADODB.Recordset
   Dim SQL As String
   
   CheckHMOAccount = False
   
   SQL = "Patient_Data..SP_AOPD_CheckCompanyAccount '" & strAccountNum & "'"
   
   With Rec
        If .State > 0 Then .Close
        .CursorLocation = adUseClient
        .Open SQL, pclsUser.SQLConnection, adOpenDynamic, adLockReadOnly
        
        If .RecordCount > 0 Then
            CheckHMOAccount = True
        End If
        .Close
   End With
   Set Rec = Nothing
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 Not IsNumeric(cAge) Then
    cAge = 0
   End If
   
   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
   ElseIf nServCode = 14 And val(cAge) > intPediaAgeLimit 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 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 Sub AppendMessage(ByRef rstrLine As String, _
                              ByVal pstrMessage As String)
    If Trim$(rstrLine) = vbNullString Then
        rstrLine = pstrMessage
    Else
        rstrLine = rstrLine & vbCrLf & pstrMessage
    End If
End Sub

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 Sub CenterForm(Anyform As Form)
'Centers a Form relative to the screen
    Anyform.Move (Screen.Width - Anyform.Width) / 2, (Screen.Height - Anyform.Height) / 2
End Sub

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
Public Function Upper(nKeyAscii)
    Upper = Asc(UCase(Chr(nKeyAscii)))
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

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 blnCheckIfConfined(strHospnum As String) As Boolean

    If pclsUser.medsysclasses.InstitutionHasINPatients = False Then
        Exit Function
    End If
    
    Dim Rec As New ADODB.Recordset
    Dim StrPatientName As String
    
    If Rec.State > 0 Then Rec.Close
    Rec.Open " Select a.DcrDate,b.LastName+', '+ b.FirstName +' '+ b.MiddleName as PatientName " _
            + " From Patient_data..tbPatient a " _
            + " Left Join Patient_Data..tbMaster b on a.HospNum = b.HospNum " _
            + " Where a.HospNum = '" & strHospnum & "'", pclsUser.SQLConnection, adOpenDynamic, adLockOptimistic
    If Not Rec.EOF Then
         If IsNull(Rec!DcrDate) Or Rec!DcrDate = "" Then
            StrPatientName = Trim$(Rec!PatientName)
            MsgBox "This patient " & StrPatientName & " is still Confined.", vbInformation
            blnCheckIfConfined = True
            Exit Function
         Else
            blnCheckIfConfined = False
            Exit Function
         End If
     End If
    Rec.Close
    Set Rec = Nothing
    blnCheckIfConfined = False
End Function

Function ValiText(KeyIn As Integer, ValidateString As String, Editable As Boolean) As Integer

    Dim ValidateList As String
    Dim KeyOut As Integer
    
    If Editable = True Then
        ValidateList = UCase(ValidateString) & Chr(8)
    Else
        ValidateList = UCase(ValidateString)
    End If
    
    If InStr(1, ValidateList, UCase(Chr(KeyIn)), 1) > 0 Then
        KeyOut = KeyIn
    Else
        KeyOut = 0
        Beep
    End If
    
    ValiText = KeyOut
End Function

Public Sub Load_OPDTaggingSetup()
Dim Rec As New ADODB.Recordset
Dim SQL As String


    blnTagHemoPatient = True
    blnTagChemo = True
    blnTagRTPatient = True
    blnTagDOTS = True
    blnTagForDeposit = True
    blnTagWithFollowUp = True
    blnTagPAD = True
    blnTagCPClearance = True
    blnTagWithMedico = True
    blnTagWomensCare = True
    blnTagHomeCarePatient = True
    blnTagHomeOfficeService = True
    blnTagPEME = True
    blnTagWalkIn = True
                    
    SQL = "Select * from Patient_Data..tbOPD_TaggingSetup WITH (NOLOCK)  "
    
    With Rec
        If .State > 0 Then .Close
        .CursorLocation = adUseServer
        .CursorType = adOpenDynamic
        .LockType = adLockOptimistic
        .Open SQL, pclsUser.SQLConnection
        
        'If .RecordCount > 0 Then
            Do While Not .EOF
                If !TagID = "1" Then
                    blnTagHemoPatient = IIf(!Status = "True", True, False)
                ElseIf !TagID = "2" Then
                    blnTagChemo = IIf(!Status = "True", True, False)
                ElseIf !TagID = "3" Then
                    blnTagRTPatient = IIf(!Status = "True", True, False)
                ElseIf !TagID = "4" Then
                    blnTagDOTS = IIf(!Status = "True", True, False)
                ElseIf !TagID = "5" Then
                    blnTagForDeposit = IIf(!Status = "True", True, False)
                ElseIf !TagID = "6" Then
                    blnTagWithFollowUp = IIf(!Status = "True", True, False)
                ElseIf !TagID = "7" Then
                    blnTagPAD = IIf(!Status = "True", True, False)
                ElseIf !TagID = "8" Then
                    blnTagCPClearance = IIf(!Status = "True", True, False)
                ElseIf !TagID = "9" Then
                    blnTagWithMedico = IIf(!Status = "True", True, False)
                ElseIf !TagID = "10" Then
                    blnTagWomensCare = IIf(!Status = "True", True, False)
                ElseIf !TagID = "11" Then
                    blnTagHomeCarePatient = IIf(!Status = "True", True, False)
                ElseIf !TagID = "12" Then
                    blnTagHomeOfficeService = IIf(!Status = "True", True, False)
                ElseIf !TagID = "13" Then
                    blnTagPEME = IIf(!Status = "True", True, False)
                ElseIf !TagID = "14" Then
                    blnTagWalkIn = IIf(!Status = "True", True, False)
                End If
                    
            .MoveNext
            Loop
        'End If
        .Close
    End With
    Set Rec = Nothing
End Sub

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 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 Sub MakeHistory(pHospNum As String, pIDNum As String, pTableName As String)

    On Error GoTo ErrTrap
    Dim RecS As New ADODB.Recordset
    Dim RecD As New ADODB.Recordset
    Dim FName As String
    Dim iX As Integer
    
    With RecS
        .Open "SELECT * FROM PATIENT_DATA.." & pTableName & " WITH (NOLOCK) WHERE Hospnum = '" & pHospNum & "'  ", pclsUser.SQLConnection, adOpenDynamic, adLockReadOnly
        RecD.Open "SELECT * FROM PATIENT_DATA.." & pTableName & "Hist   WHERE Hospnum = '" & pHospNum & "' AND Ver='" & pIDNum & "'", pclsUser.SQLConnection, adOpenDynamic, adLockOptimistic
        
        If .EOF = False Then
        
            If RecD.EOF = True Then
                RecD.AddNew
                RecD.Fields("HospNum") = pHospNum
                RecD.Fields("Ver") = pIDNum
            End If
        
            For iX = 0 To .Fields.Count - 1
                FName = .Fields(iX).Name
                'If .Fields(FName).Value = Null Then
                'End If
                'MsgBox .Fields(FName)
                'MsgBox RecD.Fields(FName)
                RecD.Fields(FName) = .Fields(FName)
            Next
            
            RecD.Update
            
        End If
        
        RecD.Close
        .Close
        
        
    End With
    Exit Sub
    
ErrTrap:
    Dim ErrDesc As String
    ErrDesc = Err.Description
    pclsUser.AddLog ErrDesc
    
    FixDB ErrDesc, FName, pTableName & "Hist"
    
    If ErrDesc = "Item cannot be found in the collection corresponding to the requested name or ordinal." Then
        Resume Next
    End If
    If ErrDesc = "Type mismatch." Then
        Resume Next
    End If
    
End Sub

Private Sub FixDB(ErrDesc As String, FName As String, pTableName As String)
    On Error Resume Next
    
    Select Case ErrDesc
    Case "Item cannot be found in the collection corresponding to the requested name or ordinal."
        pclsUser.SQLConnection.Execute "ALTER TABLE  PATIENT_DATA.." & pTableName & "  ADD " & FName & " VARCHAR(MAX) NULL"
    
    Case Else
        
        pclsUser.SQLConnection.Execute "ALTER TABLE  PATIENT_DATA.." & pTableName & " ADD " & FName & " VARCHAR(MAX) NULL"
        pclsUser.SQLConnection.Execute "ALTER TABLE  PATIENT_DATA.." & pTableName & " ALTER COLUMN " & FName & " VARCHAR(MAX) NULL"
        
        pclsUser.SQLConnection.Execute "ALTER TABLE  PATIENT_DATA.." & pTableName & " ALTER COLUMN Ver VARCHAR(30) NULL"
        MsgBox "Problem occured saving History. Please try again. " & ErrDesc & " " & pTableName & " " & FName
    End Select
     
End Sub