PSATRAN1 ;BIR/JMB-Transfer Drugs between Pharmacies - CONT'D ;7/23/97
;;3.0; DRUG ACCOUNTABILITY/INVENTORY INTERFACE;**64**; 10/24/97;Build 4
;This routine updates the dispensing and receiving locations. The drug
;balance & monthly activity are updated. It creates an activity in 58.8,
;a transaction in 58.81, sends a mail message if the drug is new to the
;receiving location, and stores the data so the signature sheet can
;print. It is called by PSATRAN.
;
UPDATE ;update location balances
D CHK Q:PSALES W !!,"Updating pharmacy on-hand balances now..."
S (PSATODA,PSAFRDA)=0
F PSALCNT=1:1:2 D CALC
I PSATODA,PSAFRDA D
.S DIE="^PSD(58.81,",DA=PSATODA,DR="16///^S X=PSAFRDA"
.F L +^PSD(58.81,DA,0):$S($G(DILOCKTM)>0:DILOCKTM,1:3) I Q
.D ^DIE L -^PSD(58.81,DA,0) K DA
.S DA=PSAFRDA,DR="16///^S X=PSATODA"
.F L +^PSD(58.81,DA,0):$S($G(DILOCKTM)>0:DILOCKTM,1:3) I Q
.D ^DIE L -^PSD(58.81,DA,0) K DA,DIE
W !,"Done!" H 1 S ^TMP("PSASIG",$J,+PSAFROM,+PSATO,PSAFRDA)=""
D:PSADD MSG I 'PSADD H 1
S (PSADD,PSAOUT)=0
Q
CALC ;sub/add qty from dsp sites
W "." S PSATEMP=+$S(PSALCNT=1:PSAFROM,1:PSATO),PSATQTY=-PSATQTY
F L +^PSD(58.8,PSATEMP,1,PSADRG,0):$S($G(DILOCKTM)>0:DILOCKTM,1:3) I Q
D NOW^%DTC S PSADT=+%
S PSABAL(PSALCNT)=$P(^PSD(58.8,PSATEMP,1,PSADRG,0),"^",4),$P(^(0),"^",4)=$P(^(0),"^",4)+PSATQTY,$P(PSABAL(PSALCNT),"^",2)=(+PSABAL(PSALCNT)+PSATQTY)
L -^PSD(58.8,PSATEMP,1,PSADRG,0)
ADD ;find entry number
F L +^PSD(58.81,0):$S($G(DILOCKTM)>0:DILOCKTM,1:3) I Q
FIND S PSAREC=$P(^PSD(58.81,0),"^",3)+1 I $D(^PSD(58.81,PSAREC)) S $P(^PSD(58.81,0),"^",3)=PSAREC G FIND
K DIC,DLAYGO S DIC(0)="L",DIC="^PSD(58.81,",DLAYGO=58.81,(X,DINUM)=PSAREC D ^DIC K DIC,DINUM,DLAYGO
L -^PSD(58.81,0) W "."
S:PSALCNT=1 PSAFRDA=PSAREC S:PSALCNT=2 PSATODA=PSAREC
TRANS ;update transaction data
K DA,DIE,DR S DA=PSAREC,DIE=58.81
S DR="1////24;2////"_PSATEMP_";4////"_PSADRG_";3////"_PSADT_";5////"_PSATQTY_";6////"_PSADUZ_";9////"_$P(PSABAL(PSALCNT),"^")
D ^DIE K DA,DIE,DR W "."
ACT ;update location drug info
S:'$D(^PSD(58.8,PSATEMP,1,PSADRG,4,0)) ^PSD(58.8,PSATEMP,1,PSADRG,4,0)="^58.800119PA^^"
I '$D(^PSD(58.8,PSATEMP,1,PSADRG,4,PSAREC,0)) K DA,DD,DO S DIC(0)="L",DIC="^PSD(58.8,"_PSATEMP_",1,"_PSADRG_",4,",DA(2)=PSATEMP,DA(1)=PSADRG,(X,DINUM)=PSAREC D ^DIC K DA,DIC,DINUM W "."
MON ;update monthly activity node
S:'$D(^PSD(58.8,PSATEMP,1,PSADRG,5,0)) ^(0)="^58.801A^^"
I '$D(^PSD(58.8,PSATEMP,1,PSADRG,5,$E(PSADT,1,5)*100,0)) D
.S DIC="^PSD(58.8,"_PSATEMP_",1,"_PSADRG_",5,",DIC(0)="LM"
.S DA(2)=PSATEMP,DA(1)=PSADRG,(X,DINUM)=($E(PSADT,1,5)*100),DLAYGO=58.8 D ^DIC K DIC,DINUM,DLAYGO W "." S DA=+Y
.S DIE="^PSD(58.8,"_PSATEMP_",1,"_PSADRG_",5,",DA(2)=PSATEMP,DA(1)=PSADRG,DR="1////^S X="_+PSABAL(PSALCNT) D ^DIE K DIE
.S X="T-1M" D ^%DT
.S DIC="^PSD(58.8,"_PSATEMP_",1,"_PSADRG_",5,",DIC(0)="LM",DA(2)=PSATEMP,DA(1)=PSADRG,(X,DINUM)=($E(Y,1,5)*100),DLAYGO=58.8 D ^DIC K DINUM,DLAYGO
;.S DIE=DIC,DR="3////^S X="_($P($G(^PSD(58.8,PSATEMP,1,PSADRG,0)),"^",4)-PSATQTY) K DIC D ^DIE K DA,DIE W "."
S DA=($E(PSADT,1,5)*100),PSANODE=$G(^PSD(58.8,PSATEMP,1,PSADRG,5,DA,0)) Q:'$D(PSANODE)
S PSAREC=$P(PSANODE,"^",3),PSADJ=$P(PSANODE,"^",5),PSADISP=$P(PSANODE,"^",6),PSARET=$P(PSANODE,"^",7),PSATF=$P(PSANODE,"^",9)+PSATQTY
S PSABAL=$P(PSANODE,"^",2)+PSAREC+PSADJ-PSADISP+PSARET+PSATF
S DIE="^PSD(58.8,"_PSATEMP_",1,"_PSADRG_",5,",DA(2)=PSATEMP,DA(1)=PSADRG
S DR="13////^S X="_($P($G(^PSD(58.8,PSATEMP,1,PSADRG,5,DA,0)),"^",9)+PSATQTY)_";3////^S X="_PSABAL
D ^DIE K DA,DIE W "."
Q
CHK ;check for valid bal
S PSALES=0 D:PSATQTY>$P(^PSD(58.8,PSAFROM,1,PSADRG,0),"^",4)
.W $C(7),!!,"=> The drug balance is "_+$P(^PSD(58.8,PSAFROM,1,PSADRG,0),"^",4)_". You cannot transfer "_PSATQTY_" for this drug.",! S PSALES=1
.W "No action taken.",!
Q
MSG ;send mailman message with transfer info
K XMY,^TMP("PSATRAN",$J)
S ^TMP("PSATRAN",$J,1,0)="Drug: "_PSADRGN
S ^TMP("PSATRAN",$J,2,0)="Quantity : "_PSATQTY_" ("_PSADU_")",^TMP("PSATRAN",$J,3,0)="Pharmacist: "_PSADUZN,^TMP("PSATRAN",$J,4,0)=" "
S ^TMP("PSATRAN",$J,5,0)="Transferred from:",^TMP("PSATRAN",$J,6,0)=PSAFROMN,^TMP("PSATRAN",$J,7,0)=" "
S ^TMP("PSATRAN",$J,8,0)="Transferred and Added to:",^TMP("PSATRAN",$J,9,0)=PSATON
S XMSUB="Drug Transfer Between Pharmacies",XMTEXT="^TMP(""PSATRAN"",$J,",XMDUZ="Drug Accountability System"
F PSAJJ=0:0 S PSAJJ=$O(^XUSEC("PSAMGR",PSAJJ)) Q:'PSAJJ S XMY(PSAJJ)=""
G:'$D(XMY) QUIT D ^XMD
QUIT K XMY,^TMP("PSATRAN",$J)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSATRAN1 4534 printed Sep 23, 2025@19:26:43 Page 2
PSATRAN1 ;BIR/JMB-Transfer Drugs between Pharmacies - CONT'D ;7/23/97
+1 ;;3.0; DRUG ACCOUNTABILITY/INVENTORY INTERFACE;**64**; 10/24/97;Build 4
+2 ;This routine updates the dispensing and receiving locations. The drug
+3 ;balance & monthly activity are updated. It creates an activity in 58.8,
+4 ;a transaction in 58.81, sends a mail message if the drug is new to the
+5 ;receiving location, and stores the data so the signature sheet can
+6 ;print. It is called by PSATRAN.
+7 ;
UPDATE ;update location balances
+1 DO CHK
if PSALES
QUIT
WRITE !!,"Updating pharmacy on-hand balances now..."
+2 SET (PSATODA,PSAFRDA)=0
+3 FOR PSALCNT=1:1:2
DO CALC
+4 IF PSATODA
IF PSAFRDA
Begin DoDot:1
+5 SET DIE="^PSD(58.81,"
SET DA=PSATODA
SET DR="16///^S X=PSAFRDA"
+6 FOR
LOCK +^PSD(58.81,DA,0):$SELECT($GET(DILOCKTM)>0:DILOCKTM,1:3)
IF $TEST
QUIT
+7 DO ^DIE
LOCK -^PSD(58.81,DA,0)
KILL DA
+8 SET DA=PSAFRDA
SET DR="16///^S X=PSATODA"
+9 FOR
LOCK +^PSD(58.81,DA,0):$SELECT($GET(DILOCKTM)>0:DILOCKTM,1:3)
IF $TEST
QUIT
+10 DO ^DIE
LOCK -^PSD(58.81,DA,0)
KILL DA,DIE
End DoDot:1
+11 WRITE !,"Done!"
HANG 1
SET ^TMP("PSASIG",$JOB,+PSAFROM,+PSATO,PSAFRDA)=""
+12 if PSADD
DO MSG
IF 'PSADD
HANG 1
+13 SET (PSADD,PSAOUT)=0
+14 QUIT
CALC ;sub/add qty from dsp sites
+1 WRITE "."
SET PSATEMP=+$SELECT(PSALCNT=1:PSAFROM,1:PSATO)
SET PSATQTY=-PSATQTY
+2 FOR
LOCK +^PSD(58.8,PSATEMP,1,PSADRG,0):$SELECT($GET(DILOCKTM)>0:DILOCKTM,1:3)
IF $TEST
QUIT
+3 DO NOW^%DTC
SET PSADT=+%
+4 SET PSABAL(PSALCNT)=$PIECE(^PSD(58.8,PSATEMP,1,PSADRG,0),"^",4)
SET $PIECE(^(0),"^",4)=$PIECE(^(0),"^",4)+PSATQTY
SET $PIECE(PSABAL(PSALCNT),"^",2)=(+PSABAL(PSALCNT)+PSATQTY)
+5 LOCK -^PSD(58.8,PSATEMP,1,PSADRG,0)
ADD ;find entry number
+1 FOR
LOCK +^PSD(58.81,0):$SELECT($GET(DILOCKTM)>0:DILOCKTM,1:3)
IF $TEST
QUIT
FIND SET PSAREC=$PIECE(^PSD(58.81,0),"^",3)+1
IF $DATA(^PSD(58.81,PSAREC))
SET $PIECE(^PSD(58.81,0),"^",3)=PSAREC
GOTO FIND
+1 KILL DIC,DLAYGO
SET DIC(0)="L"
SET DIC="^PSD(58.81,"
SET DLAYGO=58.81
SET (X,DINUM)=PSAREC
DO ^DIC
KILL DIC,DINUM,DLAYGO
+2 LOCK -^PSD(58.81,0)
WRITE "."
+3 if PSALCNT=1
SET PSAFRDA=PSAREC
if PSALCNT=2
SET PSATODA=PSAREC
TRANS ;update transaction data
+1 KILL DA,DIE,DR
SET DA=PSAREC
SET DIE=58.81
+2 SET DR="1////24;2////"_PSATEMP_";4////"_PSADRG_";3////"_PSADT_";5////"_PSATQTY_";6////"_PSADUZ_";9////"_$PIECE(PSABAL(PSALCNT),"^")
+3 DO ^DIE
KILL DA,DIE,DR
WRITE "."
ACT ;update location drug info
+1 if '$DATA(^PSD(58.8,PSATEMP,1,PSADRG,4,0))
SET ^PSD(58.8,PSATEMP,1,PSADRG,4,0)="^58.800119PA^^"
+2 IF '$DATA(^PSD(58.8,PSATEMP,1,PSADRG,4,PSAREC,0))
KILL DA,DD,DO
SET DIC(0)="L"
SET DIC="^PSD(58.8,"_PSATEMP_",1,"_PSADRG_",4,"
SET DA(2)=PSATEMP
SET DA(1)=PSADRG
SET (X,DINUM)=PSAREC
DO ^DIC
KILL DA,DIC,DINUM
WRITE "."
MON ;update monthly activity node
+1 if '$DATA(^PSD(58.8,PSATEMP,1,PSADRG,5,0))
SET ^(0)="^58.801A^^"
+2 IF '$DATA(^PSD(58.8,PSATEMP,1,PSADRG,5,$EXTRACT(PSADT,1,5)*100,0))
Begin DoDot:1
+3 SET DIC="^PSD(58.8,"_PSATEMP_",1,"_PSADRG_",5,"
SET DIC(0)="LM"
+4 SET DA(2)=PSATEMP
SET DA(1)=PSADRG
SET (X,DINUM)=($EXTRACT(PSADT,1,5)*100)
SET DLAYGO=58.8
DO ^DIC
KILL DIC,DINUM,DLAYGO
WRITE "."
SET DA=+Y
+5 SET DIE="^PSD(58.8,"_PSATEMP_",1,"_PSADRG_",5,"
SET DA(2)=PSATEMP
SET DA(1)=PSADRG
SET DR="1////^S X="_+PSABAL(PSALCNT)
DO ^DIE
KILL DIE
+6 SET X="T-1M"
DO ^%DT
+7 SET DIC="^PSD(58.8,"_PSATEMP_",1,"_PSADRG_",5,"
SET DIC(0)="LM"
SET DA(2)=PSATEMP
SET DA(1)=PSADRG
SET (X,DINUM)=($EXTRACT(Y,1,5)*100)
SET DLAYGO=58.8
DO ^DIC
KILL DINUM,DLAYGO
End DoDot:1
+8 ;.S DIE=DIC,DR="3////^S X="_($P($G(^PSD(58.8,PSATEMP,1,PSADRG,0)),"^",4)-PSATQTY) K DIC D ^DIE K DA,DIE W "."
+9 SET DA=($EXTRACT(PSADT,1,5)*100)
SET PSANODE=$GET(^PSD(58.8,PSATEMP,1,PSADRG,5,DA,0))
if '$DATA(PSANODE)
QUIT
+10 SET PSAREC=$PIECE(PSANODE,"^",3)
SET PSADJ=$PIECE(PSANODE,"^",5)
SET PSADISP=$PIECE(PSANODE,"^",6)
SET PSARET=$PIECE(PSANODE,"^",7)
SET PSATF=$PIECE(PSANODE,"^",9)+PSATQTY
+11 SET PSABAL=$PIECE(PSANODE,"^",2)+PSAREC+PSADJ-PSADISP+PSARET+PSATF
+12 SET DIE="^PSD(58.8,"_PSATEMP_",1,"_PSADRG_",5,"
SET DA(2)=PSATEMP
SET DA(1)=PSADRG
+13 SET DR="13////^S X="_($PIECE($GET(^PSD(58.8,PSATEMP,1,PSADRG,5,DA,0)),"^",9)+PSATQTY)_";3////^S X="_PSABAL
+14 DO ^DIE
KILL DA,DIE
WRITE "."
+15 QUIT
CHK ;check for valid bal
+1 SET PSALES=0
if PSATQTY>$PIECE(^PSD(58.8,PSAFROM,1,PSADRG,0),"^",4)
Begin DoDot:1
+2 WRITE $CHAR(7),!!,"=> The drug balance is "_+$PIECE(^PSD(58.8,PSAFROM,1,PSADRG,0),"^",4)_". You cannot transfer "_PSATQTY_" for this drug.",!
SET PSALES=1
+3 WRITE "No action taken.",!
End DoDot:1
+4 QUIT
MSG ;send mailman message with transfer info
+1 KILL XMY,^TMP("PSATRAN",$JOB)
+2 SET ^TMP("PSATRAN",$JOB,1,0)="Drug: "_PSADRGN
+3 SET ^TMP("PSATRAN",$JOB,2,0)="Quantity : "_PSATQTY_" ("_PSADU_")"
SET ^TMP("PSATRAN",$JOB,3,0)="Pharmacist: "_PSADUZN
SET ^TMP("PSATRAN",$JOB,4,0)=" "
+4 SET ^TMP("PSATRAN",$JOB,5,0)="Transferred from:"
SET ^TMP("PSATRAN",$JOB,6,0)=PSAFROMN
SET ^TMP("PSATRAN",$JOB,7,0)=" "
+5 SET ^TMP("PSATRAN",$JOB,8,0)="Transferred and Added to:"
SET ^TMP("PSATRAN",$JOB,9,0)=PSATON
+6 SET XMSUB="Drug Transfer Between Pharmacies"
SET XMTEXT="^TMP(""PSATRAN"",$J,"
SET XMDUZ="Drug Accountability System"
+7 FOR PSAJJ=0:0
SET PSAJJ=$ORDER(^XUSEC("PSAMGR",PSAJJ))
if 'PSAJJ
QUIT
SET XMY(PSAJJ)=""
+8 if '$DATA(XMY)
GOTO QUIT
DO ^XMD
QUIT KILL XMY,^TMP("PSATRAN",$JOB)
+1 QUIT
