PSODGDG1.m

PSODGDG1 ;BHAM ISC/SAB - DRUG INTERACTION PROCESSOR ;02/25/94 9:14

 ;;7.0;OUTPATIENT PHARMACY;**251,372**;DEC 1997;Build 54

 ;External reference ^PSDRUG( supported by DBIA 221

 ;

 G PROC^PSODGDG2

PROCESS ;verification

 Q:$P(^PSRX(PSONV,"STA"),"^")=13

 W @IOF W !,$P(^DPT(DFN,0),"^"),?40,"ID#:"_VA("PID")_"  RX #"_$P(INT,"^")

 D CUTDATE^PSOFUNC:'$G(PSODTCUT),^PSOBUILD:'+$G(PSOZVER),^PSODSPL

 S DIR("?",1)="Answer 'YES' if you DO want to "_$S($P(SER,"^",4)=1:"continue processing",1:"enter an intervention for")_" this medication,"

 S DIR("?",2)="       'NO' if you DON'T want to "_$S($P(SER,"^",4)=1:"continue processing",1:"enter an intervention for")_" this medication,",DIR("?")="    or 'P' to review medication profile."

 W $C(7),$C(7) S DIR("A",1)="",DIR("A",2)="***"_$S($P(SER,"^",4)=1:"CRITICAL",1:"SIGNIFICANT")_"*** "_"Drug Interaction with RX #"_$P(^PSRX($P($P(MED,",",INA),"^"),0),"^"),DIR("A",3)="               Drug: "_$P($G(^PSDRUG($P(^(0),"^",6),0)),"^")

 S DIR(0)="SA^1:YES;0:NO;P:PROFILE",DIR("A")="Do you want to "_$S($P(SER,"^",4)=1:"Continue? ",1:"Intervene? "),DIR("B")="Y" D ^DIR I Y="P" W ! K Y G PROCESS

 I 'Y,$P(SER,"^",4)=1 S PSVERFLG=1

 I Y,$P(SER,"^",4)=1 S PSORX("INTERVENE")=1 K DIR,DTOUT,DIRUT,DIROUT,DUOUT D CRI Q 

 I Y,$P(SER,"^",4)=2 S PSORX("INTERVENE")=2,DA=IFN D INV

 K DIR,DTOUT,DIRUT,DIROUT,DUOUT Q

 Q

CRI ;new interactions

 K DIR I $P(RX,"^",15)=4 D CRITN Q

 S DIR("A",1)="",DIR("A",2)="Do you want to Process or Cancel medication?"

 S DIR("A")="Rx #"_$P($G(^PSRX(DA,0)),"^")_"   "_"Drug: "_$P($G(^PSDRUG($P(^PSRX(DA,0),"^",6),0)),"^")_": "

 S DIR(0)="SA^1:PROCESS;0:CANCEL MEDICATION",DIR("B")="PROCESS"

 K ANSDIR

 S DIR("?",1)="Enter '1' or 'P' to Process medication",DIR("?")="      '^' to EXIT",DIR("?",2)="      '0' or 'C' to Cancel Medication" D ^DIR K DIR

 I $D(DIRUT) S (PSORX("DFLG"),PSVERFLG)=1 Q

 S ANSDIR=Y,PSONV=DA

 D SIG^XUSESIG I X1="" S (PSORX("DFLG"),PSVERFLG)=1 K ANSDIR Q

 I 'ANSDIR N PSOHDINV D  G Q1

 .D NOOR^PSOCAN4 I $D(DIRUT) D UPOUT Q

 .S DA=PSONV D RXV S DA=PSONV,PSORX("INTERVENE")=1 D INV S DA=PSONV

 .D PSDEL,HLDINVS,DEL K PSORX("INTERVENE")  S PSVERFLG=1

 I ANSDIR&'$G(PSODIR) S DA=PSONV D HLDINV,INV S DA=PSONV D

 .I '$G(PSVERFLG) D ^PSODGDG2 S $P(^PSRX(PSONV,"STA"),"^")=1 S ZONE=PSONV D ONE

Q1 K DIK,DTOUT,DIRUT,DIROUT,DUOUT,LST,ANSDIR,PSONOOR S PSVERFLG=1

 Q

HLDINV           ;

 I $G(PSORX("INTERVENE")) S PSOHDINV=$G(PSORX("INTERVENE"))

 Q

 ;

 ;

HLDINVS ;

 I $G(PSOHDINV) S PSORX("INTERVENE")=PSOHDINV

 Q

 ;

CRITN ;multiple interactions

 S PSOTHER=$P($P(MED,",",INA),"^") N PSONV

 K DIR S DIR("A",1)="",DIR("A",2)="Do you want to: ",DIR("A",3)=" 1.  Cancel Rx #"_$P(INT,"^")_"  DRUG: "_$P(^PSDRUG($P(INT,"^",6),0),"^")

 S DIR("A",4)=" 2.  Cancel Rx #"_$P(RX,"^")_"  DRUG: "_$P(^PSDRUG($P(RX,"^",6),0),"^"),DIR("A",5)=" 3.  Cancel Both 1 and 2",DIR("A")=" 5.  Leave Both Non-verified (do nothing) ?: ",DIR("A",6)=" 4.  Process Both 1 and 2"

 S DIR(0)="SA^1:1 to be Canceled;2:2 to be Canceled;3:Cancel BOTH 1 and 2;4:ACTIVATE 1 and 2;5:DO NOTHING TO 1 and 2"

 S DIR("?",1)="Enter '1' to Cancel Rx #"_$P(INT,"^")_"  DRUG: "_$P(^PSDRUG($P(INT,"^",6),0),"^"),DIR("?",2)="      '2' to Cancel Rx #"_$P(RX,"^")_"  DRUG: "_$P(^PSDRUG($P(RX,"^",6),0),"^")

 S DIR("?",3)="      '3' or 'B' to Cancel Both 1 and 2",DIR("?",4)="      '4' or 'A' to Activate both RXs",DIR("?")="      '5' or 'D' to do nothing/leave both RXs in a Pending Status" D ^DIR K DIR I Y["^"!(Y=5)!($D(DIRUT)) S PSVERFLG=1 G CRIZ

 S PSAN=Y D SIG^XUSESIG I X1="" K PSAN S (PSORX("DFLG"),PSVERFLG)=1 G CRIZ

 I PSAN=1 D  D KILL Q

 .D NOOR^PSOCAN4 I $D(DIRUT) D UPOUT,KILL K PSONORR,PSORX("INTERVENE") Q

 .S DA=IFN D RXV

 .S DA=IFN D PSDEL,DEL

 .S:$G(PSOSD) PSOSD=PSOSD-1 S DA=IFN D INV S DA=$P(MED,",",INA) S DA=PSOTHER

 .D INV S DA=PSOTHER S $P(^PSRX(PSOTHER,"STA"),"^")=1,ZONE=PSOTHER

 .D ONE K PSONOOR

 I PSAN=2 D  D KILL K PSONOOR Q

 .D NOOR^PSOCAN4 I $D(DIRUT) D UPOUT,KILL K PSONOOR,PSORX("INTERVENE") Q

 .S DA=$P(MED,",",INA) D PSDEL,DEL

 .K PSONOOR S:$G(PSOSD) PSOSD=PSOSD-1 S DA=$P(MED,",",INA)

 .D INV S DA=IFN D INV S DA=IFN

 .I 'PSVERFLG,'$P(MED,",",(INA+1)) D ^PSODGDG2 S DA=IFN,$P(^PSRX(DA,"STA"),"^")=1 S ZONE=DA D ONE

 I PSAN=3 D  D KILL K PSONOOR Q

 .D NOOR^PSOCAN4 I $D(DIRUT) D UPOUT,KILL K PSONOOR,PSORX("INTERVENE") Q

 .F DA=$P(MED,",",INA),IFN S PSHOLDDA=DA D PSDEL,DEL S DA=PSHOLDDA D INV K DTOUT,DIROUT,DIRUT,DUOUT,PSAN,PSHOLDDA

 I $G(PSAN)=4 S LST=1,PPL="" D

 .S DA=$P(MED,",",INA) D INV S $P(^PSRX(PSOTHER,"STA"),"^")=1 S ZONE=PSOTHER S PSOTHER(PSOTHER)=PSOTHER D ONE

 .S DA=IFN D INV I 'PSVERFLG,'$P(MED,",",(INA+1)) D ^PSODGDG2 S DA=IFN,$P(^PSRX(DA,"STA"),"^")=1 S ZONE=DA D ONE

 .S:$G(PSOSD) PSOSD=PSOSD-2

 D KILL

CRIZ ;

 Q

RXV S DIK="^PS(52.4," D ^DIK Q  ;251;verify there's no dosing checks before deleting

INV D EN1^PSORXI(.DA) K PSORX("INTERVENE") Q

PSDEL Q:$G(STAT)']""

 S STA="ACTIVE^NON-VERIFIED^R^HOLD^NON-VERIFIED^ACTIVE^^^^^^ACTIVE^DISCONTINUE^^DISCONTINUE^DISCONTINUE^HOLD",STAT=$P(STA,"^",$P(^PSRX(DA,"STA"),"^")+1)

 I $P($G(PSOSD(STAT,$P(^PSDRUG($P(^PSRX(DA,0),"^",6),0),"^"))),"^")=DA K PSOSD(STAT,$P(^PSDRUG($P(^PSRX(DA,0),"^",6),0),"^"))

 E  K PSOSD(STAT,$P(^PSDRUG($P(^PSRX(DA,0),"^",6),0),"^")_"^"_DA)

 Q

DEL W !!,"Canceling Rx: "_$P($G(^PSRX(DA,0)),"^")_"   "_"Drug: "_$P($G(^PSDRUG($P(^PSRX(DA,0),"^",6),0)),"^"),!

 D ENQ^PSORXDL S PSORX("DFLG")=1

 S DIR(0)="E",DIR("?")="Press Return to continue",DIR("A")="Press Return to Continue" D ^DIR K DIR

 I $G(PSOPOCK) S VALMBCK="Q"

 Q

ONE S STA="ACTIVE^NON-VERIFIED^R^HOLD^NON-VERIFIED^ACTIVE^^^^^^ACTIVE^DISCONTINUE^^DISCONTINUE^DISCONTINUE^HOLD",STAT=$P(STA,"^",$P(^PSRX(ZONE,"STA"),"^")+1)

 I $P($G(PSOSD(STAT,$P(^PSDRUG($P(^PSRX(ZONE,0),"^",6),0),"^"))),"^")=ZONE S $P(PSOSD(STAT,$P(^PSDRUG($P(^PSRX(ZONE,0),"^",6),0),"^")),"^",2)=1

 E  I $G(PSOSD(STAT,$P(^PSDRUG($P(^PSRX(ZONE,0),"^",6),0),"^")_"^"_ZONE)) S $P(PSOSD(STAT,$P(^PSDRUG($P(^PSRX(ZONE,0),"^",6),0),"^")_"^"_ZONE),"^",2)=1

 K ZONE,STA,STAT Q

KILL K DIR,DIK,DTOUT,DIROUT,DIRUT,DUOUT,LST,PPL,PSAN Q

 ;

UPOUT W " ACTION NOT TAKEN!",! K DIR S DIR(0)="E",DIR("?")="Press Return to continue",DIR("A")="Press Return to Continue" D ^DIR K DIR S PSVERFLG=1 Q

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---PSODGDG1   6236     printed  Apr 23, 2025@18:41:22                                                                                                                                                                                                    Page 2

PSODGDG1  ;BHAM ISC/SAB - DRUG INTERACTION PROCESSOR ;02/25/94 9:14

 +1       ;;7.0;OUTPATIENT PHARMACY;**251,372**;DEC 1997;Build 54

 +2       ;External reference ^PSDRUG( supported by DBIA 221

 +3       ;

 +4        GOTO PROC^PSODGDG2

PROCESS   ;verification

 +1        if $PIECE(^PSRX(PSONV,"STA"),"^")=13

               QUIT 

 +2        WRITE @IOF

           WRITE !,$PIECE(^DPT(DFN,0),"^"),?40,"ID#:"_VA("PID")_"  RX #"_$PIECE(INT,"^")

 +3        if '$GET(PSODTCUT)

               DO CUTDATE^PSOFUNC

           if '+$GET(PSOZVER)

               DO ^PSOBUILD

           DO ^PSODSPL

 +4        SET DIR("?",1)="Answer 'YES' if you DO want to "_$SELECT($PIECE(SER,"^",4)=1:"continue processing",1:"enter an intervention for")_" this medication,"

 +5        SET DIR("?",2)="       'NO' if you DON'T want to "_$SELECT($PIECE(SER,"^",4)=1:"continue processing",1:"enter an intervention for")_" this medication,"

           SET DIR("?")="    or 'P' to review medication profile."

 +6        WRITE $CHAR(7),$CHAR(7)

           SET DIR("A",1)=""

           SET DIR("A",2)="***"_$SELECT($PIECE(SER,"^",4)=1:"CRITICAL",1:"SIGNIFICANT")_"*** "_"Drug Interaction with RX #"_$PIECE(^PSRX($PIECE($PIECE(MED,",",INA),"^"),0),"^")

           SET DIR("A",3)="               Drug: "_$PIECE($GET(^PSDRUG($PIECE(^(0),"^",6),0)),"^")

 +7        SET DIR(0)="SA^1:YES;0:NO;P:PROFILE"

           SET DIR("A")="Do you want to "_$SELECT($PIECE(SER,"^",4)=1:"Continue? ",1:"Intervene? ")

           SET DIR("B")="Y"

           DO ^DIR

           IF Y="P"

               WRITE !

               KILL Y

               GOTO PROCESS

 +8        IF 'Y

               IF $PIECE(SER,"^",4)=1

                   SET PSVERFLG=1

 +9        IF Y

               IF $PIECE(SER,"^",4)=1

                   SET PSORX("INTERVENE")=1

                   KILL DIR,DTOUT,DIRUT,DIROUT,DUOUT

                   DO CRI

                   QUIT 

 +10       IF Y

               IF $PIECE(SER,"^",4)=2

                   SET PSORX("INTERVENE")=2

                   SET DA=IFN

                   DO INV

 +11       KILL DIR,DTOUT,DIRUT,DIROUT,DUOUT

           QUIT 

 +12       QUIT 

CRI       ;new interactions

 +1        KILL DIR

           IF $PIECE(RX,"^",15)=4

               DO CRITN

               QUIT 

 +2        SET DIR("A",1)=""

           SET DIR("A",2)="Do you want to Process or Cancel medication?"

 +3        SET DIR("A")="Rx #"_$PIECE($GET(^PSRX(DA,0)),"^")_"   "_"Drug: "_$PIECE($GET(^PSDRUG($PIECE(^PSRX(DA,0),"^",6),0)),"^")_": "

 +4        SET DIR(0)="SA^1:PROCESS;0:CANCEL MEDICATION"

           SET DIR("B")="PROCESS"

 +5        KILL ANSDIR

 +6        SET DIR("?",1)="Enter '1' or 'P' to Process medication"

           SET DIR("?")="      '^' to EXIT"

           SET DIR("?",2)="      '0' or 'C' to Cancel Medication"

           DO ^DIR

           KILL DIR

 +7        IF $DATA(DIRUT)

               SET (PSORX("DFLG"),PSVERFLG)=1

               QUIT 

 +8        SET ANSDIR=Y

           SET PSONV=DA

 +9        DO SIG^XUSESIG

           IF X1=""

               SET (PSORX("DFLG"),PSVERFLG)=1

               KILL ANSDIR

               QUIT 

 +10       IF 'ANSDIR

               NEW PSOHDINV

               Begin DoDot:1

 +11               DO NOOR^PSOCAN4

                   IF $DATA(DIRUT)

                       DO UPOUT

                       QUIT 

 +12               SET DA=PSONV

                   DO RXV

                   SET DA=PSONV

                   SET PSORX("INTERVENE")=1

                   DO INV

                   SET DA=PSONV

 +13               DO PSDEL

                   DO HLDINVS

                   DO DEL

                   KILL PSORX("INTERVENE")

                   SET PSVERFLG=1

               End DoDot:1

               GOTO Q1

 +14       IF ANSDIR&'$GET(PSODIR)

               SET DA=PSONV

               DO HLDINV

               DO INV

               SET DA=PSONV

               Begin DoDot:1

 +15               IF '$GET(PSVERFLG)

                       DO ^PSODGDG2

                       SET $PIECE(^PSRX(PSONV,"STA"),"^")=1

                       SET ZONE=PSONV

                       DO ONE

               End DoDot:1

Q1         KILL DIK,DTOUT,DIRUT,DIROUT,DUOUT,LST,ANSDIR,PSONOOR

           SET PSVERFLG=1

 +1        QUIT 

HLDINV    ;

 +1        IF $GET(PSORX("INTERVENE"))

               SET PSOHDINV=$GET(PSORX("INTERVENE"))

 +2        QUIT 

 +3       ;

 +4       ;

HLDINVS   ;

 +1        IF $GET(PSOHDINV)

               SET PSORX("INTERVENE")=PSOHDINV

 +2        QUIT 

 +3       ;

CRITN     ;multiple interactions

 +1        SET PSOTHER=$PIECE($PIECE(MED,",",INA),"^")

           NEW PSONV

 +2        KILL DIR

           SET DIR("A",1)=""

           SET DIR("A",2)="Do you want to: "

           SET DIR("A",3)=" 1.  Cancel Rx #"_$PIECE(INT,"^")_"  DRUG: "_$PIECE(^PSDRUG($PIECE(INT,"^",6),0),"^")

 +3        SET DIR("A",4)=" 2.  Cancel Rx #"_$PIECE(RX,"^")_"  DRUG: "_$PIECE(^PSDRUG($PIECE(RX,"^",6),0),"^")

           SET DIR("A",5)=" 3.  Cancel Both 1 and 2"

           SET DIR("A")=" 5.  Leave Both Non-verified (do nothing) ?: "

           SET DIR("A",6)=" 4.  Process Both 1 and 2"

 +4        SET DIR(0)="SA^1:1 to be Canceled;2:2 to be Canceled;3:Cancel BOTH 1 and 2;4:ACTIVATE 1 and 2;5:DO NOTHING TO 1 and 2"

 +5        SET DIR("?",1)="Enter '1' to Cancel Rx #"_$PIECE(INT,"^")_"  DRUG: "_$PIECE(^PSDRUG($PIECE(INT,"^",6),0),"^")

           SET DIR("?",2)="      '2' to Cancel Rx #"_$PIECE(RX,"^")_"  DRUG: "_$PIECE(^PSDRUG($PIECE(RX,"^",6),0),"^")

 +6        SET DIR("?",3)="      '3' or 'B' to Cancel Both 1 and 2"

           SET DIR("?",4)="      '4' or 'A' to Activate both RXs"

           SET DIR("?")="      '5' or 'D' to do nothing/leave both RXs in a Pending Status"

           DO ^DIR

           KILL DIR

           IF Y["^"!(Y=5)!($DATA(DIRUT))

               SET PSVERFLG=1

               GOTO CRIZ

 +7        SET PSAN=Y

           DO SIG^XUSESIG

           IF X1=""

               KILL PSAN

               SET (PSORX("DFLG"),PSVERFLG)=1

               GOTO CRIZ

 +8        IF PSAN=1

               Begin DoDot:1

 +9                DO NOOR^PSOCAN4

                   IF $DATA(DIRUT)

                       DO UPOUT

                       DO KILL

                       KILL PSONORR,PSORX("INTERVENE")

                       QUIT 

 +10               SET DA=IFN

                   DO RXV

 +11               SET DA=IFN

                   DO PSDEL

                   DO DEL

 +12               if $GET(PSOSD)

                       SET PSOSD=PSOSD-1

                   SET DA=IFN

                   DO INV

                   SET DA=$PIECE(MED,",",INA)

                   SET DA=PSOTHER

 +13               DO INV

                   SET DA=PSOTHER

                   SET $PIECE(^PSRX(PSOTHER,"STA"),"^")=1

                   SET ZONE=PSOTHER

 +14               DO ONE

                   KILL PSONOOR

               End DoDot:1

               DO KILL

               QUIT 

 +15       IF PSAN=2

               Begin DoDot:1

 +16               DO NOOR^PSOCAN4

                   IF $DATA(DIRUT)

                       DO UPOUT

                       DO KILL

                       KILL PSONOOR,PSORX("INTERVENE")

                       QUIT 

 +17               SET DA=$PIECE(MED,",",INA)

                   DO PSDEL

                   DO DEL

 +18               KILL PSONOOR

                   if $GET(PSOSD)

                       SET PSOSD=PSOSD-1

                   SET DA=$PIECE(MED,",",INA)

 +19               DO INV

                   SET DA=IFN

                   DO INV

                   SET DA=IFN

 +20               IF 'PSVERFLG

                       IF '$PIECE(MED,",",(INA+1))

                           DO ^PSODGDG2

                           SET DA=IFN

                           SET $PIECE(^PSRX(DA,"STA"),"^")=1

                           SET ZONE=DA

                           DO ONE

               End DoDot:1

               DO KILL

               KILL PSONOOR

               QUIT 

 +21       IF PSAN=3

               Begin DoDot:1

 +22               DO NOOR^PSOCAN4

                   IF $DATA(DIRUT)

                       DO UPOUT

                       DO KILL

                       KILL PSONOOR,PSORX("INTERVENE")

                       QUIT 

 +23               FOR DA=$PIECE(MED,",",INA),IFN

                       SET PSHOLDDA=DA

                       DO PSDEL

                       DO DEL

                       SET DA=PSHOLDDA

                       DO INV

                       KILL DTOUT,DIROUT,DIRUT,DUOUT,PSAN,PSHOLDDA

               End DoDot:1

               DO KILL

               KILL PSONOOR

               QUIT 

 +24       IF $GET(PSAN)=4

               SET LST=1

               SET PPL=""

               Begin DoDot:1

 +25               SET DA=$PIECE(MED,",",INA)

                   DO INV

                   SET $PIECE(^PSRX(PSOTHER,"STA"),"^")=1

                   SET ZONE=PSOTHER

                   SET PSOTHER(PSOTHER)=PSOTHER

                   DO ONE

 +26               SET DA=IFN

                   DO INV

                   IF 'PSVERFLG

                       IF '$PIECE(MED,",",(INA+1))

                           DO ^PSODGDG2

                           SET DA=IFN

                           SET $PIECE(^PSRX(DA,"STA"),"^")=1

                           SET ZONE=DA

                           DO ONE

 +27               if $GET(PSOSD)

                       SET PSOSD=PSOSD-2

               End DoDot:1

 +28       DO KILL

CRIZ      ;

 +1        QUIT 

RXV       ;251;verify there's no dosing checks before deleting

           SET DIK="^PS(52.4,"

           DO ^DIK

           QUIT 

INV        DO EN1^PSORXI(.DA)

           KILL PSORX("INTERVENE")

           QUIT 

PSDEL      if $GET(STAT)']""

               QUIT 

 +1        SET STA="ACTIVE^NON-VERIFIED^R^HOLD^NON-VERIFIED^ACTIVE^^^^^^ACTIVE^DISCONTINUE^^DISCONTINUE^DISCONTINUE^HOLD"

           SET STAT=$PIECE(STA,"^",$PIECE(^PSRX(DA,"STA"),"^")+1)

 +2        IF $PIECE($GET(PSOSD(STAT,$PIECE(^PSDRUG($PIECE(^PSRX(DA,0),"^",6),0),"^"))),"^")=DA

               KILL PSOSD(STAT,$PIECE(^PSDRUG($PIECE(^PSRX(DA,0),"^",6),0),"^"))

 +3       IF '$TEST

               KILL PSOSD(STAT,$PIECE(^PSDRUG($PIECE(^PSRX(DA,0),"^",6),0),"^")_"^"_DA)

 +4        QUIT 

DEL        WRITE !!,"Canceling Rx: "_$PIECE($GET(^PSRX(DA,0)),"^")_"   "_"Drug: "_$PIECE($GET(^PSDRUG($PIECE(^PSRX(DA,0),"^",6),0)),"^"),!

 +1        DO ENQ^PSORXDL

           SET PSORX("DFLG")=1

 +2        SET DIR(0)="E"

           SET DIR("?")="Press Return to continue"

           SET DIR("A")="Press Return to Continue"

           DO ^DIR

           KILL DIR

 +3        IF $GET(PSOPOCK)

               SET VALMBCK="Q"

 +4        QUIT 

ONE        SET STA="ACTIVE^NON-VERIFIED^R^HOLD^NON-VERIFIED^ACTIVE^^^^^^ACTIVE^DISCONTINUE^^DISCONTINUE^DISCONTINUE^HOLD"

           SET STAT=$PIECE(STA,"^",$PIECE(^PSRX(ZONE,"STA"),"^")+1)

 +1        IF $PIECE($GET(PSOSD(STAT,$PIECE(^PSDRUG($PIECE(^PSRX(ZONE,0),"^",6),0),"^"))),"^")=ZONE

               SET $PIECE(PSOSD(STAT,$PIECE(^PSDRUG($PIECE(^PSRX(ZONE,0),"^",6),0),"^")),"^",2)=1

 +2       IF '$TEST

               IF $GET(PSOSD(STAT,$PIECE(^PSDRUG($PIECE(^PSRX(ZONE,0),"^",6),0),"^")_"^"_ZONE))

                   SET $PIECE(PSOSD(STAT,$PIECE(^PSDRUG($PIECE(^PSRX(ZONE,0),"^",6),0),"^")_"^"_ZONE),"^",2)=1

 +3        KILL ZONE,STA,STAT

           QUIT 

KILL       KILL DIR,DIK,DTOUT,DIROUT,DIRUT,DUOUT,LST,PPL,PSAN

           QUIT 

 +1       ;

UPOUT      WRITE " ACTION NOT TAKEN!",!

           KILL DIR

           SET DIR(0)="E"

           SET DIR("?")="Press Return to continue"

           SET DIR("A")="Press Return to Continue"

           DO ^DIR

           KILL DIR

           SET PSVERFLG=1

           QUIT