- PSBOMH2 ;BIRMINGHAM/EFC-MAH ;9/13/12 5:15pm
- ;;3.0;BAR CODE MED ADMIN;**6,20,27,26,67,68,70,133**;Mar 2004;Build 1
- ;
- ; Reference/IA
- ; EN^PSJBCMA/2828
- ; GETSIOPI^PSJBCMA5/5763
- ;
- ;*68 - Add ability to get special instructions at end of each orders
- ; grid and print in free space before next orders grid, check
- ; for page overflow each line of word processing text.
- ;*70 - Print Clinic from ^TMP(""PSB",$J,"ORDERS",PSBORD,"INST") on
- ; the intruction/med cell of grid. Add psbclinord=2 mode for
- ; dual heading text.
- ;
- EN ; Add dual sections for MAH report - IM and then CO *70
- ; only one Legend section after CO section
- ; sort 1 = IM sort 2 = CO
- ;
- ;*70 MAH was missing report Title
- S Y=$S($P(PSBRPT(.1),U,8)]"":$P(PSBRPT(.1),U,8),1:$P(PSBRPT(.1),U,6))
- S PSBHDR(0)="MEDICATION ADMINISTRATION HISTORY for "_$$FMTE^XLFDT($P(PSBRPT(.1),U,6)+$P(PSBRPT(.1),U,7))_" to "_$$FMTE^XLFDT(Y+$P(PSBRPT(.1),U,9))
- ;
- ;**** INPATIENT ORDERS 1st **** *70
- N PSBSUBHD
- S PSBSUBHD="** INPATIENT ORDERS **"
- S PSBWEEK=0
- F S PSBWEEK=$O(^TMP("PSB",$J,PSBWEEK)) Q:'PSBWEEK D
- .D:$D(^TMP("PSB",$J,PSBWEEK,"SORT",1,"C"))
- ..D CONT(1)
- ;
- ; Now the PRN/One Time/On-Call Sheets
- S PSBWEEK=0
- F S PSBWEEK=$O(^TMP("PSB",$J,PSBWEEK)) Q:'PSBWEEK D
- .D:$D(^TMP("PSB",$J,PSBWEEK,"SORT",1,"P"))
- ..D PRN(1)
- ;
- ;**** CLINIC ORDERS 2nd **** *70
- S PSBSUBHD="** CLINIC ORDERS **"
- S PSBWEEK=0
- F S PSBWEEK=$O(^TMP("PSB",$J,PSBWEEK)) Q:'PSBWEEK D
- .D:$D(^TMP("PSB",$J,PSBWEEK,"SORT",2,"C"))
- ..D CONT(2)
- ;
- ; Now the PRN/One Time/On-Call Sheets
- S PSBWEEK=0
- F S PSBWEEK=$O(^TMP("PSB",$J,PSBWEEK)) Q:'PSBWEEK D
- .D:$D(^TMP("PSB",$J,PSBWEEK,"SORT",2,"P"))
- ..D PRN(2)
- ;
- S PSBSUBHD="** LEGEND **"
- D LEGEND
- K ^TMP("PSB",$J)
- Q
- ;
- CONT(XO) ;
- N SILN,SITXT
- S PSBHDR(1)="Continuing/PRN/Stat/One Time Medication/Treatment Record (VAF 10-2970 B, C, D)"
- W $$HDR()
- S PSBDRUG=""
- F S PSBDRUG=$O(^TMP("PSB",$J,PSBWEEK,"SORT",XO,"C",PSBDRUG)) Q:PSBDRUG="" D
- .S PSBORD=""
- .F S PSBORD=$O(^TMP("PSB",$J,PSBWEEK,"SORT",XO,"C",PSBDRUG,PSBORD)) Q:'PSBORD D
- ..S PSBCNT=8
- ..S:$O(^TMP("PSB",$J,"ORDERS",PSBORD,"INST",""),-1)>PSBCNT PSBCNT=$O(^(""),-1)
- ..S:$O(^TMP("PSB",$J,"ORDERS",PSBORD,"AT",""),-1)>PSBCNT PSBCNT=$O(^(""),-1)
- ..W:$Y>(IOSL-PSBCNT-4) $$HDR()
- ..F PSBLINE=0:1:PSBCNT D ;*70 start at 0 for inserted Clinic name
- ...D CHKPAGE ;*68 convert overflow logic to a tag call
- ...W !,$G(^TMP("PSB",$J,"ORDERS",PSBORD,"INST",PSBLINE))
- ...W ?32,"| " W:PSBLINE>0 $G(^TMP("PSB",$J,"ORDERS",PSBORD,"AT",PSBLINE))
- ...S PSBDAY=0,PSBCOL=0
- ...F S PSBDAY=$O(^TMP("PSB",$J,PSBWEEK,"HDR",PSBDAY)) Q:'PSBDAY D
- ....W ?(40+(PSBCOL*13)),"|" ;Remove space, PSB*3*67
- ....S Y=$G(^TMP("PSB",$J,PSBWEEK,PSBORD,PSBDAY,PSBLINE))
- ....;Write space when status does not contain >, PSB*3*67
- ....I ($L($P(Y,U,2))'=5)!($P(Y,U,3)'="RM"),($P(Y,U,3)'[">") W " "
- ....W $P(Y,U,3)
- ....W $E($P($P(Y,U,1)_"0000",".",2),1,4)," "
- ....W $P(Y,U,2)
- ....I $D(^TMP("PSB",$J,"ORDERS",PSBORD,"HOLD",PSBDAY)),(PSBLINE=PSBCNT) W "HOLD" ;output hold status
- ....I '$D(^TMP("PSB",$J,"ORDERS",PSBORD,"DISC",PSBDAY))&'$D(^TMP("PSB",$J,"ORDERS",PSBORD,"HOLD",PSBDAY)) D
- .....I $D(^TMP("PSB",$J,"ORDERS",PSBORD,"NTDUE",PSBDAY)),(PSBLINE=PSBCNT) W "***" ;write *** when day no due
- ....I $D(^TMP("PSB",$J,"ORDERS",PSBORD,"DISC",PSBDAY)),(PSBLINE=PSBCNT) W "***" ;output discontinued status
- ....S PSBCOL=PSBCOL+1
- ..D SIOPI ;*68 get and print SI lines, if exist
- ..W !,$TR($J("",IOM)," ","-")
- Q
- ;
- PRN(XO) ;
- S PSBHDR(1)="Continuing/PRN/Stat/One Time Medication/Treatment Record (VAF 10-2970 B, C, D)"
- W $$HDR(1)
- S PSBDRUG=""
- F S PSBDRUG=$O(^TMP("PSB",$J,PSBWEEK,"SORT",XO,"P",PSBDRUG)) Q:PSBDRUG="" D
- .S PSBORD=""
- .F S PSBORD=$O(^TMP("PSB",$J,PSBWEEK,"SORT",XO,"P",PSBDRUG,PSBORD)) Q:'PSBORD D
- ..S PSBCNT=$O(^TMP("PSB",$J,PSBWEEK,PSBORD,"AT",""),-1)
- ..D:PSBCNT<$O(^TMP("PSB",$J,"ORDERS",PSBORD,"INST",""),-1)
- ...S PSBCNT=$O(^TMP("PSB",$J,"ORDERS",PSBORD,"INST",""),-1)
- ..S:PSBCNT<8 PSBCNT=8 ; Minimum space for order
- ..W:$Y>(IOSL-PSBCNT-4) $$HDR(1)
- ..F PSBLINE=0:1:PSBCNT D
- ...D CHKPAGE ;*68 move overflow page logic to a tag
- ...W !,$G(^TMP("PSB",$J,"ORDERS",PSBORD,"INST",PSBLINE))
- ...W ?32,"| ",$G(^TMP("PSB",$J,PSBWEEK,PSBORD,"AT",PSBLINE))
- ..D SIOPI ;*68 get and print SI lines, if exist
- ..W !,$TR($J("",IOM)," ","-")
- Q
- ;
- LEGEND ;
- ;print the initials - name legend as an extra page ;
- N PSBCLINORD S PSBCLINORD=2 ;*70
- D PT^PSBOHDR(DFN,.PSBHDR,,,,$G(PSBSUBHD)) ;*70
- W !!,"Initial - Name Legend",! ;
- I $D(^TMP("PSB",$J,"LEGEND")) D
- .S X=$Q(^TMP("PSB",$J,"LEGEND",""))
- .F W $S($QS(X,4)[99:"",1:$QS(X,4)),?10,$QS(X,5),! S X=$Q(@X) Q:$QS(X,3)'="LEGEND" ;
- W !!,"Status Codes",!,"C - Completed",!,"G - Given",!,"H - Held",!,"I - Infusing",!,"M - Missing Dose Requested",!,"N - Not Given (Undo-Given)",!,"R - Refused",!,"RM - Removed",!,"S - Stopped",! ;P133
- W "> - Scheduled administration times for the order have been changed",!,"*** - Medication Not Due",! ;add changed Admin time message, PSB*3*67
- K ^TMP("PSJ",$J)
- Q
- ;
- HDR(PRN) ;
- ; PRN = TRUE IF DISPLAYING PRN MED (OPTIONAL)
- N PSBCLINORD S PSBCLINORD=2 ;*70
- D PT^PSBOHDR(DFN,.PSBHDR,,,,$G(PSBSUBHD)) ;*70
- W !,"Location",?32,"| " ;*70
- I '$G(PRN) F X=0:1:6 W ?(40+(X*13)),"|" ;*70
- W !,"Start Date",?20,"Stop Date",?32,"| ",$S('$G(PRN):"Admin",1:"Action Status")
- I '$G(PRN) F X=0:1:6 W ?(40+(X*13)),"|"
- W !,"and Time",?20,"and Time",?32,"| ",$S('$G(PRN):"Times",1:"Action Date/Times")
- D:'$G(PRN)
- .S PSBCOL=0,X=0 F S X=$O(^TMP("PSB",$J,PSBWEEK,"HDR",X)) Q:'X D
- ..W ?(40+(PSBCOL*13)),"| ",$E(X,4,5),"/",$E(X,6,7),"/",(1700+$E(X,1,3))
- ..S PSBCOL=PSBCOL+1
- D:$G(PRN)
- .W ?76,"PRN Reason"
- W !,$TR($J("",IOM)," ","-")
- Q ""
- ;
- PSBCK1(PSBCHK) ;
- I PSBCHK="A" D
- .S TEST=$P(^PSB(53.79,PSBIEN,0),U,6)
- .D PSBOUT^PSBOMH1(TEST,PSBINIT)
- .S X=$P(^PSB(53.79,PSBIEN,0),U,6)_U_PSBINIT_U_"G"_U_PSBIEN
- I PSBCHK="B" D
- .S TESTB=$P(^PSB(53.79,PSBIEN,0),U,6)
- .D PSBOUT^PSBOMH1(TESTB,PSBINIT)
- .S X=$P(^PSB(53.79,PSBIEN,0),U,6)_U_PSBINIT_U_$P(^(0),U,9)_U_PSBIEN
- S PSBCHK=""
- Q
- ;
- PSBENT(PSBTIS) ;
- S PSBNAME="",PSBNAME=$$GET1^DIQ(53.79,PSBIEN_",","ACTION BY:NAME")
- S ^TMP("PSB",$J,"LEGEND",$S($G(PSBTIS)="":99,1:PSBTIS),PSBNAME)=""
- Q
- ;
- PSBSTIV ;
- S YB="" F S YB=$O(PSBAUD(YB)) Q:YB="" D
- .S Z="" F S Z=$O(^PSB(53.79,PSBIEN,.9,Z)) Q:Z="" I Z'=0 D
- ..I $P(PSBAUD(YB),U,1)=$P(^PSB(53.79,PSBIEN,.9,Z,0),"^",1) D
- ...I $P(^PSB(53.79,PSBIEN,.9,Z,0),"^",3)["Instruct" D
- ....I $P(PSBAUD(YB),U,2)'["*" S $P(PSBAUD(YB),U,2)=$P(PSBAUD(YB),U,2)_"*"
- ....D PSBOUT^PSBOMH1($P(PSBAUD(YB),U,1),$P(PSBAUD(YB),U,2))
- Q
- ;
- PSBCTAR ;
- S YC="" F S YC=$O(PSBTAR(YC)) Q:YC="" D
- .S Z="" F S Z=$O(^PSB(53.79,PSBIEN,.9,Z)) Q:Z="" I Z'=0 D
- ..I $P(PSBTAR(YC),U,1)=$P(^PSB(53.79,PSBIEN,.9,Z,0),"^",1) D
- ...I $P(^PSB(53.79,PSBIEN,.9,Z,0),"^",3)["Instruct" D
- ....S $P(PSBTAR(YC),U,2)=$P(PSBTAR(YC),U,2)_"*"
- ....D PSBOUT^PSBOMH1($P(^PSB(53.79,PSBIEN,.9,Z,0),"^",1),$P(PSBTAR(YC),U,2))
- Q
- ;
- SIOPI ;Get and print SI/OPI Wp text *68
- K ^TMP("PSJBCMA5",$J,DFN)
- S SILN=$$GETSIOPI^PSJBCMA5(DFN,PSBORD,1)
- I SILN F QQ=0:0 S QQ=$O(^TMP("PSJBCMA5",$J,DFN,PSBORD,QQ)) Q:'QQ D
- .S SITXT=^TMP("PSJBCMA5",$J,DFN,PSBORD,QQ)
- .I SILN=1,SITXT="" Q
- .D CHKPAGE I QQ=1 W !," Special Instructions:"
- .D CHKPAGE W !," ",SITXT
- K ^TMP("PSJBCMA5",$J,DFN)
- Q
- ;
- CHKPAGE ;check for page full and print overflow msgs and new page headers *68
- I IOSL>24,$Y>$S(PSBCNT<13:(IOSL-PSBCNT-4),(PSBCNT-PSBLINE=12):(IOSL-12),1:(IOSL-12)) D
- .W !!?(IOM-35\2),"*** CONTINUED ON NEXT PAGE ***"
- .W $$HDR()
- .W !?(IOM-35\2),"*** CONTINUED FROM PREVIOUS PAGE ***",!
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSBOMH2 8107 printed Feb 18, 2025@23:07:03 Page 2
- PSBOMH2 ;BIRMINGHAM/EFC-MAH ;9/13/12 5:15pm
- +1 ;;3.0;BAR CODE MED ADMIN;**6,20,27,26,67,68,70,133**;Mar 2004;Build 1
- +2 ;
- +3 ; Reference/IA
- +4 ; EN^PSJBCMA/2828
- +5 ; GETSIOPI^PSJBCMA5/5763
- +6 ;
- +7 ;*68 - Add ability to get special instructions at end of each orders
- +8 ; grid and print in free space before next orders grid, check
- +9 ; for page overflow each line of word processing text.
- +10 ;*70 - Print Clinic from ^TMP(""PSB",$J,"ORDERS",PSBORD,"INST") on
- +11 ; the intruction/med cell of grid. Add psbclinord=2 mode for
- +12 ; dual heading text.
- +13 ;
- EN ; Add dual sections for MAH report - IM and then CO *70
- +1 ; only one Legend section after CO section
- +2 ; sort 1 = IM sort 2 = CO
- +3 ;
- +4 ;*70 MAH was missing report Title
- +5 SET Y=$SELECT($PIECE(PSBRPT(.1),U,8)]"":$PIECE(PSBRPT(.1),U,8),1:$PIECE(PSBRPT(.1),U,6))
- +6 SET PSBHDR(0)="MEDICATION ADMINISTRATION HISTORY for "_$$FMTE^XLFDT($PIECE(PSBRPT(.1),U,6)+$PIECE(PSBRPT(.1),U,7))_" to "_$$FMTE^XLFDT(Y+$PIECE(PSBRPT(.1),U,9))
- +7 ;
- +8 ;**** INPATIENT ORDERS 1st **** *70
- +9 NEW PSBSUBHD
- +10 SET PSBSUBHD="** INPATIENT ORDERS **"
- +11 SET PSBWEEK=0
- +12 FOR
- SET PSBWEEK=$ORDER(^TMP("PSB",$JOB,PSBWEEK))
- if 'PSBWEEK
- QUIT
- Begin DoDot:1
- +13 if $DATA(^TMP("PSB",$JOB,PSBWEEK,"SORT",1,"C"))
- Begin DoDot:2
- +14 DO CONT(1)
- End DoDot:2
- End DoDot:1
- +15 ;
- +16 ; Now the PRN/One Time/On-Call Sheets
- +17 SET PSBWEEK=0
- +18 FOR
- SET PSBWEEK=$ORDER(^TMP("PSB",$JOB,PSBWEEK))
- if 'PSBWEEK
- QUIT
- Begin DoDot:1
- +19 if $DATA(^TMP("PSB",$JOB,PSBWEEK,"SORT",1,"P"))
- Begin DoDot:2
- +20 DO PRN(1)
- End DoDot:2
- End DoDot:1
- +21 ;
- +22 ;**** CLINIC ORDERS 2nd **** *70
- +23 SET PSBSUBHD="** CLINIC ORDERS **"
- +24 SET PSBWEEK=0
- +25 FOR
- SET PSBWEEK=$ORDER(^TMP("PSB",$JOB,PSBWEEK))
- if 'PSBWEEK
- QUIT
- Begin DoDot:1
- +26 if $DATA(^TMP("PSB",$JOB,PSBWEEK,"SORT",2,"C"))
- Begin DoDot:2
- +27 DO CONT(2)
- End DoDot:2
- End DoDot:1
- +28 ;
- +29 ; Now the PRN/One Time/On-Call Sheets
- +30 SET PSBWEEK=0
- +31 FOR
- SET PSBWEEK=$ORDER(^TMP("PSB",$JOB,PSBWEEK))
- if 'PSBWEEK
- QUIT
- Begin DoDot:1
- +32 if $DATA(^TMP("PSB",$JOB,PSBWEEK,"SORT",2,"P"))
- Begin DoDot:2
- +33 DO PRN(2)
- End DoDot:2
- End DoDot:1
- +34 ;
- +35 SET PSBSUBHD="** LEGEND **"
- +36 DO LEGEND
- +37 KILL ^TMP("PSB",$JOB)
- +38 QUIT
- +39 ;
- CONT(XO) ;
- +1 NEW SILN,SITXT
- +2 SET PSBHDR(1)="Continuing/PRN/Stat/One Time Medication/Treatment Record (VAF 10-2970 B, C, D)"
- +3 WRITE $$HDR()
- +4 SET PSBDRUG=""
- +5 FOR
- SET PSBDRUG=$ORDER(^TMP("PSB",$JOB,PSBWEEK,"SORT",XO,"C",PSBDRUG))
- if PSBDRUG=""
- QUIT
- Begin DoDot:1
- +6 SET PSBORD=""
- +7 FOR
- SET PSBORD=$ORDER(^TMP("PSB",$JOB,PSBWEEK,"SORT",XO,"C",PSBDRUG,PSBORD))
- if 'PSBORD
- QUIT
- Begin DoDot:2
- +8 SET PSBCNT=8
- +9 if $ORDER(^TMP("PSB",$JOB,"ORDERS",PSBORD,"INST",""),-1)>PSBCNT
- SET PSBCNT=$ORDER(^(""),-1)
- +10 if $ORDER(^TMP("PSB",$JOB,"ORDERS",PSBORD,"AT",""),-1)>PSBCNT
- SET PSBCNT=$ORDER(^(""),-1)
- +11 if $Y>(IOSL-PSBCNT-4)
- WRITE $$HDR()
- +12 ;*70 start at 0 for inserted Clinic name
- FOR PSBLINE=0:1:PSBCNT
- Begin DoDot:3
- +13 ;*68 convert overflow logic to a tag call
- DO CHKPAGE
- +14 WRITE !,$GET(^TMP("PSB",$JOB,"ORDERS",PSBORD,"INST",PSBLINE))
- +15 WRITE ?32,"| "
- if PSBLINE>0
- WRITE $GET(^TMP("PSB",$JOB,"ORDERS",PSBORD,"AT",PSBLINE))
- +16 SET PSBDAY=0
- SET PSBCOL=0
- +17 FOR
- SET PSBDAY=$ORDER(^TMP("PSB",$JOB,PSBWEEK,"HDR",PSBDAY))
- if 'PSBDAY
- QUIT
- Begin DoDot:4
- +18 ;Remove space, PSB*3*67
- WRITE ?(40+(PSBCOL*13)),"|"
- +19 SET Y=$GET(^TMP("PSB",$JOB,PSBWEEK,PSBORD,PSBDAY,PSBLINE))
- +20 ;Write space when status does not contain >, PSB*3*67
- +21 IF ($LENGTH($PIECE(Y,U,2))'=5)!($PIECE(Y,U,3)'="RM")
- IF ($PIECE(Y,U,3)'[">")
- WRITE " "
- +22 WRITE $PIECE(Y,U,3)
- +23 WRITE $EXTRACT($PIECE($PIECE(Y,U,1)_"0000",".",2),1,4)," "
- +24 WRITE $PIECE(Y,U,2)
- +25 ;output hold status
- IF $DATA(^TMP("PSB",$JOB,"ORDERS",PSBORD,"HOLD",PSBDAY))
- IF (PSBLINE=PSBCNT)
- WRITE "HOLD"
- +26 IF '$DATA(^TMP("PSB",$JOB,"ORDERS",PSBORD,"DISC",PSBDAY))&'$DATA(^TMP("PSB",$JOB,"ORDERS",PSBORD,"HOLD",PSBDAY))
- Begin DoDot:5
- +27 ;write *** when day no due
- IF $DATA(^TMP("PSB",$JOB,"ORDERS",PSBORD,"NTDUE",PSBDAY))
- IF (PSBLINE=PSBCNT)
- WRITE "***"
- End DoDot:5
- +28 ;output discontinued status
- IF $DATA(^TMP("PSB",$JOB,"ORDERS",PSBORD,"DISC",PSBDAY))
- IF (PSBLINE=PSBCNT)
- WRITE "***"
- +29 SET PSBCOL=PSBCOL+1
- End DoDot:4
- End DoDot:3
- +30 ;*68 get and print SI lines, if exist
- DO SIOPI
- +31 WRITE !,$TRANSLATE($JUSTIFY("",IOM)," ","-")
- End DoDot:2
- End DoDot:1
- +32 QUIT
- +33 ;
- PRN(XO) ;
- +1 SET PSBHDR(1)="Continuing/PRN/Stat/One Time Medication/Treatment Record (VAF 10-2970 B, C, D)"
- +2 WRITE $$HDR(1)
- +3 SET PSBDRUG=""
- +4 FOR
- SET PSBDRUG=$ORDER(^TMP("PSB",$JOB,PSBWEEK,"SORT",XO,"P",PSBDRUG))
- if PSBDRUG=""
- QUIT
- Begin DoDot:1
- +5 SET PSBORD=""
- +6 FOR
- SET PSBORD=$ORDER(^TMP("PSB",$JOB,PSBWEEK,"SORT",XO,"P",PSBDRUG,PSBORD))
- if 'PSBORD
- QUIT
- Begin DoDot:2
- +7 SET PSBCNT=$ORDER(^TMP("PSB",$JOB,PSBWEEK,PSBORD,"AT",""),-1)
- +8 if PSBCNT<$ORDER(^TMP("PSB",$JOB,"ORDERS",PSBORD,"INST",""),-1)
- Begin DoDot:3
- +9 SET PSBCNT=$ORDER(^TMP("PSB",$JOB,"ORDERS",PSBORD,"INST",""),-1)
- End DoDot:3
- +10 ; Minimum space for order
- if PSBCNT<8
- SET PSBCNT=8
- +11 if $Y>(IOSL-PSBCNT-4)
- WRITE $$HDR(1)
- +12 FOR PSBLINE=0:1:PSBCNT
- Begin DoDot:3
- +13 ;*68 move overflow page logic to a tag
- DO CHKPAGE
- +14 WRITE !,$GET(^TMP("PSB",$JOB,"ORDERS",PSBORD,"INST",PSBLINE))
- +15 WRITE ?32,"| ",$GET(^TMP("PSB",$JOB,PSBWEEK,PSBORD,"AT",PSBLINE))
- End DoDot:3
- +16 ;*68 get and print SI lines, if exist
- DO SIOPI
- +17 WRITE !,$TRANSLATE($JUSTIFY("",IOM)," ","-")
- End DoDot:2
- End DoDot:1
- +18 QUIT
- +19 ;
- LEGEND ;
- +1 ;print the initials - name legend as an extra page ;
- +2 ;*70
- NEW PSBCLINORD
- SET PSBCLINORD=2
- +3 ;*70
- DO PT^PSBOHDR(DFN,.PSBHDR,,,,$GET(PSBSUBHD))
- +4 ;
- WRITE !!,"Initial - Name Legend",!
- +5 IF $DATA(^TMP("PSB",$JOB,"LEGEND"))
- Begin DoDot:1
- +6 SET X=$QUERY(^TMP("PSB",$JOB,"LEGEND",""))
- +7 ;
- FOR
- WRITE $SELECT($QSUBSCRIPT(X,4)[99:"",1:$QSUBSCRIPT(X,4)),?10,$QSUBSCRIPT(X,5),!
- SET X=$QUERY(@X)
- if $QSUBSCRIPT(X,3)'="LEGEND"
- QUIT
- End DoDot:1
- +8 ;P133
- WRITE !!,"Status Codes",!,"C - Completed",!,"G - Given",!,"H - Held",!,"I - Infusing",!,"M - Missing Dose Requested",!,"N - Not Given (Undo-Given)",!,"R - Refused",!,"RM - Removed",!,"S - Stopped",!
- +9 ;add changed Admin time message, PSB*3*67
- WRITE "> - Scheduled administration times for the order have been changed",!,"*** - Medication Not Due",!
- +10 KILL ^TMP("PSJ",$JOB)
- +11 QUIT
- +12 ;
- HDR(PRN) ;
- +1 ; PRN = TRUE IF DISPLAYING PRN MED (OPTIONAL)
- +2 ;*70
- NEW PSBCLINORD
- SET PSBCLINORD=2
- +3 ;*70
- DO PT^PSBOHDR(DFN,.PSBHDR,,,,$GET(PSBSUBHD))
- +4 ;*70
- WRITE !,"Location",?32,"| "
- +5 ;*70
- IF '$GET(PRN)
- FOR X=0:1:6
- WRITE ?(40+(X*13)),"|"
- +6 WRITE !,"Start Date",?20,"Stop Date",?32,"| ",$SELECT('$GET(PRN):"Admin",1:"Action Status")
- +7 IF '$GET(PRN)
- FOR X=0:1:6
- WRITE ?(40+(X*13)),"|"
- +8 WRITE !,"and Time",?20,"and Time",?32,"| ",$SELECT('$GET(PRN):"Times",1:"Action Date/Times")
- +9 if '$GET(PRN)
- Begin DoDot:1
- +10 SET PSBCOL=0
- SET X=0
- FOR
- SET X=$ORDER(^TMP("PSB",$JOB,PSBWEEK,"HDR",X))
- if 'X
- QUIT
- Begin DoDot:2
- +11 WRITE ?(40+(PSBCOL*13)),"| ",$EXTRACT(X,4,5),"/",$EXTRACT(X,6,7),"/",(1700+$EXTRACT(X,1,3))
- +12 SET PSBCOL=PSBCOL+1
- End DoDot:2
- End DoDot:1
- +13 if $GET(PRN)
- Begin DoDot:1
- +14 WRITE ?76,"PRN Reason"
- End DoDot:1
- +15 WRITE !,$TRANSLATE($JUSTIFY("",IOM)," ","-")
- +16 QUIT ""
- +17 ;
- PSBCK1(PSBCHK) ;
- +1 IF PSBCHK="A"
- Begin DoDot:1
- +2 SET TEST=$PIECE(^PSB(53.79,PSBIEN,0),U,6)
- +3 DO PSBOUT^PSBOMH1(TEST,PSBINIT)
- +4 SET X=$PIECE(^PSB(53.79,PSBIEN,0),U,6)_U_PSBINIT_U_"G"_U_PSBIEN
- End DoDot:1
- +5 IF PSBCHK="B"
- Begin DoDot:1
- +6 SET TESTB=$PIECE(^PSB(53.79,PSBIEN,0),U,6)
- +7 DO PSBOUT^PSBOMH1(TESTB,PSBINIT)
- +8 SET X=$PIECE(^PSB(53.79,PSBIEN,0),U,6)_U_PSBINIT_U_$PIECE(^(0),U,9)_U_PSBIEN
- End DoDot:1
- +9 SET PSBCHK=""
- +10 QUIT
- +11 ;
- PSBENT(PSBTIS) ;
- +1 SET PSBNAME=""
- SET PSBNAME=$$GET1^DIQ(53.79,PSBIEN_",","ACTION BY:NAME")
- +2 SET ^TMP("PSB",$JOB,"LEGEND",$SELECT($GET(PSBTIS)="":99,1:PSBTIS),PSBNAME)=""
- +3 QUIT
- +4 ;
- PSBSTIV ;
- +1 SET YB=""
- FOR
- SET YB=$ORDER(PSBAUD(YB))
- if YB=""
- QUIT
- Begin DoDot:1
- +2 SET Z=""
- FOR
- SET Z=$ORDER(^PSB(53.79,PSBIEN,.9,Z))
- if Z=""
- QUIT
- IF Z'=0
- Begin DoDot:2
- +3 IF $PIECE(PSBAUD(YB),U,1)=$PIECE(^PSB(53.79,PSBIEN,.9,Z,0),"^",1)
- Begin DoDot:3
- +4 IF $PIECE(^PSB(53.79,PSBIEN,.9,Z,0),"^",3)["Instruct"
- Begin DoDot:4
- +5 IF $PIECE(PSBAUD(YB),U,2)'["*"
- SET $PIECE(PSBAUD(YB),U,2)=$PIECE(PSBAUD(YB),U,2)_"*"
- +6 DO PSBOUT^PSBOMH1($PIECE(PSBAUD(YB),U,1),$PIECE(PSBAUD(YB),U,2))
- End DoDot:4
- End DoDot:3
- End DoDot:2
- End DoDot:1
- +7 QUIT
- +8 ;
- PSBCTAR ;
- +1 SET YC=""
- FOR
- SET YC=$ORDER(PSBTAR(YC))
- if YC=""
- QUIT
- Begin DoDot:1
- +2 SET Z=""
- FOR
- SET Z=$ORDER(^PSB(53.79,PSBIEN,.9,Z))
- if Z=""
- QUIT
- IF Z'=0
- Begin DoDot:2
- +3 IF $PIECE(PSBTAR(YC),U,1)=$PIECE(^PSB(53.79,PSBIEN,.9,Z,0),"^",1)
- Begin DoDot:3
- +4 IF $PIECE(^PSB(53.79,PSBIEN,.9,Z,0),"^",3)["Instruct"
- Begin DoDot:4
- +5 SET $PIECE(PSBTAR(YC),U,2)=$PIECE(PSBTAR(YC),U,2)_"*"
- +6 DO PSBOUT^PSBOMH1($PIECE(^PSB(53.79,PSBIEN,.9,Z,0),"^",1),$PIECE(PSBTAR(YC),U,2))
- End DoDot:4
- End DoDot:3
- End DoDot:2
- End DoDot:1
- +7 QUIT
- +8 ;
- SIOPI ;Get and print SI/OPI Wp text *68
- +1 KILL ^TMP("PSJBCMA5",$JOB,DFN)
- +2 SET SILN=$$GETSIOPI^PSJBCMA5(DFN,PSBORD,1)
- +3 IF SILN
- FOR QQ=0:0
- SET QQ=$ORDER(^TMP("PSJBCMA5",$JOB,DFN,PSBORD,QQ))
- if 'QQ
- QUIT
- Begin DoDot:1
- +4 SET SITXT=^TMP("PSJBCMA5",$JOB,DFN,PSBORD,QQ)
- +5 IF SILN=1
- IF SITXT=""
- QUIT
- +6 DO CHKPAGE
- IF QQ=1
- WRITE !," Special Instructions:"
- +7 DO CHKPAGE
- WRITE !," ",SITXT
- End DoDot:1
- +8 KILL ^TMP("PSJBCMA5",$JOB,DFN)
- +9 QUIT
- +10 ;
- CHKPAGE ;check for page full and print overflow msgs and new page headers *68
- +1 IF IOSL>24
- IF $Y>$SELECT(PSBCNT<13:(IOSL-PSBCNT-4),(PSBCNT-PSBLINE=12):(IOSL-12),1:(IOSL-12))
- Begin DoDot:1
- +2 WRITE !!?(IOM-35\2),"*** CONTINUED ON NEXT PAGE ***"
- +3 WRITE $$HDR()
- +4 WRITE !?(IOM-35\2),"*** CONTINUED FROM PREVIOUS PAGE ***",!
- End DoDot:1
- +5 QUIT
