PSAREC1 ;BIR/LTL,JMB-Receiving Directly into Drug Accountability - CONT'D ;7/23/97
;;3.0; DRUG ACCOUNTABILITY/INVENTORY INTERFACE;**21,37,64**; 10/24/97;Build 4
;References to ^PSDRUG( are covered by IA #2095
;This routine posts non-prime vendor's drugs into pharmacy locations.
;The balances are incremented in the pharmacy location & the DRUG file.
;
POST ;Posts the data in 58.8, 58.81, and 50
D NOW^%DTC S PSADT=+$E(%,1,12) K %
I '$D(^PSD(58.8,PSALOC,1,PSADRG,0)) D
.S:'$D(^PSD(58.8,PSALOC,1,0)) DIC("P")=$P(^DD(58.8,10,0),"^",2)
.S DA(1)=PSALOC,DIC="^PSD(58.8,"_DA(1)_",1,",(DA,X)=PSADRG,DIC(0)="L",DLAYGO=58.8
.F L +^PSD(58.8,PSALOC,0):$S($G(DILOCKTM)>0:DILOCKTM,1:3) I Q
.D ^DIC L -^PSD(58.8,PSALOC,0) K DIC,DA
W !!,"There were ",$S($P($G(^PSD(58.8,PSALOC,1,PSADRG,0)),"^",4):$P($G(^(0)),"^",4),1:0)," on hand.",?40,"There are now ",$P($G(^(0)),"^",4)+PSAREC," on hand.",!
F L +^PSD(58.8,PSALOC,1,PSADRG,0):$S($G(DILOCKTM)>0:DILOCKTM,1:3) I Q
S $P(^PSD(58.8,PSALOC,1,PSADRG,0),"^",4)=PSAREC+PSACBAL
L -^PSD(58.8,PSALOC,1,PSADRG,0)
;
MONTHLY I '$D(^PSD(58.8,PSALOC,1,PSADRG,5,$E(DT,1,5)*100,0)) D
.;PSA*3*31 Set zero node to correct DD (20 not 28) Dave B.
.S:'$D(^PSD(58.8,PSALOC,1,PSADRG,5,0)) DIC("P")=$P(^DD(58.8001,20,0),"^",2)
.S DIC="^PSD(58.8,PSALOC,1,PSADRG,5,",DIC(0)="L",DIC("DR")="1////^S X=$G(PSACBAL)",(X,DINUM)=$E(DT,1,5)*100,DA(2)=PSALOC,DA(1)=PSADRG,DLAYGO=58.8 D ^DIC K DIC,DINUM,DLAYGO
.S X="T-1M" D ^%DT
.S DIC="^PSD(58.8,PSALOC,1,PSADRG,5,",DIC(0)="L",(X,DINUM)=$E(Y,1,5)*100,DA(2)=PSALOC,DA(1)=PSADRG,DLAYGO=58.8 D ^DIC K DIC,DINUM,DLAYGO S DA=+Y
.S DIE="^PSD(58.8,PSALOC,1,PSADRG,5,",DA(2)=PSALOC,DA(1)=PSADRG,DR="3////^S X=$G(PSACBAL)" D ^DIE K DIE
S DIE="^PSD(58.8,"_PSALOC_",1,"_PSADRG_",5,",DA(2)=PSALOC,DA(1)=PSADRG,DA=$E(DT,1,5)*100,DR="5////^S X="_$P($G(^(0)),"^",3)+PSAREC D ^DIE
W !,"Updating monthly receipts and transaction history.",!
TR F L +^PSD(58.81,0):$S($G(DILOCKTM)>0:DILOCKTM,1:3) I Q
FIND S PSAT=$P(^PSD(58.81,0),"^",3)+1 I $D(^PSD(58.81,PSAT)) S $P(^PSD(58.81,0),"^",3)=$P(^PSD(58.81,0),"^",3)+1 G FIND
S DIC="^PSD(58.81,",DIC(0)="L",DLAYGO=58.81,(DINUM,X)=PSAT D ^DIC K DIC,DINUM,DLAYGO
S DIE="^PSD(58.81,",DA=PSAT,DR="1////1;2////^S X=PSALOC;3////^S X=PSADT;4////^S X=PSADRG;5////^S X=PSAREC;6////^S X=DUZ;7////^S X=PSACON;8////^S X=PSAPO;9////^S X=PSACBAL;71////^S X=$G(PSAPV)" D ^DIE
L -^PSD(58.81,0)
S:'$D(^PSD(58.8,PSALOC,1,PSADRG,4,0)) DIC("P")=$P(^DD(58.8001,19,0),"^",2)
ACT S DIC="^PSD(58.8,PSALOC,1,PSADRG,4,",DIC(0)="L",(X,DINUM)=PSAT,DA(2)=PSALOC,DA(1)=PSADRG,DLAYGO=58.8
F L +^PSD(58.8,PSALOC,0):$S($G(DILOCKTM)>0:DILOCKTM,1:3) I Q
D ^DIC
L -^PSD(58.8,PSALOC,0) K DA,DIC,DINUM,DLAYGO
;
50 S (PSATDRG,PSA)=0 F S PSA=$O(^PSD(58.8,"C",PSADRG,PSA)) Q:'PSA D
.I PSA=PSALOC Q:PSACBAL<0 S PSATDRG=PSATDRG+PSACBAL Q
.I +$G(^PSD(58.8,PSA,"I")),+^PSD(58.8,PSA,"I")'>DT Q
.Q:$P($G(^PSD(58.8,PSA,0)),"^",2)'="M"&($P($G(^PSD(58.8,PSA,0)),"^",2)'="P")
.S PSATDRG=PSATDRG+$P($G(^PSD(58.8,PSA,1,PSADRG,0)),"^",4)
S PSANODE=$G(^PSDRUG(PSADRG,660))
I PSACBAL>0!(PSATDRG>0) D
.S PSACOST=PSACOST+(PSATDRG*+$P(PSANODE,"^",6)),PSATDRG=PSAREC+PSATDRG,PSANPDU=+$J((PSACOST/PSATDRG),0,3),PSANPOU=PSANPDU*PSADUOU
.S PSALEN=$L($P(PSANPOU,".")),PSANPOU=$J(PSANPOU,(PSALEN+3),2)
E S PSATDRG=PSATDRG+PSACBAL,PSANPOU=PSAPOU,PSANPDU=PSAPDU
S DIE="^PSDRUG(",DA=PSADRG,DR="50////^S X="_(PSAREC+$G(^PSDRUG(PSADRG,660.1)))
F L +^PSDRUG(DA,0):$S($G(DILOCKTM)>0:DILOCKTM,1:3) I Q
D ^DIE L -^PSDRUG(DA,0) K DIE,DA
S PSAODASH=$P($G(^PSDRUG(PSADRG,2)),"^",2)
S PSAONDC=$S(PSAODASH'="":$E("000000",1,(6-$L($P(PSAODASH,"-"))))_$P(PSAODASH,"-")_$E("0000",1,(4-$L($P(PSAODASH,"-",2))))_$P(PSAODASH,"-",2)_$E("00",1,(2-$L($P(PSAODASH,"-",3))))_$P(PSAODASH,"-",3),1:"")
I +PSANPDU=+$P(PSANODE,"^",6),PSANDC=PSAONDC,PSANDC'="" G NEXT
I ($P(PSANODE,"^",2)=PSAOU&($P(PSANODE,"^",5)=PSADUOU))!('$P(PSANODE,"^",2)&('$P(PSANODE,"^",5))) D
.I PSANDC'="",PSANDC'=PSAONDC D
..S DIE="^PSDRUG(",DA=PSADRG,DR="31////^S X=PSADASH"
..F L +^PSDRUG(DA,0):$S($G(DILOCKTM)>0:DILOCKTM,1:3) I Q
..D ^DIE L -^PSDRUG(DA,0) K DIE,DA
.I +PSANPDU,+PSANPDU'=+$P(PSANODE,"^",6),+PSANPOU D
..S DIE="^PSDRUG(",DA=PSADRG,DR="13///^S X="_PSANPOU
..F L +^PSDRUG(DA,0):$S($G(DILOCKTM)>0:DILOCKTM,1:3) I Q
..D ^DIE L -^PSDRUG(DA,0) K DIE,DA
.I '$P(PSANODE,"^",2),'$P(PSANODE,"^",5),PSAOU,PSADUOU D
..S DIE="^PSDRUG(",DA=PSADRG,DR="12////^S X=PSAOU;15////^S X=PSADUOU"
..F L +^PSDRUG(DA,0):$S($G(DILOCKTM)>0:DILOCKTM,1:3) I Q
..D ^DIE L -^PSDRUG(DA,0) K DIE,DA
NEXT Q:$G(PSANDC)=""
SYNONYM D PSANDC1^PSAHELP S PSADASH=PSANDCX K PSANDCX
S PSA50SYN=+$O(^PSDRUG("C",PSANDC,PSADRG,0))
K DA,DR S:'$D(^PSDRUG(PSADRG,1,0)) DIC("P")=$P(^DD(50,9,0),"^",2)
S DA(1)=PSADRG
I 'PSA50SYN!(PSA50SYN&('$D(^PSDRUG(PSADRG,1,PSA50SYN,0)))) D Q:Y<0
.S DIC="^PSDRUG("_DA(1)_",1,",DIC(0)="LM",X=PSANDC,DLAYGO=50
.F L +^PSDRUG(PSADRG,0):$S($G(DILOCKTM)>0:DILOCKTM,1:3) I Q
.D ^DIC L -^PSDRUG(PSADRG,0) K DIC,DLAYGO S PSA50SYN=+Y
S DA=PSA50SYN,DIE="^PSDRUG("_DA(1)_",1,"
S DR="2////^S X=PSADASH;1////D"_$S(+PSAOU:";401////^S X=PSAOU",1:"")_$S(+PSAPOU:";402////^S X=PSAPOU",1:"")_";403////^S X=PSADUOU"_$S(+$G(PSAPDU):";404////^S X=PSAPDU",1:"")_$S(PSAVEND'="":";405///^S X=PSAVEND",1:"")
F L +^PSDRUG(PSADRG,0):$S($G(DILOCKTM)>0:DILOCKTM,1:3) I Q
D ^DIE L -^PSDRUG(PSADRG,0)
K DIE,DR
Q
PRICEHLP ;Extended help for price per order unit
W !?5,"Enter the cost for each order unit."
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSAREC1 5525 printed Sep 23, 2025@19:26:33 Page 2
PSAREC1 ;BIR/LTL,JMB-Receiving Directly into Drug Accountability - CONT'D ;7/23/97
+1 ;;3.0; DRUG ACCOUNTABILITY/INVENTORY INTERFACE;**21,37,64**; 10/24/97;Build 4
+2 ;References to ^PSDRUG( are covered by IA #2095
+3 ;This routine posts non-prime vendor's drugs into pharmacy locations.
+4 ;The balances are incremented in the pharmacy location & the DRUG file.
+5 ;
POST ;Posts the data in 58.8, 58.81, and 50
+1 DO NOW^%DTC
SET PSADT=+$EXTRACT(%,1,12)
KILL %
+2 IF '$DATA(^PSD(58.8,PSALOC,1,PSADRG,0))
Begin DoDot:1
+3 if '$DATA(^PSD(58.8,PSALOC,1,0))
SET DIC("P")=$PIECE(^DD(58.8,10,0),"^",2)
+4 SET DA(1)=PSALOC
SET DIC="^PSD(58.8,"_DA(1)_",1,"
SET (DA,X)=PSADRG
SET DIC(0)="L"
SET DLAYGO=58.8
+5 FOR
LOCK +^PSD(58.8,PSALOC,0):$SELECT($GET(DILOCKTM)>0:DILOCKTM,1:3)
IF $TEST
QUIT
+6 DO ^DIC
LOCK -^PSD(58.8,PSALOC,0)
KILL DIC,DA
End DoDot:1
+7 WRITE !!,"There were ",$SELECT($PIECE($GET(^PSD(58.8,PSALOC,1,PSADRG,0)),"^",4):$PIECE($GET(^(0)),"^",4),1:0)," on hand.",?40,"There are now ",$PIECE($GET(^(0)),"^",4)+PSAREC," on hand.",!
+8 FOR
LOCK +^PSD(58.8,PSALOC,1,PSADRG,0):$SELECT($GET(DILOCKTM)>0:DILOCKTM,1:3)
IF $TEST
QUIT
+9 SET $PIECE(^PSD(58.8,PSALOC,1,PSADRG,0),"^",4)=PSAREC+PSACBAL
+10 LOCK -^PSD(58.8,PSALOC,1,PSADRG,0)
+11 ;
MONTHLY IF '$DATA(^PSD(58.8,PSALOC,1,PSADRG,5,$EXTRACT(DT,1,5)*100,0))
Begin DoDot:1
+1 ;PSA*3*31 Set zero node to correct DD (20 not 28) Dave B.
+2 if '$DATA(^PSD(58.8,PSALOC,1,PSADRG,5,0))
SET DIC("P")=$PIECE(^DD(58.8001,20,0),"^",2)
+3 SET DIC="^PSD(58.8,PSALOC,1,PSADRG,5,"
SET DIC(0)="L"
SET DIC("DR")="1////^S X=$G(PSACBAL)"
SET (X,DINUM)=$EXTRACT(DT,1,5)*100
SET DA(2)=PSALOC
SET DA(1)=PSADRG
SET DLAYGO=58.8
DO ^DIC
KILL DIC,DINUM,DLAYGO
+4 SET X="T-1M"
DO ^%DT
+5 SET DIC="^PSD(58.8,PSALOC,1,PSADRG,5,"
SET DIC(0)="L"
SET (X,DINUM)=$EXTRACT(Y,1,5)*100
SET DA(2)=PSALOC
SET DA(1)=PSADRG
SET DLAYGO=58.8
DO ^DIC
KILL DIC,DINUM,DLAYGO
SET DA=+Y
+6 SET DIE="^PSD(58.8,PSALOC,1,PSADRG,5,"
SET DA(2)=PSALOC
SET DA(1)=PSADRG
SET DR="3////^S X=$G(PSACBAL)"
DO ^DIE
KILL DIE
End DoDot:1
+7 SET DIE="^PSD(58.8,"_PSALOC_",1,"_PSADRG_",5,"
SET DA(2)=PSALOC
SET DA(1)=PSADRG
SET DA=$EXTRACT(DT,1,5)*100
SET DR="5////^S X="_$PIECE($GET(^(0)),"^",3)+PSAREC
DO ^DIE
+8 WRITE !,"Updating monthly receipts and transaction history.",!
TR FOR
LOCK +^PSD(58.81,0):$SELECT($GET(DILOCKTM)>0:DILOCKTM,1:3)
IF $TEST
QUIT
FIND SET PSAT=$PIECE(^PSD(58.81,0),"^",3)+1
IF $DATA(^PSD(58.81,PSAT))
SET $PIECE(^PSD(58.81,0),"^",3)=$PIECE(^PSD(58.81,0),"^",3)+1
GOTO FIND
+1 SET DIC="^PSD(58.81,"
SET DIC(0)="L"
SET DLAYGO=58.81
SET (DINUM,X)=PSAT
DO ^DIC
KILL DIC,DINUM,DLAYGO
+2 SET DIE="^PSD(58.81,"
SET DA=PSAT
SET DR="1////1;2////^S X=PSALOC;3////^S X=PSADT;4////^S X=PSADRG;5////^S X=PSAREC;6////^S X=DUZ;7////^S X=PSACON;8////^S X=PSAPO;9////^S X=PSACBAL;71////^S X=$G(PSAPV)"
DO ^DIE
+3 LOCK -^PSD(58.81,0)
+4 if '$DATA(^PSD(58.8,PSALOC,1,PSADRG,4,0))
SET DIC("P")=$PIECE(^DD(58.8001,19,0),"^",2)
ACT SET DIC="^PSD(58.8,PSALOC,1,PSADRG,4,"
SET DIC(0)="L"
SET (X,DINUM)=PSAT
SET DA(2)=PSALOC
SET DA(1)=PSADRG
SET DLAYGO=58.8
+1 FOR
LOCK +^PSD(58.8,PSALOC,0):$SELECT($GET(DILOCKTM)>0:DILOCKTM,1:3)
IF $TEST
QUIT
+2 DO ^DIC
+3 LOCK -^PSD(58.8,PSALOC,0)
KILL DA,DIC,DINUM,DLAYGO
+4 ;
50 SET (PSATDRG,PSA)=0
FOR
SET PSA=$ORDER(^PSD(58.8,"C",PSADRG,PSA))
if 'PSA
QUIT
Begin DoDot:1
+1 IF PSA=PSALOC
if PSACBAL<0
QUIT
SET PSATDRG=PSATDRG+PSACBAL
QUIT
+2 IF +$GET(^PSD(58.8,PSA,"I"))
IF +^PSD(58.8,PSA,"I")'>DT
QUIT
+3 if $PIECE($GET(^PSD(58.8,PSA,0)),"^",2)'="M"&($PIECE($GET(^PSD(58.8,PSA,0)),"^",2)'="P")
QUIT
+4 SET PSATDRG=PSATDRG+$PIECE($GET(^PSD(58.8,PSA,1,PSADRG,0)),"^",4)
End DoDot:1
+5 SET PSANODE=$GET(^PSDRUG(PSADRG,660))
+6 IF PSACBAL>0!(PSATDRG>0)
Begin DoDot:1
+7 SET PSACOST=PSACOST+(PSATDRG*+$PIECE(PSANODE,"^",6))
SET PSATDRG=PSAREC+PSATDRG
SET PSANPDU=+$JUSTIFY((PSACOST/PSATDRG),0,3)
SET PSANPOU=PSANPDU*PSADUOU
+8 SET PSALEN=$LENGTH($PIECE(PSANPOU,"."))
SET PSANPOU=$JUSTIFY(PSANPOU,(PSALEN+3),2)
End DoDot:1
+9 IF '$TEST
SET PSATDRG=PSATDRG+PSACBAL
SET PSANPOU=PSAPOU
SET PSANPDU=PSAPDU
+10 SET DIE="^PSDRUG("
SET DA=PSADRG
SET DR="50////^S X="_(PSAREC+$GET(^PSDRUG(PSADRG,660.1)))
+11 FOR
LOCK +^PSDRUG(DA,0):$SELECT($GET(DILOCKTM)>0:DILOCKTM,1:3)
IF $TEST
QUIT
+12 DO ^DIE
LOCK -^PSDRUG(DA,0)
KILL DIE,DA
+13 SET PSAODASH=$PIECE($GET(^PSDRUG(PSADRG,2)),"^",2)
+14 SET PSAONDC=$SELECT(PSAODASH'="":$EXTRACT("000000",1,(6-$LENGTH($PIECE(PSAODASH,"-"))))_$PIECE(PSAODASH,"-")_$EXTRACT("0000",1,(4-$LENGTH($PIECE(PSAODASH,"-",2))))_$PIECE(PSAODASH,"-",2)_$EXTRACT("00",1,(2-...
... $LENGTH($PIECE(PSAODASH,"-",3))))_$PIECE(PSAODASH,"-",3),1:"")
+15 IF +PSANPDU=+$PIECE(PSANODE,"^",6)
IF PSANDC=PSAONDC
IF PSANDC'=""
GOTO NEXT
+16 IF ($PIECE(PSANODE,"^",2)=PSAOU&($PIECE(PSANODE,"^",5)=PSADUOU))!('$PIECE(PSANODE,"^",2)&('$PIECE(PSANODE,"^",5)))
Begin DoDot:1
+17 IF PSANDC'=""
IF PSANDC'=PSAONDC
Begin DoDot:2
+18 SET DIE="^PSDRUG("
SET DA=PSADRG
SET DR="31////^S X=PSADASH"
+19 FOR
LOCK +^PSDRUG(DA,0):$SELECT($GET(DILOCKTM)>0:DILOCKTM,1:3)
IF $TEST
QUIT
+20 DO ^DIE
LOCK -^PSDRUG(DA,0)
KILL DIE,DA
End DoDot:2
+21 IF +PSANPDU
IF +PSANPDU'=+$PIECE(PSANODE,"^",6)
IF +PSANPOU
Begin DoDot:2
+22 SET DIE="^PSDRUG("
SET DA=PSADRG
SET DR="13///^S X="_PSANPOU
+23 FOR
LOCK +^PSDRUG(DA,0):$SELECT($GET(DILOCKTM)>0:DILOCKTM,1:3)
IF $TEST
QUIT
+24 DO ^DIE
LOCK -^PSDRUG(DA,0)
KILL DIE,DA
End DoDot:2
+25 IF '$PIECE(PSANODE,"^",2)
IF '$PIECE(PSANODE,"^",5)
IF PSAOU
IF PSADUOU
Begin DoDot:2
+26 SET DIE="^PSDRUG("
SET DA=PSADRG
SET DR="12////^S X=PSAOU;15////^S X=PSADUOU"
+27 FOR
LOCK +^PSDRUG(DA,0):$SELECT($GET(DILOCKTM)>0:DILOCKTM,1:3)
IF $TEST
QUIT
+28 DO ^DIE
LOCK -^PSDRUG(DA,0)
KILL DIE,DA
End DoDot:2
End DoDot:1
NEXT if $GET(PSANDC)=""
QUIT
SYNONYM DO PSANDC1^PSAHELP
SET PSADASH=PSANDCX
KILL PSANDCX
+1 SET PSA50SYN=+$ORDER(^PSDRUG("C",PSANDC,PSADRG,0))
+2 KILL DA,DR
if '$DATA(^PSDRUG(PSADRG,1,0))
SET DIC("P")=$PIECE(^DD(50,9,0),"^",2)
+3 SET DA(1)=PSADRG
+4 IF 'PSA50SYN!(PSA50SYN&('$DATA(^PSDRUG(PSADRG,1,PSA50SYN,0))))
Begin DoDot:1
+5 SET DIC="^PSDRUG("_DA(1)_",1,"
SET DIC(0)="LM"
SET X=PSANDC
SET DLAYGO=50
+6 FOR
LOCK +^PSDRUG(PSADRG,0):$SELECT($GET(DILOCKTM)>0:DILOCKTM,1:3)
IF $TEST
QUIT
+7 DO ^DIC
LOCK -^PSDRUG(PSADRG,0)
KILL DIC,DLAYGO
SET PSA50SYN=+Y
End DoDot:1
if Y<0
QUIT
+8 SET DA=PSA50SYN
SET DIE="^PSDRUG("_DA(1)_",1,"
+9 SET DR="2////^S X=PSADASH;1////D"_$SELECT(+PSAOU:";401////^S X=PSAOU",1:"")_$SELECT(+PSAPOU:";402////^S X=PSAPOU",1:"")_";403////^S X=PSADUOU"_$SELECT(+$GET(PSAPDU):";404////^S X=PSAPDU",1:"")_$SELECT(PSAVEND'="":";405///^S X=PSAVEND",1:"")
+10 FOR
LOCK +^PSDRUG(PSADRG,0):$SELECT($GET(DILOCKTM)>0:DILOCKTM,1:3)
IF $TEST
QUIT
+11 DO ^DIE
LOCK -^PSDRUG(PSADRG,0)
+12 KILL DIE,DR
+13 QUIT
PRICEHLP ;Extended help for price per order unit
+1 WRITE !?5,"Enter the cost for each order unit."
+2 QUIT
