Last active
March 13, 2018 11:59
-
-
Save DrLulz/770d8a93914b936e5f051e61c44f8b78 to your computer and use it in GitHub Desktop.
New SignOut VBA
This file contains 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 characters
Public dict As Object | |
Public modBmk As String | |
Public vTimestamp As String | |
Public ufAdd As ufAddPatient | |
Public ufMod As ufModPatient | |
Public NoActivity As Date | |
Public Function residentArray() | |
Dim residents As Variant | |
Dim x As Long, y As Long | |
Dim TempTxt1 As String | |
Dim TempTxt2 As String | |
residents = Array("PGuilford", "TGuilford", "White", "Buckner", "Carlson", "Nguyen", "Varbanoff", "Beavers", "Dockery", "Kirk", "Smith", "Bowling", "Edwards", "Facelo", "McGee") | |
For x = LBound(residents) To UBound(residents) | |
For y = x To UBound(residents) | |
If UCase(residents(y)) < UCase(residents(x)) Then | |
TempTxt1 = residents(x) | |
TempTxt2 = residents(y) | |
residents(x) = TempTxt2 | |
residents(y) = TempTxt1 | |
End If | |
Next y | |
Next x | |
residentArray = residents | |
End Function | |
Public Function codeArray() | |
codeArray = Array("Full Code", "DNR/DNI", "DNR", "DNI", "Unknown") | |
End Function | |
Public Sub StartClock() | |
NoActivity = Now + TimeValue("00:10:00") | |
Application.OnTime NoActivity, "ShutDown" | |
End Sub | |
Public Sub StopClock() | |
On Error Resume Next | |
Application.OnTime NoActivity, "ShutDown" | |
End Sub | |
Public Sub ShutDown() | |
'Application.DisplayAlerts = False | |
winCaption = ActiveDocument.ActiveWindow.Caption & " - " & ThisDocument.Application.Caption | |
If ActiveDocument.ActiveWindow.WindowState = wdWindowStateMinimize Then | |
ActiveDocument.ActiveWindow.WindowState = wdWindowStateNormal | |
Else | |
AppActivate winCaption | |
End If | |
'With ActiveDocument | |
' .Save | |
'.Close | |
'End With | |
SaveToRelativePath | |
Application.Quit | |
End Sub |
This file contains 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 characters
Sub main(fx, sort) | |
On Error GoTo eh | |
Call StopClock | |
Dim oDoc As Document | |
Set oDoc = ActiveDocument | |
Dim n As Integer | |
n = ActiveDocument.Bookmarks.Count | |
'Dim coll As New Collection | |
Dim coll As Collection | |
Set coll = New Collection | |
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' | |
' MEMORY | |
For i = 1 To n | |
'MsgBox "MEMORY" | |
bmk = oDoc.Bookmarks(i).Name | |
Set d = CreateObject("Scripting.Dictionary") | |
d.Add "bmk", bmk | |
Set oTable = oDoc.Bookmarks(bmk).Range.Tables(1) | |
d.Add "room", Split(oTable.Cell(1, 1).Range.Text, vbCr)(0) | |
nameDOB = Split(oTable.Cell(1, 2).Range.Text, vbCr)(0) | |
yo = InStr(nameDOB, "yo") | |
'Last, First | |
nameBoth = Left(nameDOB, yo - 1) | |
d.Add "last", Trim(Split(nameBoth, ",")(0)) | |
fNameAGE = Trim(Split(nameBoth, ",")(1)) | |
fNameArray = Split(fNameAGE) | |
If UBound(fNameArray) >= 2 Then | |
FName = fNameArray(0) & " " & fNameArray(1) | |
Else | |
FName = fNameArray(0) | |
End If | |
d.Add "first", FName | |
'Gender | |
d.Add "gender", Mid(nameDOB, yo + 3, 1) | |
'DOB | |
dob = InStr(nameDOB, "DOB") + 5 | |
mrn = InStr(nameDOB, "MRN") - 3 | |
d.Add "dob", Mid(nameDOB, dob, mrn - dob) | |
'MRN | |
d.Add "mrn", Mid(nameDOB, mrn + 8, 6) | |
d.Add "admit", Split(oTable.Cell(1, 3).Range.Text, " ")(1) | |
d.Add "resident", Split(oTable.Cell(2, 2).Range.Text, vbCr)(0) | |
d.Add "code", Split(oTable.Cell(2, 3).Range.Text, vbCr)(0) | |
txtMeds = Replace(Split(oTable.Cell(3, 1).Range.Text, Chr(7))(0), "Rx: ", "") | |
If Right$(txtMeds, 1) = Chr(13) Then txtMeds = Left$(txtMeds, Len(txtMeds) - 1) | |
d.Add "meds", txtMeds | |
txtHPI = Split(oTable.Cell(3, 2).Range.Text, Chr(7))(0) | |
If Right$(txtHPI, 1) = Chr(13) Then txtHPI = Left$(txtHPI, Len(txtHPI) - 1) | |
d.Add "hpi", txtHPI | |
txtFU = Replace(Split(oTable.Cell(3, 3).Range.Text, Chr(7))(0), "F/U: ", "") | |
If Right$(txtFU, 1) = Chr(13) Then txtFU = Left$(txtFU, Len(txtFU) - 1) | |
d.Add "fu", Replace(txtFU, ChrW(&H2610) & " ", "") | |
txtAllergies = Replace(Split(oTable.Cell(4, 1).Range.Text, Chr(7))(0), "Allergies: ", "") | |
If Right$(txtAllergies, 1) = Chr(13) Then txtAllergies = Left$(txtAllergies, Len(txtAllergies) - 1) | |
d.Add "allergies", txtAllergies | |
d.Add "ddx", Replace(Split(oTable.Cell(4, 2).Range.Text, vbCr)(0), "DDx: ", "") | |
txtPain = Replace(Split(oTable.Cell(4, 3).Range.Text, Chr(7))(0), "Pain: ", "") | |
If Right$(txtPain, 1) = Chr(13) Then txtPain = Left$(txtPain, Len(txtPain) - 1) | |
d.Add "pain", txtPain | |
txtPPx = Replace(Split(oTable.Cell(5, 1).Range.Text, Chr(7))(0), "PPx: ", "") | |
If Right$(txtPPx, 1) = Chr(13) Then txtPPx = Left$(txtPPx, Len(txtPPx) - 1) | |
d.Add "ppx", txtPPx | |
d.Add "labs", Replace(Split(oTable.Cell(5, 2).Range.Text, vbCr)(0), "- ", "") | |
d.Add "imaging", Replace(Split(oTable.Cell(6, 2).Range.Text, vbCr)(0), "- ", "") | |
d.Add "procedures", Replace(Split(oTable.Cell(7, 2).Range.Text, vbCr)(0), "- ", "") | |
chkmks = UBound(Split(oTable.Cell(5, 3).Range.Text, ChrW(&H2611))) | |
If chkmks = 2 Then | |
d.Add "anticoag", True | |
d.Add "insulin", True | |
ElseIf chkmks = 1 Then | |
chk = Replace(Split(oTable.Cell(5, 3).Range.Text, vbCr)(0), ChrW(&H2611) & " ", "") | |
If chk = "Anticoagulated" Then | |
d.Add "anticoag", True | |
d.Add "insulin", False | |
Else | |
d.Add "anticoag", False | |
d.Add "insulin", True | |
End If | |
Else | |
d.Add "anticoag", False | |
d.Add "insulin", False | |
End If | |
d.Add "dispo", Replace(Split(oTable.Cell(oTable.Rows.Count, 1).Range.Text, vbCr)(0), "Dispo: ", "") | |
'd.Add "timestamp", Split(oTable.Cell(oTable.Rows.Count, 2).Range.Text, vbCr)(0) | |
'd.Add "username", " " | |
raw = Split(oTable.Cell(oTable.Rows.Count, 2).Range.Text, vbCr)(0) | |
dt = Mid(raw, 1, InStr(raw, " (") - 1) | |
ini = Mid(raw, InStr(raw, " (") + 2, 3) | |
d.Add "timestamp", dt | |
d.Add "username", ini | |
coll.Add d, bmk | |
Next i | |
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' | |
' ADD | |
If fx = "ADD" Then | |
'MsgBox "ADD" | |
bmk = ufAddPatient.cboResident.Text & "_" & ufAddPatient.txtRoom.Text | |
Set d = CreateObject("Scripting.Dictionary") | |
d.Add "bmk", bmk | |
d.Add "room", ufAddPatient.txtRoom.Text | |
d.Add "first", ufAddPatient.txtFirst.Text | |
d.Add "last", ufAddPatient.txtLast.Text | |
If ufAddPatient.optMale.Value Then | |
d.Add "gender", "M" | |
Else | |
d.Add "gender", "F" | |
End If | |
d.Add "dob", ufAddPatient.txtDOB.Text | |
d.Add "admit", ufAddPatient.txtAdmit.Text | |
d.Add "resident", ufAddPatient.cboResident.Text | |
d.Add "code", ufAddPatient.cboCode.Text | |
d.Add "mrn", ufAddPatient.txtMRN.Text | |
d.Add "meds", Trim(ufAddPatient.txtMeds.Text) | |
d.Add "hpi", ufAddPatient.txtHPI.Text | |
d.Add "fu", ufAddPatient.txtFU.Text | |
d.Add "allergies", ufAddPatient.txtAllergies.Text | |
d.Add "ddx", ufAddPatient.txtDDx.Text | |
d.Add "pain", ufAddPatient.txtPain.Text | |
d.Add "ppx", ufAddPatient.txtPPx.Text | |
d.Add "labs", ufAddPatient.txtLabs.Text | |
d.Add "anticoag", ufAddPatient.chkAnticoag.Value | |
d.Add "insulin", ufAddPatient.chkInsulin.Value | |
d.Add "imaging", ufAddPatient.txtImaging.Text | |
d.Add "procedures", ufAddPatient.txtProcedures.Text | |
d.Add "dispo", ufAddPatient.txtDispo.Text | |
d.Add "timestamp", Now() | |
usr = Environ$("Username") | |
d.Add "username", UCase(Right(usr, 2) & Left(usr, 1)) | |
coll.Add d, bmk | |
Unload ufAdd | |
'Unload ufAddPatient | |
End If | |
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' | |
' MODIFY | |
If fx = "MOD" Then | |
n = n + 1 | |
ufBmk = ufModPatient.cboResident.Text & "_" & ufModPatient.txtRoom.Text | |
If coll(modBmk).Item("bmk") = ufBmk Then | |
coll(modBmk).Item("bmk") = ufModPatient.cboResident.Text & "_" & ufModPatient.txtRoom.Text | |
coll(modBmk).Item("room") = ufModPatient.txtRoom.Text | |
coll(modBmk).Item("first") = ufModPatient.txtFirst.Text | |
coll(modBmk).Item("last") = ufModPatient.txtLast.Text | |
If ufModPatient.optMale.Value Then | |
coll(modBmk).Item("gender") = "M" | |
Else | |
coll(modBmk).Item("gender") = "F" | |
End If | |
coll(modBmk).Item("dob") = ufModPatient.txtDOB.Text | |
coll(modBmk).Item("admit") = ufModPatient.txtAdmit.Text | |
coll(modBmk).Item("resident") = ufModPatient.cboResident.Text | |
coll(modBmk).Item("code") = ufModPatient.cboCode.Text | |
coll(modBmk).Item("mrn") = ufModPatient.txtMRN.Text | |
coll(modBmk).Item("meds") = ufModPatient.txtMeds.Text | |
coll(modBmk).Item("hpi") = ufModPatient.txtHPI.Text | |
coll(modBmk).Item("fu") = ufModPatient.txtFU.Text | |
coll(modBmk).Item("allergies") = ufModPatient.txtAllergies.Text | |
coll(modBmk).Item("ddx") = ufModPatient.txtDDx.Text | |
coll(modBmk).Item("pain") = ufModPatient.txtPain.Text | |
coll(modBmk).Item("ppx") = ufModPatient.txtPPx.Text | |
coll(modBmk).Item("labs") = ufModPatient.txtLabs.Text | |
coll(modBmk).Item("anticoag") = ufModPatient.chkAnticoag.Value | |
coll(modBmk).Item("insulin") = ufModPatient.chkInsulin.Value | |
coll(modBmk).Item("imaging") = ufModPatient.txtImaging.Text | |
coll(modBmk).Item("procedures") = ufModPatient.txtProcedures.Text | |
coll(modBmk).Item("dispo") = ufModPatient.txtDispo.Text | |
coll(modBmk).Item("timestamp") = vTimestamp | |
usr = Environ$("Username") | |
coll(modBmk).Item("username") = UCase(Right(usr, 2) & Left(usr, 1)) | |
Else | |
coll.Remove modBmk | |
Set d = CreateObject("Scripting.Dictionary") | |
d.Add "bmk", ufBmk | |
d.Add "room", ufModPatient.txtRoom.Text | |
d.Add "first", ufModPatient.txtFirst.Text | |
d.Add "last", ufModPatient.txtLast.Text | |
If ufModPatient.optMale.Value Then | |
d.Add "gender", "M" | |
Else | |
d.Add "gender", "F" | |
End If | |
d.Add "dob", ufModPatient.txtDOB.Text | |
d.Add "admit", ufModPatient.txtAdmit.Text | |
d.Add "resident", ufModPatient.cboResident.Text | |
d.Add "code", ufModPatient.cboCode.Text | |
d.Add "mrn", ufModPatient.txtMRN.Text | |
d.Add "meds", ufModPatient.txtMeds.Text | |
d.Add "hpi", ufModPatient.txtHPI.Text | |
d.Add "fu", ufModPatient.txtFU.Text | |
d.Add "allergies", ufModPatient.txtAllergies.Text | |
d.Add "ddx", ufModPatient.txtDDx.Text | |
d.Add "pain", ufModPatient.txtPain.Text | |
d.Add "ppx", ufModPatient.txtPPx.Text | |
d.Add "labs", ufModPatient.txtLabs.Text | |
d.Add "anticoag", ufModPatient.chkAnticoag.Value | |
d.Add "insulin", ufModPatient.chkInsulin.Value | |
d.Add "imaging", ufModPatient.txtImaging.Text | |
d.Add "procedures", ufModPatient.txtProcedures.Text | |
d.Add "dispo", ufModPatient.txtDispo.Text | |
d.Add "timestamp", vTimestamp | |
usr = Environ$("Username") | |
d.Add "username", UCase(Right(usr, 2) & Left(usr, 1)) | |
coll.Add d, ufBmk | |
End If | |
modBmk = vbNullString | |
vTimestamp = vbNullString | |
Unload ufMod | |
End If | |
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' | |
' DELETE | |
If fx = "DEL" Then | |
coll.Remove sort | |
n = n - 1 | |
End If | |
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' | |
' SORT | |
If n <> 0 Then | |
Dim temp | |
If sort = "ROOM" Then | |
For i = 1 To coll.Count - 1 | |
For j = i + 1 To coll.Count | |
If coll(i).Item("room") > coll(j).Item("room") Then | |
Set temp = CreateObject("Scripting.Dictionary") | |
For Each k In coll(j).keys | |
temp.Add k, coll(j)(k) | |
Next | |
For Each k In coll(i).keys | |
coll(j).Item(k) = coll(i)(k) | |
Next | |
For Each k In temp.keys | |
coll(i).Item(k) = temp(k) | |
Next | |
End If | |
Next j | |
Next i | |
ElseIf sort = "RESIDENT" Then | |
For i = 1 To coll.Count - 1 | |
For j = i + 1 To coll.Count | |
If UCase(coll(i).Item("resident")) > UCase(coll(j).Item("resident")) Then | |
Set temp = CreateObject("Scripting.Dictionary") | |
For Each k In coll(j).keys | |
temp.Add k, coll(j)(k) | |
Next | |
For Each k In coll(i).keys | |
coll(j).Item(k) = coll(i)(k) | |
Next | |
For Each k In temp.keys | |
coll(i).Item(k) = temp(k) | |
Next | |
End If | |
Next j | |
Next i | |
Else | |
For i = 1 To coll.Count - 1 | |
For j = i + 1 To coll.Count | |
If coll(i).Item("room") > coll(j).Item("room") Then | |
Set temp = CreateObject("Scripting.Dictionary") | |
For Each k In coll(j).keys | |
temp.Add k, coll(j)(k) | |
Next | |
For Each k In coll(i).keys | |
coll(j).Item(k) = coll(i)(k) | |
Next | |
For Each k In temp.keys | |
coll(i).Item(k) = temp(k) | |
Next | |
End If | |
Next j | |
Next i | |
End If 'end sort | |
End If 'end if bmk 0 | |
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' | |
' DRAW | |
''''''''''''''''''''''''''''''''''''''' | |
' TURN OFF READ ONLY & SCREEN UPDATING | |
If oDoc.ProtectionType <> wdNoProtection Then | |
oDoc.Unprotect | |
End If | |
Application.ScreenUpdating = False | |
ActiveWindow.DisplayVerticalScrollBar = True | |
''''''''''''''''''''''' | |
' DELETE PRIOR ENTRIES | |
'Dim oBookmark As Bookmark | |
'For Each oBookmark In oDoc.Bookmarks | |
' oBookmark.Range.Tables(1).Delete | |
'Next | |
oDoc.StoryRanges(wdMainTextStory).Delete | |
''''''''''''''''' | |
' INSERT ENTRIES | |
For Each d In coll | |
Set oTable = oDoc.Tables.Add(Range:=Selection.Range, NumRows:=6, NumColumns:=1, DefaultTableBehavior:=wdWord9TableBehavior, AutoFitBehavior:=wdAutoFitFixed) | |
oTable.Range.Bookmarks.Add d.Item("bmk") | |
'MsgBox d.Item("bmk") | |
With oTable | |
.Range.Font.Name = "Courier New" | |
.Range.Font.Size = 7 | |
.Range.Paragraphs.LeftIndent = InchesToPoints(0) | |
.Range.Paragraphs.RightIndent = InchesToPoints(0) | |
.Range.ParagraphFormat.SpaceAfter = 0 | |
.Range.ParagraphFormat.SpaceBefore = 0 | |
.Borders.InsideLineStyle = wdLineStyleNone | |
.Borders.OutsideLineStyle = wdLineStyleNone | |
.Borders(wdBorderBottom).LineStyle = wdLineStyleSingle | |
.Borders(wdBorderBottom).LineWidth = wdLineWidth150pt | |
.Range.Paragraphs.KeepWithNext = True | |
'''''''''''''''''''''''''''''''''''''' | |
' SET ROW HEIGHT | |
.Rows.Height = 11 | |
'''''''''''''''''''''''''''''''''''''' | |
' SET CELL WIDTH | |
w = .Rows(1).Cells(1).Width | |
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' | |
' ROW 1 | |
.Rows(1).Cells(1).Split 1, 3 | |
.Rows(1).Cells(1).Width = (w / 10) * 1 | |
.Rows(1).Cells(2).Width = (w / 10) * 5 | |
.Rows(1).Cells(3).Width = (w / 10) * 4 | |
'''''''''''''''''''''''''''''''''''''' | |
' ROOM, PATIENT NAME, ADMIT DATE | |
.Rows(1).Cells(1).Range.Text = d.Item("room") | |
.Rows(1).Cells(2).Range.Text = d.Item("last") & ", " & d.Item("first") & " " & DateDiff("yyyy", d.Item("dob"), Now()) + Int(Format(Now(), "mmdd") < Format(d.Item("dob"), "mmdd")) & "yo " & d.Item("gender") & " (DOB: " & d.Item("dob") & ")" & " (MRN: " & d.Item("mrn") & ")" | |
.Rows(1).Cells(3).Range.Text = "Admit: " & d.Item("admit") & " (" & DateDiff("d", d.Item("admit"), Now) & ")" | |
.Rows(1).Cells(1).Range.Font.Bold = True | |
.Rows(1).Cells(3).Range.ParagraphFormat.Alignment = wdAlignParagraphRight | |
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' | |
' ROW 2 | |
.Rows(2).Cells(1).Split 1, 3 | |
.Rows(2).Cells(1).Width = (w / 10) * 1 | |
.Rows(2).Cells(2).Width = (w / 10) * 5 | |
.Rows(2).Cells(3).Width = (w / 10) * 4 | |
'''''''''''''''''''''''''''''''''''''' | |
' RESIDENT, CODE STATUS | |
.Rows(2).Cells(2).Range.Text = d.Item("resident") | |
.Rows(2).Cells(3).Range.Text = d.Item("code") | |
.Rows(2).Cells(3).Range.ParagraphFormat.Alignment = wdAlignParagraphRight | |
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' | |
' ROW 3 | |
.Rows(3).Cells(1).Split 1, 3 | |
.Rows(3).Cells(1).Width = (w / 10) * 2 | |
.Rows(3).Cells(2).Width = (w / 10) * 6 | |
.Rows(3).Cells(3).Width = (w / 10) * 2 | |
'''''''''''''''''''''''''''''''''''''' | |
' MEDICATION, HPI, FOLLOW UP | |
If d.Item("meds") <> "" Then | |
.Rows(3).Cells(1).Range.Text = d.Item("meds") | |
Else | |
.Rows(3).Cells(1).Range.Text = "Rx: " | |
End If | |
.Rows(3).Cells(2).Range.Text = d.Item("hpi") | |
If d.Item("fu") <> "" Then | |
arr = Split(d.Item("fu"), vbCr) | |
Dim sArr() As String | |
ReDim sArr(UBound(arr)) | |
For x = 0 To UBound(arr) | |
fuS = Trim(Replace(arr(x), vbLf, "")) | |
If fuS = "" Then | |
sArr(x) = "" | |
Else | |
sArr(x) = ChrW(&H2610) & " " & Trim(Replace(arr(x), vbLf, "")) | |
End If | |
Next x | |
.Rows(3).Cells(3).Range.Text = Join(sArr, vbCrLf) | |
Else | |
.Rows(3).Cells(3).Range.Text = "F/U: " | |
End If | |
'.Rows(3).Cells(3).Range.Text = "F/U: " & d.Item("fu") | |
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' | |
' ROW 4 | |
.Rows(4).Cells(1).Split 1, 3 | |
.Rows(4).Cells(1).Width = (w / 10) * 2 | |
.Rows(4).Cells(2).Width = (w / 10) * 6 | |
.Rows(4).Cells(3).Width = (w / 10) * 2 | |
If d.Item("allergies") <> "" Then | |
.Rows(4).Cells(1).VerticalAlignment = wdCellAlignVerticalCenter | |
.Rows(4).Cells(1).Range.Text = "Allergies: " & d.Item("allergies") | |
Else | |
.Rows(4).Cells(1).Range.Text = "" | |
End If | |
.Rows(4).Cells(2).Height = 14 | |
.Rows(4).Cells(2).VerticalAlignment = wdCellAlignVerticalCenter | |
.Rows(4).Cells(2).Range.Text = "DDx: " & d.Item("ddx") | |
If d.Item("pain") <> "" Then | |
.Rows(4).Cells(3).VerticalAlignment = wdCellAlignVerticalCenter | |
.Rows(4).Cells(3).Range.Text = "Pain: " & d.Item("pain") | |
Else | |
.Rows(4).Cells(3).Range.Text = "" | |
End If | |
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' | |
' ROW 5 | |
.Rows(5).Cells(1).Split 1, 3 | |
.Rows(5).Cells(1).Width = (w / 10) * 2 | |
.Rows(5).Cells(2).Width = (w / 10) * 6 | |
.Rows(5).Cells(3).Width = (w / 10) * 2 | |
.Rows(5).Cells(2).Split 3, 1 | |
If d.Item("labs") <> "" Then | |
.Range.Cells(14).Height = 14 | |
.Range.Cells(14).VerticalAlignment = wdCellAlignVerticalCenter | |
.Range.Cells(14).Range.Text = "- " & d.Item("labs") | |
Else | |
.Range.Cells(14).Height = 0 | |
.Range.Cells(14).Range.Text = "" | |
End If | |
If d.Item("imaging") <> "" Then | |
.Range.Cells(16).Height = 14 | |
.Range.Cells(16).VerticalAlignment = wdCellAlignVerticalCenter | |
.Range.Cells(16).Range.Text = "- " & d.Item("imaging") | |
Else | |
.Range.Cells(16).Height = 0 | |
.Range.Cells(16).Range.Text = "" | |
End If | |
If d.Item("procedures") <> "" Then | |
.Range.Cells(17).Height = 14 | |
.Range.Cells(17).VerticalAlignment = wdCellAlignVerticalCenter | |
.Range.Cells(17).Range.Text = "- " & d.Item("procedures") | |
Else | |
.Range.Cells(17).Height = 0 | |
.Range.Cells(17).Range.Text = "" | |
End If | |
' If d.Item("labs") = "" And d.Item("imaging") = "" And d.Item("procedures") = "" Then | |
' | |
' ElseIf d.Item("labs") = "" And d.Item("imaging") = "" Then | |
' .Rows(5).Cells(2).Split 1, 1 | |
' .Range.Cells(14).Range.Text = "Procedures: " & d.Item("procedures") | |
' | |
' ElseIf d.Item("imaging") = "" And d.Item("procedures") = "" Then | |
' .Rows(5).Cells(2).Split 1, 1 | |
' .Range.Cells(14).Range.Text = "Labs: " & d.Item("labs") | |
' | |
' MsgBox d.Item("labs"), vbOKOnly, "INSERT LABS " & d.Item("room") | |
' | |
' ElseIf d.Item("labs") = "" And d.Item("procedures") = "" Then | |
' .Rows(5).Cells(2).Split 1, 1 | |
' .Range.Cells(14).Range.Text = "Imaging: " & d.Item("imaging") | |
' | |
' ElseIf d.Item("labs") = "" Then | |
' .Rows(5).Cells(2).Split 2, 1 | |
' .Range.Cells(14).Range.Text = "Imaging: " & d.Item("imaging") | |
' .Range.Cells(16).Range.Text = "Procedures: " & d.Item("procedures") | |
' | |
' ElseIf d.Item("imaging") = "" Then | |
' .Rows(5).Cells(2).Split 2, 1 | |
' .Range.Cells(14).Range.Text = "Labs: " & d.Item("labs") | |
' .Range.Cells(16).Range.Text = "Procedures: " & d.Item("procedures") | |
' | |
' ElseIf d.Item("procedures") = "" Then | |
' .Rows(5).Cells(2).Split 2, 1 | |
' .Range.Cells(14).Range.Text = "Labs: " & d.Item("labs") | |
' .Range.Cells(16).Range.Text = "Imaging: " & d.Item("imaging") | |
' | |
' Else | |
' .Rows(5).Cells(2).Split 3, 1 | |
' .Range.Cells(14).Range.Text = "Labs: " & d.Item("labs") | |
' .Range.Cells(16).Range.Text = "Imaging: " & d.Item("imaging") | |
' .Range.Cells(17).Range.Text = "Procedures: " & d.Item("procedures") | |
' End If | |
If d.Item("ppx") <> "" Then | |
.Range.Cells(13).Range.Text = "PPx: " & d.Item("ppx") | |
Else | |
.Range.Cells(13).Range.Text = "" | |
End If | |
If d.Item("anticoag") And d.Item("insulin") Then | |
.Range.Cells(15).Range.Text = ChrW(&H2611) & " Anticoagulated" & vbCrLf & ChrW(&H2611) & " Insulin" | |
ElseIf d.Item("anticoag") Then | |
.Range.Cells(15).Range.Text = ChrW(&H2611) & " Anticoagulated" | |
ElseIf d.Item("insulin") Then | |
.Range.Cells(15).Range.Text = ChrW(&H2611) & " Insulin" | |
End If | |
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' | |
' ROW 6 | |
tCell = .Range.Cells.Count | |
.Range.Cells(tCell).Height = 16 | |
.Range.Cells(tCell).Split 1, 2 | |
.Range.Cells(tCell).Width = (w / 10) * 7 | |
.Range.Cells(tCell + 1).Width = (w / 10) * 3 | |
.Range.Cells(tCell).Range.Text = "Dispo: " & d.Item("dispo") | |
.Range.Cells(tCell + 1).Range.ParagraphFormat.Alignment = wdAlignParagraphRight | |
.Range.Cells(tCell + 1).Range.Text = d.Item("timestamp") & " (" & d.Item("username") & ")" | |
'''''''''''''''''''''''''''''''''''''' | |
' SPACING | |
'.Range.Cells(tCell + 1).Select | |
'Selection.MoveDown Unit:=wdLine, Count:=1 | |
'Selection.InsertParagraph | |
'Selection.EndKey Unit:=wdStory | |
With Selection | |
.MoveDown Unit:=wdLine, Count:=1 | |
.EndKey Unit:=wdStory | |
.Collapse Direction:=wdCollapseStart | |
.InsertParagraph | |
.Collapse Direction:=wdCollapseEnd | |
.EndKey Unit:=wdStory | |
End With | |
End With | |
Next d | |
Set coll = Nothing | |
ActiveDocument.Sections(1).PageSetup.DifferentFirstPageHeaderFooter = True | |
docHeader = ActiveDocument.Sections(1).Headers(wdHeaderFooterFirstPage) | |
oldHeader = docHeader.Tables(1).Delete | |
Set headerTable = ActiveDocument.Tables.Add(Range:=docHeader, NumRows:=1, NumColumns:=1, DefaultTableBehavior:=wdWord9TableBehavior, AutoFitBehavior:=wdAutoFitFixed) | |
With headerTable | |
'.Rows.Height = 14 | |
.Borders.InsideLineStyle = wdLineStyleNone | |
.Borders.OutsideLineStyle = wdLineStyleNone | |
w = .Rows(1).Cells(1).Width | |
.Rows(1).Cells(1).Split 1, 2 | |
.Rows(1).Cells(1).Width = (w / 10) * 8 | |
.Rows(1).Cells(2).Width = (w / 10) * 2 | |
.Rows(1).Cells(1).Range.ParagraphFormat.Alignment = wdAlignParagraphLeft | |
.Rows(1).Cells(2).Range.ParagraphFormat.Alignment = wdAlignParagraphRight | |
.Rows(1).Cells(1).Range.Text = "Total (" & n & "), " & residentTotals() | |
.Rows(1).Cells(2).Range.Text = Format(Now, "dddd, mmmm d, yyyy") | |
End With | |
ActiveDocument.Sections(1).Headers(wdHeaderFooterPrimary).Range.Text = Format(Now, "dddd, mmmm d, yyyy") | |
'''''''''''''''''''' | |
' TURN ON READ ONLY | |
Selection.HomeKey Unit:=wdStory | |
oDoc.Protect wdAllowOnlyReading | |
SaveToRelativePath | |
Call StartClock | |
Done: | |
Exit Sub | |
eh: | |
pathName = ActiveDocument.FullName | |
onlyName = Mid(pathName, InStrRev(pathName, "\") + 1, InStrRev(pathName, "--") - InStrRev(pathName, "\") - 1) | |
ext = Right(pathName, Len(pathName) - InStrRev(pathName, ".")) | |
compName = Mid(pathName, InStrRev(pathName, "\") + 1, InStrRev(pathName, ".") - InStrRev(pathName, "\") - 1) | |
fileDate = Right(compName, Len(compName) - InStrRev(compName, "--") - 1) | |
rPath = ThisDocument.Path & "\" & onlyName & "--" & fileDate & "." & ext | |
aPath = ThisDocument.Path & "\ARCHIVE\BACKUP\" & onlyName & "--" & fileDate & "." & ext | |
Dim fso As Object | |
Set fso = VBA.CreateObject("Scripting.FileSystemObject") | |
Call fso.CopyFile(rPath, aPath) | |
MsgBox "Error " & Err.Number & ": " & Err.Description | |
Debug.Print "Error " & Err.Number & ": " & Err.Description | |
procName = Application.VBE.ActiveCodePane.CodeModule.ProcOfLine(Application.VBE.ActiveCodePane.TopLine, 0) | |
Debug.Print "Error " & Err.Number & ": " & Err.Description & " in module " & VBE.ActiveCodePane.CodeModule & " sub " & procName & "()" | |
MsgBox "Error " & Err.Number & ": " & Err.Description & " in module " & VBE.ActiveCodePane.CodeModule & ", sub " & procName & "()", vbOKOnly, "Error" | |
End Sub | |
Public Function residentTotals() | |
Dim n As Integer | |
n = ActiveDocument.Bookmarks.Count | |
Dim bmkArray() | |
ReDim bmkArray(1 To n) | |
For i = 1 To n | |
nameSplit = Split(ActiveDocument.Bookmarks(i).Name, "_") | |
bmkArray(i) = nameSplit(0) | |
Next | |
Dim arr As New Collection, a | |
On Error Resume Next | |
For Each a In bmkArray | |
arr.Add a, a | |
Next | |
Dim resTotals() | |
ReDim resTotals(1 To arr.Count) | |
For j = 1 To arr.Count | |
cnt = UBound(Filter(bmkArray, arr(j), True, 1)) + 1 | |
resTotals(j) = arr(j) & " (" & cnt & ")" | |
Next | |
residentTotals = Join(resTotals, ", ") | |
End Function |
This file contains 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 characters
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 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 characters
Sub SaveToRelativePath() | |
Dim rPath As String | |
Dim aPath As String | |
'epoch = DateDiff("S", "1/1/1970", Now()) | |
dateNow = Format(Now(), "yyyy-MM-dd") | |
pathName = ActiveDocument.FullName | |
onlyName = Mid(pathName, InStrRev(pathName, "\") + 1, InStrRev(pathName, "--") - InStrRev(pathName, "\") - 1) | |
ext = Right(pathName, Len(pathName) - InStrRev(pathName, ".")) | |
compName = Mid(pathName, InStrRev(pathName, "\") + 1, InStrRev(pathName, ".") - InStrRev(pathName, "\") - 1) | |
fileDate = Right(compName, Len(compName) - InStrRev(compName, "--") - 1) | |
If InStr(pathName, "ARCHIVE") = 0 Then | |
If fileDate = dateNow Then | |
rPath = ThisDocument.Path & "\" & onlyName & "--" & dateNow & "." & ext | |
aPath = ThisDocument.Path & "\ARCHIVE\" & onlyName & "--" & dateNow & "." & ext | |
ActiveDocument.SaveAs FileName:=aPath | |
ActiveDocument.SaveAs FileName:=rPath | |
Else | |
secNow = Format(Now(), "hhmmss") | |
rPath = ThisDocument.Path & "\" & onlyName & "--" & dateNow & "." & ext | |
aPath = ThisDocument.Path & "\ARCHIVE\" & onlyName & "--" & dateNow & "-" & secNow & "." & ext | |
delPath = ThisDocument.Path & "\" & onlyName & "--" & fileDate & "." & ext | |
ActiveDocument.SaveAs FileName:=aPath | |
ActiveDocument.SaveAs FileName:=rPath | |
If FileExists(aPath) And FileExists(rPath) Then | |
If FileExists(delPath) Then | |
SetAttr delPath, vbNormal | |
Kill delPath | |
End If | |
End If | |
End If | |
End If | |
'compName = Mid(pathName, InStrRev(pathName, "\") + 1, InStrRev(pathName, ".") - InStrRev(pathName, "\") - 1) | |
'fileDate = Right(compName, Len(compName) - InStrRev(compName, "--") - 1) | |
'If fileDate = dateNow Then | |
'MsgBox "Same Date" | |
'Application.DisplayAlerts = False | |
' rPath = ThisDocument.Path & "\" & onlyName & "--" & dateNow & "." & ext | |
' ActiveDocument.SaveAs FileName:=rPath | |
'Application.DisplayAlerts = True | |
'Else | |
'MsgBox "Different Date" | |
' rPath = ThisDocument.Path & "\" & onlyName & "--" & dateNow & "." & ext | |
' ActiveDocument.SaveAs FileName:=rPath | |
'End If | |
End Sub | |
Function FileExists(ByVal FileToTest As String) As Boolean | |
FileExists = (Dir(FileToTest) <> "") | |
End Function |
This file contains 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 characters
Public Sub AutoOpen() | |
'ThisDocument.Application.ActiveWindow.View.Zoom.PageColumns = 1 | |
'ThisDocument.Application.ActiveWindow.View.Zoom.Percentage = 100 | |
ThisDocument.Application.ActiveWindow.View.Type = wdPrintView | |
ThisDocument.Application.ActiveWindow.View.Zoom.PageFit = wdPageFitBestFit | |
ThisDocument.Application.Caption = "SIGNOUT" | |
'ThisDocument.Application.ActiveWindow.Caption = "SIGNOUT" | |
With ActiveDocument.Styles(wdStyleNormal).Font | |
.Size = 1 | |
End With | |
ActiveDocument.ActiveWindow.View.ReadingLayout = False | |
'MsgBox ThisDocument.Application.UsableWidth | |
SaveToRelativePath | |
Call StartClock | |
End Sub | |
Sub RunFormAddPatient() | |
Call StopClock | |
Set ufAdd = New ufAddPatient | |
ufAdd.Show vbModeless | |
Call StartClock | |
End Sub | |
Sub RunFormSelectPatient() | |
Call StopClock | |
Dim frm As New ufSelectPatient | |
frm.Show | |
Call StartClock | |
End Sub | |
Sub RunFormDeletePatient() | |
Call StopClock | |
Dim frm As New ufDeletePatient | |
frm.Show | |
Call StartClock | |
End Sub | |
Sub sortNumbers() | |
Call StopClock | |
Call main("", "ROOM") | |
Call StartClock | |
End Sub | |
Sub sortNames() | |
Call StopClock | |
Call main("", "RESIDENT") | |
Call StartClock | |
End Sub | |
Sub ShowPrintDialog() | |
Dialogs(wdDialogFilePrint).Show | |
End Sub | |
Sub resetZoom() | |
ActiveDocument.ActiveWindow.View.Zoom.Percentage = 100 | |
End Sub | |
Sub fitZoom() | |
ActiveDocument.ActiveWindow.View.Zoom.PageFit = wdPageFitBestFit | |
End Sub | |
Sub whatPath() | |
MsgBox ActiveDocument.FullName | |
End Sub | |
Private Sub Document_Close() | |
Call StopClock | |
ActiveDocument.Save | |
Me.Saved = True | |
End Sub |
This file contains 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 characters
Private Sub UserForm_Initialize() | |
'Me.txtRoom.Value = "1234" | |
'Me.txtFirst.Value = "First" | |
'Me.txtLast.Value = "Last" | |
'Me.txtDOB.Value = "12/25/2017" | |
'Me.cboCode.Value = "Full Code" | |
'Me.txtMRN.Value = "123456" | |
'Me.cboResident.Value = "PGuilford" | |
'Me.txtMeds.Value = "meds" | |
'Me.txtHPI.Value = "Lorem ipsum dolor sit amet, consectetur adipiscing elit, sed do eiusmod tempor incididunt ut labore et dolore magna aliqua. Ut enim ad minim veniam, quis nostrud exercitation ullamco laboris nisi ut aliquip ex ea commodo consequat. Duis aute irure dolor in reprehenderit in voluptate velit esse cillum dolore eu fugiat nulla pariatur. Excepteur sint occaecat cupidatat non proident, sunt in culpa qui officia deserunt mollit anim id est laborum." | |
'Me.txtFU.Value = "f/u this" | |
Me.txtAdmit.Value = Format(Date, "mm/dd/yyyy") | |
Me.cboCode.List = codeArray() | |
Me.cboResident.List = residentArray() | |
End Sub | |
Private Sub cmdCommit_Click() | |
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' | |
' ROOM | |
If Len(txtRoom) <> 4 Then | |
MsgBox "A four-digit room number is required.", vbOKOnly, "Room Error" | |
txtRoom.SetFocus | |
Exit Sub | |
ElseIf IsNumeric(txtRoom) = False Then | |
MsgBox "Your room number contains alpha characters.", vbOKOnly, "Room Error" | |
txtRoom.SetFocus | |
Exit Sub | |
End If | |
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' | |
' NAME | |
If Len(txtLast) = 0 Or Len(txtFirst) = 0 Then | |
MsgBox "Both first and last names are required.", vbOKOnly, "Name Error" | |
If Len(txtLast) = 0 Then | |
txtLast.SetFocus | |
Else | |
txtFirst.SetFocus | |
End If | |
Exit Sub | |
End If | |
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' | |
' DATE OF BIRTH | |
If IsDate(txtDOB) Then | |
If Not dateCheckDOB(txtDOB) Then | |
MsgBox "Please enter date as MM/DD/YYYY.", vbOKOnly, "DOB Error" | |
txtDOB.SetFocus | |
Exit Sub | |
Else | |
'MsgBox "This is a date.", vbOKOnly, "DOB Error" | |
End If | |
Else | |
If Len(txtDOB) = 0 Then | |
MsgBox "Date of Birth is required.", vbOKOnly, "DOB Error" | |
Else | |
MsgBox "Please check date of birth.", vbOKOnly, "DOB Error" | |
End If | |
txtDOB.SetFocus | |
Exit Sub | |
End If | |
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' | |
' GENDER | |
If optMale = False And optFemale = False Then | |
MsgBox "Please select gender.", vbOKOnly, "Gender Error" | |
optMale.SetFocus | |
Exit Sub | |
End If | |
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' | |
' ADMIT DATE | |
If IsDate(txtAdmit) Then | |
If Not dateCheckAdmit(txtAdmit) Then | |
MsgBox "Please enter date as MM/DD/YYYY.", vbOKOnly, "Admission Date Error" | |
txtAdmit.SetFocus | |
Exit Sub | |
End If | |
Else | |
If Len(txtAdmit) = 0 Then | |
MsgBox "Admission date is required.", vbOKOnly, "Admission Date Error" | |
Else | |
MsgBox "Please check admission date.", vbOKOnly, "Admission Date Error" | |
End If | |
txtAdmit.SetFocus | |
Exit Sub | |
End If | |
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' | |
' CODE STATUS | |
If Len(cboCode) = 0 Then | |
MsgBox "Please select a code status.", vbOKOnly, "Code Status Error" | |
cboCode.SetFocus | |
Exit Sub | |
End If | |
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' | |
' MRN | |
If Len(txtMRN) <> 6 Then | |
MsgBox "MRN is six digits.", vbOKOnly, "MRN Error" | |
txtMRN.SetFocus | |
Exit Sub | |
End If | |
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' | |
' RESIDENT | |
If Len(cboResident) = 0 Then | |
MsgBox "Please select a resident.", vbOKOnly, "Resident Error" | |
cboResident.SetFocus | |
Exit Sub | |
End If | |
ufAddPatient.txtRoom.Text = Me.txtRoom.Value | |
ufAddPatient.txtFirst.Text = StrConv(Me.txtFirst.Value, vbProperCase) | |
ufAddPatient.txtLast.Text = StrConv(Me.txtLast.Value, vbProperCase) | |
ufAddPatient.txtDOB.Text = Me.txtDOB.Value | |
ufAddPatient.optMale.Value = Me.optMale.Value | |
ufAddPatient.optFemale.Value = Me.optFemale.Value | |
ufAddPatient.txtAdmit.Text = Me.txtAdmit.Value | |
ufAddPatient.cboCode.Value = Me.cboCode.Value | |
ufAddPatient.txtMRN.Value = Me.txtMRN.Value | |
ufAddPatient.txtMeds.Text = Me.txtMeds.Value | |
ufAddPatient.txtHPI.Text = Me.txtHPI.Value | |
ufAddPatient.txtFU.Text = Me.txtFU.Value | |
ufAddPatient.txtAllergies.Text = Me.txtAllergies.Value | |
ufAddPatient.txtPPx.Text = Me.txtPPx.Value | |
ufAddPatient.txtDDx.Text = Me.txtDDx.Value | |
ufAddPatient.txtPain.Text = Me.txtPain.Value | |
ufAddPatient.txtLabs.Text = Me.txtLabs.Value | |
ufAddPatient.txtImaging.Text = Me.txtImaging.Value | |
ufAddPatient.txtProcedures.Text = Me.txtProcedures.Value | |
ufAddPatient.chkAnticoag.Value = Me.chkAnticoag.Value | |
ufAddPatient.chkInsulin.Value = Me.chkInsulin.Value | |
ufAddPatient.cboResident.Value = Me.cboResident.Value | |
ufAddPatient.txtDispo.Text = Me.txtDispo.Value | |
If Me.chkTime.Value = True Then | |
vTimestamp = Now() | |
Else | |
vTimestamp = dict.Item("timestamp") | |
End If | |
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' | |
' CHECK IF ROOM EXISTS | |
Dim n As Integer | |
n = ActiveDocument.Bookmarks.Count | |
If n <> 0 Then | |
Dim roomArray() | |
ReDim roomArray(1 To n) | |
For i = 1 To n | |
roomArray(i) = Split(ActiveDocument.Bookmarks(i).Name, "_")(1) | |
Next | |
d = "#" | |
s = Join(roomArray, d) | |
s = d & s & d | |
If InStr(1, s, d & ufAddPatient.txtRoom.Text & d, vbBinaryCompare) Then | |
MsgBox "Room " & Me.txtRoom.Value & " is already on census.", vbOKOnly, "Room Number Exists" | |
txtRoom.SetFocus | |
Exit Sub | |
End If | |
End If | |
'Me.Hide | |
ufAdd.Hide | |
Call main("ADD", "ROOM") | |
End Sub | |
Private Sub cmdCancel_Click() | |
Unload Me | |
End | |
End Sub | |
Function dateCheckDOB(dateValueDOB As String) As Boolean | |
If Format(CDate(txtDOB), "mm/dd/yyyy") = dateValueDOB Or _ | |
Format(CDate(txtDOB), "m/d/yyyy") = dateValueDOB Or _ | |
Format(CDate(txtDOB), "mm/d/yyyy") = dateValueDOB Or _ | |
Format(CDate(txtDOB), "m/dd/yyyy") = dateValueDOB Then | |
dateCheckDOB = True | |
End If | |
End Function | |
Function dateCheckAdmit(dateValueAdmit As String) As Boolean | |
If Format(CDate(txtAdmit), "mm/dd/yyyy") = dateValueAdmit Or _ | |
Format(CDate(txtAdmit), "m/d/yyyy") = dateValueAdmit Or _ | |
Format(CDate(txtAdmit), "mm/d/yyyy") = dateValueAdmit Or _ | |
Format(CDate(txtAdmit), "m/dd/yyyy") = dateValueAdmit Then | |
dateCheckAdmit = True | |
End If | |
End Function |
This file contains 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 characters
Private Sub UserForm_Initialize() | |
Dim n As Integer | |
n = ActiveDocument.Bookmarks.Count | |
Dim bmkArray() | |
ReDim bmkArray(1 To n) | |
For i = 1 To n | |
nameSplit = Split(ActiveDocument.Bookmarks(i).Name, "_") | |
bmkArray(i) = nameSplit(1) & vbTab & vbTab & nameSplit(0) | |
Next | |
x = LBound(bmkArray) | |
y = UBound(bmkArray) | |
For i = x To y - 1 | |
For j = i + 1 To y | |
If bmkArray(i) > bmkArray(j) Then | |
temp = bmkArray(i) | |
bmkArray(i) = bmkArray(j) | |
bmkArray(j) = temp | |
End If | |
Next j | |
Next i | |
listPts.List = bmkArray | |
End Sub | |
Private Sub cmdSelect_Click() | |
usrSel = Split(Me.listPts.Value, vbTab & vbTab) | |
usrSelection = usrSel(1) & "_" & usrSel(0) | |
strPrompt = "Remove " & usrSel(0) & " from census?" | |
strTitle = "Delete" | |
If MsgBox(strPrompt, vbYesNo, strTitle) = vbNo Then | |
listPts.SetFocus | |
Exit Sub | |
End If | |
Me.Hide | |
Call main("DEL", usrSelection) | |
End Sub |
This file contains 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 characters
Private Sub UserForm_Initialize() | |
Me.txtRoom.Value = dict.Item("room") | |
Me.txtFirst.Value = dict.Item("first") | |
Me.txtLast.Value = dict.Item("last") | |
Me.txtDOB.Value = dict.Item("dob") | |
If dict.Item("gender") = "M" Then | |
Me.optMale.Value = True | |
Else | |
Me.optFemale.Value = True | |
End If | |
Me.txtAdmit.Value = dict.Item("admit") | |
Me.cboCode.Value = dict.Item("code") | |
Me.txtMRN.Value = dict.Item("mrn") | |
Me.txtMeds.Value = dict.Item("meds") | |
Me.txtHPI.Value = dict.Item("hpi") | |
Me.txtFU.Value = dict.Item("fu") | |
Me.txtAllergies.Value = dict.Item("allergies") | |
Me.txtDDx.Value = dict.Item("ddx") | |
Me.txtPain.Value = dict.Item("pain") | |
Me.txtLabs.Value = dict.Item("labs") | |
Me.txtImaging.Value = dict.Item("imaging") | |
Me.txtProcedures.Value = dict.Item("procedures") | |
Me.txtDispo.Value = dict.Item("dispo") | |
Me.txtPPx.Value = dict.Item("ppx") | |
Me.cboResident.Value = dict.Item("resident") | |
Me.chkAnticoag.Value = dict.Item("anticoag") | |
Me.chkInsulin.Value = dict.Item("insulin") | |
Me.cboCode.List = codeArray() | |
Me.cboResident.List = residentArray() | |
End Sub | |
Private Sub cmdCommit_Click() | |
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' | |
' ROOM | |
If Len(txtRoom) <> 4 Then | |
MsgBox "A four-digit room number is required.", vbOKOnly, "Room Error" | |
txtRoom.SetFocus | |
Exit Sub | |
ElseIf IsNumeric(txtRoom) = False Then | |
MsgBox "Your room number contains alpha characters.", vbOKOnly, "Room Error" | |
txtRoom.SetFocus | |
Exit Sub | |
End If | |
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' | |
' NAME | |
If Len(txtLast) = 0 Or Len(txtFirst) = 0 Then | |
MsgBox "Both first and last names are required.", vbOKOnly, "Name Error" | |
If Len(txtLast) = 0 Then | |
txtLast.SetFocus | |
Else | |
txtFirst.SetFocus | |
End If | |
Exit Sub | |
End If | |
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' | |
' DATE OF BIRTH | |
If IsDate(txtDOB) Then | |
If Not dateCheckDOB(txtDOB) Then | |
MsgBox "Please enter date as MM/DD/YYYY.", vbOKOnly, "DOB Error" | |
txtDOB.SetFocus | |
Exit Sub | |
Else | |
'MsgBox "This is a date.", vbOKOnly, "DOB Error" | |
End If | |
Else | |
If Len(txtDOB) = 0 Then | |
MsgBox "Date of Birth is required.", vbOKOnly, "DOB Error" | |
Else | |
MsgBox "Please check date of birth.", vbOKOnly, "DOB Error" | |
End If | |
txtDOB.SetFocus | |
Exit Sub | |
End If | |
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' | |
' GENDER | |
If optMale = False And optFemale = False Then | |
MsgBox "Please select gender.", vbOKOnly, "Gender Error" | |
optMale.SetFocus | |
Exit Sub | |
End If | |
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' | |
' ADMIT DATE | |
If IsDate(txtAdmit) Then | |
If Not dateCheckAdmit(txtAdmit) Then | |
MsgBox "Please enter date as MM/DD/YYYY.", vbOKOnly, "Admission Date Error" | |
txtAdmit.SetFocus | |
Exit Sub | |
End If | |
Else | |
If Len(txtAdmit) = 0 Then | |
MsgBox "Admission date is required.", vbOKOnly, "Admission Date Error" | |
Else | |
MsgBox "Please check admission date.", vbOKOnly, "Admission Date Error" | |
End If | |
txtAdmit.SetFocus | |
Exit Sub | |
End If | |
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' | |
' CODE STATUS | |
If Len(cboCode) = 0 Then | |
MsgBox "Please select a code status.", vbOKOnly, "Code Status Error" | |
cboCode.SetFocus | |
Exit Sub | |
End If | |
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' | |
' MRN | |
If Len(txtMRN) <> 6 Then | |
MsgBox "MRN is six digits.", vbOKOnly, "MRN Error" | |
txtMRN.SetFocus | |
Exit Sub | |
End If | |
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' | |
' RESIDENT | |
If Len(cboResident) = 0 Then | |
MsgBox "Please select a resident.", vbOKOnly, "Resident Error" | |
cboResident.SetFocus | |
Exit Sub | |
End If | |
ufModPatient.txtRoom.Text = Me.txtRoom.Value | |
ufModPatient.txtFirst.Text = Me.txtFirst.Value | |
ufModPatient.txtLast.Text = Me.txtLast.Value | |
ufModPatient.txtDOB.Text = Me.txtDOB.Value | |
ufModPatient.optMale.Value = Me.optMale.Value | |
ufModPatient.optFemale.Value = Me.optFemale.Value | |
ufModPatient.txtAdmit.Text = Me.txtAdmit.Value | |
ufModPatient.cboCode.Value = Me.cboCode.Value | |
ufModPatient.txtMRN.Value = Me.txtMRN.Value | |
ufModPatient.txtMeds.Text = Me.txtMeds.Value | |
ufModPatient.txtHPI.Text = Me.txtHPI.Value | |
ufModPatient.txtFU.Text = Me.txtFU.Value | |
ufModPatient.txtAllergies.Text = Me.txtAllergies.Value | |
ufModPatient.txtPPx.Text = Me.txtPPx.Value | |
ufModPatient.txtDDx.Text = Me.txtDDx.Value | |
ufModPatient.txtPain.Text = Me.txtPain.Value | |
ufModPatient.txtLabs.Text = Me.txtLabs.Value | |
ufModPatient.txtImaging.Text = Me.txtImaging.Value | |
ufModPatient.txtProcedures.Text = Me.txtProcedures.Value | |
ufModPatient.chkAnticoag.Value = Me.chkAnticoag.Value | |
ufModPatient.chkInsulin.Value = Me.chkInsulin.Value | |
ufModPatient.cboResident.Value = Me.cboResident.Value | |
ufModPatient.txtDispo.Text = Me.txtDispo.Value | |
If Me.chkTime.Value = True Then | |
vTimestamp = Now() | |
Else | |
vTimestamp = dict.Item("timestamp") | |
End If | |
If ufModPatient.txtRoom.Text <> dict.Item("room") Then | |
strPrompt = "Change room number?" | |
strTitle = "Room Number Check" | |
userResponse = MsgBox(strPrompt, vbYesNo, strTitle) | |
If userResponse = vbNo Then | |
txtRoom.SetFocus | |
Exit Sub | |
Else | |
Dim n As Integer | |
n = ActiveDocument.Bookmarks.Count | |
Dim roomArray() | |
ReDim roomArray(1 To n) | |
For i = 1 To n | |
roomArray(i) = Split(ActiveDocument.Bookmarks(i).Name, "_")(1) | |
Next | |
d = "#" | |
s = Join(roomArray, d) | |
s = d & s | |
If InStr(1, s, d & ufAddPatient.txtRoom.Text & d, vbBinaryCompare) Then | |
'MsgBox "Room number is already on cencus.", vbOKOnly, "Room Number Exists" | |
MsgBox "Room " & Me.txtRoom.Value & " is already on census.", vbOKOnly, "Room Number Exists" | |
txtRoom.SetFocus | |
Exit Sub | |
End If | |
End If | |
End If | |
If ufModPatient.cboResident.Value <> dict.Item("resident") Then | |
strPrompt = "Change resident assignment?" | |
strTitle = "Resident" | |
If MsgBox(strPrompt, vbYesNo, strTitle) = vbNo Then | |
cboResident.SetFocus | |
Exit Sub | |
End If | |
End If | |
ufMod.Hide | |
Call main("MOD", "ROOM") | |
dict.RemoveAll | |
End Sub | |
Private Sub cmdCancel_Click() | |
Unload Me | |
End | |
End Sub | |
Function dateCheckDOB(dateValueDOB As String) As Boolean | |
If Format(CDate(txtDOB), "mm/dd/yyyy") = dateValueDOB Or _ | |
Format(CDate(txtDOB), "m/d/yyyy") = dateValueDOB Or _ | |
Format(CDate(txtDOB), "mm/d/yyyy") = dateValueDOB Or _ | |
Format(CDate(txtDOB), "m/dd/yyyy") = dateValueDOB Then | |
dateCheckDOB = True | |
End If | |
End Function | |
Function dateCheckAdmit(dateValueAdmit As String) As Boolean | |
If Format(CDate(txtAdmit), "mm/dd/yyyy") = dateValueAdmit Or _ | |
Format(CDate(txtAdmit), "m/d/yyyy") = dateValueAdmit Or _ | |
Format(CDate(txtAdmit), "mm/d/yyyy") = dateValueAdmit Or _ | |
Format(CDate(txtAdmit), "m/dd/yyyy") = dateValueAdmit Then | |
dateCheckAdmit = True | |
End If | |
End Function |
This file contains 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 characters
Private Sub UserForm_Initialize() | |
Dim n As Integer | |
n = ActiveDocument.Bookmarks.Count | |
Dim bmkArray() | |
ReDim bmkArray(1 To n) | |
For i = 1 To n | |
nameSplit = Split(ActiveDocument.Bookmarks(i).Name, "_") | |
bmkArray(i) = nameSplit(1) & vbTab & vbTab & nameSplit(0) | |
Next | |
x = LBound(bmkArray) | |
y = UBound(bmkArray) | |
For i = x To y - 1 | |
For j = i + 1 To y | |
If bmkArray(i) > bmkArray(j) Then | |
temp = bmkArray(i) | |
bmkArray(i) = bmkArray(j) | |
bmkArray(j) = temp | |
End If | |
Next j | |
Next i | |
listPts.List = bmkArray | |
End Sub | |
Private Sub cmdSelect_Click() | |
usrSel = Split(Me.listPts.Value, vbTab & vbTab) | |
usrSelection = usrSel(1) & "_" & usrSel(0) | |
Me.Hide | |
tblDict (usrSelection) | |
Set ufMod = New ufModPatient | |
ufMod.Show vbModeless | |
End Sub | |
Sub tblDict(usrSel As String) | |
modBmk = usrSel | |
Set oTable = ActiveDocument.Bookmarks(usrSel).Range.Tables(1) | |
Set dict = CreateObject("Scripting.Dictionary") | |
dict.Add "room", Split(oTable.Cell(1, 1).Range.Text, vbCr)(0) | |
nameDOB = Split(oTable.Cell(1, 2).Range.Text, vbCr)(0) | |
yo = InStr(nameDOB, "yo") | |
'Last, First | |
nameBoth = Left(nameDOB, yo - 1) | |
dict.Add "last", Trim(Split(nameBoth, ",")(0)) | |
fNameAGE = Trim(Split(nameBoth, ",")(1)) | |
fNameArray = Split(fNameAGE) | |
If UBound(fNameArray) >= 2 Then | |
FName = fNameArray(0) & " " & fNameArray(1) | |
Else | |
FName = fNameArray(0) | |
End If | |
dict.Add "first", FName | |
'Gender | |
dict.Add "gender", Mid(nameDOB, yo + 3, 1) | |
'DOB | |
dob = InStr(nameDOB, "DOB") + 5 | |
mrn = InStr(nameDOB, "MRN") - 3 | |
dict.Add "dob", Mid(nameDOB, dob, mrn - dob) | |
'MRN | |
dict.Add "mrn", Mid(nameDOB, mrn + 8, 6) | |
dict.Add "admit", Split(oTable.Cell(1, 3).Range.Text, " ")(1) | |
dict.Add "resident", Split(oTable.Cell(2, 2).Range.Text, vbCr)(0) | |
dict.Add "code", Split(oTable.Cell(2, 3).Range.Text, vbCr)(0) | |
txtMeds = Replace(Split(oTable.Cell(3, 1).Range.Text, Chr(7))(0), "Rx: ", "") | |
If Right$(txtMeds, 1) = Chr(13) Then txtMeds = Left$(txtMeds, Len(txtMeds) - 1) | |
dict.Add "meds", txtMeds | |
txtHPI = Split(oTable.Cell(3, 2).Range.Text, Chr(7))(0) | |
If Right$(txtHPI, 1) = Chr(13) Then txtHPI = Left$(txtHPI, Len(txtHPI) - 1) | |
dict.Add "hpi", txtHPI | |
txtFU = Replace(Split(oTable.Cell(3, 3).Range.Text, Chr(7))(0), "F/U: ", "") | |
If Right$(txtFU, 1) = Chr(13) Then txtFU = Left$(txtFU, Len(txtFU) - 1) | |
dict.Add "fu", Replace(txtFU, ChrW(&H2610) & " ", "") | |
txtAllergies = Replace(Split(oTable.Cell(4, 1).Range.Text, Chr(7))(0), "Allergies: ", "") | |
If Right$(txtAllergies, 1) = Chr(13) Then txtAllergies = Left$(txtAllergies, Len(txtAllergies) - 1) | |
dict.Add "allergies", txtAllergies | |
dict.Add "ddx", Replace(Split(oTable.Cell(4, 2).Range.Text, vbCr)(0), "DDx: ", "") | |
txtPain = Replace(Split(oTable.Cell(4, 3).Range.Text, Chr(7))(0), "Pain: ", "") | |
If Right$(txtPain, 1) = Chr(13) Then txtPain = Left$(txtPain, Len(txtPain) - 1) | |
dict.Add "pain", txtPain | |
txtPPx = Replace(Split(oTable.Cell(5, 1).Range.Text, Chr(7))(0), "PPx: ", "") | |
If Right$(txtPPx, 1) = Chr(13) Then txtPPx = Left$(txtPPx, Len(txtPPx) - 1) | |
dict.Add "ppx", txtPPx | |
dict.Add "labs", Replace(Split(oTable.Cell(5, 2).Range.Text, vbCr)(0), "- ", "") | |
dict.Add "imaging", Replace(Split(oTable.Cell(6, 2).Range.Text, vbCr)(0), "- ", "") | |
dict.Add "procedures", Replace(Split(oTable.Cell(7, 2).Range.Text, vbCr)(0), "- ", "") | |
chkmks = UBound(Split(oTable.Cell(5, 3).Range.Text, ChrW(&H2611))) | |
If chkmks = 2 Then | |
dict.Add "anticoag", True | |
dict.Add "insulin", True | |
ElseIf chkmks = 1 Then | |
chk = Replace(Split(oTable.Cell(5, 3).Range.Text, vbCr)(0), ChrW(&H2611) & " ", "") | |
If chk = "Anticoagulated" Then | |
dict.Add "anticoag", True | |
dict.Add "insulin", False | |
Else | |
dict.Add "anticoag", False | |
dict.Add "insulin", True | |
End If | |
Else | |
dict.Add "anticoag", False | |
dict.Add "insulin", False | |
End If | |
dict.Add "dispo", Replace(Split(oTable.Cell(oTable.Rows.Count, 1).Range.Text, vbCr)(0), "Dispo: ", "") | |
'dict.Add "timestamp", Split(oTable.Cell(oTable.Rows.Count, 2).Range.Text, vbCr)(0) | |
'dict.Add "username", " " | |
raw = Split(oTable.Cell(oTable.Rows.Count, 2).Range.Text, vbCr)(0) | |
dt = Mid(raw, 1, InStr(raw, " (") - 1) | |
ini = Mid(raw, InStr(raw, " (") + 2, 3) | |
dict.Add "timestamp", dt | |
dict.Add "username", ini | |
End Sub |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment