- 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 ;
