PSDTRV ;BIR/JPW-Transfer CS Drugs between Vaults ; 10 Aug 94
;;3.0; CONTROLLED SUBSTANCES ;**71**;13 Feb 97;Build 29
I '$D(PSDSITE) D ^PSDSET Q:'$D(PSDSITE)
I '$D(^XUSEC("PSJ RPHARM",DUZ))&('$D(^XUSEC("PSD TECH ADV",DUZ))) D Q
.W $C(7),!!,?9,"** Please contact your Pharmacy Coordinator for access to transfer",!,?12,"controlled substances between dispensing sites.",!!,"PSJ RPHARM or PSD TECH ADV security key required.",!
I $P($G(^VA(200,DUZ,20)),U,4)']"" N XQH S XQH="PSD ESIG" D EN^XQH Q
S PSDUZ=DUZ,PSDUZN=$P($G(^VA(200,PSDUZ,0)),"^")
N X,X1 D SIG^XUSESIG G:X1="" END
FROM ;select FROM disp site
S (ADD,PSDOUT)=0
K DA,DIC W ! S DIC=58.8,DIC(0)="QEA",DIC("A")="Transfer from Dispensing Site: ",DIC("S")="I $P(^(0),""^"",3)=+PSDSITE,$S($P(^(0),""^"",2)=""M"":1,$P(^(0),""^"",2)=""S"":1,1:0)"
D ^DIC K DIC G:Y<0 END S PSDS=+Y,PSDSN=$P(Y,"^",2)
DRUG ;select drug
I '$O(^PSD(58.8,PSDS,1,0)) W !!,"There are no CS stocked drugs for your dispensing vault.",!! S PSDOUT=1 G END
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 DIC("A")="Select DRUG From "_PSDSN_": "
S DA(1)=+PSDS,DIC(0)="QEAM",DIC="^PSD(58.8,"_PSDS_",1," D ^DIC K DIC
I ($D(DTOUT))!($D(DUOUT)) S PSDOUT=1 G END
I Y<0,'PSDOUT G FROM
S PSDR=+Y,PSDRN=$P($G(^PSDRUG(PSDR,0)),"^"),QTY=+$P($G(^PSD(58.8,PSDS,1,PSDR,0)),"^",4),NBKU=$P(^(0),"^",8),NPKG=$P(^(0),"^",9),MFG=$P(^(0),"^",10),LOT=$P(^(0),"^",11),EXP=$P(^(0),"^",12)
I 'QTY W $C(7),!!,PSDRN," has a zero balance.",!,"Please select another drug to transfer.",!! G DRUG
QTY ;enter quantity
W !!,?5,"Breakdown Unit: ",NBKU,?35,"Package Size: ",NPKG,!
K DIR,DA S DIR(0)="NO^1:"_QTY_":0"
S DIR("A")="Enter Quantity to Transfer"
S DIR("?")="Answer with a whole number between 1 and "_QTY
D ^DIR K DIR
I $D(DTOUT)!$D(DUOUT)!$D(DIRUT) D MSG G END
S TQTY=+Y
TO ;transfer TO disp site (not restricted to inpat site)
K DA,DIC W ! S DIC=58.8,DIC(0)="QEA",DIC("A")="Transfer to Dispensing Site: ",DIC("S")="I $S($P(^(0),""^"",2)=""M"":1,$P(^(0),""^"",2)=""S"":1,1:0)"
D ^DIC K DIC G:Y<0 END S VAULT=+Y,VAULTN=$P(Y,"^",2)
CHK I VAULT=PSDS W $C(7),!!,?5,"** NOT ALLOWED to transfer out of and into SAME Dispensing Site! **" G END
I '$D(^PSD(58.8,VAULT,1,PSDR,0)) W $C(7),!!,?5,"** ",VAULTN," does not stock ",PSDRN,"! **",! D ADD G:PSDOUT END G ASK
I $P(^PSD(58.8,VAULT,1,PSDR,0),"^",8)'=NBKU W $C(7),!!,"** The Narcotic Breakdown Unit does not match." D MSG G END
ASK ;ask ok
W !!,"Transferring: ",TQTY," (",NBKU,")",!,"From: ",PSDSN," To: ",VAULTN,!!
K DIR,DIRUT S DIR(0)="Y",DIR("A")="Is this OK",DIR("B")="NO"
S DIR("?")="Answer 'YES' to post this transfer, 'NO' or '^' to quit."
D ^DIR K DIR I 'Y!$D(DIRUT) D MSG G END
D:ADD ADD1 D ^PSDTRV1 G:'PSDOUT DRUG
END K %,%H,%I,ADD,BAL,CNT,DA,DD,DIC,DIE,DINUM,DIR,DIROUT,DIRUT,DLAYGO,DO,DR,DTOUT,DUOUT,EXP,JJ,LOT,MFG,NBKU,NPKG,PSDT,PSDLES,PSDOUT,PSDR,PSDREC,PSDRN,PSDS,PSDSN
K PSDUZ,PSDUZN,QTY,RDT,TEMP,TQTY,VAULT,VAULTN,X,XMDUZ,XMSUB,XMTEXT,XMY,Y
Q
MSG W $C(7),!!,"No action taken.",!!
Q
ADD ;ask to add drug
K DIR,DIRUT S DIR(0)="Y",DIR("A")="Do you want to continue"
S DIR("?")="Answer 'YES' to continue with this transfer, 'NO' or '^' to quit."
D ^DIR K DIR I 'Y!$D(DIRUT) D MSG S PSDOUT=1 Q
S ADD=1
Q
ADD1 ;add drug
Q:$D(^PSD(58.8,VAULT,1,PSDR,0))
S:'$D(^PSD(58.8,VAULT,1,0)) ^PSD(58.8,VAULT,1,0)="^58.8001IP^^"
K DA,DIC,DD,DO S DIC(0)="L",DIC="^PSD(58.8,"_+VAULT_",1,",DA(1)=+VAULT,(X,DINUM)=+PSDR D FILE^DICN K DA,DIC
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSDTRV 3594 printed Dec 13, 2024@01:49:10 Page 2
PSDTRV ;BIR/JPW-Transfer CS Drugs between Vaults ; 10 Aug 94
+1 ;;3.0; CONTROLLED SUBSTANCES ;**71**;13 Feb 97;Build 29
+2 IF '$DATA(PSDSITE)
DO ^PSDSET
if '$DATA(PSDSITE)
QUIT
+3 IF '$DATA(^XUSEC("PSJ RPHARM",DUZ))&('$DATA(^XUSEC("PSD TECH ADV",DUZ)))
Begin DoDot:1
+4 WRITE $CHAR(7),!!,?9,"** Please contact your Pharmacy Coordinator for access to transfer",!,?12,"controlled substances between dispensing sites.",!!,"PSJ RPHARM or PSD TECH ADV security key required.",!
End DoDot:1
QUIT
+5 IF $PIECE($GET(^VA(200,DUZ,20)),U,4)']""
NEW XQH
SET XQH="PSD ESIG"
DO EN^XQH
QUIT
+6 SET PSDUZ=DUZ
SET PSDUZN=$PIECE($GET(^VA(200,PSDUZ,0)),"^")
+7 NEW X,X1
DO SIG^XUSESIG
if X1=""
GOTO END
FROM ;select FROM disp site
+1 SET (ADD,PSDOUT)=0
+2 KILL DA,DIC
WRITE !
SET DIC=58.8
SET DIC(0)="QEA"
SET DIC("A")="Transfer from Dispensing Site: "
SET DIC("S")="I $P(^(0),""^"",3)=+PSDSITE,$S($P(^(0),""^"",2)=""M"":1,$P(^(0),""^"",2)=""S"":1,1:0)"
+3 DO ^DIC
KILL DIC
if Y<0
GOTO END
SET PSDS=+Y
SET PSDSN=$PIECE(Y,"^",2)
DRUG ;select drug
+1 IF '$ORDER(^PSD(58.8,PSDS,1,0))
WRITE !!,"There are no CS stocked drugs for your dispensing vault.",!!
SET PSDOUT=1
GOTO END
+2 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 ***"""
+3 SET DIC("A")="Select DRUG From "_PSDSN_": "
+4 SET DA(1)=+PSDS
SET DIC(0)="QEAM"
SET DIC="^PSD(58.8,"_PSDS_",1,"
DO ^DIC
KILL DIC
+5 IF ($DATA(DTOUT))!($DATA(DUOUT))
SET PSDOUT=1
GOTO END
+6 IF Y<0
IF 'PSDOUT
GOTO FROM
+7 SET PSDR=+Y
SET PSDRN=$PIECE($GET(^PSDRUG(PSDR,0)),"^")
SET QTY=+$PIECE($GET(^PSD(58.8,PSDS,1,PSDR,0)),"^",4)
SET NBKU=$PIECE(^(0),"^",8)
SET NPKG=$PIECE(^(0),"^",9)
SET MFG=$PIECE(^(0),"^",10)
SET LOT=$PIECE(^(0),"^",11)
SET EXP=$PIECE(^(0),"^",12)
+8 IF 'QTY
WRITE $CHAR(7),!!,PSDRN," has a zero balance.",!,"Please select another drug to transfer.",!!
GOTO DRUG
QTY ;enter quantity
+1 WRITE !!,?5,"Breakdown Unit: ",NBKU,?35,"Package Size: ",NPKG,!
+2 KILL DIR,DA
SET DIR(0)="NO^1:"_QTY_":0"
+3 SET DIR("A")="Enter Quantity to Transfer"
+4 SET DIR("?")="Answer with a whole number between 1 and "_QTY
+5 DO ^DIR
KILL DIR
+6 IF $DATA(DTOUT)!$DATA(DUOUT)!$DATA(DIRUT)
DO MSG
GOTO END
+7 SET TQTY=+Y
TO ;transfer TO disp site (not restricted to inpat site)
+1 KILL DA,DIC
WRITE !
SET DIC=58.8
SET DIC(0)="QEA"
SET DIC("A")="Transfer to Dispensing Site: "
SET DIC("S")="I $S($P(^(0),""^"",2)=""M"":1,$P(^(0),""^"",2)=""S"":1,1:0)"
+2 DO ^DIC
KILL DIC
if Y<0
GOTO END
SET VAULT=+Y
SET VAULTN=$PIECE(Y,"^",2)
CHK IF VAULT=PSDS
WRITE $CHAR(7),!!,?5,"** NOT ALLOWED to transfer out of and into SAME Dispensing Site! **"
GOTO END
+1 IF '$DATA(^PSD(58.8,VAULT,1,PSDR,0))
WRITE $CHAR(7),!!,?5,"** ",VAULTN," does not stock ",PSDRN,"! **",!
DO ADD
if PSDOUT
GOTO END
GOTO ASK
+2 IF $PIECE(^PSD(58.8,VAULT,1,PSDR,0),"^",8)'=NBKU
WRITE $CHAR(7),!!,"** The Narcotic Breakdown Unit does not match."
DO MSG
GOTO END
ASK ;ask ok
+1 WRITE !!,"Transferring: ",TQTY," (",NBKU,")",!,"From: ",PSDSN," To: ",VAULTN,!!
+2 KILL DIR,DIRUT
SET DIR(0)="Y"
SET DIR("A")="Is this OK"
SET DIR("B")="NO"
+3 SET DIR("?")="Answer 'YES' to post this transfer, 'NO' or '^' to quit."
+4 DO ^DIR
KILL DIR
IF 'Y!$DATA(DIRUT)
DO MSG
GOTO END
+5 if ADD
DO ADD1
DO ^PSDTRV1
if 'PSDOUT
GOTO DRUG
END KILL %,%H,%I,ADD,BAL,CNT,DA,DD,DIC,DIE,DINUM,DIR,DIROUT,DIRUT,DLAYGO,DO,DR,DTOUT,DUOUT,EXP,JJ,LOT,MFG,NBKU,NPKG,PSDT,PSDLES,PSDOUT,PSDR,PSDREC,PSDRN,PSDS,PSDSN
+1 KILL PSDUZ,PSDUZN,QTY,RDT,TEMP,TQTY,VAULT,VAULTN,X,XMDUZ,XMSUB,XMTEXT,XMY,Y
+2 QUIT
MSG WRITE $CHAR(7),!!,"No action taken.",!!
+1 QUIT
ADD ;ask to add drug
+1 KILL DIR,DIRUT
SET DIR(0)="Y"
SET DIR("A")="Do you want to continue"
+2 SET DIR("?")="Answer 'YES' to continue with this transfer, 'NO' or '^' to quit."
+3 DO ^DIR
KILL DIR
IF 'Y!$DATA(DIRUT)
DO MSG
SET PSDOUT=1
QUIT
+4 SET ADD=1
+5 QUIT
ADD1 ;add drug
+1 if $DATA(^PSD(58.8,VAULT,1,PSDR,0))
QUIT
+2 if '$DATA(^PSD(58.8,VAULT,1,0))
SET ^PSD(58.8,VAULT,1,0)="^58.8001IP^^"
+3 KILL DA,DIC,DD,DO
SET DIC(0)="L"
SET DIC="^PSD(58.8,"_+VAULT_",1,"
SET DA(1)=+VAULT
SET (X,DINUM)=+PSDR
DO FILE^DICN
KILL DA,DIC
