Routine: BEDDEHRS

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

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

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)

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

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

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

BEDDEHRS.m