- 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
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBATRX 1430 printed Mar 13, 2025@21:12:50 Page 2
- IBATRX ;LL/ELZ - TRANSFER PRICING RX ROUTINE ; 24-FEB-99
- +1 ;;2.0;INTEGRATED BILLING;**115,309,347**;21-MAR-94;Build 24
- +2 ;;Per VHA Directive 2004-038, this routine should not be modified.
- +3 ;
- RX(DFN,DT1,DT2,ARRAY) ; look up all rxs for a patient and date range
- +1 ;
- +2 NEW PIFN,RIFN,IBX,IBY,DTE,DTR,RX,IBCNT,IBRX0,IBRX2,IBS,IBRF,LIST,LIST2,NODE,RFNUM,IBRX
- KILL ARRAY,POARR
- SET POARR=0
- +3 SET IBCNT=0
- SET DT1=$GET(DT1)-.0001
- SET DT2=$GET(DT2)
- if 'DT2
- SET DT2=9999999
- if '$GET(DFN)
- QUIT
- +4 SET LIST="IBRXARR"
- +5 DO PROF^PSO52API(DFN,LIST,DT1,DT2)
- +6 SET DTE=0
- FOR
- SET DTE=$ORDER(^TMP($JOB,LIST,"B",DTE))
- if 'DTE
- QUIT
- Begin DoDot:1
- +7 SET IBRX=0
- FOR
- SET IBRX=$ORDER(^TMP($JOB,LIST,"B",DTE,IBRX))
- if 'IBRX
- QUIT
- Begin DoDot:2
- +8 SET IBRX(0)=$$RXZERO^IBRXUTL(DFN,IBRX)
- +9 SET IBRX(2)=$$RXSEC^IBRXUTL(DFN,IBRX)
- +10 DO ZERO^IBRXUTL(+$PIECE(IBRX(0),"^",6))
- +11 ; original fill
- +12 SET DTR=$PIECE(IBRX(2),"^",2)
- IF DTR'<DT1
- IF DTR'>DT2
- Begin DoDot:3
- +13 SET ARRAY(IBRX,+DTR)=$PIECE(IBRX(0),"^")_"^"_0_"^"_$PIECE(IBRX(0),"^",6)_"^"_$GET(^TMP($JOB,"IBDRUG",+$PIECE(IBRX(0),"^",6),.01))_"^"_$PIECE(IBRX(0),"^",7)_"^"_$PIECE(IBRX(0),"^",17)
- End DoDot:3
- +14 ; refills
- +15 SET NODE="R"
- +16 SET LIST2="IBRXARR2"
- +17 DO RX^PSO52API(DFN,LIST2,IBRX,,NODE,,)
- +18 SET IBRF=0
- FOR
- SET IBRF=$ORDER(^TMP($JOB,LIST2,DFN,IBRX,"RF",IBRF))
- if IBRF'>0
- QUIT
- Begin DoDot:3
- +19 SET IBY=$$ZEROSUB^IBRXUTL(DFN,IBRX,IBRF)
- if IBY=""
- QUIT
- +20 SET ARRAY(IBRX,+IBY)=$PIECE(IBRX(0),"^")_"^"_IBRF_"^"_$PIECE(IBRX(0),"^",6)_"^"_$GET(^TMP($JOB,"IBDRUG",+$PIECE(IBRX(0),"^",6),.01))_"^"_$PIECE(IBY,"^",4)_"^"_$PIECE(IBY,"^",11)
- End DoDot:3
- +21 KILL ^TMP($JOB,LIST2)
- End DoDot:2
- End DoDot:1
- +22 KILL ^TMP($JOB,"IBDRUG"),^TMP($JOB,LIST)
- +23 QUIT
