PSDESTF ;BIR/BJW - Add Non-CS Drug to Holding file ;26 Feb 98
;;3.0;CONTROLLED SUBSTANCES ;**8,66,69,79**;13 Feb 97;Build 20
;**Y2K compliance**;display 4 digit year on va forms
;References to ^PSD(58.86, supported by DBIA4472
;
I '$D(PSDSITE) D ^PSDSET Q:'$D(PSDSITE)
I '$D(^XUSEC("PSJ RPHARM",DUZ)),'$D(^XUSEC("PSD TECH ADV",DUZ)) W !!,"Please contact your Pharmacy Coordinator for access to",!,"destroy Controlled Substances.",!!,"PSJ RPHARM or PSD TECH ADV security key required.",! G END
S PSDUZ=DUZ,PSDOUT=0 D NOW^%DTC S PSDT=+$E(%,1,12)
W !!,?5,"NOTE: This Holding for Destruction transaction WILL NOT update your",!,?5,"Controlled Substances inventory balance.",!!
ASKD ;ask disp location
S PSDS=$P(PSDSITE,U,3),PSDSN=$P(PSDSITE,U,4) G:$P(PSDSITE,U,5) DEST
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
DEST ;set up file 58.86
S PSDOUT=0,PSDCT=1
S (MFG,LOT,EXP)=""
DIR ;ask free-text drug name
W !!,"You may create a free-text CS drug to place on hold for destruction.",!,"Your Dispensing Site inventory balance WILL NOT be updated.",!!
DIR0 ;
K DA,DIR,DIRUT S DIR(0)="58.86,13" D ^DIR K DA,DIR
I $D(DIRUT) D MSG G END
I Y']"" D MSG G END
I Y[";" W !,"A semicolon is not allowed in the DRUG ITEM field. Please edit your entry.",!,$C(7) G DIR0
S PSDRN=Y
DIR2 K DA,DIR,DIRUT,DTOUT,DUOUT F PSDANS=2,4,11,12,18 S DIR(0)="58.86,"_PSDANS D ^DIR K DA,DIR D I PSDOUT D MSG G END
.I $D(DTOUT)!($D(DUOUT)) S PSDOUT=1 Q
.I PSDANS'=4,PSDANS'=18,Y']"" S PSDOUT=1 Q
.S PSD(PSDANS)=Y
.K DIRUT,DTOUT,DUOUT
;DIR3 added 5/7/95 to add comments field
DIR3 ;enter free-text information(comments)
W !!,"You may enter free-text info regarding drug placed on hold for destruction."
K DA,DIR,DIRUT S DIR(0)="58.86,14" D ^DIR K DA,DIR
I $D(DTOUT)!($D(DUOUT)) D MSG G END
I Y[";" W !,"A semicolon is not allowed in the COMMENTS field. Please edit your entry.",!,$C(7) G DIR3
S PSDCOMS=Y
ASKY ;ask ok to continue
W !!,PSDRN," has been selected.",!
K DA,DIR,DIRUT S DIR(0)="YA",DIR("B")="NO",DIR("A")="Is this OK to create Holding for Destructions number? "
S DIR("?",1)="Answer 'YES' to create a Holding for Destruction number for this drug,",DIR("?")="answer 'NO' to create a different free-text CS drug, or '^' to quit."
D ^DIR K DIR I $D(DIRUT) D MSG G END
I 'Y G DIR
W !!,"Creating an entry in the Destructions file..."
F L +^PSD(58.86,0):$S($G(DILOCKTM)>0:DILOCKTM,1:3) I Q
;5/7/95 Fld 14 added, 7/28/95 Fld 18 added
FIND S PSDHLD=$P(^PSD(58.86,0),"^",3)+1 I $D(^PSD(58.86,PSDHLD)) S $P(^PSD(58.86,0),"^",3)=PSDHLD G FIND
K DA,DIC,DLAYGO S (DIC,DLAYGO)=58.86,DIC(0)="L",(X,DINUM)=PSDHLD D ^DIC K DIC,DINUM,DLAYGO
L -^PSD(58.86,0)
W !!,"Your Destructions Holding number is ",PSDHLD
K DA,DIE,DR S DIE=58.86,DA=PSDHLD,DR="13////"_PSDRN_";2////"_PSD(2)_";3////"_PSDUZ_";5////"_PSDT_";6////"_PSDS_";4////"_$S(+PSD(4):+PSD(4),1:"")_";11////"_+PSD(11)_";12////"_PSD(12)_";14////"_PSDCOMS_";18////"_+PSD(18)
D ^DIE K DIE,DA,DR
S RQTY=$P($G(^PSD(58.86,PSDHLD,0)),"^",3),PSDRN=$P($G(^(1)),"^")
S PSDOK=1
PRINT ;print 2321
W !!,"Number of copies of VA FORM 10-2321? " R NUM:DTIME I '$T!(NUM="^")!(NUM="") W !!,"No copies printed!!",!! Q
I NUM'?1N!(NUM=0) W !!,"Enter a whole number between 1 and 9",! G PRINT
S Y=PSDT X ^DD("DD") S PSDYR=$P(Y,",",2),PSDYR=$E(PSDYR,1,4)
S PG=0,RECDT=$E(PSDT,4,5)_"/"_$E(PSDT,6,7)_"/"_PSDYR I EXP S (EXP1,EXPD)=$$FMTE^XLFDT(EXP,"5D") S:'$P(EXP1,"/",2) EXPD=$P(EXP1,"/")_"/"_$P(EXP1,"/",3)
D ^PSDGSRV2
END ;kill variables
K %,%DT,%H,%I,ALL,CNT,DA,DIC,DIE,DINUM,DIR,DIROUT,DIRUT,DLAYGO,DR,DTOUT,DUOUT,EXP,EXP1,EXPD,LN,LOT,MFG,NUM
K PG,PSD,PSDANS,PSDCT,PSDCOMS,PSDHLD,PSDOK,PSDOUT,PSDRN,PSDS,PSDSN,PSDT,PSDUZ,PSDYR,RECDT,RPDT,RQTY,X,Y,ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE,ZTSK
Q
MSG W $C(7),!!,"WARNING: Holding for Destructions entry HAS NOT been created.",!!
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSDESTF 4124 printed Dec 13, 2024@01:45:51 Page 2
PSDESTF ;BIR/BJW - Add Non-CS Drug to Holding file ;26 Feb 98
+1 ;;3.0;CONTROLLED SUBSTANCES ;**8,66,69,79**;13 Feb 97;Build 20
+2 ;**Y2K compliance**;display 4 digit year on va forms
+3 ;References to ^PSD(58.86, supported by DBIA4472
+4 ;
+5 IF '$DATA(PSDSITE)
DO ^PSDSET
if '$DATA(PSDSITE)
QUIT
+6 IF '$DATA(^XUSEC("PSJ RPHARM",DUZ))
IF '$DATA(^XUSEC("PSD TECH ADV",DUZ))
WRITE !!,"Please contact your Pharmacy Coordinator for access to",!,"destroy Controlled Substances.",!!,"PSJ RPHARM or PSD TECH ADV security key required.",!
GOTO END
+7 SET PSDUZ=DUZ
SET PSDOUT=0
DO NOW^%DTC
SET PSDT=+$EXTRACT(%,1,12)
+8 WRITE !!,?5,"NOTE: This Holding for Destruction transaction WILL NOT update your",!,?5,"Controlled Substances inventory balance.",!!
ASKD ;ask disp location
+1 SET PSDS=$PIECE(PSDSITE,U,3)
SET PSDSN=$PIECE(PSDSITE,U,4)
if $PIECE(PSDSITE,U,5)
GOTO DEST
+2 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)"
+3 SET DIC("A")="Select Primary Dispensing Site: "
SET DIC("B")=PSDSN
+4 DO ^DIC
KILL DIC
if Y<0
GOTO END
+5 SET PSDS=+Y
SET PSDSN=$PIECE(Y,"^",2)
SET $PIECE(PSDSITE,U,3)=+Y
SET $PIECE(PSDSITE,U,4)=PSDSN
DEST ;set up file 58.86
+1 SET PSDOUT=0
SET PSDCT=1
+2 SET (MFG,LOT,EXP)=""
DIR ;ask free-text drug name
+1 WRITE !!,"You may create a free-text CS drug to place on hold for destruction.",!,"Your Dispensing Site inventory balance WILL NOT be updated.",!!
DIR0 ;
+1 KILL DA,DIR,DIRUT
SET DIR(0)="58.86,13"
DO ^DIR
KILL DA,DIR
+2 IF $DATA(DIRUT)
DO MSG
GOTO END
+3 IF Y']""
DO MSG
GOTO END
+4 IF Y[";"
WRITE !,"A semicolon is not allowed in the DRUG ITEM field. Please edit your entry.",!,$CHAR(7)
GOTO DIR0
+5 SET PSDRN=Y
DIR2 KILL DA,DIR,DIRUT,DTOUT,DUOUT
FOR PSDANS=2,4,11,12,18
SET DIR(0)="58.86,"_PSDANS
DO ^DIR
KILL DA,DIR
Begin DoDot:1
+1 IF $DATA(DTOUT)!($DATA(DUOUT))
SET PSDOUT=1
QUIT
+2 IF PSDANS'=4
IF PSDANS'=18
IF Y']""
SET PSDOUT=1
QUIT
+3 SET PSD(PSDANS)=Y
+4 KILL DIRUT,DTOUT,DUOUT
End DoDot:1
IF PSDOUT
DO MSG
GOTO END
+5 ;DIR3 added 5/7/95 to add comments field
DIR3 ;enter free-text information(comments)
+1 WRITE !!,"You may enter free-text info regarding drug placed on hold for destruction."
+2 KILL DA,DIR,DIRUT
SET DIR(0)="58.86,14"
DO ^DIR
KILL DA,DIR
+3 IF $DATA(DTOUT)!($DATA(DUOUT))
DO MSG
GOTO END
+4 IF Y[";"
WRITE !,"A semicolon is not allowed in the COMMENTS field. Please edit your entry.",!,$CHAR(7)
GOTO DIR3
+5 SET PSDCOMS=Y
ASKY ;ask ok to continue
+1 WRITE !!,PSDRN," has been selected.",!
+2 KILL DA,DIR,DIRUT
SET DIR(0)="YA"
SET DIR("B")="NO"
SET DIR("A")="Is this OK to create Holding for Destructions number? "
+3 SET DIR("?",1)="Answer 'YES' to create a Holding for Destruction number for this drug,"
SET DIR("?")="answer 'NO' to create a different free-text CS drug, or '^' to quit."
+4 DO ^DIR
KILL DIR
IF $DATA(DIRUT)
DO MSG
GOTO END
+5 IF 'Y
GOTO DIR
+6 WRITE !!,"Creating an entry in the Destructions file..."
+7 FOR
LOCK +^PSD(58.86,0):$SELECT($GET(DILOCKTM)>0:DILOCKTM,1:3)
IF $TEST
QUIT
+8 ;5/7/95 Fld 14 added, 7/28/95 Fld 18 added
FIND SET PSDHLD=$PIECE(^PSD(58.86,0),"^",3)+1
IF $DATA(^PSD(58.86,PSDHLD))
SET $PIECE(^PSD(58.86,0),"^",3)=PSDHLD
GOTO FIND
+1 KILL DA,DIC,DLAYGO
SET (DIC,DLAYGO)=58.86
SET DIC(0)="L"
SET (X,DINUM)=PSDHLD
DO ^DIC
KILL DIC,DINUM,DLAYGO
+2 LOCK -^PSD(58.86,0)
+3 WRITE !!,"Your Destructions Holding number is ",PSDHLD
+4 KILL DA,DIE,DR
SET DIE=58.86
SET DA=PSDHLD
SET DR="13////"_PSDRN_";2////"_PSD(2)_";3////"_PSDUZ_";5////"_PSDT_";6////"_PSDS_";4////"_$SELECT(+PSD(4):+PSD(4),1:"")_";11////"_+PSD(11)_";12////"_PSD(12)_";14////"_PSDCOMS_";18////"_+PSD(18)
+5 DO ^DIE
KILL DIE,DA,DR
+6 SET RQTY=$PIECE($GET(^PSD(58.86,PSDHLD,0)),"^",3)
SET PSDRN=$PIECE($GET(^(1)),"^")
+7 SET PSDOK=1
PRINT ;print 2321
+1 WRITE !!,"Number of copies of VA FORM 10-2321? "
READ NUM:DTIME
IF '$TEST!(NUM="^")!(NUM="")
WRITE !!,"No copies printed!!",!!
QUIT
+2 IF NUM'?1N!(NUM=0)
WRITE !!,"Enter a whole number between 1 and 9",!
GOTO PRINT
+3 SET Y=PSDT
XECUTE ^DD("DD")
SET PSDYR=$PIECE(Y,",",2)
SET PSDYR=$EXTRACT(PSDYR,1,4)
+4 SET PG=0
SET RECDT=$EXTRACT(PSDT,4,5)_"/"_$EXTRACT(PSDT,6,7)_"/"_PSDYR
IF EXP
SET (EXP1,EXPD)=$$FMTE^XLFDT(EXP,"5D")
if '$PIECE(EXP1,"/",2)
SET EXPD=$PIECE(EXP1,"/")_"/"_$PIECE(EXP1,"/",3)
+5 DO ^PSDGSRV2
END ;kill variables
+1 KILL %,%DT,%H,%I,ALL,CNT,DA,DIC,DIE,DINUM,DIR,DIROUT,DIRUT,DLAYGO,DR,DTOUT,DUOUT,EXP,EXP1,EXPD,LN,LOT,MFG,NUM
+2 KILL PG,PSD,PSDANS,PSDCT,PSDCOMS,PSDHLD,PSDOK,PSDOUT,PSDRN,PSDS,PSDSN,PSDT,PSDUZ,PSDYR,RECDT,RPDT,RQTY,X,Y,ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE,ZTSK
+3 QUIT
MSG WRITE $CHAR(7),!!,"WARNING: Holding for Destructions entry HAS NOT been created.",!!
+1 QUIT
