PSAOP ;BIR/LTL-Outpatient Dispensing (Single Drug) ;7/23/97
;;3.0; DRUG ACCOUNTABILITY/INVENTORY INTERFACE;**3,15**; 10/24/97
;This routine is the gathers OP dispensing for a date range.
;
;References to ^PSDRUG( are covered by IA #2095
;References to ^PSRX( are covered by IA #254
;
D PSAWARN^PSAPSI I $D(PSAQUIT) K PSAQUIT Q
;
N DIC,DIE,DINUM,D0,D1,DLAYGO,DR,DIR,DIRUT,DTOUT,DUOUT,PSADR,PSADREC,PSADT,PSAPG,PSAS,PSA,PSAOUT,PSARELDT,PSADT,DA,PSADRUG,PSADRUGN,PSALN,PSAP,PSAN,PSAQ,PSAR,X,X2,Y
LOOK D:'$G(PSALOC) OP^PSADA
I $G(PSALOC)<0 K PSALOC G QUIT
S:'$G(PSALOCN) PSALOCN=$P($G(^PSD(58.8,+PSALOC,0)),U)
S DIR(0)="Y",DIR("A")="OK",DIR("B")="Yes",DIR("?")="No allows you to change Location." D ^DIR K DIR S:$D(DIRUT) PSAOUT=1 G:$D(DIRUT) QUIT I Y=0 K PSALOC D OP^PSADA G:'$G(PSALOC) QUIT
I '$O(^PSD(58.8,+PSALOC,1,0)) W !!,"There are no drugs in ",PSALOCN G QUIT
D NOW^%DTC S PSADT=X,X="T-6000" D ^%DT S PSADT(1)=Y
S DIC="^PSD(58.8,+PSALOC,1,",DIC(0)="AEQ",DIC("A")="Please select "_PSALOCN_"'S drug: ",DIC("S")="I $S($P($G(^(0)),U,14):$P($G(^(0)),U,14)>DT,1:1)"
S PSAS=$P($G(^PSD(58.8,+PSALOC,0)),U,10),PSADT(3)=0
F W ! S DA(1)=PSALOC D ^DIC G:Y<0 QUIT S PSADRUG=+Y D G:$G(PSAOUT) QUIT G:$G(PSA(5)) TR D DEV Q:$G(PSAOUT)
.D:'$G(^PSD(58.8,+PSALOC,1,+PSADRUG,6)) Q:$G(PSAOUT)
..W !!,"Dispensing has never been collected for this drug.",!!
..S DIR(0)="D^"_PSADT(1)_":"_PSADT_":AEX",DIR("A")="How far back would you like to collect",DIR("B")="T-6000" D ^DIR K DIR S (PSADT(2),PSADT(4),PSAR,PSAP,PSAN)=Y,(PSADT(3),PSAR(1),PSAP(1),PSAN(1))=0 I Y<1 S PSAOUT=1 Q
.S PSAG=$G(^PSD(58.8,+PSALOC,1,+PSADRUG,6))
.S:'$G(PSADT(2)) PSADT(2)=$P(PSAG,U),PSA(7)=1
.W !!,"Checking dispensing"
.S:'$G(PSAR) PSAR=$P(PSAG,U,2) S:'$G(PSAP) PSAP=$P(PSAG,U,7)
.S:'$G(PSAN) PSAN=$P(PSAG,U,9) S (PSAR(1),PSAP(1),PSAN(1))=0
.F S PSADT(2)=$O(^PSRX("AL",PSADT(2))) Q:'PSADT(2) F S PSADT(3)=$O(^PSRX("AL",+PSADT(2),PSADT(3))) Q:'PSADT(3) W:'(PSADT(3)#10) "." D:$P($G(^PSRX(+PSADT(3),0)),U,6)=PSADRUG&($P($G(^PSRX(+PSADT(3),2)),U,9)=PSAS)
..S PSADT(4)="" F S PSADT(4)=$O(^PSRX("AL",+PSADT(2),+PSADT(3),PSADT(4))) Q:PSADT(4)="" D
...;
...;DAVE B (PSA*3*3)
...Q:$D(^PSRX("AR",+PSADT(2),+PSADT(3),PSADT(4))) ;Released to CMOP, do not count
...S ^TMP("PSA",$J,+PSADRUG,$E(PSADT(2),1,7))=($P($G(^TMP("PSA",$J,+PSADRUG,$E(PSADT(2),1,7))),U)+$S(PSADT(4):$P($G(^PSRX(+PSADT(3),1,+PSADT(4),0)),U,4),1:$P($G(^PSRX(+PSADT(3),0)),U,7)))_U_PSADT(2)_U_PSADT(3),PSA(9)=PSADT(3)
.W !!,"Checking refills"
.D:$O(^PSRX("AJ",PSAR))
..F S PSAR=$O(^PSRX("AJ",PSAR)) Q:'PSAR F S PSAR(1)=$O(^PSRX("AJ",+PSAR,+PSAR(1))) Q:'PSAR(1) W "." D:$P($G(^PSRX(+PSAR(1),0)),U,6)=PSADRUG&($P($G(^PSRX(+PSAR(1),2)),U,9)=PSAS)
...S PSAR(3)="" F S PSAR(3)=$O(^PSRX("AJ",+PSAR,+PSAR(1),PSAR(3))) Q:PSAR(3)="" D
....S $P(^TMP("PSA",$J,+PSADRUG,$E(PSAR,1,7)),U)=($P($G(^TMP("PSA",$J,+PSADRUG,$E(PSAR,1,7))),U)-$S(PSAR(3):$P($G(^PSRX(+PSAR(1),1,+PSAR(3),0)),U,4),1:$P($G(^PSRX(+PSAR(1),0)),U,7)))
....S $P(^TMP("PSA",$J,+PSADRUG,$E(PSAR,1,7)),U,4)=PSAR,$P(^($E(PSAR,1,7)),U,5)=PSAR(1),PSAR(2)=PSAR(1)
.D:$O(^PSRX("AM",+PSAP))!($O(^PSRX("AN",+PSAN))) AM^PSAOP4
.I '$D(^TMP("PSA",$J,+PSADRUG)) W !!,"Sorry, no dispensing for this drug has occurred since " S Y=$S($P(PSAG,U):$P(PSAG,U),1:$G(PSADT(4))) X ^DD("DD") W Y,".",! S PSAOUT=1 Q
.S DIR(0)="Y",DIR("A")="Would you like a report of dispensing totals",DIR("B")="Yes" D ^DIR K DIR S:$D(DIRUT) PSAOUT=1 S:Y'=1 PSA(5)=1
;
DEV K IO("Q") N %ZIS,IOP,POP S %ZIS="Q" I Y=1 W ! D ^%ZIS
I $G(POP) W !,"NO DEVICE SELECTED OR ACTION TAKEN!" S PSAOUT=1 G QUIT
I $D(IO("Q")) N ZTDESC,ZTIO,ZTRTN,ZTSAVE,ZTDTH,ZTSK S ZTRTN="LUP^PSAOP",ZTDESC="Drug Acct-OP Dispensing Log",(ZTSAVE("^TMP(""PSA"",$J,+PSADRUG,"),ZTSAVE("PSA*"))="" D ^%ZTLOAD,HOME^%ZIS G QUIT
LUP S (PSAPG,PSAOUT)=0,PSADRUG(1)=$P($G(^PSDRUG(+PSADRUG,660)),U,6),PSADRUG(2)=$P($G(^(660)),U,8)
S X=PSADRUG(1),X2="3$" D COMMA^%DTC S PSADRUG(3)=X
D HEADER
S (PSA(4),PSA(6))=0 F S PSA(4)=$O(^TMP("PSA",$J,+PSADRUG,PSA(4))) Q:'PSA(4) S PSA(6)=PSA(6)+1,Y=PSA(4) X ^DD("DD") D
.W !!,Y S X=$P($G(^TMP("PSA",$J,+PSADRUG,PSA(4))),U),X2=0 D COMMA^%DTC W ?14,X,PSADRUG(2),?40,PSADRUG(3),"/",PSADRUG(2),?63
.S PSADRUG(4)=$G(PSADRUG(4))+$P($G(^TMP("PSA",$J,+PSADRUG,PSA(4))),U)
.S X=$P($G(^TMP("PSA",$J,+PSADRUG,PSA(4))),U)*PSADRUG(1),PSADRUG(5)=$G(PSADRUG(5))+X,X2="2$" D COMMA^%DTC W ?40,X
W !,PSALN,!,PSA(6)," DAY TOTALS: " S X=PSADRUG(4),X2=0 D COMMA^%DTC W ?5,X,PSADRUG(2)
S X=PSADRUG(5),X2="2$" D COMMA^%DTC W ?63,X
STOP W:$E(IOST)'="C" @IOF
I $E(IOST,1,2)="C-",'$G(PSAOUT) W ! S DIR(0)="EA",DIR("A")="END OF REPORT! Press <RET> to return to the menu." D ^DIR K DIR
D ^%ZISC S:$D(ZTQUEUED) ZTREQ="@" K IO("Q")
W !!,"Updating history and dispensing totals."
TR S ZTIO="",ZTRTN="LOOP^PSAOP",ZTDESC="Drug Acct-Dispensing Totals",ZTDTH=$H,(ZTSAVE("^TMP(""PSA"",$J,+PSADRUG,"),ZTSAVE("PSA*"))="" D ^%ZTLOAD,HOME^%ZIS
K ^TMP("PSA",$J,+PSADRUG),PSA,PSADRUG
QUIT Q
I $$S^%ZTLOAD S PSAOUT=1 Q
W:$Y @IOF S $P(PSALN,"-",81)="",PSAPG=PSAPG+1 W !,?2,"DAILY DISPENSING TOTALS FOR ",$E($P($G(^PSDRUG(+PSADRUG,0)),U),1,30),?70,"PAGE: ",PSAPG,!,PSALN,!
W " DATE",?23,"TOTAL",?45,"$/DISP",?67,"TOTAL",!
W "DISPENSED",?23,"DISP",?46,"UNIT",?68,"COST",!,PSALN
Q
LOOP S PSA(2)=0 F S PSA(2)=$O(^TMP("PSA",$J,+PSADRUG,PSA(2))) Q:'PSA(2) S PSA(3)=$P(^TMP("PSA",$J,+PSADRUG,PSA(2)),"^") D
.;PSA*3*25 Dave B - Remove single reference for OP site
.S PSA=^TMP("PSA",$J,+PSADRUG,PSA(2)),PSAOP=+$P($G(^PSD(58.8,PSALOC,0)),"^",10),PSARELDT=+$P(PSA(2),".")
.K:$D(^XTMP("PSA",PSAOP,PSADRUG,PSARELDT)) ^XTMP("PSA",PSAOP,PSADRUG,PSARELDT)
.D ^PSAOP1
.S DIE="^PSD(58.8,"_+PSALOC_",1,",DA(1)=PSALOC,DA=PSADRUG
.S DR="22////"_$P(PSA,U,2)_";22.1////"_$P(PSA,U,3)_";23////"_$P(PSA,U,4)_";23.1////"_$P(PSA,U,5)_";22.2////"_$P(PSA,U,6)_";22.3////"_$P(PSA,U,7)_";23.2////"_$P(PSA,U,8)_";23.3////"_$P(PSA,U,9)
.D ^DIE K DA,DIE,DR
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSAOP 6049 printed Nov 22, 2024@16:59:59 Page 2
PSAOP ;BIR/LTL-Outpatient Dispensing (Single Drug) ;7/23/97
+1 ;;3.0; DRUG ACCOUNTABILITY/INVENTORY INTERFACE;**3,15**; 10/24/97
+2 ;This routine is the gathers OP dispensing for a date range.
+3 ;
+4 ;References to ^PSDRUG( are covered by IA #2095
+5 ;References to ^PSRX( are covered by IA #254
+6 ;
+7 DO PSAWARN^PSAPSI
IF $DATA(PSAQUIT)
KILL PSAQUIT
QUIT
+8 ;
+9 NEW DIC,DIE,DINUM,D0,D1,DLAYGO,DR,DIR,DIRUT,DTOUT,DUOUT,PSADR,PSADREC,PSADT,PSAPG,PSAS,PSA,PSAOUT,PSARELDT,PSADT,DA,PSADRUG,PSADRUGN,PSALN,PSAP,PSAN,PSAQ,PSAR,X,X2,Y
LOOK if '$GET(PSALOC)
DO OP^PSADA
+1 IF $GET(PSALOC)<0
KILL PSALOC
GOTO QUIT
+2 if '$GET(PSALOCN)
SET PSALOCN=$PIECE($GET(^PSD(58.8,+PSALOC,0)),U)
+3 SET DIR(0)="Y"
SET DIR("A")="OK"
SET DIR("B")="Yes"
SET DIR("?")="No allows you to change Location."
DO ^DIR
KILL DIR
if $DATA(DIRUT)
SET PSAOUT=1
if $DATA(DIRUT)
GOTO QUIT
IF Y=0
KILL PSALOC
DO OP^PSADA
if '$GET(PSALOC)
GOTO QUIT
+4 IF '$ORDER(^PSD(58.8,+PSALOC,1,0))
WRITE !!,"There are no drugs in ",PSALOCN
GOTO QUIT
+5 DO NOW^%DTC
SET PSADT=X
SET X="T-6000"
DO ^%DT
SET PSADT(1)=Y
+6 SET DIC="^PSD(58.8,+PSALOC,1,"
SET DIC(0)="AEQ"
SET DIC("A")="Please select "_PSALOCN_"'S drug: "
SET DIC("S")="I $S($P($G(^(0)),U,14):$P($G(^(0)),U,14)>DT,1:1)"
+7 SET PSAS=$PIECE($GET(^PSD(58.8,+PSALOC,0)),U,10)
SET PSADT(3)=0
+8 FOR
WRITE !
SET DA(1)=PSALOC
DO ^DIC
if Y<0
GOTO QUIT
SET PSADRUG=+Y
Begin DoDot:1
+9 if '$GET(^PSD(58.8,+PSALOC,1,+PSADRUG,6))
Begin DoDot:2
+10 WRITE !!,"Dispensing has never been collected for this drug.",!!
+11 SET DIR(0)="D^"_PSADT(1)_":"_PSADT_":AEX"
SET DIR("A")="How far back would you like to collect"
SET DIR("B")="T-6000"
DO ^DIR
KILL DIR
SET (PSADT(2),PSADT(4),PSAR,PSAP,PSAN)=Y
SET (PSADT(3),PSAR(1),PSAP(1),PSAN(1))=0
IF Y<1
SET PSAOUT=1
QUIT
End DoDot:2
if $GET(PSAOUT)
QUIT
+12 SET PSAG=$GET(^PSD(58.8,+PSALOC,1,+PSADRUG,6))
+13 if '$GET(PSADT(2))
SET PSADT(2)=$PIECE(PSAG,U)
SET PSA(7)=1
+14 WRITE !!,"Checking dispensing"
+15 if '$GET(PSAR)
SET PSAR=$PIECE(PSAG,U,2)
if '$GET(PSAP)
SET PSAP=$PIECE(PSAG,U,7)
+16 if '$GET(PSAN)
SET PSAN=$PIECE(PSAG,U,9)
SET (PSAR(1),PSAP(1),PSAN(1))=0
+17 FOR
SET PSADT(2)=$ORDER(^PSRX("AL",PSADT(2)))
if 'PSADT(2)
QUIT
FOR
SET PSADT(3)=$ORDER(^PSRX("AL",+PSADT(2),PSADT(3)))
if 'PSADT(3)
QUIT
if '(PSADT(3)#10)
WRITE "."
if $PIECE($GET(^PSRX(+PSADT(3),0)),U,6)=PSADRUG&($PIECE($GET(^PSRX(+PSADT(3),2)),U,9)=PSAS)
Begin DoDot:2
+18 SET PSADT(4)=""
FOR
SET PSADT(4)=$ORDER(^PSRX("AL",+PSADT(2),+PSADT(3),PSADT(4)))
if PSADT(4)=""
QUIT
Begin DoDot:3
+19 ;
+20 ;DAVE B (PSA*3*3)
+21 ;Released to CMOP, do not count
if $DATA(^PSRX("AR",+PSADT(2),+PSADT(3),PSADT(4)))
QUIT
+22 SET ^TMP("PSA",$JOB,+PSADRUG,$EXTRACT(PSADT(2),1,7))=($PIECE($GET(^TMP("PSA",$JOB,+PSADRUG,$EXTRACT(PSADT(2),1,7))),U)+$SELECT(PSADT(4):$PIECE($GET(^PSRX(+PSADT(3),1,+PSADT(4),0)),U,4),1:$PIECE($GET(^PSRX(+PSADT(
3),0)),U,7)))_U_PSADT(2)_U_PSADT(3)
SET PSA(9)=PSADT(3)
End DoDot:3
End DoDot:2
+23 WRITE !!,"Checking refills"
+24 if $ORDER(^PSRX("AJ",PSAR))
Begin DoDot:2
+25 FOR
SET PSAR=$ORDER(^PSRX("AJ",PSAR))
if 'PSAR
QUIT
FOR
SET PSAR(1)=$ORDER(^PSRX("AJ",+PSAR,+PSAR(1)))
if 'PSAR(1)
QUIT
WRITE "."
if $PIECE($GET(^PSRX(+PSAR(1),0)),U,6)=PSADRUG&($PIECE($GET(^PSRX(+PSAR(1),2)),U,9)=PSAS)
Begin DoDot:3
+26 SET PSAR(3)=""
FOR
SET PSAR(3)=$ORDER(^PSRX("AJ",+PSAR,+PSAR(1),PSAR(3)))
if PSAR(3)=""
QUIT
Begin DoDot:4
+27 SET $PIECE(^TMP("PSA",$JOB,+PSADRUG,$EXTRACT(PSAR,1,7)),U)=($PIECE($GET(^TMP("PSA",$JOB,+PSADRUG,$EXTRACT(PSAR,1,7))),U)-$SELECT(PSAR(3):$PIECE($GET(^PSRX(+PSAR(1),1,+PSAR(3),0)),U,4),1:$PIECE($GET(^PSRX(
+PSAR(1),0)),U,7)))
+28 SET $PIECE(^TMP("PSA",$JOB,+PSADRUG,$EXTRACT(PSAR,1,7)),U,4)=PSAR
SET $PIECE(^($EXTRACT(PSAR,1,7)),U,5)=PSAR(1)
SET PSAR(2)=PSAR(1)
End DoDot:4
End DoDot:3
End DoDot:2
+29 if $ORDER(^PSRX("AM",+PSAP))!($ORDER(^PSRX("AN",+PSAN)))
DO AM^PSAOP4
+30 IF '$DATA(^TMP("PSA",$JOB,+PSADRUG))
WRITE !!,"Sorry, no dispensing for this drug has occurred since "
SET Y=$SELECT($PIECE(PSAG,U):$PIECE(PSAG,U),1:$GET(PSADT(4)))
XECUTE ^DD("DD")
WRITE Y,".",!
SET PSAOUT=1
QUIT
+31 SET DIR(0)="Y"
SET DIR("A")="Would you like a report of dispensing totals"
SET DIR("B")="Yes"
DO ^DIR
KILL DIR
if $DATA(DIRUT)
SET PSAOUT=1
if Y'=1
SET PSA(5)=1
End DoDot:1
if $GET(PSAOUT)
GOTO QUIT
if $GET(PSA(5))
GOTO TR
DO DEV
if $GET(PSAOUT)
QUIT
+32 ;
DEV KILL IO("Q")
NEW %ZIS,IOP,POP
SET %ZIS="Q"
IF Y=1
WRITE !
DO ^%ZIS
+1 IF $GET(POP)
WRITE !,"NO DEVICE SELECTED OR ACTION TAKEN!"
SET PSAOUT=1
GOTO QUIT
+2 IF $DATA(IO("Q"))
NEW ZTDESC,ZTIO,ZTRTN,ZTSAVE,ZTDTH,ZTSK
SET ZTRTN="LUP^PSAOP"
SET ZTDESC="Drug Acct-OP Dispensing Log"
SET (ZTSAVE("^TMP(""PSA"",$J,+PSADRUG,"),ZTSAVE("PSA*"))=""
DO ^%ZTLOAD
DO HOME^%ZIS
GOTO QUIT
LUP SET (PSAPG,PSAOUT)=0
SET PSADRUG(1)=$PIECE($GET(^PSDRUG(+PSADRUG,660)),U,6)
SET PSADRUG(2)=$PIECE($GET(^(660)),U,8)
+1 SET X=PSADRUG(1)
SET X2="3$"
DO COMMA^%DTC
SET PSADRUG(3)=X
+2 DO HEADER
+3 SET (PSA(4),PSA(6))=0
FOR
SET PSA(4)=$ORDER(^TMP("PSA",$JOB,+PSADRUG,PSA(4)))
if 'PSA(4)
QUIT
SET PSA(6)=PSA(6)+1
SET Y=PSA(4)
XECUTE ^DD("DD")
Begin DoDot:1
+4 WRITE !!,Y
SET X=$PIECE($GET(^TMP("PSA",$JOB,+PSADRUG,PSA(4))),U)
SET X2=0
DO COMMA^%DTC
WRITE ?14,X,PSADRUG(2),?40,PSADRUG(3),"/",PSADRUG(2),?63
+5 SET PSADRUG(4)=$GET(PSADRUG(4))+$PIECE($GET(^TMP("PSA",$JOB,+PSADRUG,PSA(4))),U)
+6 SET X=$PIECE($GET(^TMP("PSA",$JOB,+PSADRUG,PSA(4))),U)*PSADRUG(1)
SET PSADRUG(5)=$GET(PSADRUG(5))+X
SET X2="2$"
DO COMMA^%DTC
WRITE ?40,X
End DoDot:1
+7 WRITE !,PSALN,!,PSA(6)," DAY TOTALS: "
SET X=PSADRUG(4)
SET X2=0
DO COMMA^%DTC
WRITE ?5,X,PSADRUG(2)
+8 SET X=PSADRUG(5)
SET X2="2$"
DO COMMA^%DTC
WRITE ?63,X
STOP if $EXTRACT(IOST)'="C"
WRITE @IOF
+1 IF $EXTRACT(IOST,1,2)="C-"
IF '$GET(PSAOUT)
WRITE !
SET DIR(0)="EA"
SET DIR("A")="END OF REPORT! Press <RET> to return to the menu."
DO ^DIR
KILL DIR
+2 DO ^%ZISC
if $DATA(ZTQUEUED)
SET ZTREQ="@"
KILL IO("Q")
+3 WRITE !!,"Updating history and dispensing totals."
TR SET ZTIO=""
SET ZTRTN="LOOP^PSAOP"
SET ZTDESC="Drug Acct-Dispensing Totals"
SET ZTDTH=$HOROLOG
SET (ZTSAVE("^TMP(""PSA"",$J,+PSADRUG,"),ZTSAVE("PSA*"))=""
DO ^%ZTLOAD
DO HOME^%ZIS
+1 KILL ^TMP("PSA",$JOB,+PSADRUG),PSA,PSADRUG
QUIT QUIT
IF PSAPG
SET DIR(0)="E"
DO ^DIR
KILL DIR
IF 'Y
SET PSAOUT=1
QUIT
+1 IF $$S^%ZTLOAD
SET PSAOUT=1
QUIT
+2 if $Y
WRITE @IOF
SET $PIECE(PSALN,"-",81)=""
SET PSAPG=PSAPG+1
WRITE !,?2,"DAILY DISPENSING TOTALS FOR ",$EXTRACT($PIECE($GET(^PSDRUG(+PSADRUG,0)),U),1,30),?70,"PAGE: ",PSAPG,!,PSALN,!
+3 WRITE " DATE",?23,"TOTAL",?45,"$/DISP",?67,"TOTAL",!
+4 WRITE "DISPENSED",?23,"DISP",?46,"UNIT",?68,"COST",!,PSALN
+5 QUIT
LOOP SET PSA(2)=0
FOR
SET PSA(2)=$ORDER(^TMP("PSA",$JOB,+PSADRUG,PSA(2)))
if 'PSA(2)
QUIT
SET PSA(3)=$PIECE(^TMP("PSA",$JOB,+PSADRUG,PSA(2)),"^")
Begin DoDot:1
+1 ;PSA*3*25 Dave B - Remove single reference for OP site
+2 SET PSA=^TMP("PSA",$JOB,+PSADRUG,PSA(2))
SET PSAOP=+$PIECE($GET(^PSD(58.8,PSALOC,0)),"^",10)
SET PSARELDT=+$PIECE(PSA(2),".")
+3 if $DATA(^XTMP("PSA",PSAOP,PSADRUG,PSARELDT))
KILL ^XTMP("PSA",PSAOP,PSADRUG,PSARELDT)
+4 DO ^PSAOP1
+5 SET DIE="^PSD(58.8,"_+PSALOC_",1,"
SET DA(1)=PSALOC
SET DA=PSADRUG
+6 SET DR="22////"_$PIECE(PSA,U,2)_";22.1////"_$PIECE(PSA,U,3)_";23////"_$PIECE(PSA,U,4)_";23.1////"_$PIECE(PSA,U,5)_";22.2////"_$PIECE(PSA,U,6)_";22.3////"_$PIECE(PSA,U,7)_";23.2////"_$PIECE(PSA,U,8)_";23.3////"_$PIECE(PSA,U,9)
+7 DO ^DIE
KILL DA,DIE,DR
End DoDot:1
+8 QUIT
