- PSAREC1 ;BIR/LTL,JMB-Receiving Directly into Drug Accountability - CONT'D ;7/23/97
- ;;3.0; DRUG ACCOUNTABILITY/INVENTORY INTERFACE;**21,37**; 10/24/97
- ;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):0 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):0 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):0 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):0 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):0 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):0 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):0 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):0 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):0 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):0 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
- PSAREC1 ;BIR/LTL,JMB-Receiving Directly into Drug Accountability - CONT'D ;7/23/97
- +1 ;;3.0; DRUG ACCOUNTABILITY/INVENTORY INTERFACE;**21,37**; 10/24/97
- +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):0
- 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):0
- 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):0
- 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):0
- 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):0
- 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):0
- 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):0
- 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):0
- 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):0
- 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):0
- 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
