PSDEST.m

PSDEST ;BIR/BJW - Destroy a Drug from the Holding file ;9 Feb 98

 ;;3.0;CONTROLLED SUBSTANCES ;**8,79**;13 Feb 97;Build 20

 ;**Y2K compliance**, "P" added to date input string

 I '$D(PSDSITE) D ^PSDSET Q:'$D(PSDSITE)

 I '$D(^XUSEC("PSDMGR",DUZ)) W !!,"Please contact your Pharmacy Coordinator for access to",!,"destroy Controlled Substances.",!!,"PSDMGR security key required.",! G END

 S PSDUZ=DUZ

 I PSDUZ S PSDUZAN=$P($G(^VA(200,+PSDUZ,0)),"^")

SETDATE ;7/17/96,inital set to current date

 S PSDT=DT

ASKD ;ask disp location

 S PSDS=$P(PSDSITE,U,3),PSDSN=$P(PSDSITE,U,4)

 G:$P(PSDSITE,U,5) ASKN

 K DIC,DA S DIC=58.8,DIC(0)="QEAZ",DIC("S")="I $P(^(0),""^"",3)=+PSDSITE,$S($P(^(0),""^"",2)[""M"":1,$P(^(0),""^"",2)[""S"":1,1:0)"

 S DIC("A")="Select Primary Dispensing Site: ",DIC("B")=PSDSN

 D ^DIC K DIC G:Y<0 END

 S PSDS=+Y,PSDSN=$P(Y,"^",2),$P(PSDSITE,U,3)=+Y,$P(PSDSITE,U,4)=PSDSN

ASKN ;ask holding number

 W !!,?3,"**Searching for the next available drug awaiting destruction**",!

 K DIC,DA S DIC=58.86,DIC("A")="Select Destructions #: ",DIC(0)="QEAZ",DIC("S")="I $P(^(0),""^"",7)=PSDS"

 F PSD=0:0 S PSD=$O(^PSD(58.86,PSD)) Q:'PSD!($D(DIC("B")))  I $D(^PSD(58.86,PSD,0)),'+$P(^(0),"^",10),+$P(^(0),"^",7)=+PSDS S DIC("B")=PSD

 D ^DIC K DA,DIC G:Y<0 END S PSDA=+Y

 W !!,?3,"**You Must enter a DATE to destroy or cancel this Holding Num**"

DISPLAY ;

 K LN S $P(LN,"-",30)="",PSDR=$P(Y(0),"^",2),PSDRN=$S($P($G(^PSD(58.86,PSDA,1)),"^")]"":$P($G(^PSD(58.86,PSDA,1)),"^"),1:$P($G(^PSDRUG(+PSDR,0)),"^")),NUM=$P(Y(0),"^"),QTY=$P(Y(0),"^",3)

 S PSDCT=$S($P(Y(0),"^",8)]"":$P(Y(0),"^",8),1:1),NBKU=$S($P(Y(0),"^",12)]"":$P(Y(0),"^",12),1:$P($G(^PSD(58.8,+PSDS,1,+PSDR,0)),"^",8))

 S PSDCAN=$P($G(^PSD(58.86,PSDA,3)),"^") I PSDCAN S Y=PSDCAN X ^DD("DD") S PSDCAN=Y D MSG2 G ASKN

 S PSDST=$P(Y(0),"^",11) I PSDST S Y=PSDST X ^DD("DD") S PSDST=Y D MSG1 G ASKN

 W @IOF,!,"HOLDING FOR DESTRUCTION",!,LN,!!,"Holding Number: ",NUM

 W !,"Drug: ",PSDRN,!,"Quantity "_$S($D(^PSD(58.8,+PSDR,0)):"("_NBKU_")",1:"")_": ",QTY,!

OK ;ask ok

 K DA,DIR,DIRUT S DIR(0)="Y",DIR("B")="YES",DIR("A")="Do you want to destroy this Controlled Substances"

 S DIR("?",1)="Answer 'YES' if you are destroying this drug,",DIR("?")="answer 'NO' and this drug will remain pending destruction."

 D ^DIR K DIR I $D(DIRUT) D MSG G END

 S ANS=Y(0) I ANS="YES" D DATE G:'$D(PSDT) END G DIE

 I ANS="NO" G OK1 G:'$D(PSDT) END

DATE ; ask date,7/17/96 added %DT("B")default date or user can enter new date

 K %DT W !

 S %DT="AEPTX",%DT(0)="-NOW",%DT("A")="DATE DESTROYED/CANCELLED: ",%DT("B")=$$FMTE^XLFDT(PSDT) D ^%DT G:Y<0 END S PSDT=Y W !

 Q

OK1 ;ask if entry error

 K DA,DIR,DIRUT S DIR(0)="Y",DIR("B")="NO",DIR("A")="Was this a destruction holding number entry error"

 S DIR("?",1)="Answer 'NO' drug will be destroyed,",DIR("?")="answer 'YES' and this drug will not be destroyed."

 D ^DIR K DIR I $D(DIRUT) D MSG G END

OK2 ;ask do you want to cancel holding #,E3R# 4990

 K DA,DIR,DIRUT S DIR(0)="Y",DIR("B")="NO",DIR("A")="Do you want to cancel this destruction holding number"

 S DIR("?",1)="Answer 'NO' if you do not want to cancel this destruction holding number,",DIR("?")="answer 'YES' and the destruction holding number will be cancelled."

 D ^DIR K DIR I $D(DIRUT) D MSG G END

 I 'Y DO MSG G ASKN

DIRC ;enter reason,date and pharmacist cancelling holding #,E3R# 4990

 W !! D DATE G:'$D(PSDT) END

COM ; enter free-text information(comments) 

 K DA,DIR,DIRUT S DIR(0)="58.86,17" D ^DIR K DIR I $D(DIRUT) D MSG G END

 I Y[";" W !,"A semicolon is not allowed in the COMMENTS field. Please edit your entry.",$C(7) G COM

 S PSDCOM3=Y

 K DIRUT,DTOUT,DUOUT

 I PSDT S (Y,YYY)=PSDT X ^DD("DD") S PSDT=Y

 W !,"DATE/TIME CANCELLED: ",PSDT

 W !,"CANCELLED BY: ",PSDUZAN

DIE1 ;update 58.86 for cancelling holding #,E3R# 4990

 ;The AC,AD X-ref's entries are built on the condition that data is in

 ;Field 10(date/time destroyed),11/29/95 added I $D(Y) 

 K DA,DIE,DR S DA=PSDA,DIE=58.86,DR="9////"_PSDUZ_";10///"_PSDT_";15///"_PSDT_";16////"_PSDUZ_";17////"_PSDCOM3_";11///^S X=PSDCT;12///^S X=NBKU" D ^DIE K DA,DIE,DR I $D(Y) D MSG G END

 W !!,"Holding Number: ",NUM,?19," flagged as entry error"

 S PSDT=YYY G ASKN

DIE ;update 58.86

 ;10/22/96 added / to fld#11,12 to remove prompt;11/29/95 added I $D(Y)

 W !,?3,"** Updating the record **",! K DA,DIE,DR S DA=PSDA,DIE=58.86,DR="9////"_PSDUZ_";10///"_PSDT_";11///^S X=PSDCT;12///^S X=NBKU" D ^DIE K DA,DIE,DR

 I $D(Y) D MSG G END

 W !!,?3,"=> Holding Number: ",NUM," has been destroyed.",!!

 G ASKN

END K %,%DT,%H,%I,ANS,DA,DIC,DIE,DIR,DIROUT,DIRUT,DR,DTOUT,DUOUT,LN,NBKU,NUM

 K PSD,PSDA,PSDCAN,PSDCOM3,PSDR,PSDRN,PSDCT,PSDS,PSDSN,PSDT,PSDST,PSDUZ,PSDUZAN,QTY,X,Y,YYY

 Q

MSG W !!,"No action taken",!!

 Q

MSG1 ;msg when already destroyed

 W $C(7),!!,"Drug: ",PSDRN,!,"=> Destruction #: ",NUM," was destroyed on ",PSDST,".",!!

 Q

MSG2 ;msg when cancelled,E3R# 4990

 W $C(7),!!,"Drug: ",PSDRN,!,"=> Destruction #: ",NUM," was cancelled on ",PSDCAN,".",!!

 Q

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---PSDEST   5040     printed  Mar 13, 2025@20:50:31                                                                                                                                                                                                      Page 2

PSDEST    ;BIR/BJW - Destroy a Drug from the Holding file ;9 Feb 98

 +1       ;;3.0;CONTROLLED SUBSTANCES ;**8,79**;13 Feb 97;Build 20

 +2       ;**Y2K compliance**, "P" added to date input string

 +3        IF '$DATA(PSDSITE)

               DO ^PSDSET

               if '$DATA(PSDSITE)

                   QUIT 

 +4        IF '$DATA(^XUSEC("PSDMGR",DUZ))

               WRITE !!,"Please contact your Pharmacy Coordinator for access to",!,"destroy Controlled Substances.",!!,"PSDMGR security key required.",!

               GOTO END

 +5        SET PSDUZ=DUZ

 +6        IF PSDUZ

               SET PSDUZAN=$PIECE($GET(^VA(200,+PSDUZ,0)),"^")

SETDATE   ;7/17/96,inital set to current date

 +1        SET PSDT=DT

ASKD      ;ask disp location

 +1        SET PSDS=$PIECE(PSDSITE,U,3)

           SET PSDSN=$PIECE(PSDSITE,U,4)

 +2        if $PIECE(PSDSITE,U,5)

               GOTO ASKN

 +3        KILL DIC,DA

           SET DIC=58.8

           SET DIC(0)="QEAZ"

           SET DIC("S")="I $P(^(0),""^"",3)=+PSDSITE,$S($P(^(0),""^"",2)[""M"":1,$P(^(0),""^"",2)[""S"":1,1:0)"

 +4        SET DIC("A")="Select Primary Dispensing Site: "

           SET DIC("B")=PSDSN

 +5        DO ^DIC

           KILL DIC

           if Y<0

               GOTO END

 +6        SET PSDS=+Y

           SET PSDSN=$PIECE(Y,"^",2)

           SET $PIECE(PSDSITE,U,3)=+Y

           SET $PIECE(PSDSITE,U,4)=PSDSN

ASKN      ;ask holding number

 +1        WRITE !!,?3,"**Searching for the next available drug awaiting destruction**",!

 +2        KILL DIC,DA

           SET DIC=58.86

           SET DIC("A")="Select Destructions #: "

           SET DIC(0)="QEAZ"

           SET DIC("S")="I $P(^(0),""^"",7)=PSDS"

 +3        FOR PSD=0:0

               SET PSD=$ORDER(^PSD(58.86,PSD))

               if 'PSD!($DATA(DIC("B")))

                   QUIT 

               IF $DATA(^PSD(58.86,PSD,0))

                   IF '+$PIECE(^(0),"^",10)

                       IF +$PIECE(^(0),"^",7)=+PSDS

                           SET DIC("B")=PSD

 +4        DO ^DIC

           KILL DA,DIC

           if Y<0

               GOTO END

           SET PSDA=+Y

 +5        WRITE !!,?3,"**You Must enter a DATE to destroy or cancel this Holding Num**"

DISPLAY   ;

 +1        KILL LN

           SET $PIECE(LN,"-",30)=""

           SET PSDR=$PIECE(Y(0),"^",2)

           SET PSDRN=$SELECT($PIECE($GET(^PSD(58.86,PSDA,1)),"^")]"":$PIECE($GET(^PSD(58.86,PSDA,1)),"^"),1:$PIECE($GET(^PSDRUG(+PSDR,0)),"^"))

           SET NUM=$PIECE(Y(0),"^")

           SET QTY=$PIECE(Y(0),"^",3)

 +2        SET PSDCT=$SELECT($PIECE(Y(0),"^",8)]"":$PIECE(Y(0),"^",8),1:1)

           SET NBKU=$SELECT($PIECE(Y(0),"^",12)]"":$PIECE(Y(0),"^",12),1:$PIECE($GET(^PSD(58.8,+PSDS,1,+PSDR,0)),"^",8))

 +3        SET PSDCAN=$PIECE($GET(^PSD(58.86,PSDA,3)),"^")

           IF PSDCAN

               SET Y=PSDCAN

               XECUTE ^DD("DD")

               SET PSDCAN=Y

               DO MSG2

               GOTO ASKN

 +4        SET PSDST=$PIECE(Y(0),"^",11)

           IF PSDST

               SET Y=PSDST

               XECUTE ^DD("DD")

               SET PSDST=Y

               DO MSG1

               GOTO ASKN

 +5        WRITE @IOF,!,"HOLDING FOR DESTRUCTION",!,LN,!!,"Holding Number: ",NUM

 +6        WRITE !,"Drug: ",PSDRN,!,"Quantity "_$SELECT($DATA(^PSD(58.8,+PSDR,0)):"("_NBKU_")",1:"")_": ",QTY,!

OK        ;ask ok

 +1        KILL DA,DIR,DIRUT

           SET DIR(0)="Y"

           SET DIR("B")="YES"

           SET DIR("A")="Do you want to destroy this Controlled Substances"

 +2        SET DIR("?",1)="Answer 'YES' if you are destroying this drug,"

           SET DIR("?")="answer 'NO' and this drug will remain pending destruction."

 +3        DO ^DIR

           KILL DIR

           IF $DATA(DIRUT)

               DO MSG

               GOTO END

 +4        SET ANS=Y(0)

           IF ANS="YES"

               DO DATE

               if '$DATA(PSDT)

                   GOTO END

               GOTO DIE

 +5        IF ANS="NO"

               GOTO OK1

               if '$DATA(PSDT)

                   GOTO END

DATE      ; ask date,7/17/96 added %DT("B")default date or user can enter new date

 +1        KILL %DT

           WRITE !

 +2        SET %DT="AEPTX"

           SET %DT(0)="-NOW"

           SET %DT("A")="DATE DESTROYED/CANCELLED: "

           SET %DT("B")=$$FMTE^XLFDT(PSDT)

           DO ^%DT

           if Y<0

               GOTO END

           SET PSDT=Y

           WRITE !

 +3        QUIT 

OK1       ;ask if entry error

 +1        KILL DA,DIR,DIRUT

           SET DIR(0)="Y"

           SET DIR("B")="NO"

           SET DIR("A")="Was this a destruction holding number entry error"

 +2        SET DIR("?",1)="Answer 'NO' drug will be destroyed,"

           SET DIR("?")="answer 'YES' and this drug will not be destroyed."

 +3        DO ^DIR

           KILL DIR

           IF $DATA(DIRUT)

               DO MSG

               GOTO END

OK2       ;ask do you want to cancel holding #,E3R# 4990

 +1        KILL DA,DIR,DIRUT

           SET DIR(0)="Y"

           SET DIR("B")="NO"

           SET DIR("A")="Do you want to cancel this destruction holding number"

 +2        SET DIR("?",1)="Answer 'NO' if you do not want to cancel this destruction holding number,"

           SET DIR("?")="answer 'YES' and the destruction holding number will be cancelled."

 +3        DO ^DIR

           KILL DIR

           IF $DATA(DIRUT)

               DO MSG

               GOTO END

 +4        IF 'Y

               DO MSG

               GOTO ASKN

DIRC      ;enter reason,date and pharmacist cancelling holding #,E3R# 4990

 +1        WRITE !!

           DO DATE

           if '$DATA(PSDT)

               GOTO END

COM       ; enter free-text information(comments) 

 +1        KILL DA,DIR,DIRUT

           SET DIR(0)="58.86,17"

           DO ^DIR

           KILL DIR

           IF $DATA(DIRUT)

               DO MSG

               GOTO END

 +2        IF Y[";"

               WRITE !,"A semicolon is not allowed in the COMMENTS field. Please edit your entry.",$CHAR(7)

               GOTO COM

 +3        SET PSDCOM3=Y

 +4        KILL DIRUT,DTOUT,DUOUT

 +5        IF PSDT

               SET (Y,YYY)=PSDT

               XECUTE ^DD("DD")

               SET PSDT=Y

 +6        WRITE !,"DATE/TIME CANCELLED: ",PSDT

 +7        WRITE !,"CANCELLED BY: ",PSDUZAN

DIE1      ;update 58.86 for cancelling holding #,E3R# 4990

 +1       ;The AC,AD X-ref's entries are built on the condition that data is in

 +2       ;Field 10(date/time destroyed),11/29/95 added I $D(Y) 

 +3        KILL DA,DIE,DR

           SET DA=PSDA

           SET DIE=58.86

           SET DR="9////"_PSDUZ_";10///"_PSDT_";15///"_PSDT_";16////"_PSDUZ_";17////"_PSDCOM3_";11///^S X=PSDCT;12///^S X=NBKU"

           DO ^DIE

           KILL DA,DIE,DR

           IF $DATA(Y)

               DO MSG

               GOTO END

 +4        WRITE !!,"Holding Number: ",NUM,?19," flagged as entry error"

 +5        SET PSDT=YYY

           GOTO ASKN

DIE       ;update 58.86

 +1       ;10/22/96 added / to fld#11,12 to remove prompt;11/29/95 added I $D(Y)

 +2        WRITE !,?3,"** Updating the record **",!

           KILL DA,DIE,DR

           SET DA=PSDA

           SET DIE=58.86

           SET DR="9////"_PSDUZ_";10///"_PSDT_";11///^S X=PSDCT;12///^S X=NBKU"

           DO ^DIE

           KILL DA,DIE,DR

 +3        IF $DATA(Y)

               DO MSG

               GOTO END

 +4        WRITE !!,?3,"=> Holding Number: ",NUM," has been destroyed.",!!

 +5        GOTO ASKN

END        KILL %,%DT,%H,%I,ANS,DA,DIC,DIE,DIR,DIROUT,DIRUT,DR,DTOUT,DUOUT,LN,NBKU,NUM

 +1        KILL PSD,PSDA,PSDCAN,PSDCOM3,PSDR,PSDRN,PSDCT,PSDS,PSDSN,PSDT,PSDST,PSDUZ,PSDUZAN,QTY,X,Y,YYY

 +2        QUIT 

MSG        WRITE !!,"No action taken",!!

 +1        QUIT 

MSG1      ;msg when already destroyed

 +1        WRITE $CHAR(7),!!,"Drug: ",PSDRN,!,"=> Destruction #: ",NUM," was destroyed on ",PSDST,".",!!

 +2        QUIT 

MSG2      ;msg when cancelled,E3R# 4990

 +1        WRITE $CHAR(7),!!,"Drug: ",PSDRN,!,"=> Destruction #: ",NUM," was cancelled on ",PSDCAN,".",!!

 +2        QUIT