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 Dec 13, 2024@01:40:40 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
