- PSDSTK ;BIR/JPW-Stock Drugs Enter/Edit ; 8 Aug 94
- ;;3.0; CONTROLLED SUBSTANCES ;**44,47**;13 Feb 97
- I '$D(PSDSITE) D ^PSDSET Q:'$D(PSDSITE)
- STOCK ;entry for NAOU stocked drugs into file 58.8
- 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
- S PSDA=+Y,PSDS=+$P(Y(0),"^",4),TYPE=$P(Y(0),"^",2) D DRUG
- G:('PSDOUT)!(FLAG1) STOCK
- 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
- Q
- DRUG ;add drugs
- S (FLAG,FLAG1,PSDOUT)=0
- W !! K DA,DIR,DIRUT S DIR(0)="SOA^A:ADD;E:EDIT",DIR("A")="Do you wish to ADD or EDIT stock drugs? "
- S DIR("?",1)="Answer 'ADD' to add new CS stock drugs, or",DIR("?")="answer 'EDIT' to edit existing stock drugs, or '^' to quit."
- S DIR("B")="ADD" D ^DIR K DIR I $D(DIRUT) S PSDOUT=1 Q
- S ADD=Y
- I TYPE'="M",ADD="A" D VAULT Q:(PSDOUT)!(FLAG1) G:FLAG DRUG G DIE
- 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 ***"""
- I TYPE="M",ADD="A",'$D(^PSD(58.8,PSDA,1,0)) S ^(0)="^58.8001IP^^"
- 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
- ;DIE;Modified DIE DR string;teh/OIFO Bay Pines
- ;D CHKID I OK D
- ;.K DA,DIE,DR S DIE="^PSD(58.8,"_PSDA_",1,",DA(1)=+PSDA,DA=+PSDR D
- ;..I $P(^PSD(58.8,PSDA,0),U,2)'="N" D
- ;...S DR=16,DR(2,58.800116)=.01 D ^DIE
- ;...S DR=15,DR(2,58.800115)=.01 D ^DIE
- ;...K DR S DR="2;4;5" D ^DIE
- ;..I $P(^PSD(58.8,PSDA,0),U,2)="N" D
- ;...S DR="9;7;8;26;28;29;8.5;10;11" D ^DIE
- ;K DA,DIE,DR
- ; PSD*3*47 RETURN ORIGINAL FUNCTIONALITY
- 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
- G DRUG
- ;
- CHKID ;check for current inactivation date
- I $P($G(^PSD(58.8,PSDA,1,PSDR,0)),"^",14)="" D CHKNP Q
- D CHKNP Q:'OK
- 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.",!
- 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 !
- Q
- CHKNP ;check for non-CS entries in file 50
- S OK=$S($P($G(^PSDRUG(PSDR,2)),"^",3)["N":1,1:0) Q:OK
- 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
- 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,!
- Q
- VAULT ;check for stock drugs in vault
- I '$O(^PSD(58.8,PSDS,1,0)) W !!,"There are no CS stocked drugs for your dispensing vault.",!! S PSDOUT=1 Q
- W !!,"You may select only CS drugs stocked in your dispensing vault.",!!
- 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 ***"""
- S DA(1)=+PSDS,DIC(0)="QEAM",DIC="^PSD(58.8,"_PSDS_",1," D ^DIC K DIC I Y<0 S FLAG1=1 Q
- S PSDR=+Y I $D(^PSD(58.8,PSDA,1,PSDR,0)) Q
- S PSDRN=$P($G(^PSDRUG(PSDR,0)),"^")
- S:'$D(^PSD(58.8,PSDA,1,0)) ^(0)="^58.8001IP^^"
- S NEW=+$P(^PSD(58.8,PSDA,1,0),"^",4)+1
- 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"
- D ^DIR K DIR I $D(DIRUT) S PSDOUT=1 Q
- I 'Y S FLAG=1 Q
- 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
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSDSTK 3951 printed Feb 18, 2025@23:15:25 Page 2
- PSDSTK ;BIR/JPW-Stock Drugs Enter/Edit ; 8 Aug 94
- +1 ;;3.0; CONTROLLED SUBSTANCES ;**44,47**;13 Feb 97
- +2 IF '$DATA(PSDSITE)
- DO ^PSDSET
- if '$DATA(PSDSITE)
- QUIT
- STOCK ;entry for NAOU stocked drugs into file 58.8
- +1 WRITE !
- KILL DIC,DA
- SET DIC=58.8
- SET DIC(0)="QEAZ"
- SET DIC("A")="Select NAOU: "
- SET DIC("S")="I $P(^(0),""^"",3)=+PSDSITE,$P(^(0),""^"",2)'=""P"""
- DO ^DIC
- KILL DIC
- if Y<0
- GOTO END
- +2 SET PSDA=+Y
- SET PSDS=+$PIECE(Y(0),"^",4)
- SET TYPE=$PIECE(Y(0),"^",2)
- DO DRUG
- +3 if ('PSDOUT)!(FLAG1)
- GOTO STOCK
- END KILL 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
- +1 QUIT
- DRUG ;add drugs
- +1 SET (FLAG,FLAG1,PSDOUT)=0
- +2 WRITE !!
- KILL DA,DIR,DIRUT
- SET DIR(0)="SOA^A:ADD;E:EDIT"
- SET DIR("A")="Do you wish to ADD or EDIT stock drugs? "
- +3 SET DIR("?",1)="Answer 'ADD' to add new CS stock drugs, or"
- SET DIR("?")="answer 'EDIT' to edit existing stock drugs, or '^' to quit."
- +4 SET DIR("B")="ADD"
- DO ^DIR
- KILL DIR
- IF $DATA(DIRUT)
- SET PSDOUT=1
- QUIT
- +5 SET ADD=Y
- +6 IF TYPE'="M"
- IF ADD="A"
- DO VAULT
- if (PSDOUT)!(FLAG1)
- QUIT
- if FLAG
- GOTO DRUG
- GOTO DIE
- +7 WRITE !
- KILL DA,DIC
- SET 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 ***"""
- +8 IF TYPE="M"
- IF ADD="A"
- IF '$DATA(^PSD(58.8,PSDA,1,0))
- SET ^(0)="^58.8001IP^^"
- +9 SET DA(1)=+PSDA
- SET DIC(0)=$SELECT(ADD="E":"QEAMZ",1:"QEAMLZ")
- SET DIC="^PSD(58.8,"_PSDA_",1,"
- SET DLAYGO=58.8
- DO ^DIC
- KILL DIC,DLAYGO
- if Y<0
- QUIT
- SET PSDR=+Y
- +10 ;DIE;Modified DIE DR string;teh/OIFO Bay Pines
- +11 ;D CHKID I OK D
- +12 ;.K DA,DIE,DR S DIE="^PSD(58.8,"_PSDA_",1,",DA(1)=+PSDA,DA=+PSDR D
- +13 ;..I $P(^PSD(58.8,PSDA,0),U,2)'="N" D
- +14 ;...S DR=16,DR(2,58.800116)=.01 D ^DIE
- +15 ;...S DR=15,DR(2,58.800115)=.01 D ^DIE
- +16 ;...K DR S DR="2;4;5" D ^DIE
- +17 ;..I $P(^PSD(58.8,PSDA,0),U,2)="N" D
- +18 ;...S DR="9;7;8;26;28;29;8.5;10;11" D ^DIE
- +19 ;K DA,DIE,DR
- +20 ; PSD*3*47 RETURN ORIGINAL FUNCTIONALITY
- DIE DO CHKID
- IF OK
- KILL DA,DIE,DR
- SET DIE="^PSD(58.8,"_PSDA_",1,"
- SET DA(1)=+PSDA
- SET DA=+PSDR
- SET 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"
- DO ^DIE
- KILL DA,DIE,DR
- +1 GOTO DRUG
- +2 ;
- CHKID ;check for current inactivation date
- +1 IF $PIECE($GET(^PSD(58.8,PSDA,1,PSDR,0)),"^",14)=""
- DO CHKNP
- QUIT
- +2 DO CHKNP
- if 'OK
- QUIT
- +3 WRITE $CHAR(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.",!
- +4 KILL DA,DIE,DR
- SET OK=1
- SET DA(1)=PSDA
- SET DA=PSDR
- SET DIE="^PSD(58.8,"_PSDA_",1,"
- SET DR="13"
- DO ^DIE
- KILL DIE
- if $PIECE($GET(^PSD(58.8,PSDA,1,PSDR,0)),"^",14)]""
- SET OK=0
- WRITE !
- +5 QUIT
- CHKNP ;check for non-CS entries in file 50
- +1 SET OK=$SELECT($PIECE($GET(^PSDRUG(PSDR,2)),"^",3)["N":1,1:0)
- if OK
- QUIT
- +2 IF $PIECE($GET(^PSD(58.8,PSDA,1,PSDR,0)),"^",14)=""
- KILL DA,DIE,DR
- SET DA(1)=PSDA
- SET DA=PSDR
- SET DIE="^PSD(58.8,"_PSDA_",1,"
- SET DR="13///"_DT_";14////O;14.5////NON-CS DRUG"
- DO ^DIE
- KILL DIE
- +3 WRITE $CHAR(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 "
- SET Y=$PIECE($GET(^PSD(58.8,PSDA,1,PSDR,0)),"^",14)
- XECUTE ^DD("DD")
- WRITE Y,!
- +4 QUIT
- VAULT ;check for stock drugs in vault
- +1 IF '$ORDER(^PSD(58.8,PSDS,1,0))
- WRITE !!,"There are no CS stocked drugs for your dispensing vault.",!!
- SET PSDOUT=1
- QUIT
- +2 WRITE !!,"You may select only CS drugs stocked in your dispensing vault.",!!
- +3 WRITE !
- KILL DA,DIC
- SET 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 ***"""
- +4 SET DA(1)=+PSDS
- SET DIC(0)="QEAM"
- SET DIC="^PSD(58.8,"_PSDS_",1,"
- DO ^DIC
- KILL DIC
- IF Y<0
- SET FLAG1=1
- QUIT
- +5 SET PSDR=+Y
- IF $DATA(^PSD(58.8,PSDA,1,PSDR,0))
- QUIT
- +6 SET PSDRN=$PIECE($GET(^PSDRUG(PSDR,0)),"^")
- +7 if '$DATA(^PSD(58.8,PSDA,1,0))
- SET ^(0)="^58.8001IP^^"
- +8 SET NEW=+$PIECE(^PSD(58.8,PSDA,1,0),"^",4)+1
- +9 KILL DA,DIR,DIRUT,Y
- SET DIR(0)="YO"
- SET DIR("A")="ARE YOU ADDING '"_PSDRN_"' AS A NEW DRUG (FOR THIS DRUG ACCOUNTABILITY STATS)"
- SET DIR("B")="Y"
- +10 DO ^DIR
- KILL DIR
- IF $DATA(DIRUT)
- SET PSDOUT=1
- QUIT
- +11 IF 'Y
- SET FLAG=1
- QUIT
- +12 KILL DA,DIC,DD,DO
- SET DA(1)=PSDA
- SET DIC(0)="L"
- SET (X,DINUM)=PSDR
- SET DIC="^PSD(58.8,"_PSDA_",1,"
- DO FILE^DICN
- KILL DIC
- IF Y<0
- SET PSDOUT=1
- QUIT
- +13 QUIT
