IBARX1 ;ALB/AAS - INTEGRATED BILLING, PHARMACY COPAY INTERFACE (CONT.) ; 21-FEB-91
;;2.0;INTEGRATED BILLING;**34,101,150,158,156,234,247,563,614,651,653**;21-MAR-94;Build 19
;;Per VA Directive 6402, this routine should not be modified.
;
; - process 1 rx entry and accumulate totals
; ICR 2056 - $$GET1^DIQ
; ICR 4820 RX^PSO52API
;
RX N IBAM,IBNOCH,IBTIER
;if Combat Vet send alert e-mail to mailgroup "IB COMBAT VET RX COPAY"
D
. N Y D NOW^%DTC S Y=%\1
. D RXALRT^IBACV(DFN,Y,+$P($P($G(IBSAVX(1)),"^",1),":",2))
;
I $P(IBX,"^")'?1.N1":"1.N.ANP S Y="-1^IB012" G RXQ
I $P(IBX,"^",2)<1 S Y="-1^IB013" G RXQ
;
D BDESC
;
; make sure effective date defined
S IBEFDT=$G(IBEFDT,DT)
; determine rx copay copay tier
S IBTIER=$$RXTIER^IBAUTL(DFN,+$P($P(IBX,"^"),":",2),IBEFDT)
; determine rx cost
S DA=IBATYP D COST^IBAUTL I $P($G(Y),"^")=-1 G RXQ
;
; IB*2.0*614 Prorate rx's with less than 30 day supply if National HRfS flag is active
; Check for an original fill or a refill.
N IBISDT,IBRXN,IBRFN,IBLIST,IBDATA,IBLSRF S IBRXN=+$P($P(IBX,"^"),":",2) ;IBRXN = IEN of the Drug file
S IBLIST="IBARX1" K ^TMP($J,IBLIST)
D RX^PSO52API(DFN,IBLIST,IBRXN,,"2,R,I") S IBDATA=$NA(^TMP($J,IBLIST,DFN,IBRXN))
S IBISDT=+@IBDATA@(1) ;Get original released date (field 31)
;
S IBLSRF=$O(@IBDATA@("RF","A"),-1) ;get last refill
I IBLSRF D ;If this is a refill use the refill date to prorate amount billed
. I $G(@IBDATA@("RF",IBLSRF,17))="" Q ;Check released date/time quit if not released
. S IBISDT=+@IBDATA@("RF",IBLSRF,17) ;Reset fill date to date of refill
;
; X1 - standard calculated amount for this tier #
; IB*2.0*653 calculate flat rate Rx's copay amount if National HRfS flag is active
; if rate is above 0, and the Pt has an active HRfS flag at the date of fill/refill, and # of days is greater than 0, then set rate to $2
I X1,$$CHKHRFS^IBAMTS3(DFN,IBISDT) S:@IBDATA@(8)>0 X1=2
K ^TMP($J,"IBARX1")
;
; compute amount above cap
D NEW^IBARXMC($P(IBX,"^",2),X1,DT,.IBCHRG,.IBNOCH)
;
S IBTCH=$P(IBX,"^",2)*X1
;
; add to 354.71
S IBAM=$$ADD^IBARXMN(DFN,"^^"_IBEFDT_"^^P^"_$P(IBX,"^")_"^"_$P(IBX,"^",2)_"^"_IBTCH_"^"_IBDESC_"^"_$S($G(IBAMP):IBAMP,1:"")_"^"_IBCHRG_"^"_IBNOCH_"^"_(+$P($$SITE^IBARXMU,"^",3))_"^^^^^^^"_$G(IBTIER),IBATYP) I IBAM<1 S Y="-1^IB316" G RXQ
;
; setup new pieces (4, 5, 6, and 7), quit if above cap
S $P(IBSAVY(IBJ),"^",4,7)=$S(IBNOCH:1,1:0)_"^"_$S(IBNOCH&(IBCHRG):"P",IBCHRG:"F",1:"")_"^"_(+$G(IBEXMP))_"^"_IBAM G:'IBCHRG RXQ
;
S IBTOTL=IBTOTL+IBCHRG
S IBWHER=2
D ADD^IBAUTL
I +Y<1 G RXQ
S IBPARNT=$S($D(IBPARNT):IBPARNT,1:IBN)
;IB*2.0*651 - Add now as event date
S $P(^IB(IBN,1),"^")=IBDUZ
S $P(^IB(IBN,0),"^",2,17)=DFN_"^"_IBATYP_"^"_$P(IBX,"^")_"^2^"_$P(IBX,"^",2)_"^"_IBCHRG_"^"_IBDESC_"^"_IBPARNT_"^^"_IBIL_"^"_IBTRAN_"^"_IBFAC_"^"_IBEFDT_"^"_IBEFDT_"^^"_$$NOW^XLFDT(),$P(^(0),"^",19,22)=IBAM_"^^^"_$G(IBTIER)
K IBPARNT,^IB("AC",1,IBN) ;S ^IB("AC",2,IBN)=""
D INDEX
S $P(IBSAVY(IBJ),"^",1,3)=IBN_"^"_IBCHRG_"^"_IBIL
S:'$D(IBNOS) IBNOS="" S IBNOS=IBN_"^"_IBNOS
RXQ Q
;
CANRX ; - ibx = ibn for parent entry
; - ibn = new cancellation entry
N IBAM,IBAMY,IBEFDT,IBTIER
S IBY(IBJ)=1
I '$D(^IBE(350.3,+$P(IBX,"^",2),0)) S (Y,IBY(IBJ))="-1^IB020" G CANRXQ
I '$D(^IB(+IBX,0)) S (Y,IBY(IBJ))="-1^IB021" G CANRXQ
S IBND=^IB(+IBX,0)
S IBCRES=$P(IBX,"^",2)
; -find most recent entry for parent ibx
; -if status isn't an update or new, error already cancelled?
D LAST I IBLAST'=IBPARNT,$D(^IB(IBLAST,0)),$P(^IBE(350.1,$P(^IB(IBLAST,0),"^",3),0),"^",5)=2 S (Y,IBY(IBJ))="-1^IB026^ Ref. No: "_+^IB(+IBLAST,0) G CANRXQ ;already cancelled
;
; cancel 354.71
S IBAM=$$CANCEL^IBARXMN(DFN,$P(IBND,"^",19),.IBAMY,IBCRES) I $G(IBAMY)<0 S (Y,IBY(IBJ))=IBAMY G CANRXQ
;
I $P(IBND,"^",5)=8 D QUIT ;Cancel a charge with a status of HOLD
. N DIE,DA,DR
. S DIE="^IB(",DA=+IBX,DR=".05////10;.1////"_IBCRES
. DO ^DIE
. S Y=1,IBY(IBJ)=1,Y(IBJ)=+IBX
;
S IBPARNT=$P(IBND,"^",9) I '$D(^IB(IBPARNT,0)) S (Y,IBY(IBJ))="-1^IB027" G CANRXQ
S IBATYP=$P(^IBE(350.1,$P(IBND,"^",3),0),"^",6) ;cancellation action type for parent
I '$D(^IBE(350.1,+IBATYP,0)) S (Y,IBY(IBJ))="-1^IB022" G CANRXQ
S IBSEQNO=$P(^IBE(350.1,+IBATYP,0),"^",5) I 'IBSEQNO S (Y,IBY(IBJ))="-1^IB023" G CANRXQ
S IBIL=$P(IBND,"^",11) I IBIL="" S (Y,IBY(IBJ))="-1^IB024" G CANRXQ
S IBUNIT=$S($D(^IB(+IBLAST,0)):$P(^(0),"^",6),1:$P(IBND,"^",6)) I IBUNIT<1 S (Y,IBY(IBJ))="-1^IB025" G CANRXQ
S IBCHRG=$S($D(^IB(+IBLAST,0)):$P(^(0),"^",7),1:$P(IBND,"^",7)) I IBCHRG<1 S (Y,IBY(IBJ))="-1^IB025" G CANRXQ
S IBEFDT=$S($P(IBND,"^",14):$P(IBND,"^",14),1:$P($G(^IB(+IBX,1)),"^",2))
S IBTIER=$P(IBND,"^",22)
S IBTOTL=IBTOTL+IBCHRG
S IBWHER=2
D ADD^IBAUTL I +Y<1 S IBY(IBJ)=Y G CANRXQ
S $P(^IB(IBN,1),"^",1)=IBDUZ
S $P(^IB(IBN,0),"^",2,15)=DFN_"^"_IBATYP_"^"_$P(IBND,"^",4)_"^2^"_IBUNIT_"^"_IBCHRG_"^"_$P(IBND,"^",8)_"^"_IBPARNT_"^"_IBCRES_"^"_IBIL_"^^"_IBFAC_"^"_IBEFDT_"^"_IBEFDT S:IBAM $P(^(0),"^",19)=IBAM S:IBTIER $P(^(0),"^",22)=IBTIER
K ^IB("AC",1,IBN) ;S ^IB("AC",2,IBN)=""
D INDEX
S Y(IBJ)=IBN_"^"_IBCHRG_"^"_IBIL
S IBNOS=IBN
CANRXQ Q
;
BDESC ; -return brief description
N X,Y S IBDESC="",X=$P(IBX,"^")
I $D(^IBE(350.1,IBATYP,20)) X ^(20) S IBDESC=X
Q
LAST ;find last entry
S IBLAST=""
S IBPARNT=$P(^IB(+IBX,0),"^",9) I 'IBPARNT S IBPARNT=+IBX
S IBLDT=$O(^IB("APDT",IBPARNT,"")) I +IBLDT F IBL=0:0 S IBL=$O(^IB("APDT",IBPARNT,IBLDT,IBL)) Q:'IBL S IBLAST=IBL
I IBLAST="" S IBLAST=IBPARNT
Q
;
INDEX ;cross-reference entry
N X,Y
S DA=IBN,DIK="^IB(" D IX^DIK
K DIK Q
;
SERV(Y) ; -- Service check for Pharmacy
; called by the screen in the input transform for the IB SERVICE/SECTION
; field of the PHARMACY SITE file.
; input = Y internal entry number in service section file
; output = 1 if okay to use (service matches) or 0 if not okay
;
; -- screen logic for field 1003 in file 59 should be
; S DIC("S")="I $$SERV^IBARX1(+Y)"
;
Q $S('$G(Y):0,1:$D(^IBE(350.1,"ANEW",Y,1,1))&$D(^IBE(350.1,"ANEW",Y,1,2)))
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBARX1 6146 printed Dec 13, 2024@02:06:55 Page 2
IBARX1 ;ALB/AAS - INTEGRATED BILLING, PHARMACY COPAY INTERFACE (CONT.) ; 21-FEB-91
+1 ;;2.0;INTEGRATED BILLING;**34,101,150,158,156,234,247,563,614,651,653**;21-MAR-94;Build 19
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;
+4 ; - process 1 rx entry and accumulate totals
+5 ; ICR 2056 - $$GET1^DIQ
+6 ; ICR 4820 RX^PSO52API
+7 ;
RX NEW IBAM,IBNOCH,IBTIER
+1 ;if Combat Vet send alert e-mail to mailgroup "IB COMBAT VET RX COPAY"
+2 Begin DoDot:1
+3 NEW Y
DO NOW^%DTC
SET Y=%\1
+4 DO RXALRT^IBACV(DFN,Y,+$PIECE($PIECE($GET(IBSAVX(1)),"^",1),":",2))
End DoDot:1
+5 ;
+6 IF $PIECE(IBX,"^")'?1.N1":"1.N.ANP
SET Y="-1^IB012"
GOTO RXQ
+7 IF $PIECE(IBX,"^",2)<1
SET Y="-1^IB013"
GOTO RXQ
+8 ;
+9 DO BDESC
+10 ;
+11 ; make sure effective date defined
+12 SET IBEFDT=$GET(IBEFDT,DT)
+13 ; determine rx copay copay tier
+14 SET IBTIER=$$RXTIER^IBAUTL(DFN,+$PIECE($PIECE(IBX,"^"),":",2),IBEFDT)
+15 ; determine rx cost
+16 SET DA=IBATYP
DO COST^IBAUTL
IF $PIECE($GET(Y),"^")=-1
GOTO RXQ
+17 ;
+18 ; IB*2.0*614 Prorate rx's with less than 30 day supply if National HRfS flag is active
+19 ; Check for an original fill or a refill.
+20 ;IBRXN = IEN of the Drug file
NEW IBISDT,IBRXN,IBRFN,IBLIST,IBDATA,IBLSRF
SET IBRXN=+$PIECE($PIECE(IBX,"^"),":",2)
+21 SET IBLIST="IBARX1"
KILL ^TMP($JOB,IBLIST)
+22 DO RX^PSO52API(DFN,IBLIST,IBRXN,,"2,R,I")
SET IBDATA=$NAME(^TMP($JOB,IBLIST,DFN,IBRXN))
+23 ;Get original released date (field 31)
SET IBISDT=+@IBDATA@(1)
+24 ;
+25 ;get last refill
SET IBLSRF=$ORDER(@IBDATA@("RF","A"),-1)
+26 ;If this is a refill use the refill date to prorate amount billed
IF IBLSRF
Begin DoDot:1
+27 ;Check released date/time quit if not released
IF $GET(@IBDATA@("RF",IBLSRF,17))=""
QUIT
+28 ;Reset fill date to date of refill
SET IBISDT=+@IBDATA@("RF",IBLSRF,17)
End DoDot:1
+29 ;
+30 ; X1 - standard calculated amount for this tier #
+31 ; IB*2.0*653 calculate flat rate Rx's copay amount if National HRfS flag is active
+32 ; if rate is above 0, and the Pt has an active HRfS flag at the date of fill/refill, and # of days is greater than 0, then set rate to $2
+33 IF X1
IF $$CHKHRFS^IBAMTS3(DFN,IBISDT)
if @IBDATA@(8)>0
SET X1=2
+34 KILL ^TMP($JOB,"IBARX1")
+35 ;
+36 ; compute amount above cap
+37 DO NEW^IBARXMC($PIECE(IBX,"^",2),X1,DT,.IBCHRG,.IBNOCH)
+38 ;
+39 SET IBTCH=$PIECE(IBX,"^",2)*X1
+40 ;
+41 ; add to 354.71
+42 SET IBAM=$$ADD^IBARXMN(DFN,"^^"_IBEFDT_"^^P^"_$PIECE(IBX,"^")_"^"_$PIECE(IBX,"^",2)_"^"_IBTCH_"^"_IBDESC_"^"_$SELECT($GET(IBAMP):IBAMP,1:"")_"^"_IBCHRG_"^"_IBNOCH_"^"_(+$PIECE($$SITE^IBARXMU,"^",3))_"^^^^^^^"_$GET(IBTIER),IBATYP)
IF IBAM<1
SET Y="-1^IB316"
GOTO RXQ
+43 ;
+44 ; setup new pieces (4, 5, 6, and 7), quit if above cap
+45 SET $PIECE(IBSAVY(IBJ),"^",4,7)=$SELECT(IBNOCH:1,1:0)_"^"_$SELECT(IBNOCH&(IBCHRG):"P",IBCHRG:"F",1:"")_"^"_(+$GET(IBEXMP))_"^"_IBAM
if 'IBCHRG
GOTO RXQ
+46 ;
+47 SET IBTOTL=IBTOTL+IBCHRG
+48 SET IBWHER=2
+49 DO ADD^IBAUTL
+50 IF +Y<1
GOTO RXQ
+51 SET IBPARNT=$SELECT($DATA(IBPARNT):IBPARNT,1:IBN)
+52 ;IB*2.0*651 - Add now as event date
+53 SET $PIECE(^IB(IBN,1),"^")=IBDUZ
+54 SET $PIECE(^IB(IBN,0),"^",2,17)=DFN_"^"_IBATYP_"^"_$PIECE(IBX,"^")_"^2^"_$PIECE(IBX,"^",2)_"^"_IBCHRG_"^"_IBDESC_"^"_IBPARNT_"^^"_IBIL_"^"_IBTRAN_"^"_IBFAC_"^"_IBEFDT_"^"_IBEFDT_"^^"_$$NOW^XLFDT()
SET $PIECE(^(0),"^",19,22)=IBAM_"^^^"_$GET(IBTIER)
+55 ;S ^IB("AC",2,IBN)=""
KILL IBPARNT,^IB("AC",1,IBN)
+56 DO INDEX
+57 SET $PIECE(IBSAVY(IBJ),"^",1,3)=IBN_"^"_IBCHRG_"^"_IBIL
+58 if '$DATA(IBNOS)
SET IBNOS=""
SET IBNOS=IBN_"^"_IBNOS
RXQ QUIT
+1 ;
CANRX ; - ibx = ibn for parent entry
+1 ; - ibn = new cancellation entry
+2 NEW IBAM,IBAMY,IBEFDT,IBTIER
+3 SET IBY(IBJ)=1
+4 IF '$DATA(^IBE(350.3,+$PIECE(IBX,"^",2),0))
SET (Y,IBY(IBJ))="-1^IB020"
GOTO CANRXQ
+5 IF '$DATA(^IB(+IBX,0))
SET (Y,IBY(IBJ))="-1^IB021"
GOTO CANRXQ
+6 SET IBND=^IB(+IBX,0)
+7 SET IBCRES=$PIECE(IBX,"^",2)
+8 ; -find most recent entry for parent ibx
+9 ; -if status isn't an update or new, error already cancelled?
+10 ;already cancelled
DO LAST
IF IBLAST'=IBPARNT
IF $DATA(^IB(IBLAST,0))
IF $PIECE(^IBE(350.1,$PIECE(^IB(IBLAST,0),"^",3),0),"^",5)=2
SET (Y,IBY(IBJ))="-1^IB026^ Ref. No: "_+^IB(+IBLAST,0)
GOTO CANRXQ
+11 ;
+12 ; cancel 354.71
+13 SET IBAM=$$CANCEL^IBARXMN(DFN,$PIECE(IBND,"^",19),.IBAMY,IBCRES)
IF $GET(IBAMY)<0
SET (Y,IBY(IBJ))=IBAMY
GOTO CANRXQ
+14 ;
+15 ;Cancel a charge with a status of HOLD
IF $PIECE(IBND,"^",5)=8
Begin DoDot:1
+16 NEW DIE,DA,DR
+17 SET DIE="^IB("
SET DA=+IBX
SET DR=".05////10;.1////"_IBCRES
+18 DO ^DIE
+19 SET Y=1
SET IBY(IBJ)=1
SET Y(IBJ)=+IBX
End DoDot:1
QUIT
+20 ;
+21 SET IBPARNT=$PIECE(IBND,"^",9)
IF '$DATA(^IB(IBPARNT,0))
SET (Y,IBY(IBJ))="-1^IB027"
GOTO CANRXQ
+22 ;cancellation action type for parent
SET IBATYP=$PIECE(^IBE(350.1,$PIECE(IBND,"^",3),0),"^",6)
+23 IF '$DATA(^IBE(350.1,+IBATYP,0))
SET (Y,IBY(IBJ))="-1^IB022"
GOTO CANRXQ
+24 SET IBSEQNO=$PIECE(^IBE(350.1,+IBATYP,0),"^",5)
IF 'IBSEQNO
SET (Y,IBY(IBJ))="-1^IB023"
GOTO CANRXQ
+25 SET IBIL=$PIECE(IBND,"^",11)
IF IBIL=""
SET (Y,IBY(IBJ))="-1^IB024"
GOTO CANRXQ
+26 SET IBUNIT=$SELECT($DATA(^IB(+IBLAST,0)):$PIECE(^(0),"^",6),1:$PIECE(IBND,"^",6))
IF IBUNIT<1
SET (Y,IBY(IBJ))="-1^IB025"
GOTO CANRXQ
+27 SET IBCHRG=$SELECT($DATA(^IB(+IBLAST,0)):$PIECE(^(0),"^",7),1:$PIECE(IBND,"^",7))
IF IBCHRG<1
SET (Y,IBY(IBJ))="-1^IB025"
GOTO CANRXQ
+28 SET IBEFDT=$SELECT($PIECE(IBND,"^",14):$PIECE(IBND,"^",14),1:$PIECE($GET(^IB(+IBX,1)),"^",2))
+29 SET IBTIER=$PIECE(IBND,"^",22)
+30 SET IBTOTL=IBTOTL+IBCHRG
+31 SET IBWHER=2
+32 DO ADD^IBAUTL
IF +Y<1
SET IBY(IBJ)=Y
GOTO CANRXQ
+33 SET $PIECE(^IB(IBN,1),"^",1)=IBDUZ
+34 SET $PIECE(^IB(IBN,0),"^",2,15)=DFN_"^"_IBATYP_"^"_$PIECE(IBND,"^",4)_"^2^"_IBUNIT_"^"_IBCHRG_"^"_$PIECE(IBND,"^",8)_"^"_IBPARNT_"^"_IBCRES_"^"_IBIL_"^^"_IBFAC_"^"_IBEFDT_"^"_IBEFDT
if IBAM
SET $PIECE(^(0),"^",19)=IBAM
if IBTIER
SET $PIECE(^(0),"^",22)=IBTIER
+35 ;S ^IB("AC",2,IBN)=""
KILL ^IB("AC",1,IBN)
+36 DO INDEX
+37 SET Y(IBJ)=IBN_"^"_IBCHRG_"^"_IBIL
+38 SET IBNOS=IBN
CANRXQ QUIT
+1 ;
BDESC ; -return brief description
+1 NEW X,Y
SET IBDESC=""
SET X=$PIECE(IBX,"^")
+2 IF $DATA(^IBE(350.1,IBATYP,20))
XECUTE ^(20)
SET IBDESC=X
+3 QUIT
LAST ;find last entry
+1 SET IBLAST=""
+2 SET IBPARNT=$PIECE(^IB(+IBX,0),"^",9)
IF 'IBPARNT
SET IBPARNT=+IBX
+3 SET IBLDT=$ORDER(^IB("APDT",IBPARNT,""))
IF +IBLDT
FOR IBL=0:0
SET IBL=$ORDER(^IB("APDT",IBPARNT,IBLDT,IBL))
if 'IBL
QUIT
SET IBLAST=IBL
+4 IF IBLAST=""
SET IBLAST=IBPARNT
+5 QUIT
+6 ;
INDEX ;cross-reference entry
+1 NEW X,Y
+2 SET DA=IBN
SET DIK="^IB("
DO IX^DIK
+3 KILL DIK
QUIT
+4 ;
SERV(Y) ; -- Service check for Pharmacy
+1 ; called by the screen in the input transform for the IB SERVICE/SECTION
+2 ; field of the PHARMACY SITE file.
+3 ; input = Y internal entry number in service section file
+4 ; output = 1 if okay to use (service matches) or 0 if not okay
+5 ;
+6 ; -- screen logic for field 1003 in file 59 should be
+7 ; S DIC("S")="I $$SERV^IBARX1(+Y)"
+8 ;
+9 QUIT $SELECT('$GET(Y):0,1:$DATA(^IBE(350.1,"ANEW",Y,1,1))&$DATA(^IBE(350.1,"ANEW",Y,1,2)))
