| 1 | PSDSTK ;BIR/JPW-Stock Drugs Enter/Edit ; 8 Aug 94
|
---|
| 2 | ;;3.0; CONTROLLED SUBSTANCES ;**44,47**;13 Feb 97
|
---|
| 3 | I '$D(PSDSITE) D ^PSDSET Q:'$D(PSDSITE)
|
---|
| 4 | STOCK ;entry for NAOU stocked drugs into file 58.8
|
---|
| 5 | W ! K DIC,DA S DIC=58.8,DIC(0)="QEAZ",DIC("A")="Select NAOU: ",DIC("S")="I $P(^(0),""^"",3)=+PSDSITE,$P(^(0),""^"",2)'=""P""" D ^DIC K DIC G:Y<0 END
|
---|
| 6 | S PSDA=+Y,PSDS=+$P(Y(0),"^",4),TYPE=$P(Y(0),"^",2) D DRUG
|
---|
| 7 | G:('PSDOUT)!(FLAG1) STOCK
|
---|
| 8 | END K ADD,DA,DIC,DIE,DINUM,DIR,DIRUT,DIROUT,DLAYGO,DR,DTOUT,DUOUT,FLAG,FLAG1,NAOU,NEW,OK,PSDA,PSDR,PSDRN,PSDRG,PSDOUT,PSDS,TYPE,SITE,X,Y
|
---|
| 9 | Q
|
---|
| 10 | DRUG ;add drugs
|
---|
| 11 | S (FLAG,FLAG1,PSDOUT)=0
|
---|
| 12 | W !! K DA,DIR,DIRUT S DIR(0)="SOA^A:ADD;E:EDIT",DIR("A")="Do you wish to ADD or EDIT stock drugs? "
|
---|
| 13 | S DIR("?",1)="Answer 'ADD' to add new CS stock drugs, or",DIR("?")="answer 'EDIT' to edit existing stock drugs, or '^' to quit."
|
---|
| 14 | S DIR("B")="ADD" D ^DIR K DIR I $D(DIRUT) S PSDOUT=1 Q
|
---|
| 15 | S ADD=Y
|
---|
| 16 | I TYPE'="M",ADD="A" D VAULT Q:(PSDOUT)!(FLAG1) G:FLAG DRUG G DIE
|
---|
| 17 | W ! K DA,DIC S DIC("W")="W:$P(^PSDRUG(Y,0),""^"",9) "" N/F"" I $P(^PSD(58.8,PSDA,1,Y,0),""^"",14)]"""",$P(^(0),""^"",14)'>DT W $C(7),"" *** INACTIVE ***"""
|
---|
| 18 | I TYPE="M",ADD="A",'$D(^PSD(58.8,PSDA,1,0)) S ^(0)="^58.8001IP^^"
|
---|
| 19 | S DA(1)=+PSDA,DIC(0)=$S(ADD="E":"QEAMZ",1:"QEAMLZ"),DIC="^PSD(58.8,"_PSDA_",1,",DLAYGO=58.8 D ^DIC K DIC,DLAYGO Q:Y<0 S PSDR=+Y
|
---|
| 20 | ;DIE;Modified DIE DR string;teh/OIFO Bay Pines
|
---|
| 21 | ;D CHKID I OK D
|
---|
| 22 | ;.K DA,DIE,DR S DIE="^PSD(58.8,"_PSDA_",1,",DA(1)=+PSDA,DA=+PSDR D
|
---|
| 23 | ;..I $P(^PSD(58.8,PSDA,0),U,2)'="N" D
|
---|
| 24 | ;...S DR=16,DR(2,58.800116)=.01 D ^DIE
|
---|
| 25 | ;...S DR=15,DR(2,58.800115)=.01 D ^DIE
|
---|
| 26 | ;...K DR S DR="2;4;5" D ^DIE
|
---|
| 27 | ;..I $P(^PSD(58.8,PSDA,0),U,2)="N" D
|
---|
| 28 | ;...S DR="9;7;8;26;28;29;8.5;10;11" D ^DIE
|
---|
| 29 | ;K DA,DIE,DR
|
---|
| 30 | ; PSD*3*47 RETURN ORIGINAL FUNCTIONALITY
|
---|
| 31 | DIE D CHKID I OK K DA,DIE,DR S DIE="^PSD(58.8,"_PSDA_",1,",DA(1)=+PSDA,DA=+PSDR,DR="1;I $P(^PSD(58.8,PSDA,0),""^"",2)'=""N"" S Y=16;15;16;2;4;5;I $P(^PSD(58.8,PSDA,0),""^"",2)=""N"" S Y=9;7;8;26;28;29;8.5;9;10;11" D ^DIE K DA,DIE,DR
|
---|
| 32 | G DRUG
|
---|
| 33 | ;
|
---|
| 34 | CHKID ;check for current inactivation date
|
---|
| 35 | I $P($G(^PSD(58.8,PSDA,1,PSDR,0)),"^",14)="" D CHKNP Q
|
---|
| 36 | D CHKNP Q:'OK
|
---|
| 37 | W $C(7),!!,?5,"This Drug is currently defined for this NAOU with an INACTIVATION DATE.",!!,?5,"If you want to add this Drug as a new standard Stock Drug for this NAOU",!,?5,"you must delete the INACTIVATION DATE.",!
|
---|
| 38 | K DA,DIE,DR S OK=1,DA(1)=PSDA,DA=PSDR,DIE="^PSD(58.8,"_PSDA_",1,",DR="13" D ^DIE K DIE S:$P($G(^PSD(58.8,PSDA,1,PSDR,0)),"^",14)]"" OK=0 W !
|
---|
| 39 | Q
|
---|
| 40 | CHKNP ;check for non-CS entries in file 50
|
---|
| 41 | S OK=$S($P($G(^PSDRUG(PSDR,2)),"^",3)["N":1,1:0) Q:OK
|
---|
| 42 | I $P($G(^PSD(58.8,PSDA,1,PSDR,0)),"^",14)="" K DA,DIE,DR S DA(1)=PSDA,DA=PSDR,DIE="^PSD(58.8,"_PSDA_",1,",DR="13///"_DT_";14////O;14.5////NON-CS DRUG" D ^DIE K DIE
|
---|
| 43 | W $C(7),!!,?5,"This stocked drug is currently defined for this NAOU but appears to be",!,?5,"a non-CS drug. It has been inactivated as of " S Y=$P($G(^PSD(58.8,PSDA,1,PSDR,0)),"^",14) X ^DD("DD") W Y,!
|
---|
| 44 | Q
|
---|
| 45 | VAULT ;check for stock drugs in vault
|
---|
| 46 | I '$O(^PSD(58.8,PSDS,1,0)) W !!,"There are no CS stocked drugs for your dispensing vault.",!! S PSDOUT=1 Q
|
---|
| 47 | W !!,"You may select only CS drugs stocked in your dispensing vault.",!!
|
---|
| 48 | W ! K DA,DIC S DIC("W")="W:$P(^PSDRUG(Y,0),""^"",9) "" N/F"" I $P(^PSD(58.8,PSDS,1,Y,0),""^"",14)]"""",$P(^(0),""^"",14)'>DT W $C(7),"" *** INACTIVE ***"""
|
---|
| 49 | S DA(1)=+PSDS,DIC(0)="QEAM",DIC="^PSD(58.8,"_PSDS_",1," D ^DIC K DIC I Y<0 S FLAG1=1 Q
|
---|
| 50 | S PSDR=+Y I $D(^PSD(58.8,PSDA,1,PSDR,0)) Q
|
---|
| 51 | S PSDRN=$P($G(^PSDRUG(PSDR,0)),"^")
|
---|
| 52 | S:'$D(^PSD(58.8,PSDA,1,0)) ^(0)="^58.8001IP^^"
|
---|
| 53 | S NEW=+$P(^PSD(58.8,PSDA,1,0),"^",4)+1
|
---|
| 54 | K DA,DIR,DIRUT,Y S DIR(0)="YO",DIR("A")="ARE YOU ADDING '"_PSDRN_"' AS A NEW DRUG (FOR THIS DRUG ACCOUNTABILITY STATS)",DIR("B")="Y"
|
---|
| 55 | D ^DIR K DIR I $D(DIRUT) S PSDOUT=1 Q
|
---|
| 56 | I 'Y S FLAG=1 Q
|
---|
| 57 | K DA,DIC,DD,DO S DA(1)=PSDA,DIC(0)="L",(X,DINUM)=PSDR,DIC="^PSD(58.8,"_PSDA_",1," D FILE^DICN K DIC I Y<0 S PSDOUT=1 Q
|
---|
| 58 | Q
|
---|