PSDTRV1 ;BIR/JPW-Transfer CS Drugs between Vaults (cont'd) ; 17 Nov 93
;;3.0; CONTROLLED SUBSTANCES ;**66**;13 Feb 97;Build 3
UPDATE ;update vault balances
D CHK G:PSDLES END
W !!,"Updating vault on-hand balances now..." F CNT=1:1:2 D CALC
W "done!",!! D:ADD MSG
S (ADD,PSDOUT)=0
END K %,%H,%I,BAL,CNT,DA,DD,DIC,DIE,DINUM,DIR,DIROUT,DIRUT,DLAYGO,DO,DR,DTOUT,DUOUT,EXP,JJ,LOT,MFG,NBKU,NPKG,PSDT,PSDLES,PSDR,PSDREC,PSDRN
K QTY,RDT,TEMP,TQTY,VAULT,VAULTN,X,XMDUZ,XMSUB,XMTEXT,XMY,Y
Q
CALC ;sub/add qty from dsp sites
W $S(CNT=2:VAULTN,1:PSDSN)_"..."
S TEMP=$S(CNT=2:VAULT,1:PSDS),TQTY=-TQTY
F L +^PSD(58.8,TEMP,1,PSDR,0):$S($G(DILOCKTM)>0:DILOCKTM,1:3) I Q
D NOW^%DTC S PSDT=+%
S BAL(CNT)=$P(^PSD(58.8,TEMP,1,PSDR,0),"^",4),$P(^(0),"^",4)=$P(^(0),"^",4)+TQTY,$P(BAL(CNT),"^",2)=+BAL(CNT)+TQTY
L -^PSD(58.8,TEMP,1,PSDR,0)
ADD ;find entry number
F L +^PSD(58.81,0):$S($G(DILOCKTM)>0:DILOCKTM,1:3) I Q
FIND S PSDREC=$P(^PSD(58.81,0),"^",3)+1 I $D(^PSD(58.81,PSDREC)) S $P(^PSD(58.81,0),"^",3)=PSDREC G FIND
K DIC,DLAYGO S DIC(0)="L",(DIC,DLAYGO)=58.81,(X,DINUM)=PSDREC D ^DIC K DIC,DLAYGO
L -^PSD(58.81,0)
DIE ;update transaction data
K DA,DIE,DR S DA=PSDREC,DIE=58.81
S DR="1////16;2////"_+TEMP_";4////"_PSDR_";3////"_PSDT_";Q;5////"_TQTY_";6////"_PSDUZ_";9////"_$P(BAL(CNT),"^")_";100////1"
D ^DIE K DA,DIE,DR W !,"Still updating..."
;update vault drug info
I CNT=2 K DA,DIE,DR S DIE="^PSD(58.8,"_+TEMP_",1,",DA(1)=+TEMP,DA=+PSDR,DR="I 'ADD S Y=9;7////"_NBKU_";8////"_NPKG_";9////"_MFG_";10////"_LOT_";11////"_EXP D ^DIE K DA,DIE,DR
S:'$D(^PSD(58.8,+TEMP,1,+PSDR,4,0)) ^PSD(58.8,+TEMP,1,+PSDR,4,0)="^58.800119PA^^"
I '$D(^PSD(58.8,+TEMP,1,+PSDR,4,PSDREC,0)) K DA,DIC,DD,DO S DIC(0)="L",DIC="^PSD(58.8,"_+TEMP_",1,"_+PSDR_",4,",DA(2)=+TEMP,DA(1)=+PSDR,(X,DINUM)=PSDREC D FILE^DICN K DA,DIC
Q
CHK ;check for valid bal
S PSDLES=0 D:TQTY>$P(^PSD(58.8,PSDS,1,PSDR,0),"^",4)
.W $C(7),!!,"=> The drug balance is "_+$P(^PSD(58.8,PSDS,1,PSDR,0),"^",4)_". You cannot transfer "_TQTY_" for this drug.",! S PSDLES=1
.W "No action taken.",!
Q
MSG ;send mailman message with transfer info
K XMY,^TMP("PSDTRV",$J) D NOW^%DTC S Y=X X ^DD("DD") S RDT=Y S ^TMP("PSDTRV",$J,1,0)="Controlled Substances have been transferred between Dispensing Sites."
S ^TMP("PSDTRV",$J,2,0)="Run Date: "_RDT,^TMP("PSDTRV",$J,3,0)=""
S ^TMP("PSDTRV",$J,4,0)="Drug: "_PSDRN
S ^TMP("PSDTRV",$J,5,0)="Transferred from: "_PSDSN,^TMP("PSDTRV",$J,6,0)="Transferred and Added to: "_VAULTN
S ^TMP("PSDTRV",$J,7,0)="Quantity ("_NBKU_"): "_TQTY,^TMP("PSDTRV",$J,8,0)="Pharmacist: "_PSDUZN
S XMSUB="CS DRUG TRANSFER BETWEEN VAULTS",XMTEXT="^TMP(""PSDTRV"",$J,",XMDUZ="CONTROLLED SUBSTANCES PHARMACY" F JJ=0:0 S JJ=$O(^XUSEC("PSDMGR",JJ)) Q:'JJ S XMY(JJ)=""
S:'$D(XMY) XMY(.5)="" D ^XMD K XMY,^TMP("PSDTRV",$J)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSDTRV1 2850 printed Dec 13, 2024@01:49:11 Page 2
PSDTRV1 ;BIR/JPW-Transfer CS Drugs between Vaults (cont'd) ; 17 Nov 93
+1 ;;3.0; CONTROLLED SUBSTANCES ;**66**;13 Feb 97;Build 3
UPDATE ;update vault balances
+1 DO CHK
if PSDLES
GOTO END
+2 WRITE !!,"Updating vault on-hand balances now..."
FOR CNT=1:1:2
DO CALC
+3 WRITE "done!",!!
if ADD
DO MSG
+4 SET (ADD,PSDOUT)=0
END KILL %,%H,%I,BAL,CNT,DA,DD,DIC,DIE,DINUM,DIR,DIROUT,DIRUT,DLAYGO,DO,DR,DTOUT,DUOUT,EXP,JJ,LOT,MFG,NBKU,NPKG,PSDT,PSDLES,PSDR,PSDREC,PSDRN
+1 KILL QTY,RDT,TEMP,TQTY,VAULT,VAULTN,X,XMDUZ,XMSUB,XMTEXT,XMY,Y
+2 QUIT
CALC ;sub/add qty from dsp sites
+1 WRITE $SELECT(CNT=2:VAULTN,1:PSDSN)_"..."
+2 SET TEMP=$SELECT(CNT=2:VAULT,1:PSDS)
SET TQTY=-TQTY
+3 FOR
LOCK +^PSD(58.8,TEMP,1,PSDR,0):$SELECT($GET(DILOCKTM)>0:DILOCKTM,1:3)
IF $TEST
QUIT
+4 DO NOW^%DTC
SET PSDT=+%
+5 SET BAL(CNT)=$PIECE(^PSD(58.8,TEMP,1,PSDR,0),"^",4)
SET $PIECE(^(0),"^",4)=$PIECE(^(0),"^",4)+TQTY
SET $PIECE(BAL(CNT),"^",2)=+BAL(CNT)+TQTY
+6 LOCK -^PSD(58.8,TEMP,1,PSDR,0)
ADD ;find entry number
+1 FOR
LOCK +^PSD(58.81,0):$SELECT($GET(DILOCKTM)>0:DILOCKTM,1:3)
IF $TEST
QUIT
FIND SET PSDREC=$PIECE(^PSD(58.81,0),"^",3)+1
IF $DATA(^PSD(58.81,PSDREC))
SET $PIECE(^PSD(58.81,0),"^",3)=PSDREC
GOTO FIND
+1 KILL DIC,DLAYGO
SET DIC(0)="L"
SET (DIC,DLAYGO)=58.81
SET (X,DINUM)=PSDREC
DO ^DIC
KILL DIC,DLAYGO
+2 LOCK -^PSD(58.81,0)
DIE ;update transaction data
+1 KILL DA,DIE,DR
SET DA=PSDREC
SET DIE=58.81
+2 SET DR="1////16;2////"_+TEMP_";4////"_PSDR_";3////"_PSDT_";Q;5////"_TQTY_";6////"_PSDUZ_";9////"_$PIECE(BAL(CNT),"^")_";100////1"
+3 DO ^DIE
KILL DA,DIE,DR
WRITE !,"Still updating..."
+4 ;update vault drug info
+5 IF CNT=2
KILL DA,DIE,DR
SET DIE="^PSD(58.8,"_+TEMP_",1,"
SET DA(1)=+TEMP
SET DA=+PSDR
SET DR="I 'ADD S Y=9;7////"_NBKU_";8////"_NPKG_";9////"_MFG_";10////"_LOT_";11////"_EXP
DO ^DIE
KILL DA,DIE,DR
+6 if '$DATA(^PSD(58.8,+TEMP,1,+PSDR,4,0))
SET ^PSD(58.8,+TEMP,1,+PSDR,4,0)="^58.800119PA^^"
+7 IF '$DATA(^PSD(58.8,+TEMP,1,+PSDR,4,PSDREC,0))
KILL DA,DIC,DD,DO
SET DIC(0)="L"
SET DIC="^PSD(58.8,"_+TEMP_",1,"_+PSDR_",4,"
SET DA(2)=+TEMP
SET DA(1)=+PSDR
SET (X,DINUM)=PSDREC
DO FILE^DICN
KILL DA,DIC
+8 QUIT
CHK ;check for valid bal
+1 SET PSDLES=0
if TQTY>$PIECE(^PSD(58.8,PSDS,1,PSDR,0),"^",4)
Begin DoDot:1
+2 WRITE $CHAR(7),!!,"=> The drug balance is "_+$PIECE(^PSD(58.8,PSDS,1,PSDR,0),"^",4)_". You cannot transfer "_TQTY_" for this drug.",!
SET PSDLES=1
+3 WRITE "No action taken.",!
End DoDot:1
+4 QUIT
MSG ;send mailman message with transfer info
+1 KILL XMY,^TMP("PSDTRV",$JOB)
DO NOW^%DTC
SET Y=X
XECUTE ^DD("DD")
SET RDT=Y
SET ^TMP("PSDTRV",$JOB,1,0)="Controlled Substances have been transferred between Dispensing Sites."
+2 SET ^TMP("PSDTRV",$JOB,2,0)="Run Date: "_RDT
SET ^TMP("PSDTRV",$JOB,3,0)=""
+3 SET ^TMP("PSDTRV",$JOB,4,0)="Drug: "_PSDRN
+4 SET ^TMP("PSDTRV",$JOB,5,0)="Transferred from: "_PSDSN
SET ^TMP("PSDTRV",$JOB,6,0)="Transferred and Added to: "_VAULTN
+5 SET ^TMP("PSDTRV",$JOB,7,0)="Quantity ("_NBKU_"): "_TQTY
SET ^TMP("PSDTRV",$JOB,8,0)="Pharmacist: "_PSDUZN
+6 SET XMSUB="CS DRUG TRANSFER BETWEEN VAULTS"
SET XMTEXT="^TMP(""PSDTRV"",$J,"
SET XMDUZ="CONTROLLED SUBSTANCES PHARMACY"
FOR JJ=0:0
SET JJ=$ORDER(^XUSEC("PSDMGR",JJ))
if 'JJ
QUIT
SET XMY(JJ)=""
+7 if '$DATA(XMY)
SET XMY(.5)=""
DO ^XMD
KILL XMY,^TMP("PSDTRV",$JOB)
+8 QUIT
