New SignOut VBA

modDeclarations.vba

Public dict As Object
Public modBmk As String
Public vTimestamp As String
Public ufAdd As ufAddPatient
Public ufMod As ufModPatient
Public NoActivity As Date
Public Function residentArray()

    Dim residents As Variant
    Dim x As Long, y As Long
    Dim TempTxt1 As String
    Dim TempTxt2 As String
    
    residents = Array("PGuilford", "TGuilford", "White", "Buckner", "Carlson", "Nguyen", "Varbanoff", "Beavers", "Dockery", "Kirk", "Smith", "Bowling", "Edwards", "Facelo", "McGee")
    
    For x = LBound(residents) To UBound(residents)
        For y = x To UBound(residents)
            If UCase(residents(y)) < UCase(residents(x)) Then
                TempTxt1 = residents(x)
                TempTxt2 = residents(y)
                residents(x) = TempTxt2
                residents(y) = TempTxt1
            End If
        Next y
    Next x
    
    residentArray = residents
    
End Function
Public Function codeArray()
    codeArray = Array("Full Code", "DNR/DNI", "DNR", "DNI", "Unknown")
End Function
Public Sub StartClock()
    NoActivity = Now + TimeValue("00:10:00")
    Application.OnTime NoActivity, "ShutDown"
End Sub
Public Sub StopClock()
    On Error Resume Next
    Application.OnTime NoActivity, "ShutDown"
End Sub
Public Sub ShutDown()
    'Application.DisplayAlerts = False
    
    winCaption = ActiveDocument.ActiveWindow.Caption & " - " & ThisDocument.Application.Caption
    
    If ActiveDocument.ActiveWindow.WindowState = wdWindowStateMinimize Then
        ActiveDocument.ActiveWindow.WindowState = wdWindowStateNormal
    Else
        AppActivate winCaption
    End If
    
    
    'With ActiveDocument
    '    .Save
        '.Close
    'End With
    
    SaveToRelativePath
    Application.Quit
End Sub

modMain.vba

Sub main(fx, sort)
    On Error GoTo eh

    Call StopClock
    
    Dim oDoc As Document
    Set oDoc = ActiveDocument
    
    Dim n As Integer
    n = ActiveDocument.Bookmarks.Count

    'Dim coll As New Collection
    Dim coll As Collection
    Set coll = New Collection

    ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    ' MEMORY

    For i = 1 To n
        'MsgBox "MEMORY"
        bmk = oDoc.Bookmarks(i).Name
        
        Set d = CreateObject("Scripting.Dictionary")
        
        d.Add "bmk", bmk
        
        
        Set oTable = oDoc.Bookmarks(bmk).Range.Tables(1)
        
        
        d.Add "room", Split(oTable.Cell(1, 1).Range.Text, vbCr)(0)
    
        nameDOB = Split(oTable.Cell(1, 2).Range.Text, vbCr)(0)
        
        yo = InStr(nameDOB, "yo")
    
        'Last, First
        nameBoth = Left(nameDOB, yo - 1)
        d.Add "last", Trim(Split(nameBoth, ",")(0))
        fNameAGE = Trim(Split(nameBoth, ",")(1))
        fNameArray = Split(fNameAGE)
        If UBound(fNameArray) >= 2 Then
            FName = fNameArray(0) & " " & fNameArray(1)
        Else
            FName = fNameArray(0)
        End If
        d.Add "first", FName
    
        'Gender
        d.Add "gender", Mid(nameDOB, yo + 3, 1)
    
        'DOB
        dob = InStr(nameDOB, "DOB") + 5
        mrn = InStr(nameDOB, "MRN") - 3
        d.Add "dob", Mid(nameDOB, dob, mrn - dob)
    
        'MRN
        d.Add "mrn", Mid(nameDOB, mrn + 8, 6)
        
        d.Add "admit", Split(oTable.Cell(1, 3).Range.Text, " ")(1)
        d.Add "resident", Split(oTable.Cell(2, 2).Range.Text, vbCr)(0)
        d.Add "code", Split(oTable.Cell(2, 3).Range.Text, vbCr)(0)

        txtMeds = Replace(Split(oTable.Cell(3, 1).Range.Text, Chr(7))(0), "Rx: ", "")
        If Right$(txtMeds, 1) = Chr(13) Then txtMeds = Left$(txtMeds, Len(txtMeds) - 1)
        d.Add "meds", txtMeds

        txtHPI = Split(oTable.Cell(3, 2).Range.Text, Chr(7))(0)
        If Right$(txtHPI, 1) = Chr(13) Then txtHPI = Left$(txtHPI, Len(txtHPI) - 1)
        d.Add "hpi", txtHPI

        txtFU = Replace(Split(oTable.Cell(3, 3).Range.Text, Chr(7))(0), "F/U: ", "")
        If Right$(txtFU, 1) = Chr(13) Then txtFU = Left$(txtFU, Len(txtFU) - 1)
        d.Add "fu", Replace(txtFU, ChrW(&H2610) & " ", "")
        
        txtAllergies = Replace(Split(oTable.Cell(4, 1).Range.Text, Chr(7))(0), "Allergies: ", "")
        If Right$(txtAllergies, 1) = Chr(13) Then txtAllergies = Left$(txtAllergies, Len(txtAllergies) - 1)
        d.Add "allergies", txtAllergies

        d.Add "ddx", Replace(Split(oTable.Cell(4, 2).Range.Text, vbCr)(0), "DDx: ", "")

        txtPain = Replace(Split(oTable.Cell(4, 3).Range.Text, Chr(7))(0), "Pain: ", "")
        If Right$(txtPain, 1) = Chr(13) Then txtPain = Left$(txtPain, Len(txtPain) - 1)
        d.Add "pain", txtPain

        txtPPx = Replace(Split(oTable.Cell(5, 1).Range.Text, Chr(7))(0), "PPx: ", "")
        If Right$(txtPPx, 1) = Chr(13) Then txtPPx = Left$(txtPPx, Len(txtPPx) - 1)
        d.Add "ppx", txtPPx

        d.Add "labs", Replace(Split(oTable.Cell(5, 2).Range.Text, vbCr)(0), "- ", "")
        d.Add "imaging", Replace(Split(oTable.Cell(6, 2).Range.Text, vbCr)(0), "- ", "")
        d.Add "procedures", Replace(Split(oTable.Cell(7, 2).Range.Text, vbCr)(0), "- ", "")
    
        chkmks = UBound(Split(oTable.Cell(5, 3).Range.Text, ChrW(&H2611)))
        If chkmks = 2 Then
            d.Add "anticoag", True
            d.Add "insulin", True
        ElseIf chkmks = 1 Then
            chk = Replace(Split(oTable.Cell(5, 3).Range.Text, vbCr)(0), ChrW(&H2611) & " ", "")
            If chk = "Anticoagulated" Then
                d.Add "anticoag", True
                d.Add "insulin", False
            Else
                d.Add "anticoag", False
                d.Add "insulin", True
            End If
        Else
            d.Add "anticoag", False
            d.Add "insulin", False
        End If
        
        d.Add "dispo", Replace(Split(oTable.Cell(oTable.Rows.Count, 1).Range.Text, vbCr)(0), "Dispo: ", "")
        
        'd.Add "timestamp", Split(oTable.Cell(oTable.Rows.Count, 2).Range.Text, vbCr)(0)
        'd.Add "username", "   "
        
        raw = Split(oTable.Cell(oTable.Rows.Count, 2).Range.Text, vbCr)(0)
        dt = Mid(raw, 1, InStr(raw, " (") - 1)
        ini = Mid(raw, InStr(raw, " (") + 2, 3)
        d.Add "timestamp", dt
        d.Add "username", ini

        coll.Add d, bmk
        
    Next i


    ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    ' ADD

    If fx = "ADD" Then
        'MsgBox "ADD"
        bmk = ufAddPatient.cboResident.Text & "_" & ufAddPatient.txtRoom.Text

        Set d = CreateObject("Scripting.Dictionary")
        
        d.Add "bmk", bmk
        d.Add "room", ufAddPatient.txtRoom.Text
        d.Add "first", ufAddPatient.txtFirst.Text
        d.Add "last", ufAddPatient.txtLast.Text
        
        If ufAddPatient.optMale.Value Then
            d.Add "gender", "M"
        Else
            d.Add "gender", "F"
        End If
        
        d.Add "dob", ufAddPatient.txtDOB.Text
        d.Add "admit", ufAddPatient.txtAdmit.Text
        d.Add "resident", ufAddPatient.cboResident.Text
        d.Add "code", ufAddPatient.cboCode.Text
        d.Add "mrn", ufAddPatient.txtMRN.Text
        d.Add "meds", Trim(ufAddPatient.txtMeds.Text)
        d.Add "hpi", ufAddPatient.txtHPI.Text
        d.Add "fu", ufAddPatient.txtFU.Text
        d.Add "allergies", ufAddPatient.txtAllergies.Text
        d.Add "ddx", ufAddPatient.txtDDx.Text
        d.Add "pain", ufAddPatient.txtPain.Text
        d.Add "ppx", ufAddPatient.txtPPx.Text
        d.Add "labs", ufAddPatient.txtLabs.Text
        d.Add "anticoag", ufAddPatient.chkAnticoag.Value
        d.Add "insulin", ufAddPatient.chkInsulin.Value
        d.Add "imaging", ufAddPatient.txtImaging.Text
        d.Add "procedures", ufAddPatient.txtProcedures.Text
        d.Add "dispo", ufAddPatient.txtDispo.Text
        d.Add "timestamp", Now()
        
        usr = Environ$("Username")
        d.Add "username", UCase(Right(usr, 2) & Left(usr, 1))
        

        coll.Add d, bmk
    
        Unload ufAdd
        'Unload ufAddPatient
    End If

    
    ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    ' MODIFY

    If fx = "MOD" Then
        
        n = n + 1

        ufBmk = ufModPatient.cboResident.Text & "_" & ufModPatient.txtRoom.Text

        If coll(modBmk).Item("bmk") = ufBmk Then

            coll(modBmk).Item("bmk") = ufModPatient.cboResident.Text & "_" & ufModPatient.txtRoom.Text
            coll(modBmk).Item("room") = ufModPatient.txtRoom.Text
            coll(modBmk).Item("first") = ufModPatient.txtFirst.Text
            coll(modBmk).Item("last") = ufModPatient.txtLast.Text
            If ufModPatient.optMale.Value Then
                coll(modBmk).Item("gender") = "M"
            Else
                coll(modBmk).Item("gender") = "F"
            End If
            coll(modBmk).Item("dob") = ufModPatient.txtDOB.Text
            coll(modBmk).Item("admit") = ufModPatient.txtAdmit.Text
            coll(modBmk).Item("resident") = ufModPatient.cboResident.Text
            coll(modBmk).Item("code") = ufModPatient.cboCode.Text
            coll(modBmk).Item("mrn") = ufModPatient.txtMRN.Text
            coll(modBmk).Item("meds") = ufModPatient.txtMeds.Text
            coll(modBmk).Item("hpi") = ufModPatient.txtHPI.Text
            coll(modBmk).Item("fu") = ufModPatient.txtFU.Text
            coll(modBmk).Item("allergies") = ufModPatient.txtAllergies.Text
            coll(modBmk).Item("ddx") = ufModPatient.txtDDx.Text
            coll(modBmk).Item("pain") = ufModPatient.txtPain.Text
            coll(modBmk).Item("ppx") = ufModPatient.txtPPx.Text
            coll(modBmk).Item("labs") = ufModPatient.txtLabs.Text
            coll(modBmk).Item("anticoag") = ufModPatient.chkAnticoag.Value
            coll(modBmk).Item("insulin") = ufModPatient.chkInsulin.Value
            coll(modBmk).Item("imaging") = ufModPatient.txtImaging.Text
            coll(modBmk).Item("procedures") = ufModPatient.txtProcedures.Text
            coll(modBmk).Item("dispo") = ufModPatient.txtDispo.Text
            coll(modBmk).Item("timestamp") = vTimestamp
            
            usr = Environ$("Username")
            coll(modBmk).Item("username") = UCase(Right(usr, 2) & Left(usr, 1))

        Else

            coll.Remove modBmk

            Set d = CreateObject("Scripting.Dictionary")
            
            d.Add "bmk", ufBmk
            d.Add "room", ufModPatient.txtRoom.Text
            d.Add "first", ufModPatient.txtFirst.Text
            d.Add "last", ufModPatient.txtLast.Text
            If ufModPatient.optMale.Value Then
                d.Add "gender", "M"
            Else
                d.Add "gender", "F"
            End If
            d.Add "dob", ufModPatient.txtDOB.Text
            d.Add "admit", ufModPatient.txtAdmit.Text
            d.Add "resident", ufModPatient.cboResident.Text
            d.Add "code", ufModPatient.cboCode.Text
            d.Add "mrn", ufModPatient.txtMRN.Text
            d.Add "meds", ufModPatient.txtMeds.Text
            d.Add "hpi", ufModPatient.txtHPI.Text
            d.Add "fu", ufModPatient.txtFU.Text
            d.Add "allergies", ufModPatient.txtAllergies.Text
            d.Add "ddx", ufModPatient.txtDDx.Text
            d.Add "pain", ufModPatient.txtPain.Text
            d.Add "ppx", ufModPatient.txtPPx.Text
            d.Add "labs", ufModPatient.txtLabs.Text
            d.Add "anticoag", ufModPatient.chkAnticoag.Value
            d.Add "insulin", ufModPatient.chkInsulin.Value
            d.Add "imaging", ufModPatient.txtImaging.Text
            d.Add "procedures", ufModPatient.txtProcedures.Text
            d.Add "dispo", ufModPatient.txtDispo.Text
            d.Add "timestamp", vTimestamp

            usr = Environ$("Username")
            d.Add "username", UCase(Right(usr, 2) & Left(usr, 1))

            coll.Add d, ufBmk

        End If

        modBmk = vbNullString
        vTimestamp = vbNullString

        Unload ufMod

    End If

    
    ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    ' DELETE

    If fx = "DEL" Then
        coll.Remove sort
        n = n - 1
    End If

    ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    ' SORT

    If n <> 0 Then
        Dim temp

        If sort = "ROOM" Then
            For i = 1 To coll.Count - 1
                For j = i + 1 To coll.Count
                    
                    If coll(i).Item("room") > coll(j).Item("room") Then
                        Set temp = CreateObject("Scripting.Dictionary")

                        For Each k In coll(j).keys
                            temp.Add k, coll(j)(k)
                        Next

                        For Each k In coll(i).keys
                            coll(j).Item(k) = coll(i)(k)
                        Next
                             
                        For Each k In temp.keys
                            coll(i).Item(k) = temp(k)
                        Next
                        
                    End If
                    
                Next j
            Next i
        
        ElseIf sort = "RESIDENT" Then
    
            For i = 1 To coll.Count - 1
                For j = i + 1 To coll.Count
                
                    If UCase(coll(i).Item("resident")) > UCase(coll(j).Item("resident")) Then
                        Set temp = CreateObject("Scripting.Dictionary")

                        For Each k In coll(j).keys
                            temp.Add k, coll(j)(k)
                        Next

                        For Each k In coll(i).keys
                            coll(j).Item(k) = coll(i)(k)
                        Next
                             
                        For Each k In temp.keys
                            coll(i).Item(k) = temp(k)
                        Next
                    End If
                    
                Next j
            Next i
        
        Else
        
            For i = 1 To coll.Count - 1
                For j = i + 1 To coll.Count
                    
                    If coll(i).Item("room") > coll(j).Item("room") Then
                        Set temp = CreateObject("Scripting.Dictionary")

                        For Each k In coll(j).keys
                            temp.Add k, coll(j)(k)
                        Next

                        For Each k In coll(i).keys
                            coll(j).Item(k) = coll(i)(k)
                        Next
                             
                        For Each k In temp.keys
                            coll(i).Item(k) = temp(k)
                        Next
                        
                    End If
                    
                Next j
            Next i

        End If 'end sort
        
    End If 'end if bmk 0

    ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    ' DRAW


    '''''''''''''''''''''''''''''''''''''''
    ' TURN OFF READ ONLY & SCREEN UPDATING
    
    If oDoc.ProtectionType <> wdNoProtection Then
        oDoc.Unprotect
    End If
    Application.ScreenUpdating = False
    ActiveWindow.DisplayVerticalScrollBar = True


    '''''''''''''''''''''''
    ' DELETE PRIOR ENTRIES
    
    'Dim oBookmark As Bookmark
    'For Each oBookmark In oDoc.Bookmarks
    '    oBookmark.Range.Tables(1).Delete
    'Next
    oDoc.StoryRanges(wdMainTextStory).Delete


    '''''''''''''''''
    ' INSERT ENTRIES

    For Each d In coll

        Set oTable = oDoc.Tables.Add(Range:=Selection.Range, NumRows:=6, NumColumns:=1, DefaultTableBehavior:=wdWord9TableBehavior, AutoFitBehavior:=wdAutoFitFixed)
        
        oTable.Range.Bookmarks.Add d.Item("bmk")
        
        'MsgBox d.Item("bmk")
        
        With oTable
            .Range.Font.Name = "Courier New"
            .Range.Font.Size = 7
            .Range.Paragraphs.LeftIndent = InchesToPoints(0)
            .Range.Paragraphs.RightIndent = InchesToPoints(0)
            .Range.ParagraphFormat.SpaceAfter = 0
            .Range.ParagraphFormat.SpaceBefore = 0
        
            .Borders.InsideLineStyle = wdLineStyleNone
            .Borders.OutsideLineStyle = wdLineStyleNone
            
            .Borders(wdBorderBottom).LineStyle = wdLineStyleSingle
            .Borders(wdBorderBottom).LineWidth = wdLineWidth150pt
            
            .Range.Paragraphs.KeepWithNext = True
            
            
            ''''''''''''''''''''''''''''''''''''''
            ' SET ROW HEIGHT
            
            .Rows.Height = 11
            
            
            ''''''''''''''''''''''''''''''''''''''
            ' SET CELL WIDTH
            
            w = .Rows(1).Cells(1).Width


            ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
            ' ROW 1
            
            .Rows(1).Cells(1).Split 1, 3
            .Rows(1).Cells(1).Width = (w / 10) * 1
            .Rows(1).Cells(2).Width = (w / 10) * 5
            .Rows(1).Cells(3).Width = (w / 10) * 4
            
            
            ''''''''''''''''''''''''''''''''''''''
            ' ROOM, PATIENT NAME, ADMIT DATE
            
            .Rows(1).Cells(1).Range.Text = d.Item("room")
            .Rows(1).Cells(2).Range.Text = d.Item("last") & ", " & d.Item("first") & " " & DateDiff("yyyy", d.Item("dob"), Now()) + Int(Format(Now(), "mmdd") < Format(d.Item("dob"), "mmdd")) & "yo " & d.Item("gender") & " (DOB: " & d.Item("dob") & ")" & " (MRN: " & d.Item("mrn") & ")"
            .Rows(1).Cells(3).Range.Text = "Admit: " & d.Item("admit") & " (" & DateDiff("d", d.Item("admit"), Now) & ")"
            
            .Rows(1).Cells(1).Range.Font.Bold = True
            .Rows(1).Cells(3).Range.ParagraphFormat.Alignment = wdAlignParagraphRight
            
            
            
            ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
            ' ROW 2
            
            .Rows(2).Cells(1).Split 1, 3
            .Rows(2).Cells(1).Width = (w / 10) * 1
            .Rows(2).Cells(2).Width = (w / 10) * 5
            .Rows(2).Cells(3).Width = (w / 10) * 4
            
            
            ''''''''''''''''''''''''''''''''''''''
            ' RESIDENT, CODE STATUS
            
            .Rows(2).Cells(2).Range.Text = d.Item("resident")
            .Rows(2).Cells(3).Range.Text = d.Item("code")
            
            .Rows(2).Cells(3).Range.ParagraphFormat.Alignment = wdAlignParagraphRight
            
            

            ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
            ' ROW 3
            
            .Rows(3).Cells(1).Split 1, 3
            .Rows(3).Cells(1).Width = (w / 10) * 2
            .Rows(3).Cells(2).Width = (w / 10) * 6
            .Rows(3).Cells(3).Width = (w / 10) * 2
            
            ''''''''''''''''''''''''''''''''''''''
            ' MEDICATION, HPI, FOLLOW UP
            
            If d.Item("meds") <> "" Then
                .Rows(3).Cells(1).Range.Text = d.Item("meds")
            Else
                .Rows(3).Cells(1).Range.Text = "Rx: "
            End If
            .Rows(3).Cells(2).Range.Text = d.Item("hpi")

            If d.Item("fu") <> "" Then
                arr = Split(d.Item("fu"), vbCr)
                Dim sArr() As String
                ReDim sArr(UBound(arr))
                For x = 0 To UBound(arr)
                    fuS = Trim(Replace(arr(x), vbLf, ""))
                    If fuS = "" Then
                        sArr(x) = ""
                    Else
                        sArr(x) = ChrW(&H2610) & " " & Trim(Replace(arr(x), vbLf, ""))
                    End If
                    
                Next x
                .Rows(3).Cells(3).Range.Text = Join(sArr, vbCrLf)
            Else
                .Rows(3).Cells(3).Range.Text = "F/U: "
            End If
            '.Rows(3).Cells(3).Range.Text = "F/U: " & d.Item("fu")
            
            
            
            ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
            ' ROW 4
                
            .Rows(4).Cells(1).Split 1, 3
            .Rows(4).Cells(1).Width = (w / 10) * 2
            .Rows(4).Cells(2).Width = (w / 10) * 6
            .Rows(4).Cells(3).Width = (w / 10) * 2

            If d.Item("allergies") <> "" Then
                .Rows(4).Cells(1).VerticalAlignment = wdCellAlignVerticalCenter
                .Rows(4).Cells(1).Range.Text = "Allergies: " & d.Item("allergies")
            Else
                .Rows(4).Cells(1).Range.Text = ""
            End If

            .Rows(4).Cells(2).Height = 14
            .Rows(4).Cells(2).VerticalAlignment = wdCellAlignVerticalCenter
            .Rows(4).Cells(2).Range.Text = "DDx: " & d.Item("ddx")

            If d.Item("pain") <> "" Then
                .Rows(4).Cells(3).VerticalAlignment = wdCellAlignVerticalCenter
                .Rows(4).Cells(3).Range.Text = "Pain: " & d.Item("pain")
            Else
                .Rows(4).Cells(3).Range.Text = ""
            End If
            
            
            
            
            ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
            ' ROW 5
            
            .Rows(5).Cells(1).Split 1, 3
            .Rows(5).Cells(1).Width = (w / 10) * 2
            .Rows(5).Cells(2).Width = (w / 10) * 6
            .Rows(5).Cells(3).Width = (w / 10) * 2
            
            
            
            .Rows(5).Cells(2).Split 3, 1

            If d.Item("labs") <> "" Then
                .Range.Cells(14).Height = 14
                .Range.Cells(14).VerticalAlignment = wdCellAlignVerticalCenter
                .Range.Cells(14).Range.Text = "- " & d.Item("labs")
            Else
                .Range.Cells(14).Height = 0
                .Range.Cells(14).Range.Text = ""
            End If

            If d.Item("imaging") <> "" Then
                .Range.Cells(16).Height = 14
                .Range.Cells(16).VerticalAlignment = wdCellAlignVerticalCenter
                .Range.Cells(16).Range.Text = "- " & d.Item("imaging")
            Else
                .Range.Cells(16).Height = 0
                .Range.Cells(16).Range.Text = ""
            End If

            If d.Item("procedures") <> "" Then
                .Range.Cells(17).Height = 14
                .Range.Cells(17).VerticalAlignment = wdCellAlignVerticalCenter
                .Range.Cells(17).Range.Text = "- " & d.Item("procedures")
            Else
                .Range.Cells(17).Height = 0
                .Range.Cells(17).Range.Text = ""
            End If



'            If d.Item("labs") = "" And d.Item("imaging") = "" And d.Item("procedures") = "" Then
'
'            ElseIf d.Item("labs") = "" And d.Item("imaging") = "" Then
'                .Rows(5).Cells(2).Split 1, 1
'                .Range.Cells(14).Range.Text = "Procedures: " & d.Item("procedures")
'
'            ElseIf d.Item("imaging") = "" And d.Item("procedures") = "" Then
'                .Rows(5).Cells(2).Split 1, 1
'                .Range.Cells(14).Range.Text = "Labs: " & d.Item("labs")
'
'                MsgBox d.Item("labs"), vbOKOnly, "INSERT LABS " & d.Item("room")
'
'            ElseIf d.Item("labs") = "" And d.Item("procedures") = "" Then
'                .Rows(5).Cells(2).Split 1, 1
'                .Range.Cells(14).Range.Text = "Imaging: " & d.Item("imaging")
'
'            ElseIf d.Item("labs") = "" Then
'                .Rows(5).Cells(2).Split 2, 1
'                .Range.Cells(14).Range.Text = "Imaging: " & d.Item("imaging")
'                .Range.Cells(16).Range.Text = "Procedures: " & d.Item("procedures")
'
'            ElseIf d.Item("imaging") = "" Then
'                .Rows(5).Cells(2).Split 2, 1
'                .Range.Cells(14).Range.Text = "Labs: " & d.Item("labs")
'                .Range.Cells(16).Range.Text = "Procedures: " & d.Item("procedures")
'
'            ElseIf d.Item("procedures") = "" Then
'                .Rows(5).Cells(2).Split 2, 1
'                .Range.Cells(14).Range.Text = "Labs: " & d.Item("labs")
'                .Range.Cells(16).Range.Text = "Imaging: " & d.Item("imaging")
'
'            Else
'                .Rows(5).Cells(2).Split 3, 1
'                .Range.Cells(14).Range.Text = "Labs: " & d.Item("labs")
'                .Range.Cells(16).Range.Text = "Imaging: " & d.Item("imaging")
'                .Range.Cells(17).Range.Text = "Procedures: " & d.Item("procedures")
'            End If
            
            
            If d.Item("ppx") <> "" Then
                .Range.Cells(13).Range.Text = "PPx: " & d.Item("ppx")
            Else
                .Range.Cells(13).Range.Text = ""
            End If
            
            If d.Item("anticoag") And d.Item("insulin") Then
                .Range.Cells(15).Range.Text = ChrW(&H2611) & " Anticoagulated" & vbCrLf & ChrW(&H2611) & " Insulin"
            ElseIf d.Item("anticoag") Then
                .Range.Cells(15).Range.Text = ChrW(&H2611) & " Anticoagulated"
            ElseIf d.Item("insulin") Then
                .Range.Cells(15).Range.Text = ChrW(&H2611) & " Insulin"
            End If
            
            
            
            ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
            ' ROW 6
            
            tCell = .Range.Cells.Count
            
            .Range.Cells(tCell).Height = 16
            .Range.Cells(tCell).Split 1, 2
            .Range.Cells(tCell).Width = (w / 10) * 7
            .Range.Cells(tCell + 1).Width = (w / 10) * 3
            
            .Range.Cells(tCell).Range.Text = "Dispo: " & d.Item("dispo")
            
            .Range.Cells(tCell + 1).Range.ParagraphFormat.Alignment = wdAlignParagraphRight
            
            .Range.Cells(tCell + 1).Range.Text = d.Item("timestamp") & " (" & d.Item("username") & ")"
            
            
            ''''''''''''''''''''''''''''''''''''''
            ' SPACING
            
            '.Range.Cells(tCell + 1).Select
            'Selection.MoveDown Unit:=wdLine, Count:=1
            'Selection.InsertParagraph
            'Selection.EndKey Unit:=wdStory
            With Selection
                .MoveDown Unit:=wdLine, Count:=1
                .EndKey Unit:=wdStory
                .Collapse Direction:=wdCollapseStart
                .InsertParagraph
                .Collapse Direction:=wdCollapseEnd
                .EndKey Unit:=wdStory
            End With
            
        End With
    Next d
    Set coll = Nothing

    ActiveDocument.Sections(1).PageSetup.DifferentFirstPageHeaderFooter = True
    docHeader = ActiveDocument.Sections(1).Headers(wdHeaderFooterFirstPage)
    oldHeader = docHeader.Tables(1).Delete

    Set headerTable = ActiveDocument.Tables.Add(Range:=docHeader, NumRows:=1, NumColumns:=1, DefaultTableBehavior:=wdWord9TableBehavior, AutoFitBehavior:=wdAutoFitFixed)
    With headerTable
    
        '.Rows.Height = 14
        
        .Borders.InsideLineStyle = wdLineStyleNone
        .Borders.OutsideLineStyle = wdLineStyleNone

        w = .Rows(1).Cells(1).Width
        .Rows(1).Cells(1).Split 1, 2
        .Rows(1).Cells(1).Width = (w / 10) * 8
        .Rows(1).Cells(2).Width = (w / 10) * 2

        .Rows(1).Cells(1).Range.ParagraphFormat.Alignment = wdAlignParagraphLeft
        .Rows(1).Cells(2).Range.ParagraphFormat.Alignment = wdAlignParagraphRight

        .Rows(1).Cells(1).Range.Text = "Total (" & n & "), " & residentTotals()
        .Rows(1).Cells(2).Range.Text = Format(Now, "dddd, mmmm d, yyyy")
    End With
    ActiveDocument.Sections(1).Headers(wdHeaderFooterPrimary).Range.Text = Format(Now, "dddd, mmmm d, yyyy")

    ''''''''''''''''''''
    ' TURN ON READ ONLY

    Selection.HomeKey Unit:=wdStory
    oDoc.Protect wdAllowOnlyReading
    SaveToRelativePath
    Call StartClock
    
Done:
    Exit Sub
    
eh:
    pathName = ActiveDocument.FullName
    onlyName = Mid(pathName, InStrRev(pathName, "\") + 1, InStrRev(pathName, "--") - InStrRev(pathName, "\") - 1)
    ext = Right(pathName, Len(pathName) - InStrRev(pathName, "."))
    compName = Mid(pathName, InStrRev(pathName, "\") + 1, InStrRev(pathName, ".") - InStrRev(pathName, "\") - 1)
    fileDate = Right(compName, Len(compName) - InStrRev(compName, "--") - 1)
    
    rPath = ThisDocument.Path & "\" & onlyName & "--" & fileDate & "." & ext
    aPath = ThisDocument.Path & "\ARCHIVE\BACKUP\" & onlyName & "--" & fileDate & "." & ext
    
    Dim fso As Object
    Set fso = VBA.CreateObject("Scripting.FileSystemObject")
    Call fso.CopyFile(rPath, aPath)
    
    MsgBox "Error " & Err.Number & ": " & Err.Description
    Debug.Print "Error " & Err.Number & ": " & Err.Description
    
    procName = Application.VBE.ActiveCodePane.CodeModule.ProcOfLine(Application.VBE.ActiveCodePane.TopLine, 0)
    Debug.Print "Error " & Err.Number & ": " & Err.Description & " in module " & VBE.ActiveCodePane.CodeModule & " sub " & procName & "()"
    MsgBox "Error " & Err.Number & ": " & Err.Description & " in module " & VBE.ActiveCodePane.CodeModule & ", sub " & procName & "()", vbOKOnly, "Error"
    
    
End Sub
Public Function residentTotals()
    Dim n As Integer
    n = ActiveDocument.Bookmarks.Count
    Dim bmkArray()
    ReDim bmkArray(1 To n)

    For i = 1 To n
        nameSplit = Split(ActiveDocument.Bookmarks(i).Name, "_")
        bmkArray(i) = nameSplit(0)
    Next

    Dim arr As New Collection, a
    On Error Resume Next
    For Each a In bmkArray
        arr.Add a, a
    Next

    Dim resTotals()
    ReDim resTotals(1 To arr.Count)
    For j = 1 To arr.Count
        cnt = UBound(Filter(bmkArray, arr(j), True, 1)) + 1
        resTotals(j) = arr(j) & " (" & cnt & ")"
    Next

    residentTotals = Join(resTotals, ", ")
End Function

modMerge.vba

Sub MergeDocs()
    Dim rng As Range
    Dim MainDoc As Document
    Dim strFile As String, strFolder As String
    
    
    With Application.FileDialog(msoFileDialogFilePicker)
        .InitialFileName = ActiveDocument.Path & "\"
        .Title = "Pick files to merge."
        .AllowMultiSelect = False
        If .Show Then
            strFolder = .SelectedItems(1) & Application.PathSeparator
        Else
            Exit Sub
        End If
    End With
    
    'Set MainDoc = Documents.Add
    'strFile = Dir$(strFolder & "*.doc") ' can change to .docx
    'Do Until strFile = ""
    '    Set rng = MainDoc.Range
    '    rng.Collapse wdCollapseEnd
    '    rng.InsertFile strFolder & strFile
    '    strFile = Dir$()
    'Loop
    'MsgBox ("Files are merged")
    
lbl_Exit:
    Exit Sub
End Sub

modSave.vba

Sub SaveToRelativePath()
    Dim rPath As String
    Dim aPath As String
    
    'epoch = DateDiff("S", "1/1/1970", Now())
    dateNow = Format(Now(), "yyyy-MM-dd")
    
    
    pathName = ActiveDocument.FullName
    
    
    onlyName = Mid(pathName, InStrRev(pathName, "\") + 1, InStrRev(pathName, "--") - InStrRev(pathName, "\") - 1)
    ext = Right(pathName, Len(pathName) - InStrRev(pathName, "."))
    
    
    compName = Mid(pathName, InStrRev(pathName, "\") + 1, InStrRev(pathName, ".") - InStrRev(pathName, "\") - 1)
    fileDate = Right(compName, Len(compName) - InStrRev(compName, "--") - 1)
    
    
    If InStr(pathName, "ARCHIVE") = 0 Then
        
        If fileDate = dateNow Then
            rPath = ThisDocument.Path & "\" & onlyName & "--" & dateNow & "." & ext
            aPath = ThisDocument.Path & "\ARCHIVE\" & onlyName & "--" & dateNow & "." & ext
            ActiveDocument.SaveAs FileName:=aPath
            ActiveDocument.SaveAs FileName:=rPath
        Else
            secNow = Format(Now(), "hhmmss")
            rPath = ThisDocument.Path & "\" & onlyName & "--" & dateNow & "." & ext
            aPath = ThisDocument.Path & "\ARCHIVE\" & onlyName & "--" & dateNow & "-" & secNow & "." & ext
            delPath = ThisDocument.Path & "\" & onlyName & "--" & fileDate & "." & ext
            
            ActiveDocument.SaveAs FileName:=aPath
            ActiveDocument.SaveAs FileName:=rPath
            
            If FileExists(aPath) And FileExists(rPath) Then
                If FileExists(delPath) Then
                    SetAttr delPath, vbNormal
                    Kill delPath
                End If
            End If
            
        End If
        
    End If
    

    
    
    
    'compName = Mid(pathName, InStrRev(pathName, "\") + 1, InStrRev(pathName, ".") - InStrRev(pathName, "\") - 1)
    'fileDate = Right(compName, Len(compName) - InStrRev(compName, "--") - 1)
    
    'If fileDate = dateNow Then
        
        'MsgBox "Same Date"
        'Application.DisplayAlerts = False
        
    '    rPath = ThisDocument.Path & "\" & onlyName & "--" & dateNow & "." & ext
    '    ActiveDocument.SaveAs FileName:=rPath
        
        'Application.DisplayAlerts = True
        
    'Else
        
        'MsgBox "Different Date"
    '    rPath = ThisDocument.Path & "\" & onlyName & "--" & dateNow & "." & ext
    '    ActiveDocument.SaveAs FileName:=rPath
        
    'End If
    
End Sub
Function FileExists(ByVal FileToTest As String) As Boolean
   FileExists = (Dir(FileToTest) <> "")
End Function

ThisDocument.vba

Public Sub AutoOpen()
    'ThisDocument.Application.ActiveWindow.View.Zoom.PageColumns = 1
    'ThisDocument.Application.ActiveWindow.View.Zoom.Percentage = 100
    ThisDocument.Application.ActiveWindow.View.Type = wdPrintView
    ThisDocument.Application.ActiveWindow.View.Zoom.PageFit = wdPageFitBestFit
    
    ThisDocument.Application.Caption = "SIGNOUT"
    'ThisDocument.Application.ActiveWindow.Caption = "SIGNOUT"
    
    With ActiveDocument.Styles(wdStyleNormal).Font
        .Size = 1
    End With
    ActiveDocument.ActiveWindow.View.ReadingLayout = False
    'MsgBox ThisDocument.Application.UsableWidth
    SaveToRelativePath
    Call StartClock
End Sub
Sub RunFormAddPatient()
    Call StopClock
    Set ufAdd = New ufAddPatient
    ufAdd.Show vbModeless
    Call StartClock
End Sub
Sub RunFormSelectPatient()
    Call StopClock
    Dim frm As New ufSelectPatient
    frm.Show
    Call StartClock
End Sub
Sub RunFormDeletePatient()
    Call StopClock
    Dim frm As New ufDeletePatient
    frm.Show
    Call StartClock
End Sub
Sub sortNumbers()
    Call StopClock
    Call main("", "ROOM")
    Call StartClock
End Sub
Sub sortNames()
    Call StopClock
    Call main("", "RESIDENT")
    Call StartClock
End Sub
Sub ShowPrintDialog()
    Dialogs(wdDialogFilePrint).Show
End Sub
Sub resetZoom()
    ActiveDocument.ActiveWindow.View.Zoom.Percentage = 100
End Sub
Sub fitZoom()
    ActiveDocument.ActiveWindow.View.Zoom.PageFit = wdPageFitBestFit
End Sub
Sub whatPath()
    MsgBox ActiveDocument.FullName
End Sub
Private Sub Document_Close()
    Call StopClock
    ActiveDocument.Save
    Me.Saved = True
End Sub

ufAddPatient.vba

Private Sub UserForm_Initialize()

    'Me.txtRoom.Value = "1234"
    'Me.txtFirst.Value = "First"
    'Me.txtLast.Value = "Last"
    'Me.txtDOB.Value = "12/25/2017"
    'Me.cboCode.Value = "Full Code"
    'Me.txtMRN.Value = "123456"
    'Me.cboResident.Value = "PGuilford"
    'Me.txtMeds.Value = "meds"
    'Me.txtHPI.Value = "Lorem ipsum dolor sit amet, consectetur adipiscing elit, sed do eiusmod tempor incididunt ut labore et dolore magna aliqua. Ut enim ad minim veniam, quis nostrud exercitation ullamco laboris nisi ut aliquip ex ea commodo consequat. Duis aute irure dolor in reprehenderit in voluptate velit esse cillum dolore eu fugiat nulla pariatur. Excepteur sint occaecat cupidatat non proident, sunt in culpa qui officia deserunt mollit anim id est laborum."
    'Me.txtFU.Value = "f/u this"

    Me.txtAdmit.Value = Format(Date, "mm/dd/yyyy")
    
    Me.cboCode.List = codeArray()

    Me.cboResident.List = residentArray()
    

End Sub
Private Sub cmdCommit_Click()
    
    ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    ' ROOM
    
    If Len(txtRoom) <> 4 Then
        MsgBox "A four-digit room number is required.", vbOKOnly, "Room Error"
        txtRoom.SetFocus
        Exit Sub
    ElseIf IsNumeric(txtRoom) = False Then
        MsgBox "Your room number contains alpha characters.", vbOKOnly, "Room Error"
        txtRoom.SetFocus
        Exit Sub
    End If
    
    ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    ' NAME
    
    If Len(txtLast) = 0 Or Len(txtFirst) = 0 Then
        MsgBox "Both first and last names are required.", vbOKOnly, "Name Error"
        If Len(txtLast) = 0 Then
            txtLast.SetFocus
        Else
            txtFirst.SetFocus
        End If
        Exit Sub
    End If
    
    
    ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    ' DATE OF BIRTH
    
    If IsDate(txtDOB) Then
        
        If Not dateCheckDOB(txtDOB) Then
            MsgBox "Please enter date as MM/DD/YYYY.", vbOKOnly, "DOB Error"
            txtDOB.SetFocus
            Exit Sub
        Else
            'MsgBox "This is a date.", vbOKOnly, "DOB Error"
        End If
        
    Else
    
        If Len(txtDOB) = 0 Then
            MsgBox "Date of Birth is required.", vbOKOnly, "DOB Error"
        Else
            MsgBox "Please check date of birth.", vbOKOnly, "DOB Error"
        End If
        
        txtDOB.SetFocus
        Exit Sub
        
    End If


    ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    ' GENDER
    
    If optMale = False And optFemale = False Then
        MsgBox "Please select gender.", vbOKOnly, "Gender Error"
        optMale.SetFocus
        Exit Sub
    End If


    ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    ' ADMIT DATE
    
    If IsDate(txtAdmit) Then
        
        If Not dateCheckAdmit(txtAdmit) Then
            MsgBox "Please enter date as MM/DD/YYYY.", vbOKOnly, "Admission Date Error"
            txtAdmit.SetFocus
            Exit Sub
        End If
        
    Else
    
        If Len(txtAdmit) = 0 Then
            MsgBox "Admission date is required.", vbOKOnly, "Admission Date Error"
        Else
            MsgBox "Please check admission date.", vbOKOnly, "Admission Date Error"
        End If
        
        txtAdmit.SetFocus
        Exit Sub
        
    End If

    ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    ' CODE STATUS
    
    If Len(cboCode) = 0 Then
        MsgBox "Please select a code status.", vbOKOnly, "Code Status Error"
        cboCode.SetFocus
        Exit Sub
    End If
    
    
    ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    ' MRN
    If Len(txtMRN) <> 6 Then
        MsgBox "MRN is six digits.", vbOKOnly, "MRN Error"
        txtMRN.SetFocus
        Exit Sub
    End If
    
    
    ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    ' RESIDENT
    
    If Len(cboResident) = 0 Then
        MsgBox "Please select a resident.", vbOKOnly, "Resident Error"
        cboResident.SetFocus
        Exit Sub
    End If
    
    
    ufAddPatient.txtRoom.Text = Me.txtRoom.Value
    ufAddPatient.txtFirst.Text = StrConv(Me.txtFirst.Value, vbProperCase)
    ufAddPatient.txtLast.Text = StrConv(Me.txtLast.Value, vbProperCase)
    ufAddPatient.txtDOB.Text = Me.txtDOB.Value
    ufAddPatient.optMale.Value = Me.optMale.Value
    ufAddPatient.optFemale.Value = Me.optFemale.Value
    ufAddPatient.txtAdmit.Text = Me.txtAdmit.Value
    ufAddPatient.cboCode.Value = Me.cboCode.Value
    ufAddPatient.txtMRN.Value = Me.txtMRN.Value
    ufAddPatient.txtMeds.Text = Me.txtMeds.Value
    ufAddPatient.txtHPI.Text = Me.txtHPI.Value
    ufAddPatient.txtFU.Text = Me.txtFU.Value
    ufAddPatient.txtAllergies.Text = Me.txtAllergies.Value
    ufAddPatient.txtPPx.Text = Me.txtPPx.Value
    ufAddPatient.txtDDx.Text = Me.txtDDx.Value
    ufAddPatient.txtPain.Text = Me.txtPain.Value
    ufAddPatient.txtLabs.Text = Me.txtLabs.Value
    ufAddPatient.txtImaging.Text = Me.txtImaging.Value
    ufAddPatient.txtProcedures.Text = Me.txtProcedures.Value
    ufAddPatient.chkAnticoag.Value = Me.chkAnticoag.Value
    ufAddPatient.chkInsulin.Value = Me.chkInsulin.Value
    ufAddPatient.cboResident.Value = Me.cboResident.Value
    ufAddPatient.txtDispo.Text = Me.txtDispo.Value
    
    If Me.chkTime.Value = True Then
        vTimestamp = Now()
    Else
        vTimestamp = dict.Item("timestamp")
    End If
    
    ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    ' CHECK IF ROOM EXISTS
    
    Dim n As Integer
    n = ActiveDocument.Bookmarks.Count
    
    If n <> 0 Then
        Dim roomArray()
        ReDim roomArray(1 To n)
   
        For i = 1 To n
            roomArray(i) = Split(ActiveDocument.Bookmarks(i).Name, "_")(1)
        Next
    
        d = "#"
        s = Join(roomArray, d)
        s = d & s & d
        
        If InStr(1, s, d & ufAddPatient.txtRoom.Text & d, vbBinaryCompare) Then
            MsgBox "Room " & Me.txtRoom.Value & " is already on census.", vbOKOnly, "Room Number Exists"
            txtRoom.SetFocus
            Exit Sub
        End If

    End If
    
    'Me.Hide
    ufAdd.Hide
    Call main("ADD", "ROOM")

End Sub
Private Sub cmdCancel_Click()
    Unload Me
    End
End Sub
Function dateCheckDOB(dateValueDOB As String) As Boolean
    If Format(CDate(txtDOB), "mm/dd/yyyy") = dateValueDOB Or _
            Format(CDate(txtDOB), "m/d/yyyy") = dateValueDOB Or _
            Format(CDate(txtDOB), "mm/d/yyyy") = dateValueDOB Or _
            Format(CDate(txtDOB), "m/dd/yyyy") = dateValueDOB Then
            
        dateCheckDOB = True
    End If
End Function
Function dateCheckAdmit(dateValueAdmit As String) As Boolean
    If Format(CDate(txtAdmit), "mm/dd/yyyy") = dateValueAdmit Or _
            Format(CDate(txtAdmit), "m/d/yyyy") = dateValueAdmit Or _
            Format(CDate(txtAdmit), "mm/d/yyyy") = dateValueAdmit Or _
            Format(CDate(txtAdmit), "m/dd/yyyy") = dateValueAdmit Then
        
        dateCheckAdmit = True
    End If
End Function

ufDeletePatient.vba

Private Sub UserForm_Initialize()
    Dim n As Integer
    n = ActiveDocument.Bookmarks.Count
    
    Dim bmkArray()
    ReDim bmkArray(1 To n)
   
    For i = 1 To n
        nameSplit = Split(ActiveDocument.Bookmarks(i).Name, "_")
        bmkArray(i) = nameSplit(1) & vbTab & vbTab & nameSplit(0)
    Next
    
    x = LBound(bmkArray)
    y = UBound(bmkArray)
    For i = x To y - 1
        For j = i + 1 To y
            If bmkArray(i) > bmkArray(j) Then
                temp = bmkArray(i)
                bmkArray(i) = bmkArray(j)
                bmkArray(j) = temp
            End If
        Next j
    Next i
    
    listPts.List = bmkArray
End Sub
Private Sub cmdSelect_Click()
    usrSel = Split(Me.listPts.Value, vbTab & vbTab)
    usrSelection = usrSel(1) & "_" & usrSel(0)
    
    strPrompt = "Remove " & usrSel(0) & " from census?"
    strTitle = "Delete"
        
    If MsgBox(strPrompt, vbYesNo, strTitle) = vbNo Then
        listPts.SetFocus
        Exit Sub
    End If
    
    Me.Hide
    Call main("DEL", usrSelection)
End Sub

ufModPatient.vba

Private Sub UserForm_Initialize()
    
    Me.txtRoom.Value = dict.Item("room")
    Me.txtFirst.Value = dict.Item("first")
    Me.txtLast.Value = dict.Item("last")
    Me.txtDOB.Value = dict.Item("dob")
    
    If dict.Item("gender") = "M" Then
        Me.optMale.Value = True
    Else
        Me.optFemale.Value = True
    End If
    
    Me.txtAdmit.Value = dict.Item("admit")
    Me.cboCode.Value = dict.Item("code")
    Me.txtMRN.Value = dict.Item("mrn")
    Me.txtMeds.Value = dict.Item("meds")
    Me.txtHPI.Value = dict.Item("hpi")
    Me.txtFU.Value = dict.Item("fu")
    Me.txtAllergies.Value = dict.Item("allergies")
    Me.txtDDx.Value = dict.Item("ddx")
    Me.txtPain.Value = dict.Item("pain")
    Me.txtLabs.Value = dict.Item("labs")
    Me.txtImaging.Value = dict.Item("imaging")
    Me.txtProcedures.Value = dict.Item("procedures")
    Me.txtDispo.Value = dict.Item("dispo")
    Me.txtPPx.Value = dict.Item("ppx")
    Me.cboResident.Value = dict.Item("resident")
    Me.chkAnticoag.Value = dict.Item("anticoag")
    Me.chkInsulin.Value = dict.Item("insulin")
    
    Me.cboCode.List = codeArray()

    Me.cboResident.List = residentArray()
    
End Sub
Private Sub cmdCommit_Click()
    
    ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    ' ROOM
    
    If Len(txtRoom) <> 4 Then
        MsgBox "A four-digit room number is required.", vbOKOnly, "Room Error"
        txtRoom.SetFocus
        Exit Sub
    ElseIf IsNumeric(txtRoom) = False Then
        MsgBox "Your room number contains alpha characters.", vbOKOnly, "Room Error"
        txtRoom.SetFocus
        Exit Sub
    End If
    
    ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    ' NAME
    
    If Len(txtLast) = 0 Or Len(txtFirst) = 0 Then
        MsgBox "Both first and last names are required.", vbOKOnly, "Name Error"
        If Len(txtLast) = 0 Then
            txtLast.SetFocus
        Else
            txtFirst.SetFocus
        End If
        Exit Sub
    End If
    
    
    ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    ' DATE OF BIRTH
    
    If IsDate(txtDOB) Then
        
        If Not dateCheckDOB(txtDOB) Then
            MsgBox "Please enter date as MM/DD/YYYY.", vbOKOnly, "DOB Error"
            txtDOB.SetFocus
            Exit Sub
        Else
            'MsgBox "This is a date.", vbOKOnly, "DOB Error"
        End If
        
    Else
    
        If Len(txtDOB) = 0 Then
            MsgBox "Date of Birth is required.", vbOKOnly, "DOB Error"
        Else
            MsgBox "Please check date of birth.", vbOKOnly, "DOB Error"
        End If
        
        txtDOB.SetFocus
        Exit Sub
        
    End If


    ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    ' GENDER
    
    If optMale = False And optFemale = False Then
        MsgBox "Please select gender.", vbOKOnly, "Gender Error"
        optMale.SetFocus
        Exit Sub
    End If


    ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    ' ADMIT DATE
    
    If IsDate(txtAdmit) Then
        
        If Not dateCheckAdmit(txtAdmit) Then
            MsgBox "Please enter date as MM/DD/YYYY.", vbOKOnly, "Admission Date Error"
            txtAdmit.SetFocus
            Exit Sub
        End If
        
    Else
    
        If Len(txtAdmit) = 0 Then
            MsgBox "Admission date is required.", vbOKOnly, "Admission Date Error"
        Else
            MsgBox "Please check admission date.", vbOKOnly, "Admission Date Error"
        End If
        
        txtAdmit.SetFocus
        Exit Sub
        
    End If

    ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    ' CODE STATUS
    
    If Len(cboCode) = 0 Then
        MsgBox "Please select a code status.", vbOKOnly, "Code Status Error"
        cboCode.SetFocus
        Exit Sub
    End If
    
    ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    ' MRN
    If Len(txtMRN) <> 6 Then
        MsgBox "MRN is six digits.", vbOKOnly, "MRN Error"
        txtMRN.SetFocus
        Exit Sub
    End If
    
    ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    ' RESIDENT
    
    If Len(cboResident) = 0 Then
        MsgBox "Please select a resident.", vbOKOnly, "Resident Error"
        cboResident.SetFocus
        Exit Sub
    End If
    
    
    ufModPatient.txtRoom.Text = Me.txtRoom.Value
    ufModPatient.txtFirst.Text = Me.txtFirst.Value
    ufModPatient.txtLast.Text = Me.txtLast.Value
    ufModPatient.txtDOB.Text = Me.txtDOB.Value
    ufModPatient.optMale.Value = Me.optMale.Value
    ufModPatient.optFemale.Value = Me.optFemale.Value
    ufModPatient.txtAdmit.Text = Me.txtAdmit.Value
    ufModPatient.cboCode.Value = Me.cboCode.Value
    ufModPatient.txtMRN.Value = Me.txtMRN.Value
    ufModPatient.txtMeds.Text = Me.txtMeds.Value
    ufModPatient.txtHPI.Text = Me.txtHPI.Value
    ufModPatient.txtFU.Text = Me.txtFU.Value
    ufModPatient.txtAllergies.Text = Me.txtAllergies.Value
    ufModPatient.txtPPx.Text = Me.txtPPx.Value
    ufModPatient.txtDDx.Text = Me.txtDDx.Value
    ufModPatient.txtPain.Text = Me.txtPain.Value
    ufModPatient.txtLabs.Text = Me.txtLabs.Value
    ufModPatient.txtImaging.Text = Me.txtImaging.Value
    ufModPatient.txtProcedures.Text = Me.txtProcedures.Value
    ufModPatient.chkAnticoag.Value = Me.chkAnticoag.Value
    ufModPatient.chkInsulin.Value = Me.chkInsulin.Value
    ufModPatient.cboResident.Value = Me.cboResident.Value
    ufModPatient.txtDispo.Text = Me.txtDispo.Value
    
    If Me.chkTime.Value = True Then
        vTimestamp = Now()
    Else
        vTimestamp = dict.Item("timestamp")
    End If
    

    
    If ufModPatient.txtRoom.Text <> dict.Item("room") Then
        
        strPrompt = "Change room number?"
        strTitle = "Room Number Check"
        userResponse = MsgBox(strPrompt, vbYesNo, strTitle)
        
        If userResponse = vbNo Then
            txtRoom.SetFocus
            Exit Sub
        Else
            Dim n As Integer
            n = ActiveDocument.Bookmarks.Count
    
            Dim roomArray()
            ReDim roomArray(1 To n)
   
            For i = 1 To n
                roomArray(i) = Split(ActiveDocument.Bookmarks(i).Name, "_")(1)
            Next
    
            d = "#"
            s = Join(roomArray, d)
            s = d & s
    
            If InStr(1, s, d & ufAddPatient.txtRoom.Text & d, vbBinaryCompare) Then
                'MsgBox "Room number is already on cencus.", vbOKOnly, "Room Number Exists"
                MsgBox "Room " & Me.txtRoom.Value & " is already on census.", vbOKOnly, "Room Number Exists"
                txtRoom.SetFocus
                Exit Sub
            End If
        End If

    End If
    
    If ufModPatient.cboResident.Value <> dict.Item("resident") Then
    
        strPrompt = "Change resident assignment?"
        strTitle = "Resident"
        
        If MsgBox(strPrompt, vbYesNo, strTitle) = vbNo Then
            cboResident.SetFocus
            Exit Sub
        End If
        
    End If
    
    ufMod.Hide
    Call main("MOD", "ROOM")
    dict.RemoveAll

End Sub
Private Sub cmdCancel_Click()
    Unload Me
    End
End Sub
Function dateCheckDOB(dateValueDOB As String) As Boolean
    If Format(CDate(txtDOB), "mm/dd/yyyy") = dateValueDOB Or _
            Format(CDate(txtDOB), "m/d/yyyy") = dateValueDOB Or _
            Format(CDate(txtDOB), "mm/d/yyyy") = dateValueDOB Or _
            Format(CDate(txtDOB), "m/dd/yyyy") = dateValueDOB Then
            
        dateCheckDOB = True
    End If
End Function
Function dateCheckAdmit(dateValueAdmit As String) As Boolean
    If Format(CDate(txtAdmit), "mm/dd/yyyy") = dateValueAdmit Or _
            Format(CDate(txtAdmit), "m/d/yyyy") = dateValueAdmit Or _
            Format(CDate(txtAdmit), "mm/d/yyyy") = dateValueAdmit Or _
            Format(CDate(txtAdmit), "m/dd/yyyy") = dateValueAdmit Then
        
        dateCheckAdmit = True
    End If
End Function

ufSelectPatient.vba

Private Sub UserForm_Initialize()
    Dim n As Integer
    n = ActiveDocument.Bookmarks.Count
    
    Dim bmkArray()
    ReDim bmkArray(1 To n)
   
    For i = 1 To n
        nameSplit = Split(ActiveDocument.Bookmarks(i).Name, "_")
        bmkArray(i) = nameSplit(1) & vbTab & vbTab & nameSplit(0)
    Next
    
    x = LBound(bmkArray)
    y = UBound(bmkArray)
    For i = x To y - 1
        For j = i + 1 To y
            If bmkArray(i) > bmkArray(j) Then
                temp = bmkArray(i)
                bmkArray(i) = bmkArray(j)
                bmkArray(j) = temp
            End If
        Next j
    Next i
    
    listPts.List = bmkArray
End Sub
Private Sub cmdSelect_Click()
    
    usrSel = Split(Me.listPts.Value, vbTab & vbTab)
    usrSelection = usrSel(1) & "_" & usrSel(0)
    Me.Hide
    tblDict (usrSelection)
    
    Set ufMod = New ufModPatient
    ufMod.Show vbModeless
    
End Sub
Sub tblDict(usrSel As String)
    
    modBmk = usrSel
    
    Set oTable = ActiveDocument.Bookmarks(usrSel).Range.Tables(1)
    Set dict = CreateObject("Scripting.Dictionary")
    
    dict.Add "room", Split(oTable.Cell(1, 1).Range.Text, vbCr)(0)
    
    
    nameDOB = Split(oTable.Cell(1, 2).Range.Text, vbCr)(0)

    yo = InStr(nameDOB, "yo")
    
    'Last, First
    nameBoth = Left(nameDOB, yo - 1)
    dict.Add "last", Trim(Split(nameBoth, ",")(0))
    fNameAGE = Trim(Split(nameBoth, ",")(1))
    fNameArray = Split(fNameAGE)
    If UBound(fNameArray) >= 2 Then
        FName = fNameArray(0) & " " & fNameArray(1)
    Else
        FName = fNameArray(0)
    End If
    dict.Add "first", FName
    
    'Gender
    dict.Add "gender", Mid(nameDOB, yo + 3, 1)
    
    'DOB
    dob = InStr(nameDOB, "DOB") + 5
    mrn = InStr(nameDOB, "MRN") - 3
    dict.Add "dob", Mid(nameDOB, dob, mrn - dob)
    
    'MRN
    dict.Add "mrn", Mid(nameDOB, mrn + 8, 6)
    
    
    dict.Add "admit", Split(oTable.Cell(1, 3).Range.Text, " ")(1)
    dict.Add "resident", Split(oTable.Cell(2, 2).Range.Text, vbCr)(0)
    dict.Add "code", Split(oTable.Cell(2, 3).Range.Text, vbCr)(0)
    
    txtMeds = Replace(Split(oTable.Cell(3, 1).Range.Text, Chr(7))(0), "Rx: ", "")
    If Right$(txtMeds, 1) = Chr(13) Then txtMeds = Left$(txtMeds, Len(txtMeds) - 1)
    dict.Add "meds", txtMeds

    txtHPI = Split(oTable.Cell(3, 2).Range.Text, Chr(7))(0)
    If Right$(txtHPI, 1) = Chr(13) Then txtHPI = Left$(txtHPI, Len(txtHPI) - 1)
    dict.Add "hpi", txtHPI

    txtFU = Replace(Split(oTable.Cell(3, 3).Range.Text, Chr(7))(0), "F/U: ", "")
    If Right$(txtFU, 1) = Chr(13) Then txtFU = Left$(txtFU, Len(txtFU) - 1)
    dict.Add "fu", Replace(txtFU, ChrW(&H2610) & " ", "")
    
    txtAllergies = Replace(Split(oTable.Cell(4, 1).Range.Text, Chr(7))(0), "Allergies: ", "")
    If Right$(txtAllergies, 1) = Chr(13) Then txtAllergies = Left$(txtAllergies, Len(txtAllergies) - 1)
    dict.Add "allergies", txtAllergies

    dict.Add "ddx", Replace(Split(oTable.Cell(4, 2).Range.Text, vbCr)(0), "DDx: ", "")

    txtPain = Replace(Split(oTable.Cell(4, 3).Range.Text, Chr(7))(0), "Pain: ", "")
    If Right$(txtPain, 1) = Chr(13) Then txtPain = Left$(txtPain, Len(txtPain) - 1)
    dict.Add "pain", txtPain

    txtPPx = Replace(Split(oTable.Cell(5, 1).Range.Text, Chr(7))(0), "PPx: ", "")
    If Right$(txtPPx, 1) = Chr(13) Then txtPPx = Left$(txtPPx, Len(txtPPx) - 1)
    dict.Add "ppx", txtPPx

    dict.Add "labs", Replace(Split(oTable.Cell(5, 2).Range.Text, vbCr)(0), "- ", "")
    dict.Add "imaging", Replace(Split(oTable.Cell(6, 2).Range.Text, vbCr)(0), "- ", "")
    dict.Add "procedures", Replace(Split(oTable.Cell(7, 2).Range.Text, vbCr)(0), "- ", "")

    chkmks = UBound(Split(oTable.Cell(5, 3).Range.Text, ChrW(&H2611)))
    If chkmks = 2 Then
        dict.Add "anticoag", True
        dict.Add "insulin", True
    ElseIf chkmks = 1 Then
        chk = Replace(Split(oTable.Cell(5, 3).Range.Text, vbCr)(0), ChrW(&H2611) & " ", "")
        If chk = "Anticoagulated" Then
            dict.Add "anticoag", True
            dict.Add "insulin", False
        Else
            dict.Add "anticoag", False
            dict.Add "insulin", True
        End If
    Else
        dict.Add "anticoag", False
        dict.Add "insulin", False
    End If
    
    dict.Add "dispo", Replace(Split(oTable.Cell(oTable.Rows.Count, 1).Range.Text, vbCr)(0), "Dispo: ", "")
    
    'dict.Add "timestamp", Split(oTable.Cell(oTable.Rows.Count, 2).Range.Text, vbCr)(0)
    'dict.Add "username", "   "
    
    raw = Split(oTable.Cell(oTable.Rows.Count, 2).Range.Text, vbCr)(0)
    dt = Mid(raw, 1, InStr(raw, " (") - 1)
    ini = Mid(raw, InStr(raw, " (") + 2, 3)
    dict.Add "timestamp", dt
    dict.Add "username", ini
    
    
End Sub