Routine: PSDTRV1

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

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

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

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)

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSDTRV1   2850     printed  Mar 13, 2025@20:53:51                                                                                                                                                                                                     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

PSDTRV1.m