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 ---[H[J[2J[HPSDEST 5040 printed Oct 16, 2024@17:46:41 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
