source: FOIAVistA/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBATRX.m@ 1757

Last change on this file since 1757 was 628, checked in by George Lilly, 15 years ago

initial load of FOIAVistA 6/30/08 version

File size: 1.4 KB
Line 
1IBATRX ;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 ;
5RX(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
Note: See TracBrowser for help on using the repository browser.