| [613] | 1 | IBATRX ;LL/ELZ - TRANSFER PRICING RX ROUTINE ; 24-FEB-99
|
|---|
| 2 | ;;2.0;INTEGRATED BILLING;**115,309,347**;21-MAR-94;Build 24
|
|---|
| 3 | ;;Per VHA Directive 2004-038, this routine should not be modified.
|
|---|
| 4 | ;
|
|---|
| 5 | RX(DFN,DT1,DT2,ARRAY) ; look up all rxs for a patient and date range
|
|---|
| 6 | ;
|
|---|
| 7 | N PIFN,RIFN,IBX,IBY,DTE,DTR,RX,IBCNT,IBRX0,IBRX2,IBS,IBRF,LIST,LIST2,NODE,RFNUM,IBRX K ARRAY,POARR S POARR=0
|
|---|
| 8 | S IBCNT=0,DT1=$G(DT1)-.0001,DT2=$G(DT2) S:'DT2 DT2=9999999 Q:'$G(DFN)
|
|---|
| 9 | S LIST="IBRXARR"
|
|---|
| 10 | D PROF^PSO52API(DFN,LIST,DT1,DT2)
|
|---|
| 11 | S DTE=0 F S DTE=$O(^TMP($J,LIST,"B",DTE)) Q:'DTE D
|
|---|
| 12 | . S IBRX=0 F S IBRX=$O(^TMP($J,LIST,"B",DTE,IBRX)) Q:'IBRX D
|
|---|
| 13 | .. S IBRX(0)=$$RXZERO^IBRXUTL(DFN,IBRX)
|
|---|
| 14 | .. S IBRX(2)=$$RXSEC^IBRXUTL(DFN,IBRX)
|
|---|
| 15 | .. D ZERO^IBRXUTL(+$P(IBRX(0),"^",6))
|
|---|
| 16 | .. ; original fill
|
|---|
| 17 | .. S DTR=$P(IBRX(2),"^",2) I DTR'<DT1,DTR'>DT2 D
|
|---|
| 18 | ... 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)
|
|---|
| 19 | .. ; refills
|
|---|
| 20 | .. S NODE="R"
|
|---|
| 21 | .. S LIST2="IBRXARR2"
|
|---|
| 22 | .. D RX^PSO52API(DFN,LIST2,IBRX,,NODE,,)
|
|---|
| 23 | .. S IBRF=0 F S IBRF=$O(^TMP($J,LIST2,DFN,IBRX,"RF",IBRF)) Q:IBRF'>0 D
|
|---|
| 24 | ... S IBY=$$ZEROSUB^IBRXUTL(DFN,IBRX,IBRF) Q:IBY=""
|
|---|
| 25 | ... 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)
|
|---|
| 26 | .. K ^TMP($J,LIST2)
|
|---|
| 27 | K ^TMP($J,"IBDRUG"),^TMP($J,LIST)
|
|---|
| 28 | Q
|
|---|
