29 lines
1.4 KiB
Mathematica
29 lines
1.4 KiB
Mathematica
|
IBATRX ;LL/ELZ - TRANSFER PRICING RX ROUTINE ; 24-FEB-99
|
||
|
|
;;2.0;INTEGRATED BILLING;**115,309,347**;21-MAR-94;Build 24
|
||
|
|
;;Per VHA Directive 2004-038, this routine should not be modified.
|
||
|
|
;
|
||
|
|
RX(DFN,DT1,DT2,ARRAY) ; look up all rxs for a patient and date range
|
||
|
|
;
|
||
|
|
N PIFN,RIFN,IBX,IBY,DTE,DTR,RX,IBCNT,IBRX0,IBRX2,IBS,IBRF,LIST,LIST2,NODE,RFNUM,IBRX K ARRAY,POARR S POARR=0
|
||
|
|
S IBCNT=0,DT1=$G(DT1)-.0001,DT2=$G(DT2) S:'DT2 DT2=9999999 Q:'$G(DFN)
|
||
|
|
S LIST="IBRXARR"
|
||
|
|
D PROF^PSO52API(DFN,LIST,DT1,DT2)
|
||
|
|
S DTE=0 F S DTE=$O(^TMP($J,LIST,"B",DTE)) Q:'DTE D
|
||
|
|
. S IBRX=0 F S IBRX=$O(^TMP($J,LIST,"B",DTE,IBRX)) Q:'IBRX D
|
||
|
|
.. S IBRX(0)=$$RXZERO^IBRXUTL(DFN,IBRX)
|
||
|
|
.. S IBRX(2)=$$RXSEC^IBRXUTL(DFN,IBRX)
|
||
|
|
.. D ZERO^IBRXUTL(+$P(IBRX(0),"^",6))
|
||
|
|
.. ; original fill
|
||
|
|
.. S DTR=$P(IBRX(2),"^",2) I DTR'<DT1,DTR'>DT2 D
|
||
|
|
... S ARRAY(IBRX,+DTR)=$P(IBRX(0),"^")_"^"_0_"^"_$P(IBRX(0),"^",6)_"^"_$G(^TMP($J,"IBDRUG",+$P(IBRX(0),"^",6),.01))_"^"_$P(IBRX(0),"^",7)_"^"_$P(IBRX(0),"^",17)
|
||
|
|
.. ; refills
|
||
|
|
.. S NODE="R"
|
||
|
|
.. S LIST2="IBRXARR2"
|
||
|
|
.. D RX^PSO52API(DFN,LIST2,IBRX,,NODE,,)
|
||
|
|
.. S IBRF=0 F S IBRF=$O(^TMP($J,LIST2,DFN,IBRX,"RF",IBRF)) Q:IBRF'>0 D
|
||
|
|
... S IBY=$$ZEROSUB^IBRXUTL(DFN,IBRX,IBRF) Q:IBY=""
|
||
|
|
... S ARRAY(IBRX,+IBY)=$P(IBRX(0),"^")_"^"_IBRF_"^"_$P(IBRX(0),"^",6)_"^"_$G(^TMP($J,"IBDRUG",+$P(IBRX(0),"^",6),.01))_"^"_$P(IBY,"^",4)_"^"_$P(IBY,"^",11)
|
||
|
|
.. K ^TMP($J,LIST2)
|
||
|
|
K ^TMP($J,"IBDRUG"),^TMP($J,LIST)
|
||
|
|
Q
|