Routine: PSDESTF

PSDESTF ;BIR/BJW-Add Non-CS Drug to Holding file ;29-May-2012 14:24;PLS

 ;;3.0; CONTROLLED SUBSTANCES ;**8,66,1015**;13 Feb 97;Build 62

 ;**Y2K compliance**;display 4 digit year on va forms

 ; Modified - IHS/CIA/PLS - 01/28/04 - Removed references to VA FORM

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

 I '$D(^XUSEC("PSJ RPHARM",DUZ)) W !!,"Please contact your Pharmacy Coordinator for access to",!,"destroy Controlled Substances.",!!,"PSJ RPHARM 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.",!!

 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

 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

 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

 ; IHS/CIA/PLS - 01/28/04 - Remove reference to VA FORM #

 ;W !!,"Number of copies of VA FORM 10-2321? " R NUM:DTIME I '$T!(NUM="^")!(NUM="") W !!,"No copies printed!!",!! Q

 W !!,"Number of copies of form? " 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

MSG W $C(7),!!,"WARNING: Holding for Destructions entry HAS NOT been created.",!!

PSDESTF   ;BIR/BJW-Add Non-CS Drug to Holding file ;29-May-2012 14:24;PLS

 +1       ;;3.0; CONTROLLED SUBSTANCES ;**8,66,1015**;13 Feb 97;Build 62

 +2       ;**Y2K compliance**;display 4 digit year on va forms

 +3       ; Modified - IHS/CIA/PLS - 01/28/04 - Removed references to VA FORM

 +4        IF '$DATA(PSDSITE)

               DO ^PSDSET

               IF '$DATA(PSDSITE)

                   QUIT

 +5        IF '$DATA(^XUSEC("PSJ RPHARM",DUZ))

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

               GOTO END

 +6        SET PSDUZ=DUZ

           SET PSDOUT=0

           DO NOW^%DTC

           SET PSDT=+$EXTRACT(%,1,12)

 +7        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.",!!

 +2        KILL DA,DIR,DIRUT

           SET DIR(0)="58.86,13"

           DO ^DIR

           KILL DA,DIR

 +3        IF $DATA(DIRUT)

               DO MSG

               GOTO END

 +4        IF Y']""

               DO MSG

               GOTO END

 +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        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       ; IHS/CIA/PLS - 01/28/04 - Remove reference to VA FORM #

 +2       ;W !!,"Number of copies of VA FORM 10-2321? " R NUM:DTIME I '$T!(NUM="^")!(NUM="") W !!,"No copies printed!!",!! Q

 +3        WRITE !!,"Number of copies of form? "

           READ NUM:DTIME

           IF '$TEST!(NUM="^")!(NUM="")

               WRITE !!,"No copies printed!!",!!

               QUIT

 +4        IF NUM'?1N!(NUM=0)

               WRITE !!,"Enter a whole number between 1 and 9",!

               GOTO PRINT

 +5        SET Y=PSDT

           XECUTE ^DD("DD")

           SET PSDYR=$PIECE(Y,",",2)

           SET PSDYR=$EXTRACT(PSDYR,1,4)

 +6        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)

 +7        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

PSDESTF.m