PSBOMH2 ;BIRMINGHAM/EFC-MAH ;29-May-2012 14:20;PLS
;;3.0;BAR CODE MED ADMIN;**6,20,1005,27,26,1015**;Mar 2004;Build 62
;
; Modified - IHS/CIA/PLS - 06/21/04 - Line CONT+1
; Reference/IA
; EN^PSJBCMA/2828
;
EN ;
; Okay, let's print this puppy
S PSBWEEK=0
F S PSBWEEK=$O(^TMP("PSB",$J,PSBWEEK)) Q:'PSBWEEK D
.D:$D(^TMP("PSB",$J,PSBWEEK,"SORT","C"))
..D CONT
;
; 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","P"))
..D PRN
;
D LEGEND
Q
CONT ;
; IHS/CIA/PLS - 06/21/04 - Removed reference to VA Form
;S PSBHDR(1)="Continuing/PRN/Stat/One Time Medication/Treatment Record (VAF 10-2970 B, C, D)"
S PSBHDR(1)="Continuing/PRN/Stat/One Time Medication/Treatment Record"
W $$HDR()
S PSBDRUG=""
F S PSBDRUG=$O(^TMP("PSB",$J,PSBWEEK,"SORT","C",PSBDRUG)) Q:PSBDRUG="" D
.S PSBORD=""
.F S PSBORD=$O(^TMP("PSB",$J,PSBWEEK,"SORT","C",PSBDRUG,PSBORD)) Q:'PSBORD D
..;S X="",PSBNAF=0 F S X=$O(^TMP("PSB",$J,PSBWEEK,PSBORD,X)) Q:X="" I ^TMP("PSB",$J,PSBWEEK,PSBORD,X,0)'=0 S PSBNAF=1 ; check for data
..;D CLEAN^PSBVT,PSJ1^PSBVT(DFN,PSBORD)
..;S X=PSBOST D H^%DTC S PSBOSTH=%H
..;S X=PSBOSP D H^%DTC S PSBOSPH=%H
..;I PSBNAF=0 Q
..;I PSBNAF=0,$G(PSBAR(PSBOSTH))'=PSBWEEK,$G(PSBAR(PSBOSPH))'=PSBWEEK Q ; no data for this week and neither start or stop date is this week
..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=1:1:PSBCNT D
...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 ***"
...W !,$G(^TMP("PSB",$J,"ORDERS",PSBORD,"INST",PSBLINE))
...W ?32,"| ",$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)),"| "
....S Y=$G(^TMP("PSB",$J,PSBWEEK,PSBORD,PSBDAY,PSBLINE))
....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
..W !,$TR($J("",IOM)," ","-")
Q
;
PRN ;
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","P",PSBDRUG)) Q:PSBDRUG="" D
.S PSBORD=""
.F S PSBORD=$O(^TMP("PSB",$J,PSBWEEK,"SORT","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=1:1:PSBCNT D
...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(1)
....W !?(IOM-35\2),"*** CONTINUED FROM PREVIOUS PAGE ***"
...W !,$G(^TMP("PSB",$J,"ORDERS",PSBORD,"INST",PSBLINE))
...W ?32,"| ",$G(^TMP("PSB",$J,PSBWEEK,PSBORD,"AT",PSBLINE))
..W !,$TR($J("",IOM)," ","-")
Q
;
LEGEND ;
;print the initials - name legend as an extra page ;
;I '$D(^TMP("PSB",$J,"LEGEND")) K ^TMP("PSJ",$J),^TMP("PSB",$J) Q ;
D PT^PSBOHDR(DFN,.PSBHDR) ;
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",!,"R - Refused",!,"RM - Removed",!,"S - Stopped",!,"*** - Medication Not Due",! ;
K ^TMP("PSJ",$J),^TMP("PSB",$J)
Q
;
HDR(PRN) ;
; PRN = TRUE IF DISPLAYING PRN MED (OPTIONAL)
D PT^PSBOHDR(DFN,.PSBHDR)
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
;
PSBOMH2 ;BIRMINGHAM/EFC-MAH ;29-May-2012 14:20;PLS
+1 ;;3.0;BAR CODE MED ADMIN;**6,20,1005,27,26,1015**;Mar 2004;Build 62
+2 ;
+3 ; Modified - IHS/CIA/PLS - 06/21/04 - Line CONT+1
+4 ; Reference/IA
+5 ; EN^PSJBCMA/2828
+6 ;
EN ;
+1 ; Okay, let's print this puppy
+2 SET PSBWEEK=0
+3 FOR
SET PSBWEEK=$ORDER(^TMP("PSB",$JOB,PSBWEEK))
IF 'PSBWEEK
QUIT
Begin DoDot:1
+4 IF $DATA(^TMP("PSB",$JOB,PSBWEEK,"SORT","C"))
Begin DoDot:2
+5 DO CONT
End DoDot:2
End DoDot:1
+6 ;
+7 ; Now the PRN/One Time/On-Call Sheets
+8 SET PSBWEEK=0
+9 FOR
SET PSBWEEK=$ORDER(^TMP("PSB",$JOB,PSBWEEK))
IF 'PSBWEEK
QUIT
Begin DoDot:1
+10 IF $DATA(^TMP("PSB",$JOB,PSBWEEK,"SORT","P"))
Begin DoDot:2
+11 DO PRN
End DoDot:2
End DoDot:1
+12 ;
+13 DO LEGEND
+14 QUIT
CONT ;
+1 ; IHS/CIA/PLS - 06/21/04 - Removed reference to VA Form
+2 ;S PSBHDR(1)="Continuing/PRN/Stat/One Time Medication/Treatment Record (VAF 10-2970 B, C, D)"
+3 SET PSBHDR(1)="Continuing/PRN/Stat/One Time Medication/Treatment Record"
+4 WRITE $$HDR()
+5 SET PSBDRUG=""
+6 FOR
SET PSBDRUG=$ORDER(^TMP("PSB",$JOB,PSBWEEK,"SORT","C",PSBDRUG))
IF PSBDRUG=""
QUIT
Begin DoDot:1
+7 SET PSBORD=""
+8 FOR
SET PSBORD=$ORDER(^TMP("PSB",$JOB,PSBWEEK,"SORT","C",PSBDRUG,PSBORD))
IF 'PSBORD
QUIT
Begin DoDot:2
+9 ;S X="",PSBNAF=0 F S X=$O(^TMP("PSB",$J,PSBWEEK,PSBORD,X)) Q:X="" I ^TMP("PSB",$J,PSBWEEK,PSBORD,X,0)'=0 S PSBNAF=1 ; check for data
+10 ;D CLEAN^PSBVT,PSJ1^PSBVT(DFN,PSBORD)
+11 ;S X=PSBOST D H^%DTC S PSBOSTH=%H
+12 ;S X=PSBOSP D H^%DTC S PSBOSPH=%H
+13 ;I PSBNAF=0 Q
+14 ;I PSBNAF=0,$G(PSBAR(PSBOSTH))'=PSBWEEK,$G(PSBAR(PSBOSPH))'=PSBWEEK Q ; no data for this week and neither start or stop date is this week
+15 SET PSBCNT=8
+16 IF $ORDER(^TMP("PSB",$JOB,"ORDERS",PSBORD,"INST",""),-1)>PSBCNT
SET PSBCNT=$ORDER(^(""),-1)
+17 IF $ORDER(^TMP("PSB",$JOB,"ORDERS",PSBORD,"AT",""),-1)>PSBCNT
SET PSBCNT=$ORDER(^(""),-1)
+18 IF $Y>(IOSL-PSBCNT-4)
WRITE $$HDR()
+19 FOR PSBLINE=1:1:PSBCNT
Begin DoDot:3
+20 IF IOSL>24
IF $Y>$SELECT(PSBCNT<13:(IOSL-PSBCNT-4),(PSBCNT-PSBLINE=12):(IOSL-12),1:(IOSL-12))
Begin DoDot:4
+21 WRITE !?(IOM-35\2),"*** CONTINUED ON NEXT PAGE ***"
+22 WRITE $$HDR()
+23 WRITE !?(IOM-35\2),"*** CONTINUED FROM PREVIOUS PAGE ***"
End DoDot:4
+24 WRITE !,$GET(^TMP("PSB",$JOB,"ORDERS",PSBORD,"INST",PSBLINE))
+25 WRITE ?32,"| ",$GET(^TMP("PSB",$JOB,"ORDERS",PSBORD,"AT",PSBLINE))
+26 SET PSBDAY=0
SET PSBCOL=0
+27 FOR
SET PSBDAY=$ORDER(^TMP("PSB",$JOB,PSBWEEK,"HDR",PSBDAY))
IF 'PSBDAY
QUIT
Begin DoDot:4
+28 WRITE ?(40+(PSBCOL*13)),"| "
+29 SET Y=$GET(^TMP("PSB",$JOB,PSBWEEK,PSBORD,PSBDAY,PSBLINE))
+30 WRITE $PIECE(Y,U,3)
+31 WRITE $EXTRACT($PIECE($PIECE(Y,U,1)_"0000",".",2),1,4)," "
+32 WRITE $PIECE(Y,U,2)
+33 ;output hold status
IF $DATA(^TMP("PSB",$JOB,"ORDERS",PSBORD,"HOLD",PSBDAY))
IF (PSBLINE=PSBCNT)
WRITE "HOLD"
+34 IF '$DATA(^TMP("PSB",$JOB,"ORDERS",PSBORD,"DISC",PSBDAY))&'$DATA(^TMP("PSB",$JOB,"ORDERS",PSBORD,"HOLD",PSBDAY))
Begin DoDot:5
+35 ;write *** when day no due
IF $DATA(^TMP("PSB",$JOB,"ORDERS",PSBORD,"NTDUE",PSBDAY))
IF (PSBLINE=PSBCNT)
WRITE "***"
End DoDot:5
+36 ;output discontinued status
IF $DATA(^TMP("PSB",$JOB,"ORDERS",PSBORD,"DISC",PSBDAY))
IF (PSBLINE=PSBCNT)
WRITE "***"
+37 SET PSBCOL=PSBCOL+1
End DoDot:4
End DoDot:3
+38 WRITE !,$TRANSLATE($JUSTIFY("",IOM)," ","-")
End DoDot:2
End DoDot:1
+39 QUIT
+40 ;
PRN ;
+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","P",PSBDRUG))
IF PSBDRUG=""
QUIT
Begin DoDot:1
+5 SET PSBORD=""
+6 FOR
SET PSBORD=$ORDER(^TMP("PSB",$JOB,PSBWEEK,"SORT","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=1:1:PSBCNT
Begin DoDot:3
+13 IF IOSL>24
IF $Y>$SELECT(PSBCNT<13:(IOSL-PSBCNT-4),(PSBCNT-PSBLINE=12):(IOSL-12),1:(IOSL-12))
Begin DoDot:4
+14 WRITE !?(IOM-35\2),"*** CONTINUED ON NEXT PAGE ***"
+15 WRITE $$HDR(1)
+16 WRITE !?(IOM-35\2),"*** CONTINUED FROM PREVIOUS PAGE ***"
End DoDot:4
+17 WRITE !,$GET(^TMP("PSB",$JOB,"ORDERS",PSBORD,"INST",PSBLINE))
+18 WRITE ?32,"| ",$GET(^TMP("PSB",$JOB,PSBWEEK,PSBORD,"AT",PSBLINE))
End DoDot:3
+19 WRITE !,$TRANSLATE($JUSTIFY("",IOM)," ","-")
End DoDot:2
End DoDot:1
+20 QUIT
+21 ;
LEGEND ;
+1 ;print the initials - name legend as an extra page ;
+2 ;I '$D(^TMP("PSB",$J,"LEGEND")) K ^TMP("PSJ",$J),^TMP("PSB",$J) Q ;
+3 ;
DO PT^PSBOHDR(DFN,.PSBHDR)
+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 ;
WRITE !!,"Status Codes",!,"C - Completed",!,"G - Given",!,"H - Held",!,"I - Infusing",!,"M - Missing Dose Requested",!,"R - Refused",!,"RM - Removed",!,"S - Stopped",!,"*** - Medication Not Due",!
+9 KILL ^TMP("PSJ",$JOB),^TMP("PSB",$JOB)
+10 QUIT
+11 ;
HDR(PRN) ;
+1 ; PRN = TRUE IF DISPLAYING PRN MED (OPTIONAL)
+2 DO PT^PSBOHDR(DFN,.PSBHDR)
+3 WRITE !,"Start Date",?20,"Stop Date",?32,"| ",$SELECT('$GET(PRN):"Admin",1:"Action Status")
+4 IF '$GET(PRN)
FOR X=0:1:6
WRITE ?(40+(X*13)),"|"
+5 WRITE !,"and Time",?20,"and Time",?32,"| ",$SELECT('$GET(PRN):"Times",1:"Action Date/Times")
+6 IF '$GET(PRN)
Begin DoDot:1
+7 SET PSBCOL=0
SET X=0
FOR
SET X=$ORDER(^TMP("PSB",$JOB,PSBWEEK,"HDR",X))
IF 'X
QUIT
Begin DoDot:2
+8 WRITE ?(40+(PSBCOL*13)),"| ",$EXTRACT(X,4,5),"/",$EXTRACT(X,6,7),"/",(1700+$EXTRACT(X,1,3))
+9 SET PSBCOL=PSBCOL+1
End DoDot:2
End DoDot:1
+10 IF $GET(PRN)
Begin DoDot:1
+11 WRITE ?76,"PRN Reason"
End DoDot:1
+12 WRITE !,$TRANSLATE($JUSTIFY("",IOM)," ","-")
+13 QUIT ""
+14 ;
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 ;
