IBCSC5C ;ALB/ARH - ADD/EDIT PRESCRIPTION FILLS (CONTINUED) ;3/4/94
;;2.0;INTEGRATED BILLING;**27,52,130,51,160,260,309,315,339,347,363,381,405,432,461**;21-MAR-94;Build 58
;;Per VHA Directive 2004-038, this routine should not be modified.
;
;
DEFAULT(IFN,IBRX) ; add default DX and CPT to a prescription bill
; if one is not in PSO. If there is, use it instead.
; IFN = ien of bill entry
N IBX,IBPAR1,IBDX,IBCPT,IBDT,IBBIL,IBDXIFN,IBCPTIFN,IBY,IB52,IBC,PDFN,LIST,NODE
S IBDXIFN=0
S IBPAR1=$G(^IBE(350.9,1,1)),IBCPT=$P(IBPAR1,U,30)
S IBDX=$P(IBPAR1,U,29) I $$ICD9SYS^IBACSV($$BDATE^IBACSV(IFN))=30 S IBDX=$P($G(^IBE(350.9,1,7)),U,5)
S IBBIL=$G(^DGCR(399,+$G(IFN),0)) Q:IBBIL=""
S IBX=$S($G(IBRX):$P($G(^DGCR(399,IFN,"RC",+IBRX,0)),U,11),1:$O(^IBA(362.4,"C",IFN,0))) Q:'IBX
S IB52=+$P($G(^IBA(362.4,IBX,0)),"^",5),IBY=0 Q:IB52=0
S PDFN=$$FILE^IBRXUTL(IB52,2)
S LIST="IBCSC5CARR"
S NODE="ICD"
D RX^PSO52API(PDFN,LIST,IB52,,NODE,,)
I ^TMP($J,LIST,PDFN,IB52,"ICD",0)>0 D
.S IBY=0 F S IBY=$O(^TMP($J,LIST,PDFN,IB52,"ICD",IBY)) Q:IBY'>0 D
..S IBDX(IBY)=$$ICD^IBRXUTL1(PDFN,IB52,IBY,LIST)
..I 'IBDX(IBY) K IBDX(IBY)
K ^TMP($J,LIST)
I 'IBDX,'IBCPT,$D(IBDX)<10 Q
S IBDT=$P($G(^IBA(362.4,+IBX,0)),U,3) Q:'IBDT
; add dx associated with rx if they are there.
I $D(IBDX)>9 S (IBC,IBDX,IBY)=0 F S IBY=$O(IBDX(IBY)) Q:'IBY D
. I $D(^IBA(362.3,"AIFN"_IFN,+IBDX(IBY))) Q
. S IBC=IBC+1
. S DIC="^IBA(362.3,",DIC(0)="L",DIC("DR")=".02////"_IFN_";.03////"_IBC,X=+IBDX(IBY),DLAYGO=362.3
. K DD,DO D FILE^DICN K DIC,DA,DR,DD,DO,DLAYGO
. S IBDXIFN(IBC)=+Y
; add default dx if none found on actual rx.
I +IBDX,'$D(^IBA(362.3,"AIFN"_IFN,+IBDX)) S DIC="^IBA(362.3,",DIC(0)="L",DIC("DR")=".02////"_IFN,X=IBDX,DLAYGO=362.3 K DD,DO D FILE^DICN K DIC,DA,DR,DD,DO,DLAYGO S IBDXIFN=+Y
I +IBCPT D ;Check if the procedure is already present for the Rx
. N Z,Z0,DUP
. S (DUP,Z)=0 F S Z=$O(^DGCR(399,IFN,"RC",Z)) Q:'Z S Z0=$G(^(Z,0)) D Q:DUP
.. I $P(Z0,U,10)=3,$P(Z0,U,15),$P(Z0,U,11)=IBX S DUP=1
. Q:DUP
. I $P($G(^DGCR(399,IFN,0)),U,9)="" S DIE="^DGCR(399,",DA=IFN,DR=".09////5" D ^DIE K DIE,DIC,DA,DR
. I '$D(^DGCR(399,IFN,"CP",0)) S DIC("P")=$$GETSPEC^IBEFUNC(399,304)
. S DLAYGO=399,DIC("DR")="1////"_IBDT D
. . I +IBDXIFN>0 S DIC("DR")=DIC("DR")_";10////"_IBDXIFN Q
. . I $D(IBDXIFN)>9 F IBY=1:1:4 I $D(IBDXIFN(IBY)) S DIC("DR")=DIC("DR")_";"_(IBY+9)_"////"_IBDXIFN(IBY)
. S DIC="^DGCR(399,"_IFN_",""CP"",",DIC(0)="L",DA(1)=IFN,X=IBCPT_";ICPT(" K DD,DO D FILE^DICN K DIC,DA,DD,DO,DR,DLAYGO
. I +Y D
.. N Z,IBZ
.. S IBZ=+Y,Z=$S($G(IBREV):IBREV,1:$$FINDREV^IBCSC5A(IFN,3,+IBX))
.. I Z S DR=".15////"_IBZ_";.06////"_IBCPT,DA=+Z,DA(1)=IFN,DIE="^DGCR(399,"_DA(1)_",""RC""," D ^DIE
Q
;
RXDISP(DFN,DT1,DT2,ARRAY,POARR,RXARR,IBRXALL,NODISP) ; display all rx fills for a patient and date range
;RXARR (as defined by SET^IBCSC5A) passed by ref. only to check if rx-fill is on the bill, not necessary not changed
;returns: ARRAY(RX #, FILL DT) = RX IFN (52) ^ FILL IFN ^ DRUG ^ DAYS SUPPLY ^ QTY ^ NDC ^ ORDER DATE, pass by reference if desired
; POARR(CNT)=RX # ^ FILL DT
N PIFN,RIFN,IBX,IBY,DTE,DTR,RX,IBCNT,IBRX0,IBRX2,IBS,LIST,LIST2 K ARRAY,POARR S POARR=0,NODISP=+$G(NODISP)
S IBCNT=0,DT1=$G(DT1)-.0001,DT2=$G(DT2) S:'DT2 DT2=9999999 Q:'$G(DFN)
;^PS(55,DFN,"P","A",EXPIRATION DATE, RX) is the best xref available for finding patient fills in a date range
;if RX expires/cancelled before start of bill then should not be applicable to bill
S LIST="IBRXDISPARR"
D PROF^PSO52API(DFN,LIST,DT1)
S DTE=0 F S DTE=$O(^TMP($J,LIST,"B",DTE)) Q:'DTE D
. S PIFN=0 F S PIFN=$O(^TMP($J,LIST,"B",DTE,PIFN)) Q:'PIFN D
.. S IBRX0=$$RXZERO^IBRXUTL(DFN,PIFN),IBRX2=$$RXSEC^IBRXUTL(DFN,PIFN)
.. ; original fill
.. I +$G(IBRXALL) S DTR=$P(IBRX2,U,2) I DTR'<DT1,DTR'>DT2 D
... D DATA^IBRXUTL(+$P(IBRX0,U,6))
... ; add issue date to array so order date can be displayed
... ;S ARRAY($P(IBRX0,U,1),+DTR)=PIFN_U_0_U_$P(IBRX0,U,6)_U_$P(IBRX0,U,8)_U_$P(IBRX0,U,7)_U_$$GETNDC^PSONDCUT(PIFN,0)
... S ARRAY($P(IBRX0,U,1),+DTR)=PIFN_U_0_U_$P(IBRX0,U,6)_U_$P(IBRX0,U,8)_U_$P(IBRX0,U,7)_U_$$GETNDC^PSONDCUT(PIFN,0)_U_$P(IBRX0,U,13)
... K ^TMP($J,"IBDRUG")
... Q
.. ; refills
.. S LIST2="IBDISPSUB"
.. S NODE="R"
.. D RX^PSO52API(DFN,LIST2,PIFN,,NODE,,)
.. S RIFN=0 F S RIFN=$O(^TMP($J,LIST2,DFN,PIFN,"RF",RIFN)) Q:RIFN'>0 D
... S IBY=$$ZEROSUB^IBRXUTL(DFN,PIFN,RIFN) Q:IBY=""
... Q:+IBY<DT1!(+IBY>DT2)
... D DATA^IBRXUTL(+$P(IBRX0,U,6))
... ; add issue date to array so order date can be displayed
... ;S ARRAY($P(IBRX0,U,1),+IBY)=PIFN_U_RIFN_U_$P(IBRX0,U,6)_U_$P(IBRX0,U,8)_U_$P(IBY,U,4)_U_$$GETNDC^PSONDCUT(PIFN,RIFN)
... S ARRAY($P(IBRX0,U,1),+IBY)=PIFN_U_RIFN_U_$P(IBRX0,U,6)_U_$P(IBRX0,U,8)_U_$P(IBY,U,4)_U_$$GETNDC^PSONDCUT(PIFN,RIFN)_U_$P(IBRX0,U,13)
... K ^TMP($J,"IBDRUG")
... Q
.. K ^TMP($J,LIST2)
K ^TMP($J,LIST)
;
S IBX="",IBS=0 F S IBX=$O(ARRAY(IBX)) Q:IBX="" S IBY=0 F S IBY=$O(ARRAY(IBX,IBY)) Q:'IBY D
. S IBCNT=IBCNT+1,POARR(IBCNT)=$P(IBX,U,1)_"^"_+IBY,POARR=IBCNT I $D(RXARR(IBX,IBY)) S IBS=IBS+1
S $P(POARR,U,2)=IBCNT-IBS
;
Q:+NODISP
W @IOF,?33,"PRESCRIPTIONS IN DATE RANGE",!,"===============================================================================",!
S IBCNT=0 F S IBCNT=$O(POARR(IBCNT)) Q:IBCNT="" S RX=$P(POARR(IBCNT),U,1),DTR=$P(POARR(IBCNT),U,2) I RX'="",DTR'="" D
. S IBS=$$RXSTAT^IBCU1($P(ARRAY(RX,DTR),U,3),$P(ARRAY(RX,DTR),U,1),DTR)
. S IBY="" I $D(RXARR(RX,+DTR)) S IBY="*"
. D ZERO^IBRXUTL(+$P(ARRAY(RX,DTR),U,3))
. W !,$J(IBCNT,2),")",?5,IBY,?6,RX,?19,$E($G(^TMP($J,"IBDRUG",+$P(ARRAY(RX,DTR),U,3),.01)),1,25),?46,$$DATE(+DTR),?56,$P(IBS,U,1),?61,$P(IBS,U,2),?69,$P(IBS,U,3),?75,$$EXEMPT(+ARRAY(RX,DTR))
. S IBY=$$RXDUP^IBCU3(RX,DTR,IBIFN) I +IBY W ?73,$P($G(^DGCR(399,+IBY,0)),U,1)
. K ^TMP($J,"IBDRUG")
Q
DATE(X) Q $E(X,4,5)_"/"_$E(X,6,7)_"/"_$E(X,2,3)
;
NEWRX(IBX) ;
Q:'$G(IBX) N X,Y K IBLIST W !
NEWRX1 S DIR("?")="Enter the number preceding the RX Fills you want added to the bill. "_$$HTEXT
S DIR("A")="SELECT NEW RX FILLS TO ADD THE BILL"
S DIR(0)="LO^1:"_+IBX D ^DIR K DIR G:'Y!$D(DIRUT) NEWRXE
S IBLIST=Y
;
S DIR("A")="YOU HAVE SELECTED "_IBLIST_" TO BE ADDED TO THE BILL IS THIS CORRECT",DIR("B")="YES"
S DIR(0)="YO" D ^DIR K DIR I $D(DIRUT) K IBLIST G NEWRXE
I 'Y K IBLIST G NEWRX1
NEWRXE Q
;
ADDNEW(IBIFN,LIST,IBPR,IBPRO) ;
Q:'LIST N IBI,IBX,IBRX,IBDT,IBQ,IBY,IBPIFN,IBZ
F IBI=1:1 S IBX=$P(LIST,",",IBI) Q:'IBX I $D(IBPRO(IBX)) D
. S IBRX=$P(IBPRO(IBX),U,1),IBDT=$P(IBPRO(IBX),U,2) Q:IBRX=""
. S IBQ=0,IBY=$G(IBPR(IBRX,+IBDT)) Q:'IBY
. S IBPIFN=0 F S IBPIFN=$O(^IBA(362.4,"AIFN"_IBIFN,IBRX,IBPIFN)) Q:'IBPIFN I $P($G(^IBA(362.4,IBPIFN,0)),U,3)=IBDT S IBQ=1 Q
. ;I 'IBQ S IBZ=$G(IBPR(IBRX,IBDT)) I $$ADD^IBCSC5A(IBRX,IBIFN,IBDT,$P(IBZ,U,3),$P(IBZ,U,1),$P(IBZ,U,4,6),$P(IBZ,U,2)) W "."
. ; IB*2.0*432 - include issue date from file 52 to display to user when adding
. I 'IBQ S IBZ=$G(IBPR(IBRX,IBDT)) I $$ADD^IBCSC5A(IBRX,IBIFN,IBDT,$P(IBZ,U,3),$P(IBZ,U,1),$P(IBZ,U,4,7),$P(IBZ,U,2)) W "."
Q
;
HTEXT() ;
N X S X="If an Rx fill has been assigned to another bill it will be displayed in the last column. [ORG=Original Fill, NR=Not Released, RTS=Returned to Stock, OTC=Over-the-Counter, INV=Investigational, SUP=Supply Item]"
Q X
;
RXLINK(IBIFN,CPIEN) ; Function returns the ien of the Rx rev code the proc
; code is linked to or 0 if no link found.
Q +$O(^DGCR(399,IBIFN,"RC","ACP",+CPIEN,0))
;
EXEMPT(RX) ; Used to look up exemption if any on rx, the return value
; will be only the first exemption reason found.
N IBX,IBZ,IBS,IBR,PDFN,LIST,NODE,ICDCT
S PDFN=$$FILE^IBRXUTL(RX,2)
S LIST="IBRXARREX"
S NODE="ICD"
D RX^PSO52API(PDFN,LIST,RX,,NODE,,)
S ICDCT=$G(^TMP($J,LIST,PDFN,RX,"ICD",0))
S IBR="",(IBS,IBX)=0
I ICDCT>0 D
.S IBX=0 F S IBX=$O(^TMP($J,LIST,PDFN,RX,"ICD",IBX)) Q:IBX'>0!(IBS) D
..S IBZ=$$ICD^IBRXUTL1(PDFN,RX,IBX,LIST) F IBP=2:1:8 Q:IBS I $P(IBZ,"^",IBP) S IBR=$P($T(EREASON+(IBP-1)),";",3),IBS=1
K ^TMP($J,LIST)
Q IBR
EREASON ;
;;AO
;;IR
;;SC
;;SWA
;;MST
;;HNC
;;CV
;;SHAD
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCSC5C 8215 printed Oct 16, 2024@18:21:01 Page 2
IBCSC5C ;ALB/ARH - ADD/EDIT PRESCRIPTION FILLS (CONTINUED) ;3/4/94
+1 ;;2.0;INTEGRATED BILLING;**27,52,130,51,160,260,309,315,339,347,363,381,405,432,461**;21-MAR-94;Build 58
+2 ;;Per VHA Directive 2004-038, this routine should not be modified.
+3 ;
+4 ;
DEFAULT(IFN,IBRX) ; add default DX and CPT to a prescription bill
+1 ; if one is not in PSO. If there is, use it instead.
+2 ; IFN = ien of bill entry
+3 NEW IBX,IBPAR1,IBDX,IBCPT,IBDT,IBBIL,IBDXIFN,IBCPTIFN,IBY,IB52,IBC,PDFN,LIST,NODE
+4 SET IBDXIFN=0
+5 SET IBPAR1=$GET(^IBE(350.9,1,1))
SET IBCPT=$PIECE(IBPAR1,U,30)
+6 SET IBDX=$PIECE(IBPAR1,U,29)
IF $$ICD9SYS^IBACSV($$BDATE^IBACSV(IFN))=30
SET IBDX=$PIECE($GET(^IBE(350.9,1,7)),U,5)
+7 SET IBBIL=$GET(^DGCR(399,+$GET(IFN),0))
if IBBIL=""
QUIT
+8 SET IBX=$SELECT($GET(IBRX):$PIECE($GET(^DGCR(399,IFN,"RC",+IBRX,0)),U,11),1:$ORDER(^IBA(362.4,"C",IFN,0)))
if 'IBX
QUIT
+9 SET IB52=+$PIECE($GET(^IBA(362.4,IBX,0)),"^",5)
SET IBY=0
if IB52=0
QUIT
+10 SET PDFN=$$FILE^IBRXUTL(IB52,2)
+11 SET LIST="IBCSC5CARR"
+12 SET NODE="ICD"
+13 DO RX^PSO52API(PDFN,LIST,IB52,,NODE,,)
+14 IF ^TMP($JOB,LIST,PDFN,IB52,"ICD",0)>0
Begin DoDot:1
+15 SET IBY=0
FOR
SET IBY=$ORDER(^TMP($JOB,LIST,PDFN,IB52,"ICD",IBY))
if IBY'>0
QUIT
Begin DoDot:2
+16 SET IBDX(IBY)=$$ICD^IBRXUTL1(PDFN,IB52,IBY,LIST)
+17 IF 'IBDX(IBY)
KILL IBDX(IBY)
End DoDot:2
End DoDot:1
+18 KILL ^TMP($JOB,LIST)
+19 IF 'IBDX
IF 'IBCPT
IF $DATA(IBDX)<10
QUIT
+20 SET IBDT=$PIECE($GET(^IBA(362.4,+IBX,0)),U,3)
if 'IBDT
QUIT
+21 ; add dx associated with rx if they are there.
+22 IF $DATA(IBDX)>9
SET (IBC,IBDX,IBY)=0
FOR
SET IBY=$ORDER(IBDX(IBY))
if 'IBY
QUIT
Begin DoDot:1
+23 IF $DATA(^IBA(362.3,"AIFN"_IFN,+IBDX(IBY)))
QUIT
+24 SET IBC=IBC+1
+25 SET DIC="^IBA(362.3,"
SET DIC(0)="L"
SET DIC("DR")=".02////"_IFN_";.03////"_IBC
SET X=+IBDX(IBY)
SET DLAYGO=362.3
+26 KILL DD,DO
DO FILE^DICN
KILL DIC,DA,DR,DD,DO,DLAYGO
+27 SET IBDXIFN(IBC)=+Y
End DoDot:1
+28 ; add default dx if none found on actual rx.
+29 IF +IBDX
IF '$DATA(^IBA(362.3,"AIFN"_IFN,+IBDX))
SET DIC="^IBA(362.3,"
SET DIC(0)="L"
SET DIC("DR")=".02////"_IFN
SET X=IBDX
SET DLAYGO=362.3
KILL DD,DO
DO FILE^DICN
KILL DIC,DA,DR,DD,DO,DLAYGO
SET IBDXIFN=+Y
+30 ;Check if the procedure is already present for the Rx
IF +IBCPT
Begin DoDot:1
+31 NEW Z,Z0,DUP
+32 SET (DUP,Z)=0
FOR
SET Z=$ORDER(^DGCR(399,IFN,"RC",Z))
if 'Z
QUIT
SET Z0=$GET(^(Z,0))
Begin DoDot:2
+33 IF $PIECE(Z0,U,10)=3
IF $PIECE(Z0,U,15)
IF $PIECE(Z0,U,11)=IBX
SET DUP=1
End DoDot:2
if DUP
QUIT
+34 if DUP
QUIT
+35 IF $PIECE($GET(^DGCR(399,IFN,0)),U,9)=""
SET DIE="^DGCR(399,"
SET DA=IFN
SET DR=".09////5"
DO ^DIE
KILL DIE,DIC,DA,DR
+36 IF '$DATA(^DGCR(399,IFN,"CP",0))
SET DIC("P")=$$GETSPEC^IBEFUNC(399,304)
+37 SET DLAYGO=399
SET DIC("DR")="1////"_IBDT
Begin DoDot:2
+38 IF +IBDXIFN>0
SET DIC("DR")=DIC("DR")_";10////"_IBDXIFN
QUIT
+39 IF $DATA(IBDXIFN)>9
FOR IBY=1:1:4
IF $DATA(IBDXIFN(IBY))
SET DIC("DR")=DIC("DR")_";"_(IBY+9)_"////"_IBDXIFN(IBY)
End DoDot:2
+40 SET DIC="^DGCR(399,"_IFN_",""CP"","
SET DIC(0)="L"
SET DA(1)=IFN
SET X=IBCPT_";ICPT("
KILL DD,DO
DO FILE^DICN
KILL DIC,DA,DD,DO,DR,DLAYGO
+41 IF +Y
Begin DoDot:2
+42 NEW Z,IBZ
+43 SET IBZ=+Y
SET Z=$SELECT($GET(IBREV):IBREV,1:$$FINDREV^IBCSC5A(IFN,3,+IBX))
+44 IF Z
SET DR=".15////"_IBZ_";.06////"_IBCPT
SET DA=+Z
SET DA(1)=IFN
SET DIE="^DGCR(399,"_DA(1)_",""RC"","
DO ^DIE
End DoDot:2
End DoDot:1
+45 QUIT
+46 ;
RXDISP(DFN,DT1,DT2,ARRAY,POARR,RXARR,IBRXALL,NODISP) ; display all rx fills for a patient and date range
+1 ;RXARR (as defined by SET^IBCSC5A) passed by ref. only to check if rx-fill is on the bill, not necessary not changed
+2 ;returns: ARRAY(RX #, FILL DT) = RX IFN (52) ^ FILL IFN ^ DRUG ^ DAYS SUPPLY ^ QTY ^ NDC ^ ORDER DATE, pass by reference if desired
+3 ; POARR(CNT)=RX # ^ FILL DT
+4 NEW PIFN,RIFN,IBX,IBY,DTE,DTR,RX,IBCNT,IBRX0,IBRX2,IBS,LIST,LIST2
KILL ARRAY,POARR
SET POARR=0
SET NODISP=+$GET(NODISP)
+5 SET IBCNT=0
SET DT1=$GET(DT1)-.0001
SET DT2=$GET(DT2)
if 'DT2
SET DT2=9999999
if '$GET(DFN)
QUIT
+6 ;^PS(55,DFN,"P","A",EXPIRATION DATE, RX) is the best xref available for finding patient fills in a date range
+7 ;if RX expires/cancelled before start of bill then should not be applicable to bill
+8 SET LIST="IBRXDISPARR"
+9 DO PROF^PSO52API(DFN,LIST,DT1)
+10 SET DTE=0
FOR
SET DTE=$ORDER(^TMP($JOB,LIST,"B",DTE))
if 'DTE
QUIT
Begin DoDot:1
+11 SET PIFN=0
FOR
SET PIFN=$ORDER(^TMP($JOB,LIST,"B",DTE,PIFN))
if 'PIFN
QUIT
Begin DoDot:2
+12 SET IBRX0=$$RXZERO^IBRXUTL(DFN,PIFN)
SET IBRX2=$$RXSEC^IBRXUTL(DFN,PIFN)
+13 ; original fill
+14 IF +$GET(IBRXALL)
SET DTR=$PIECE(IBRX2,U,2)
IF DTR'<DT1
IF DTR'>DT2
Begin DoDot:3
+15 DO DATA^IBRXUTL(+$PIECE(IBRX0,U,6))
+16 ; add issue date to array so order date can be displayed
+17 ;S ARRAY($P(IBRX0,U,1),+DTR)=PIFN_U_0_U_$P(IBRX0,U,6)_U_$P(IBRX0,U,8)_U_$P(IBRX0,U,7)_U_$$GETNDC^PSONDCUT(PIFN,0)
+18 SET ARRAY($PIECE(IBRX0,U,1),+DTR)=PIFN_U_0_U_$PIECE(IBRX0,U,6)_U_$PIECE(IBRX0,U,8)_U_$PIECE(IBRX0,U,7)_U_$$GETNDC^PSONDCUT(PIFN,0)_U_$PIECE(IBRX0,U,13)
+19 KILL ^TMP($JOB,"IBDRUG")
+20 QUIT
End DoDot:3
+21 ; refills
+22 SET LIST2="IBDISPSUB"
+23 SET NODE="R"
+24 DO RX^PSO52API(DFN,LIST2,PIFN,,NODE,,)
+25 SET RIFN=0
FOR
SET RIFN=$ORDER(^TMP($JOB,LIST2,DFN,PIFN,"RF",RIFN))
if RIFN'>0
QUIT
Begin DoDot:3
+26 SET IBY=$$ZEROSUB^IBRXUTL(DFN,PIFN,RIFN)
if IBY=""
QUIT
+27 if +IBY<DT1!(+IBY>DT2)
QUIT
+28 DO DATA^IBRXUTL(+$PIECE(IBRX0,U,6))
+29 ; add issue date to array so order date can be displayed
+30 ;S ARRAY($P(IBRX0,U,1),+IBY)=PIFN_U_RIFN_U_$P(IBRX0,U,6)_U_$P(IBRX0,U,8)_U_$P(IBY,U,4)_U_$$GETNDC^PSONDCUT(PIFN,RIFN)
+31 SET ARRAY($PIECE(IBRX0,U,1),+IBY)=PIFN_U_RIFN_U_$PIECE(IBRX0,U,6)_U_$PIECE(IBRX0,U,8)_U_$PIECE(IBY,U,4)_U_$$GETNDC^PSONDCUT(PIFN,RIFN)_U_$PIECE(IBRX0,U,13)
+32 KILL ^TMP($JOB,"IBDRUG")
+33 QUIT
End DoDot:3
+34 KILL ^TMP($JOB,LIST2)
End DoDot:2
End DoDot:1
+35 KILL ^TMP($JOB,LIST)
+36 ;
+37 SET IBX=""
SET IBS=0
FOR
SET IBX=$ORDER(ARRAY(IBX))
if IBX=""
QUIT
SET IBY=0
FOR
SET IBY=$ORDER(ARRAY(IBX,IBY))
if 'IBY
QUIT
Begin DoDot:1
+38 SET IBCNT=IBCNT+1
SET POARR(IBCNT)=$PIECE(IBX,U,1)_"^"_+IBY
SET POARR=IBCNT
IF $DATA(RXARR(IBX,IBY))
SET IBS=IBS+1
End DoDot:1
+39 SET $PIECE(POARR,U,2)=IBCNT-IBS
+40 ;
+41 if +NODISP
QUIT
+42 WRITE @IOF,?33,"PRESCRIPTIONS IN DATE RANGE",!,"===============================================================================",!
+43 SET IBCNT=0
FOR
SET IBCNT=$ORDER(POARR(IBCNT))
if IBCNT=""
QUIT
SET RX=$PIECE(POARR(IBCNT),U,1)
SET DTR=$PIECE(POARR(IBCNT),U,2)
IF RX'=""
IF DTR'=""
Begin DoDot:1
+44 SET IBS=$$RXSTAT^IBCU1($PIECE(ARRAY(RX,DTR),U,3),$PIECE(ARRAY(RX,DTR),U,1),DTR)
+45 SET IBY=""
IF $DATA(RXARR(RX,+DTR))
SET IBY="*"
+46 DO ZERO^IBRXUTL(+$PIECE(ARRAY(RX,DTR),U,3))
+47 WRITE !,$JUSTIFY(IBCNT,2),")",?5,IBY,?6,RX,?19,$EXTRACT($GET(^TMP($JOB,"IBDRUG",+$PIECE(ARRAY(RX,DTR),U,3),.01)),1,25),?46,$$DATE(+DTR),?56,$PIECE(IBS,U,1),?61,$PIECE(IBS,U,2),?69,$PIECE(IBS,U,3),?75,$$EXEMPT(+ARRAY(RX,DTR))
+48 SET IBY=$$RXDUP^IBCU3(RX,DTR,IBIFN)
IF +IBY
WRITE ?73,$PIECE($GET(^DGCR(399,+IBY,0)),U,1)
+49 KILL ^TMP($JOB,"IBDRUG")
End DoDot:1
+50 QUIT
DATE(X) QUIT $EXTRACT(X,4,5)_"/"_$EXTRACT(X,6,7)_"/"_$EXTRACT(X,2,3)
+1 ;
NEWRX(IBX) ;
+1 if '$GET(IBX)
QUIT
NEW X,Y
KILL IBLIST
WRITE !
NEWRX1 SET DIR("?")="Enter the number preceding the RX Fills you want added to the bill. "_$$HTEXT
+1 SET DIR("A")="SELECT NEW RX FILLS TO ADD THE BILL"
+2 SET DIR(0)="LO^1:"_+IBX
DO ^DIR
KILL DIR
if 'Y!$DATA(DIRUT)
GOTO NEWRXE
+3 SET IBLIST=Y
+4 ;
+5 SET DIR("A")="YOU HAVE SELECTED "_IBLIST_" TO BE ADDED TO THE BILL IS THIS CORRECT"
SET DIR("B")="YES"
+6 SET DIR(0)="YO"
DO ^DIR
KILL DIR
IF $DATA(DIRUT)
KILL IBLIST
GOTO NEWRXE
+7 IF 'Y
KILL IBLIST
GOTO NEWRX1
NEWRXE QUIT
+1 ;
ADDNEW(IBIFN,LIST,IBPR,IBPRO) ;
+1 if 'LIST
QUIT
NEW IBI,IBX,IBRX,IBDT,IBQ,IBY,IBPIFN,IBZ
+2 FOR IBI=1:1
SET IBX=$PIECE(LIST,",",IBI)
if 'IBX
QUIT
IF $DATA(IBPRO(IBX))
Begin DoDot:1
+3 SET IBRX=$PIECE(IBPRO(IBX),U,1)
SET IBDT=$PIECE(IBPRO(IBX),U,2)
if IBRX=""
QUIT
+4 SET IBQ=0
SET IBY=$GET(IBPR(IBRX,+IBDT))
if 'IBY
QUIT
+5 SET IBPIFN=0
FOR
SET IBPIFN=$ORDER(^IBA(362.4,"AIFN"_IBIFN,IBRX,IBPIFN))
if 'IBPIFN
QUIT
IF $PIECE($GET(^IBA(362.4,IBPIFN,0)),U,3)=IBDT
SET IBQ=1
QUIT
+6 ;I 'IBQ S IBZ=$G(IBPR(IBRX,IBDT)) I $$ADD^IBCSC5A(IBRX,IBIFN,IBDT,$P(IBZ,U,3),$P(IBZ,U,1),$P(IBZ,U,4,6),$P(IBZ,U,2)) W "."
+7 ; IB*2.0*432 - include issue date from file 52 to display to user when adding
+8 IF 'IBQ
SET IBZ=$GET(IBPR(IBRX,IBDT))
IF $$ADD^IBCSC5A(IBRX,IBIFN,IBDT,$PIECE(IBZ,U,3),$PIECE(IBZ,U,1),$PIECE(IBZ,U,4,7),$PIECE(IBZ,U,2))
WRITE "."
End DoDot:1
+9 QUIT
+10 ;
HTEXT() ;
+1 NEW X
SET X="If an Rx fill has been assigned to another bill it will be displayed in the last column. [ORG=Original Fill, NR=Not Released, RTS=Returned to Stock, OTC=Over-the-Counter, INV=Investigational, SUP=Supply Item]"
+2 QUIT X
+3 ;
RXLINK(IBIFN,CPIEN) ; Function returns the ien of the Rx rev code the proc
+1 ; code is linked to or 0 if no link found.
+2 QUIT +$ORDER(^DGCR(399,IBIFN,"RC","ACP",+CPIEN,0))
+3 ;
EXEMPT(RX) ; Used to look up exemption if any on rx, the return value
+1 ; will be only the first exemption reason found.
+2 NEW IBX,IBZ,IBS,IBR,PDFN,LIST,NODE,ICDCT
+3 SET PDFN=$$FILE^IBRXUTL(RX,2)
+4 SET LIST="IBRXARREX"
+5 SET NODE="ICD"
+6 DO RX^PSO52API(PDFN,LIST,RX,,NODE,,)
+7 SET ICDCT=$GET(^TMP($JOB,LIST,PDFN,RX,"ICD",0))
+8 SET IBR=""
SET (IBS,IBX)=0
+9 IF ICDCT>0
Begin DoDot:1
+10 SET IBX=0
FOR
SET IBX=$ORDER(^TMP($JOB,LIST,PDFN,RX,"ICD",IBX))
if IBX'>0!(IBS)
QUIT
Begin DoDot:2
+11 SET IBZ=$$ICD^IBRXUTL1(PDFN,RX,IBX,LIST)
FOR IBP=2:1:8
if IBS
QUIT
IF $PIECE(IBZ,"^",IBP)
SET IBR=$PIECE($TEXT(EREASON+(IBP-1)),";",3)
SET IBS=1
End DoDot:2
End DoDot:1
+12 KILL ^TMP($JOB,LIST)
+13 QUIT IBR
EREASON ;
+1 ;;AO
+2 ;;IR
+3 ;;SC
+4 ;;SWA
+5 ;;MST
+6 ;;HNC
+7 ;;CV
+8 ;;SHAD
+9 ;
