Last active
March 13, 2018 11:59
-
-
Save DrLulz/770d8a93914b936e5f051e61c44f8b78 to your computer and use it in GitHub Desktop.
Revisions
-
DrLulz revised this gist
Mar 13, 2018 . 8 changed files with 131 additions and 54 deletions.There are no files selected for viewing
This file contains hidden or bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters. Learn more about bidirectional Unicode charactersOriginal file line number Diff line number Diff line change @@ -3,33 +3,45 @@ Public Sub AutoOpen() '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 @@ -44,7 +56,7 @@ Sub whatPath() MsgBox ActiveDocument.FullName End Sub Private Sub Document_Close() Call StopClock ActiveDocument.Save Me.Saved = True End Sub This file contains hidden or bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters. Learn more about bidirectional Unicode charactersOriginal file line number Diff line number Diff line change @@ -30,19 +30,31 @@ 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 This file contains hidden or bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters. Learn more about bidirectional Unicode charactersOriginal file line number Diff line number Diff line change @@ -1,7 +1,7 @@ Sub main(fx, sort) On Error GoTo eh Call StopClock Dim oDoc As Document Set oDoc = ActiveDocument @@ -87,9 +87,9 @@ Sub main(fx, sort) 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 @@ -110,14 +110,15 @@ Sub main(fx, sort) 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 @@ -165,7 +166,7 @@ Sub main(fx, sort) d.Add "timestamp", Now() usr = Environ$("Username") d.Add "username", UCase(Right(usr, 2) & Left(usr, 1)) coll.Add d, bmk @@ -179,6 +180,8 @@ Sub main(fx, sort) ' MODIFY If fx = "MOD" Then n = n + 1 ufBmk = ufModPatient.cboResident.Text & "_" & ufModPatient.txtRoom.Text @@ -214,7 +217,7 @@ Sub main(fx, sort) coll(modBmk).Item("timestamp") = vTimestamp usr = Environ$("Username") coll(modBmk).Item("username") = UCase(Right(usr, 2) & Left(usr, 1)) Else @@ -252,7 +255,7 @@ Sub main(fx, sort) d.Add "timestamp", vTimestamp usr = Environ$("Username") d.Add "username", UCase(Right(usr, 2) & Left(usr, 1)) coll.Add d, ufBmk @@ -271,6 +274,7 @@ Sub main(fx, sort) If fx = "DEL" Then coll.Remove sort n = n - 1 End If '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' @@ -483,7 +487,13 @@ Sub main(fx, sort) 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 @@ -535,21 +545,27 @@ Sub main(fx, sort) .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 = "" @@ -619,8 +635,8 @@ Sub main(fx, sort) .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") @@ -655,6 +671,9 @@ Sub main(fx, sort) 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 @@ -677,7 +696,7 @@ Sub main(fx, sort) Selection.HomeKey Unit:=wdStory oDoc.Protect wdAllowOnlyReading SaveToRelativePath Call StartClock Done: Exit Sub @@ -696,6 +715,9 @@ eh: 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" This file contains hidden or bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters. Learn more about bidirectional Unicode charactersOriginal file line number Diff line number Diff line change @@ -0,0 +1,30 @@ 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 This file contains hidden or bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters. Learn more about bidirectional Unicode charactersOriginal file line number Diff line number Diff line change @@ -187,7 +187,7 @@ Private Sub cmdCommit_Click() 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 This file contains hidden or bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters. Learn more about bidirectional Unicode charactersOriginal file line number Diff line number Diff line change @@ -28,7 +28,7 @@ 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 This file contains hidden or bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters. Learn more about bidirectional Unicode charactersOriginal file line number Diff line number Diff line change @@ -208,7 +208,8 @@ Private Sub cmdCommit_Click() 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 This file contains hidden or bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters. Learn more about bidirectional Unicode charactersOriginal file line number Diff line number Diff line change @@ -103,9 +103,9 @@ Sub tblDict(usrSel As String) 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 @@ -127,14 +127,14 @@ Sub tblDict(usrSel As String) 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 -
Jan 30, 2018 . 1 changed file with 1 addition and 1 deletion.There are no files selected for viewing
This file contains hidden or bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters. Learn more about bidirectional Unicode charactersOriginal file line number Diff line number Diff line change @@ -666,7 +666,7 @@ Sub main(fx, sort) .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") -
Jan 28, 2018 . 2 changed files with 15 additions and 11 deletions.There are no files selected for viewing
This file contains hidden or bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters. Learn more about bidirectional Unicode charactersOriginal file line number Diff line number Diff line change @@ -110,12 +110,14 @@ Sub main(fx, sort) 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 This file contains hidden or bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters. Learn more about bidirectional Unicode charactersOriginal file line number Diff line number Diff line change @@ -126,13 +126,15 @@ Sub tblDict(usrSel As String) 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 -
Jan 28, 2018 . 4 changed files with 199 additions and 196 deletions.There are no files selected for viewing
This file contains hidden or bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters. Learn more about bidirectional Unicode charactersOriginal file line number Diff line number Diff line change @@ -28,7 +28,7 @@ Public Function residentArray() End Function Public Function codeArray() codeArray = Array("Full Code", "DNR/DNI", "DNR", "DNI", "Unknown") End Function 'Public Sub StartClock() ' NoActivity = Now + TimeValue("01:00:00") This file contains hidden or bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters. Learn more about bidirectional Unicode charactersOriginal file line number Diff line number Diff line change @@ -22,108 +22,102 @@ Sub main(fx, sort) 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), "Labs: ", "") d.Add "imaging", Replace(Split(oTable.Cell(6, 2).Range.Text, vbCr)(0), "Imaging: ", "") d.Add "procedures", Replace(Split(oTable.Cell(7, 2).Range.Text, vbCr)(0), "Procedures: ", "") 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: ", "") 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 @@ -137,38 +131,42 @@ Sub main(fx, sort) 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", Right(usr, 2) & Left(usr, 1) coll.Add d, bmk Unload ufAdd 'Unload ufAddPatient @@ -212,51 +210,56 @@ Sub main(fx, sort) 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") = 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", Right(usr, 2) & Left(usr, 1) coll.Add d, ufBmk End If modBmk = vbNullString vTimestamp = vbNullString Unload ufMod End If @@ -282,7 +285,7 @@ Sub main(fx, sort) 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 @@ -307,7 +310,7 @@ Sub main(fx, sort) 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 @@ -331,7 +334,7 @@ Sub main(fx, sort) 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 @@ -380,9 +383,9 @@ Sub main(fx, sort) 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") @@ -621,7 +624,7 @@ Sub main(fx, sort) .Range.Cells(tCell + 1).Range.ParagraphFormat.Alignment = wdAlignParagraphRight .Range.Cells(tCell + 1).Range.Text = d.Item("timestamp") & " (" & d.Item("username") & ")" '''''''''''''''''''''''''''''''''''''' @@ -643,7 +646,29 @@ Sub main(fx, sort) 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 .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 = 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 @@ -669,6 +694,35 @@ eh: Set fso = VBA.CreateObject("Scripting.FileSystemObject") Call fso.CopyFile(rPath, aPath) 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 This file contains hidden or bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters. Learn more about bidirectional Unicode charactersOriginal file line number Diff line number Diff line change @@ -1,29 +1,5 @@ Private Sub UserForm_Initialize() Me.txtRoom.Value = dict.Item("room") Me.txtFirst.Value = dict.Item("first") Me.txtLast.Value = dict.Item("last") This file contains hidden or bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters. Learn more about bidirectional Unicode charactersOriginal file line number Diff line number Diff line change @@ -25,13 +25,12 @@ Private Sub UserForm_Initialize() 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 @@ -43,123 +42,97 @@ Sub tblDict(usrSel As String) 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), "Labs: ", "") dict.Add "imaging", Replace(Split(oTable.Cell(6, 2).Range.Text, vbCr)(0), "Imaging: ", "") dict.Add "procedures", Replace(Split(oTable.Cell(7, 2).Range.Text, vbCr)(0), "Procedures: ", "") 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) 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 -
Jan 27, 2018 . 2 changed files with 18 additions and 4 deletions.There are no files selected for viewing
This file contains hidden or bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters. Learn more about bidirectional Unicode charactersOriginal file line number Diff line number Diff line change @@ -36,9 +36,16 @@ Sub main(fx, sort) 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) This file contains hidden or bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters. Learn more about bidirectional Unicode charactersOriginal file line number Diff line number Diff line change @@ -51,9 +51,16 @@ Sub tblDict(usrSel As String) 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) -
Jan 27, 2018 . 1 changed file with 1 addition and 1 deletion.There are no files selected for viewing
This file contains hidden or bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters. Learn more about bidirectional Unicode charactersOriginal file line number Diff line number Diff line change @@ -28,7 +28,7 @@ Public Function residentArray() End Function Public Function codeArray() codeArray = Array("Full Code", "DNR/DNI", "DNR", "DNI", "Unknown") End Function 'Public Sub StartClock() ' NoActivity = Now + TimeValue("01:00:00") -
Jan 27, 2018 . 6 changed files with 164 additions and 45 deletions.There are no files selected for viewing
This file contains hidden or bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters. Learn more about bidirectional Unicode charactersOriginal file line number Diff line number Diff line change @@ -1,15 +1,15 @@ 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 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() 'Dim frm As New ufAddPatient @@ -44,7 +44,7 @@ Sub whatPath() MsgBox ActiveDocument.FullName End Sub Private Sub Document_Close() 'Call StopClock ActiveDocument.Save Me.Saved = True End Sub This file contains hidden or bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters. Learn more about bidirectional Unicode charactersOriginal file line number Diff line number Diff line change @@ -30,19 +30,19 @@ End Function Public Function codeArray() codeArray = Array("Full Code", "DNR/DNI", "DNR", "DNI") End Function 'Public Sub StartClock() ' NoActivity = Now + TimeValue("01:00: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 ' With ActiveDocument ' .Save ' '.Close ' End With ' Application.Quit 'End Sub This file contains hidden or bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters. Learn more about bidirectional Unicode charactersOriginal file line number Diff line number Diff line change @@ -1,5 +1,7 @@ Sub main(fx, sort) On Error GoTo eh 'Call StopClock Dim oDoc As Document Set oDoc = ActiveDocument @@ -29,12 +31,36 @@ Sub main(fx, sort) 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 - 4) d.add "last", Trim(Split(nameBoth, ",")(0)) d.add "first", Trim(Split(nameBoth, ",")(1)) '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 "last", Split(nameDOB, ",")(0) 'lastGenderDOB = Split(nameDOB, ",")(1) 'd.add "first", Split(lastGenderDOB, " ")(1) 'd.add "gender", Split(lastGenderDOB, " ")(3) 'd.add "dob", Replace(Left(Split(lastGenderDOB, " ")(5), 10), ")", "") 'd.add "mrn", Replace(Left(Split(lastGenderDOB, " ")(7), 10), ")", "") 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) @@ -120,7 +146,7 @@ Sub main(fx, sort) 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 @@ -288,6 +314,31 @@ Sub main(fx, sort) 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 @@ -420,7 +471,7 @@ Sub main(fx, sort) Dim sArr() As String ReDim sArr(UBound(arr)) For x = 0 To UBound(arr) sArr(x) = ChrW(&H2610) & " " & Trim(Replace(arr(x), vbLf, "")) Next x .Rows(3).Cells(3).Range.Text = Join(sArr, vbCrLf) Else @@ -569,10 +620,18 @@ Sub main(fx, sort) '''''''''''''''''''''''''''''''''''''' ' 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 @@ -584,6 +643,25 @@ Sub main(fx, sort) 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 "The following error occurred: " & Err.Description End Sub This file contains hidden or bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters. Learn more about bidirectional Unicode charactersOriginal file line number Diff line number Diff line change @@ -204,12 +204,20 @@ Private Sub cmdCancel_Click() 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 This file contains hidden or bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters. Learn more about bidirectional Unicode charactersOriginal file line number Diff line number Diff line change @@ -262,12 +262,20 @@ Private Sub cmdCancel_Click() 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 This file contains hidden or bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters. Learn more about bidirectional Unicode charactersOriginal file line number Diff line number Diff line change @@ -25,6 +25,7 @@ Private Sub UserForm_Initialize() listPts.List = bmkArray End Sub Private Sub cmdSelect_Click() usrSel = Split(Me.listPts.Value, vbTab & vbTab) usrSelection = usrSel(1) & "_" & usrSel(0) Me.Hide @@ -44,14 +45,38 @@ Sub tblDict(usrSel As String) 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 - 4) dict.add "last", Trim(Split(nameBoth, ",")(0)) dict.add "first", Trim(Split(nameBoth, ",")(1)) '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) ''''' 'nameDOB = Split(oTable.Cell(1, 2).Range.Text, vbCr)(0) 'dict.add "last", Split(nameDOB, ",")(0) 'lastGenderDOB = Split(nameDOB, ",")(1) 'dict.add "first", Split(lastGenderDOB, " ")(1) 'dict.add "gender", Split(lastGenderDOB, " ")(3) 'dict.add "dob", Replace(Left(Split(lastGenderDOB, " ")(5), 10), ")", "") 'dict.add "mrn", Replace(Left(Split(lastGenderDOB, " ")(7), 10), ")", "") 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) -
Jan 25, 2018 . 1 changed file with 1 addition and 1 deletion.There are no files selected for viewing
This file contains hidden or bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters. Learn more about bidirectional Unicode charactersOriginal file line number Diff line number Diff line change @@ -31,7 +31,7 @@ Public Function codeArray() codeArray = Array("Full Code", "DNR/DNI", "DNR", "DNI") End Function Public Sub StartClock() NoActivity = Now + TimeValue("00:02:00") Application.OnTime NoActivity, "ShutDown" End Sub Public Sub StopClock() -
Jan 25, 2018 . 4 changed files with 30 additions and 6 deletions.There are no files selected for viewing
This file contains hidden or bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters. Learn more about bidirectional Unicode charactersOriginal file line number Diff line number Diff line change @@ -9,6 +9,7 @@ Public Sub AutoOpen() ActiveDocument.ActiveWindow.View.ReadingLayout = False 'MsgBox ThisDocument.Application.UsableWidth SaveToRelativePath Call StartClock End Sub Sub RunFormAddPatient() 'Dim frm As New ufAddPatient @@ -39,7 +40,11 @@ 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 This file contains hidden or bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters. Learn more about bidirectional Unicode charactersOriginal file line number Diff line number Diff line change @@ -3,6 +3,7 @@ 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 @@ -28,4 +29,20 @@ Public Function residentArray() End Function Public Function codeArray() codeArray = Array("Full Code", "DNR/DNI", "DNR", "DNI") End Function Public Sub StartClock() NoActivity = Now + TimeValue("01:02: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 With ActiveDocument .Save '.Close End With Application.Quit End Sub This file contains hidden or bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters. Learn more about bidirectional Unicode charactersOriginal file line number Diff line number Diff line change @@ -1,4 +1,6 @@ Sub main(fx, sort) Call StopClock Dim oDoc As Document Set oDoc = ActiveDocument @@ -27,10 +29,9 @@ Sub main(fx, sort) d.add "room", Split(oTable.Cell(1, 1).Range.Text, vbCr)(0) nameDOB = Split(oTable.Cell(1, 2).Range.Text, vbCr)(0) d.add "last", Split(nameDOB, ",")(0) lastGenderDOB = Split(nameDOB, ",")(1) d.add "first", Split(lastGenderDOB, " ")(1) d.add "gender", Split(lastGenderDOB, " ")(3) d.add "dob", Replace(Left(Split(lastGenderDOB, " ")(5), 10), ")", "") d.add "mrn", Replace(Left(Split(lastGenderDOB, " ")(7), 10), ")", "") @@ -583,5 +584,6 @@ Sub main(fx, sort) Selection.HomeKey Unit:=wdStory oDoc.Protect wdAllowOnlyReading SaveToRelativePath Call StartClock End Sub This file contains hidden or bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters. Learn more about bidirectional Unicode charactersOriginal file line number Diff line number Diff line change @@ -139,8 +139,8 @@ Private Sub cmdCommit_Click() 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 -
Jan 24, 2018 . 1 changed file with 2 additions and 2 deletions.There are no files selected for viewing
This file contains hidden or bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters. Learn more about bidirectional Unicode charactersOriginal file line number Diff line number Diff line change @@ -27,13 +27,13 @@ Sub SaveToRelativePath() 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 -
Jan 23, 2018 . 7 changed files with 61 additions and 13 deletions.There are no files selected for viewing
This file contains hidden or bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters. Learn more about bidirectional Unicode charactersOriginal file line number Diff line number Diff line change @@ -11,8 +11,10 @@ Public Sub AutoOpen() SaveToRelativePath End Sub Sub RunFormAddPatient() 'Dim frm As New ufAddPatient 'frm.Show vbModeless Set ufAdd = New ufAddPatient ufAdd.Show vbModeless End Sub Sub RunFormSelectPatient() Dim frm As New ufSelectPatient This file contains hidden or bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters. Learn more about bidirectional Unicode charactersOriginal file line number Diff line number Diff line change @@ -1,6 +1,8 @@ Public dict As Object Public modBmk As String Public vTimestamp As String Public ufAdd As ufAddPatient Public ufMod As ufModPatient Public Function residentArray() Dim residents As Variant This file contains hidden or bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters. Learn more about bidirectional Unicode charactersOriginal file line number Diff line number Diff line change @@ -135,9 +135,10 @@ Sub main(fx, sort) d.add "timestamp", Now() coll.add d, bmk Unload ufAdd 'Unload ufAddPatient End If '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' @@ -220,7 +221,8 @@ Sub main(fx, sort) modBmk = vbNullString vTimestamp = vbNullString Unload ufMod 'Unload ufModPatient End If This file contains hidden or bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters. Learn more about bidirectional Unicode charactersOriginal file line number Diff line number Diff line change @@ -1,19 +1,52 @@ 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 & "--" & fileDate & "-" & secNow & "." & ext delPath = ThisDocument.Path & "\" & onlyName & "--" & fileDate & "." & ext ActiveDocument.SaveAs FileName:=aPath ActiveDocument.SaveAs FileName:=rPath If FileExists(aPath) 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) @@ -36,4 +69,7 @@ Sub SaveToRelativePath() 'End If End Sub Function FileExists(ByVal FileToTest As String) As Boolean FileExists = (Dir(FileToTest) <> "") End Function This file contains hidden or bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters. Learn more about bidirectional Unicode charactersOriginal file line number Diff line number Diff line change @@ -194,7 +194,8 @@ Private Sub cmdCommit_Click() End If 'Me.Hide ufAdd.Hide Call main("ADD", "ROOM") End Sub This file contains hidden or bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters. Learn more about bidirectional Unicode charactersOriginal file line number Diff line number Diff line change @@ -252,6 +252,7 @@ Private Sub cmdCommit_Click() End If ufMod.Hide Call main("MOD", "ROOM") dict.RemoveAll This file contains hidden or bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters. Learn more about bidirectional Unicode charactersOriginal file line number Diff line number Diff line change @@ -29,7 +29,11 @@ Private Sub cmdSelect_Click() usrSelection = usrSel(1) & "_" & usrSel(0) Me.Hide tblDict (usrSelection) 'ufModPatient.Show Set ufMod = New ufModPatient ufMod.Show vbModeless End Sub Sub tblDict(usrSel As String) -
Jan 23, 2018 . 3 changed files with 91 additions and 58 deletions.There are no files selected for viewing
This file contains hidden or bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters. Learn more about bidirectional Unicode charactersOriginal file line number Diff line number Diff line change @@ -1,5 +1,4 @@ Sub main(fx, sort) Dim oDoc As Document Set oDoc = ActiveDocument @@ -146,43 +145,77 @@ Sub main(fx, sort) If fx = "MOD" Then 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 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 coll.add d, ufBmk End If modBmk = vbNullString vTimestamp = vbNullString @@ -196,11 +229,7 @@ Sub main(fx, sort) ' DELETE If fx = "DEL" Then coll.Remove sort End If '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' @@ -272,15 +301,16 @@ Sub main(fx, sort) 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 @@ -441,18 +471,21 @@ Sub main(fx, sort) If d.Item("labs") <> "" Then .Range.Cells(14).Range.Text = "Labs: " & d.Item("labs") Else .Range.Cells(14).Height = 0 .Range.Cells(14).Range.Text = "" End If If d.Item("imaging") <> "" Then .Range.Cells(16).Range.Text = "Imaging: " & d.Item("imaging") Else .Range.Cells(16).Height = 0 .Range.Cells(16).Range.Text = "" End If If d.Item("procedures") <> "" Then .Range.Cells(17).Range.Text = "Procedures: " & d.Item("procedures") Else .Range.Cells(17).Height = 0 .Range.Cells(17).Range.Text = "" End If @@ -545,8 +578,8 @@ Sub main(fx, sort) '''''''''''''''''''' ' TURN ON READ ONLY Selection.HomeKey Unit:=wdStory oDoc.Protect wdAllowOnlyReading SaveToRelativePath End Sub This file contains hidden or bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters. Learn more about bidirectional Unicode charactersOriginal file line number Diff line number Diff line change @@ -8,7 +8,7 @@ Sub SaveToRelativePath() pathName = ActiveDocument.FullName onlyName = mid(pathName, InStrRev(pathName, "\") + 1, InStrRev(pathName, "--") - InStrRev(pathName, "\") - 1) ext = Right(pathName, Len(pathName) - InStrRev(pathName, ".")) This file contains hidden or bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters. Learn more about bidirectional Unicode charactersOriginal file line number Diff line number Diff line change @@ -1,15 +1,15 @@ 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") -
Jan 23, 2018 . 1 changed file with 2 additions and 0 deletions.There are no files selected for viewing
This file contains hidden or bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters. Learn more about bidirectional Unicode charactersOriginal file line number Diff line number Diff line change @@ -406,6 +406,7 @@ Sub main(fx, sort) .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 = "" @@ -416,6 +417,7 @@ Sub main(fx, sort) .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 = "" -
Jan 23, 2018 .There are no files selected for viewing
This file contains hidden or bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters. Learn more about bidirectional Unicode charactersOriginal file line number Diff line number Diff line change @@ -0,0 +1,43 @@ Public Sub AutoOpen() ThisDocument.Application.ActiveWindow.View.Zoom.PageColumns = 1 'ThisDocument.Application.ActiveWindow.View.Zoom.Percentage = 100 ThisDocument.Application.ActiveWindow.View.Zoom.PageFit = wdPageFitBestFit ThisDocument.Application.ActiveWindow.View.Type = wdPrintView With ActiveDocument.Styles(wdStyleNormal).Font .Size = 1 End With ActiveDocument.ActiveWindow.View.ReadingLayout = False 'MsgBox ThisDocument.Application.UsableWidth SaveToRelativePath End Sub Sub RunFormAddPatient() Dim frm As New ufAddPatient frm.Show End Sub Sub RunFormSelectPatient() Dim frm As New ufSelectPatient frm.Show End Sub Sub RunFormDeletePatient() Dim frm As New ufDeletePatient frm.Show End Sub Sub sortNumbers() Call main("", "ROOM") End Sub Sub sortNames() Call main("", "RESIDENT") 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 Private Sub Document_Close() ActiveDocument.Save Me.Saved = True End Sub This file contains hidden or bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters. Learn more about bidirectional Unicode charactersOriginal file line number Diff line number Diff line change @@ -0,0 +1,29 @@ Public dict As Object Public modBmk As String Public vTimestamp As String 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") End Function This file contains hidden or bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters. Learn more about bidirectional Unicode charactersOriginal file line number Diff line number Diff line change @@ -0,0 +1,550 @@ Sub main(fx, sort) 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) d.add "first", Split(nameDOB, ",")(0) lastGenderDOB = Split(nameDOB, ",")(1) d.add "last", Split(lastGenderDOB, " ")(1) d.add "gender", Split(lastGenderDOB, " ")(3) d.add "dob", Replace(Left(Split(lastGenderDOB, " ")(5), 10), ")", "") d.add "mrn", Replace(Left(Split(lastGenderDOB, " ")(7), 10), ")", "") 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), "Labs: ", "") d.add "imaging", Replace(Split(oTable.Cell(6, 2).Range.Text, vbCr)(0), "Imaging: ", "") d.add "procedures", Replace(Split(oTable.Cell(7, 2).Range.Text, vbCr)(0), "Procedures: ", "") 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) 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", 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() coll.add d, bmk End If 'Unload ufAddPatient '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' ' MODIFY If fx = "MOD" Then For Each d In coll If d.Item("bmk") = modBmk Then 'MsgBox d.Item("bmk"), vbOKOnly, "MOD" d.Item("bmk") = ufModPatient.cboResident.Text & "_" & ufModPatient.txtRoom.Text d.Item("room") = ufModPatient.txtRoom.Text d.Item("first") = ufModPatient.txtFirst.Text d.Item("last") = ufModPatient.txtLast.Text If ufModPatient.optMale.Value Then d.Item("gender") = "M" Else d.Item("gender") = "F" End If d.Item("dob") = ufModPatient.txtDOB.Text d.Item("admit") = ufModPatient.txtAdmit.Text d.Item("resident") = ufModPatient.cboResident.Text d.Item("code") = ufModPatient.cboCode.Text d.Item("mrn") = ufModPatient.txtMRN.Text d.Item("meds") = ufModPatient.txtMeds.Text d.Item("hpi") = ufModPatient.txtHPI.Text d.Item("fu") = ufModPatient.txtFU.Text d.Item("allergies") = ufModPatient.txtAllergies.Text d.Item("ddx") = ufModPatient.txtDDx.Text d.Item("pain") = ufModPatient.txtPain.Text d.Item("ppx") = ufModPatient.txtPPx.Text d.Item("labs") = ufModPatient.txtLabs.Text d.Item("anticoag") = ufModPatient.chkAnticoag.Value d.Item("insulin") = ufModPatient.chkInsulin.Value d.Item("imaging") = ufModPatient.txtImaging.Text d.Item("procedures") = ufModPatient.txtProcedures.Text d.Item("dispo") = ufModPatient.txtDispo.Text d.Item("timestamp") = vTimestamp End If Next d modBmk = vbNullString vTimestamp = vbNullString Unload ufModPatient End If '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' ' DELETE If fx = "DEL" Then For i = 1 To coll.Count If coll(i).Item("bmk") = sort Then coll.Remove (i) End If Next i 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 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 ''''''''''''''''''''''' ' 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) sArr(x) = ChrW(&H2610) & " " & Replace(arr(x), vbLf, "") 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).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).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).Range.Text = "Labs: " & d.Item("labs") Else .Range.Cells(14).Range.Text = "" End If If d.Item("imaging") <> "" Then .Range.Cells(16).Range.Text = "Imaging: " & d.Item("imaging") Else .Range.Cells(16).Range.Text = "" End If If d.Item("procedures") <> "" Then .Range.Cells(17).Range.Text = "Procedures: " & d.Item("procedures") Else .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) * 6 .Range.Cells(tCell + 1).Width = (w / 10) * 4 .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") '''''''''''''''''''''''''''''''''''''' ' SPACING .Range.Cells(tCell + 1).Select Selection.MoveDown Unit:=wdLine, Count:=1 Selection.InsertParagraph Selection.EndKey Unit:=wdStory End With Next d Set coll = Nothing '''''''''''''''''''' ' TURN ON READ ONLY oDoc.Protect wdAllowOnlyReading SaveToRelativePath End Sub This file contains hidden or bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters. Learn more about bidirectional Unicode charactersOriginal file line number Diff line number Diff line change @@ -0,0 +1,39 @@ Sub SaveToRelativePath() Dim rPath As String 'epoch = DateDiff("S", "1/1/1970", Now()) 'dateNow = Format(Now(), "yyyy-MM-dd-hhmmss") 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, ".")) rPath = ThisDocument.Path & "\" & onlyName & "--" & dateNow & "." & ext ActiveDocument.SaveAs FileName:=rPath '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 This file contains hidden or bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters. Learn more about bidirectional Unicode charactersOriginal file line number Diff line number Diff line change @@ -0,0 +1,214 @@ 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 = Me.txtFirst.Value ufAddPatient.txtLast.Text = Me.txtLast.Value 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 number is already on cencus.", vbOKOnly, "Room Number Exists" txtRoom.SetFocus Exit Sub End If End If Me.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 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 Then dateCheckAdmit = True End If End Function This file contains hidden or bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters. Learn more about bidirectional Unicode charactersOriginal file line number Diff line number Diff line change @@ -0,0 +1,41 @@ 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 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 This file contains hidden or bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters. Learn more about bidirectional Unicode charactersOriginal file line number Diff line number Diff line change @@ -0,0 +1,272 @@ Private Sub UserForm_Initialize() 'dict.Item("room") 'dict.Item("first") 'dict.Item("last") 'dict.Item("gender") 'dict.Item("dob") 'dict.Item("admit") 'dict.Item("resident") 'dict.Item("code") 'dict.Item("meds") 'dict.Item("hpi") 'dict.Item("fu") 'dict.Item("allergies") 'dict.Item("ddx") 'dict.Item("pain") 'dict.Item("ppx") 'dict.Item("labs") 'dict.Item("anticoag") 'dict.Item("insulin") 'dict.Item("imaging") 'dict.Item("procedures") 'dict.Item("dispo") 'dict.Item("timestamp") 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" 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 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 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 Then dateCheckAdmit = True End If End Function This file contains hidden or bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters. Learn more about bidirectional Unicode charactersOriginal file line number Diff line number Diff line change @@ -0,0 +1,129 @@ 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) ufModPatient.Show 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) dict.add "first", Split(nameDOB, ",")(0) lastGenderDOB = Split(nameDOB, ",")(1) dict.add "last", Split(lastGenderDOB, " ")(1) dict.add "gender", Split(lastGenderDOB, " ")(3) dict.add "dob", Replace(Left(Split(lastGenderDOB, " ")(5), 10), ")", "") dict.add "mrn", Replace(Left(Split(lastGenderDOB, " ")(7), 10), ")", "") 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), "Labs: ", "") dict.add "imaging", Replace(Split(oTable.Cell(6, 2).Range.Text, vbCr)(0), "Imaging: ", "") dict.add "procedures", Replace(Split(oTable.Cell(7, 2).Range.Text, vbCr)(0), "Procedures: ", "") 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) 'MsgBox dict.Item("room"), vbOKOnly, "Room Number" 'MsgBox dict.Item("first"), vbOKOnly, "First Name" 'MsgBox dict.Item("last"), vbOKOnly, "Last Name" 'MsgBox dict.Item("gender"), vbOKOnly, "Gender" 'MsgBox dict.Item("dob"), vbOKOnly, "DOB" 'MsgBox dict.Item("admit"), vbOKOnly, "Admit Date" 'MsgBox dict.Item("resident"), vbOKOnly, "Resident" 'MsgBox dict.Item("code"), vbOKOnly, "Code Status" 'MsgBox dict.Item("meds"), vbOKOnly, "Medication" 'MsgBox dict.Item("hpi"), vbOKOnly, "HPI" 'MsgBox dict.Item("fu"), vbOKOnly, "Follow Up" 'MsgBox dict.Item("allergies"), vbOKOnly, "Allergies" 'MsgBox dict.Item("ddx"), vbOKOnly, "Differential" 'MsgBox dict.Item("pain"), vbOKOnly, "Pain" 'MsgBox dict.Item("ppx"), vbOKOnly, "PPx" 'MsgBox dict.Item("labs"), vbOKOnly, "Labs" 'MsgBox dict.Item("anticoag"), vbOKOnly, "Anticoagulation" 'MsgBox dict.Item("insulin"), vbOKOnly, "Insulin" 'MsgBox dict.Item("imaging"), vbOKOnly, "Imaging" 'MsgBox dict.Item("procedures"), vbOKOnly, "Procedures" 'MsgBox dict.Item("dispo"), vbOKOnly, "Disposition" 'MsgBox dict.Item("timestamp"), vbOKOnly, "Time Stamp" End Sub