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 Dec 13, 2024@02:08 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
