BEDDEHRS ;VNGT/HS/BEE-BEDD Patient Routing Slip ; 08 Nov 2011 12:00 PM
;;2.0;BEDD DASHBOARD;;Jun 04, 2014;Build 13
;
;Adapted from BEDDEHRRS/CNHS/RPF
;
; Input:
; BEDDDFN (optional) - Patient DFN
;
Q
;
EN(BEDDDFN) ;EP - Patient Routing Slip
;
S BEDDDFN=$G(BEDDDFN,"")
;
NEW %,AGE,%ZIS,AGPATDFN,AUPNDAYS,AUPNDOB,AUPNDOD,AUPNPAT,AUPNSEX,DFN,DIC,DOB
NEW POP,REC,RHIFLAG,SEX,SSN,X,Y
;
;
;Select Patient
S:BEDDDFN]"" DFN=BEDDDFN
I BEDDDFN="" D PTLK^AG
Q:'$D(DFN)
;
;Select Device
S %ZIS="QA"
D ^%ZIS
I POP N IOP S IOP=ION D ^%ZIS Q
I $G(IO("Q")) D QUE D HOME^%ZIS Q
U IO
D START
D ^%ZISC
D HOME^%ZIS
Q
;
START ;Display Report
;
NEW PNAME,PSEX,PDOB,PSITE,PCHRT,RPTDTM,ELIG,LINE,ALINE,I
;
S PNAME=$$GET1^DIQ(2,DFN_",",.01,"E")
S PSEX=$$GET1^DIQ(2,DFN_",",.02,"E")
S PDOB=$$FMTE^BEDDUTIL($$GET1^DIQ(2,DFN_",",.03,"I"))
S PSITE=$$GET1^DIQ(4,DUZ(2)_",",.01,"E")
S PCHRT=$$GET1^DIQ(9000001.41,DUZ(2)_","_DFN_",",.02,"E")
S RPTDTM=$TR($$XNOW^BEDDUTIL("5FMZ"),"@"," ")
S ELIG=$$GET1^DIQ(9000001,DFN_",",1112,"E")
S $P(LINE,"_",78)="_"
S $P(ALINE,"*",79)="*"
;
;Print the Routing Slip
;
;Display Header
D HDR
;
;Current Visit Section
W !,ALINE
W !,"Other Information / Instructions: ",!
F I=1:1:3 W !,LINE
;
W !,ALINE
W !,"Departments for Patient to visit today:"
W !,"(Patient: Please check in at any indicated department)"
W !!,?4,"Return to Clinic Today",?35,"___ Yes ___ No " ;; added for modifications
W !!,"***Note to Surgery Patient: You must go to all indicated departments TODAY,"
W !,"or your surgery may be cancelled!"
;
W !!,"_____ Lab",?26,"_____ Imaging",?53,"_____ Tribal Health Prog."
W !!,"_____ Testing Ctr Imaging",?26,"_____ Pharmacy",?53,"_____ Respiratory Therapy"
W !!,"_____ Cardiology",?26,"_____ Medisaw",?53,"_____ BC Orientation"
W !!,"_____ Admissions",?26,"_____ Behavioral Health",?53,"_____ ___________________"
W !!,"***Note to nurses: For pre-op patient, please complete the following:"
W !,"Surgery Date:",$E(LINE,1,19)
W !!,"Diagnosis:",$E(LINE,1,45)
W ?56,"Surgeon:",$E(LINE,1,14)
W !!,"Procedure:",$E(LINE,1,45)
W ?56,"LOS:",$E(LINE,1,18)
;
;Follow-Up Section
W !,ALINE
W !,"Follow-Up"
W !,"Return to Clinic in: _____________ ",?40,"Days",?50,"Weeks",?60,"Months",?70,"PRN"
W !!,"Appointment date/time:",$E(LINE,1,20)
W !,"For: ___ 15 mins ___ 20 mins ___ 30 mins ___ 40 mins ___ 60 mins"
W !!,"With: ",$E(LINE,1,35)
W !!,"Purpose of appt:",$E(LINE,1,62)
W !!,"Other instructions:",$E(LINE,1,59)
W !,LINE
W !!,"Other Appointments Needed: ",$E(LINE,1,45)
;
;Bottom Section
W !,ALINE
W !,"PATIENT: ",PNAME
W !,"___ Was seen in clinic today."
W !,"___ Should not work or attend school from _______________ to _______________"
W !,"___ Should be excused from Phys Ed from ________________ to ________________"
W !,"___ ",$E(LINE,1,74)
W !!,"Signature:",$E(LINE,1,44)
W "Date:",$E(LINE,1,19)
;
END ; KILL VARIABLES
I $E(IOST)'="C" D CLOSE^%ZISH(IO)
Q
;
HDR ;EP - Display Report Header
;
NEW ALERT,PRINT,PCOPY,TITLE
;
;Handle Screen Printing
;
U IO
S ALERT="***ALERT - THIS PAPER CONTAINS YOUR ELIGIBILITY***"
S TITLE="PATIENT ROUTING SLIP - PRINTED: "_RPTDTM
S PCOPY="***PATIENT COPY***"
;
W !,?((80-$L(PSITE))/2),PSITE
W !,?((80-$L(TITLE))/2),TITLE
W !,?((80-$L(ALERT))/2),ALERT
W !!,"PATIENT NAME: ",PNAME
W ?46,"SEX: ",PSEX
W !,?5,"CHART #: ",PCHRT,?46,"DOB: ",PDOB
W !," ELIGIBILITY: ",ELIG
;
Q
;
QUE ;Queue Task
NEW ZTRTN,ZTSAVE,ZTDESC
K IO("Q")
S ZTRTN="START^BEDDEHRS",ZTDESC="Patient Routing Slip"
S ZTSAVE("*")=""
K ZTSK D ^%ZTLOAD
I $D(ZTSK)[0 W !!?5,"Report Cancelled!"
E W !!?5,"Task # ",ZTSK," queued.",!
H 3
Q
BEDDEHRS ;VNGT/HS/BEE-BEDD Patient Routing Slip ; 08 Nov 2011 12:00 PM
+1 ;;2.0;BEDD DASHBOARD;;Jun 04, 2014;Build 13
+2 ;
+3 ;Adapted from BEDDEHRRS/CNHS/RPF
+4 ;
+5 ; Input:
+6 ; BEDDDFN (optional) - Patient DFN
+7 ;
+8 QUIT
+9 ;
EN(BEDDDFN) ;EP - Patient Routing Slip
+1 ;
+2 SET BEDDDFN=$GET(BEDDDFN,"")
+3 ;
+4 NEW %,AGE,%ZIS,AGPATDFN,AUPNDAYS,AUPNDOB,AUPNDOD,AUPNPAT,AUPNSEX,DFN,DIC,DOB
+5 NEW POP,REC,RHIFLAG,SEX,SSN,X,Y
+6 ;
+7 ;
+8 ;Select Patient
+9 IF BEDDDFN]""
SET DFN=BEDDDFN
+10 IF BEDDDFN=""
DO PTLK^AG
+11 IF '$DATA(DFN)
QUIT
+12 ;
+13 ;Select Device
+14 SET %ZIS="QA"
+15 DO ^%ZIS
+16 IF POP
NEW IOP
SET IOP=ION
DO ^%ZIS
QUIT
+17 IF $GET(IO("Q"))
DO QUE
DO HOME^%ZIS
QUIT
+18 USE IO
+19 DO START
+20 DO ^%ZISC
+21 DO HOME^%ZIS
+22 QUIT
+23 ;
START ;Display Report
+1 ;
+2 NEW PNAME,PSEX,PDOB,PSITE,PCHRT,RPTDTM,ELIG,LINE,ALINE,I
+3 ;
+4 SET PNAME=$$GET1^DIQ(2,DFN_",",.01,"E")
+5 SET PSEX=$$GET1^DIQ(2,DFN_",",.02,"E")
+6 SET PDOB=$$FMTE^BEDDUTIL($$GET1^DIQ(2,DFN_",",.03,"I"))
+7 SET PSITE=$$GET1^DIQ(4,DUZ(2)_",",.01,"E")
+8 SET PCHRT=$$GET1^DIQ(9000001.41,DUZ(2)_","_DFN_",",.02,"E")
+9 SET RPTDTM=$TRANSLATE($$XNOW^BEDDUTIL("5FMZ"),"@"," ")
+10 SET ELIG=$$GET1^DIQ(9000001,DFN_",",1112,"E")
+11 SET $PIECE(LINE,"_",78)="_"
+12 SET $PIECE(ALINE,"*",79)="*"
+13 ;
+14 ;Print the Routing Slip
+15 ;
+16 ;Display Header
+17 DO HDR
+18 ;
+19 ;Current Visit Section
+20 WRITE !,ALINE
+21 WRITE !,"Other Information / Instructions: ",!
+22 FOR I=1:1:3
WRITE !,LINE
+23 ;
+24 WRITE !,ALINE
+25 WRITE !,"Departments for Patient to visit today:"
+26 WRITE !,"(Patient: Please check in at any indicated department)"
+27 ;; added for modifications
WRITE !!,?4,"Return to Clinic Today",?35,"___ Yes ___ No "
+28 WRITE !!,"***Note to Surgery Patient: You must go to all indicated departments TODAY,"
+29 WRITE !,"or your surgery may be cancelled!"
+30 ;
+31 WRITE !!,"_____ Lab",?26,"_____ Imaging",?53,"_____ Tribal Health Prog."
+32 WRITE !!,"_____ Testing Ctr Imaging",?26,"_____ Pharmacy",?53,"_____ Respiratory Therapy"
+33 WRITE !!,"_____ Cardiology",?26,"_____ Medisaw",?53,"_____ BC Orientation"
+34 WRITE !!,"_____ Admissions",?26,"_____ Behavioral Health",?53,"_____ ___________________"
+35 WRITE !!,"***Note to nurses: For pre-op patient, please complete the following:"
+36 WRITE !,"Surgery Date:",$EXTRACT(LINE,1,19)
+37 WRITE !!,"Diagnosis:",$EXTRACT(LINE,1,45)
+38 WRITE ?56,"Surgeon:",$EXTRACT(LINE,1,14)
+39 WRITE !!,"Procedure:",$EXTRACT(LINE,1,45)
+40 WRITE ?56,"LOS:",$EXTRACT(LINE,1,18)
+41 ;
+42 ;Follow-Up Section
+43 WRITE !,ALINE
+44 WRITE !,"Follow-Up"
+45 WRITE !,"Return to Clinic in: _____________ ",?40,"Days",?50,"Weeks",?60,"Months",?70,"PRN"
+46 WRITE !!,"Appointment date/time:",$EXTRACT(LINE,1,20)
+47 WRITE !,"For: ___ 15 mins ___ 20 mins ___ 30 mins ___ 40 mins ___ 60 mins"
+48 WRITE !!,"With: ",$EXTRACT(LINE,1,35)
+49 WRITE !!,"Purpose of appt:",$EXTRACT(LINE,1,62)
+50 WRITE !!,"Other instructions:",$EXTRACT(LINE,1,59)
+51 WRITE !,LINE
+52 WRITE !!,"Other Appointments Needed: ",$EXTRACT(LINE,1,45)
+53 ;
+54 ;Bottom Section
+55 WRITE !,ALINE
+56 WRITE !,"PATIENT: ",PNAME
+57 WRITE !,"___ Was seen in clinic today."
+58 WRITE !,"___ Should not work or attend school from _______________ to _______________"
+59 WRITE !,"___ Should be excused from Phys Ed from ________________ to ________________"
+60 WRITE !,"___ ",$EXTRACT(LINE,1,74)
+61 WRITE !!,"Signature:",$EXTRACT(LINE,1,44)
+62 WRITE "Date:",$EXTRACT(LINE,1,19)
+63 ;
END ; KILL VARIABLES
+1 IF $EXTRACT(IOST)'="C"
DO CLOSE^%ZISH(IO)
+2 QUIT
+3 ;
HDR ;EP - Display Report Header
+1 ;
+2 NEW ALERT,PRINT,PCOPY,TITLE
+3 ;
+4 ;Handle Screen Printing
+5 ;
+6 USE IO
+7 SET ALERT="***ALERT - THIS PAPER CONTAINS YOUR ELIGIBILITY***"
+8 SET TITLE="PATIENT ROUTING SLIP - PRINTED: "_RPTDTM
+9 SET PCOPY="***PATIENT COPY***"
+10 ;
+11 WRITE !,?((80-$LENGTH(PSITE))/2),PSITE
+12 WRITE !,?((80-$LENGTH(TITLE))/2),TITLE
+13 WRITE !,?((80-$LENGTH(ALERT))/2),ALERT
+14 WRITE !!,"PATIENT NAME: ",PNAME
+15 WRITE ?46,"SEX: ",PSEX
+16 WRITE !,?5,"CHART #: ",PCHRT,?46,"DOB: ",PDOB
+17 WRITE !," ELIGIBILITY: ",ELIG
+18 ;
+19 QUIT
+20 ;
QUE ;Queue Task
+1 NEW ZTRTN,ZTSAVE,ZTDESC
+2 KILL IO("Q")
+3 SET ZTRTN="START^BEDDEHRS"
SET ZTDESC="Patient Routing Slip"
+4 SET ZTSAVE("*")=""
+5 KILL ZTSK
DO ^%ZTLOAD
+6 IF $DATA(ZTSK)[0
WRITE !!?5,"Report Cancelled!"
+7 IF '$TEST
WRITE !!?5,"Task # ",ZTSK," queued.",!
+8 HANG 3
+9 QUIT
