IBARXEU3 ;ALB/AAS - RX COPAY EXEMPTION PROCESS AR CANCELS ; 8-JAN-93
;;Version 2.0 ; INTEGRATED BILLING ;; 21-MAR-94
;;Per VHA Directive 10-93-142, this routine should not be modified.
;
CANCEL ; -- cancel old ib and ar logic if going from non-exempt to exempt
; based on updated income testing.
; -- called whenever adding an exemption
; requires event driver variables.
;
Q:'IBSTAT ; non-exempt patient
N IBDT,IBEDT,IBCODA,IBCODP,IBSITE,IBAFY,IBATYP,IBCANDT,IBCHRG,IBCRES,IBERR,IBFAC,IBIL,IBL,IBLAST,IBLDT,IBN,IBND,IBNN,IBNOW,IBPARNT,IBPARNT1,IBSEQNO,IBUNIT,LST
;
; -- if new code is income < pension (120) and no prior code or
; prior code was no income data cancel charges
;
S IBCODP=$$ACODE^IBARXEU0(IBEVTP),IBCODA=$$ACODE^IBARXEU0(IBEVTA)
I '$$NETW^IBARXEU1 G:IBCODA'=120 CANCELQ I $S(IBCODP="":0,IBCODP=210:0,1:1) G CANCELQ
I $$NETW^IBARXEU1,$S(IBCODA=120:$S(IBCODP="":0,IBCODP=210:0,1:1),IBCODA=150:$S(IBCODP=130:0,1:1),1:1) G CANCELQ
;
; -- set begin and end dates
S IBDT=+IBEVTP
I IBDT<$$STDATE^IBARXEU S IBDT=$$STDATE^IBARXEU
; -- if new exemption is most current, set begin date to dt, else set to exemption date
S IBEDT=$S(+$$LST^IBARXEU0(DFN,DT)=+IBEVTA:DT,1:+IBEVTA)
;
; -- see if exemption prior to one being canceled same
S LST=$$LST^IBARXEU0(DFN,+IBEVTP-.01)
I +LST,$P(IBEVTP,"^",5)=$P(LST,"^",5) S IBDT=+LST
D CANDT^IBARXEU4
;
; -- See if patient has any bills
S X=$O(^IB("APTDT",DFN,(IBDT-.01))) I 'X!(X>(IBEDT+.9)) G CANCELQ
;
; -- cancel bills in IB
D ARPARM^IBAUTL
S IBBDT=$P(IBCANDT,"^")-.0001
F S IBBDT=$O(^IB("APTDT",DFN,IBBDT)) Q:'IBBDT!((IBEDT+.9)<IBBDT) S IBN=0 F S IBN=$O(^IB("APTDT",DFN,IBBDT,IBN)) Q:'IBN D BILL
;
; -- cancel bills in AR
Q:$P(IBCANDT,"^",2)<$P(IBCANDT,"^") D ARCAN^IBARXEU4(DFN,IBSTAT,$P(IBCANDT,"^"),$P(IBCANDT,"^",2))
;
CANCELQ Q
;
BILL ; -- process cancelling one bill
S X=$G(^IB(IBN,0)) Q:X=""
Q:+$P(X,"^",4)'=52 ;quit if not pharmacy co-pay
;
; -- find parent
S IBPARNT=$P(X,"^",9)
;
S IBPARDT=$P($G(^IB(IBPARNT,1)),"^",2) ; get date of parent charge
I $S(IBPARDT="":1,IBPARDT<IBDT:1,IBPARDT>(IBEDT+.9):1,1:0) Q ; ignore charges started before or after date range
;
; -- get must recent ibaction
S IBPARNT1=IBPARNT F S IBPARNT1=$P($G(^IB(IBPARNT,0)),"^",9) Q:IBPARNT1=IBPARNT S IBPARNT=IBPARNT1 ;gets parent of parents
D LAST
;
Q:$P(^IBE(350.1,$P(^IB(IBLAST,0),"^",3),0),"^",5)=2 ;quit if already cancelled
;
S IBCRES=$O(^IBE(350.3,"B","RX COPAY INCOME EXEMPTION",0)) ; get cancellation reason
;
D CANRX
Q
;
CANRX ; -- do acutal cancellation without calling ar
; input : iblast := last entry for parnt
; ibparnt := parent charge
; ibnd := ^(0) node of iblast
;
; returns: ibnn := entry number of new node
;
N IBN
S IBNN="" ;return new node in ibnn
I $D(^IB(IBLAST,0)),$P(^IBE(350.1,$P(^IB(IBLAST,0),"^",3),0),"^",5)=2 G CANRXQ ;already cancelled
S IBND=$G(^IB(+IBLAST,0)),IBDUZ=DUZ
;
S IBATYP=$P(^IBE(350.1,+$P($G(^IB(IBPARNT,0)),"^",3),0),"^",6) ;cancellation action type for parent
I '$D(^IBE(350.1,+IBATYP,0)) G CANRXQ
S IBSEQNO=$P(^IBE(350.1,+IBATYP,0),"^",5) I 'IBSEQNO G CANRXQ
S IBIL=$P($G(^IB(IBPARNT,0)),"^",11)
S IBUNIT=$S($P(IBND,"^",6):$P(IBND,"^",6),$D(^IB(IBPARNT,0)):$P(^(0),"^",6),1:0) I IBUNIT<1 G CANRXQ
S DA=IBATYP D COST^IBAUTL S IBCHRG=IBUNIT*X1
;
D ADD^IBAUTL I +Y<1 G CANRXQ
S $P(^IB(IBN,1),"^",1)=IBDUZ,$P(^IB(IBN,0),"^",2,13)=DFN_"^"_IBATYP_"^"_$P(IBND,"^",4)_"^11^"_IBUNIT_"^"_IBCHRG_"^"_$P(IBND,"^",8)_"^"_IBPARNT_"^"_IBCRES_"^"_IBIL_"^^"_IBFAC
K ^IB("AC",1,IBN)
S DA=IBN,DIK="^IB(" D IX^DIK
S IBNN=IBN
;
; -- update parent to cancelled
; note: parent status=10, cancellation due to exemption reason only
; on charge cancelled so reports work right.
S DIE="^IB(",DA=IBPARNT,DR=".05////10;.1////"_IBCRES D ^DIE K DIE,DA,DR
CANRXQ Q
;
LAST ; -- find most recent (the last) entry for a parent action
S IBLAST=""
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
IBARXEU3 ;ALB/AAS - RX COPAY EXEMPTION PROCESS AR CANCELS ; 8-JAN-93
+1 ;;Version 2.0 ; INTEGRATED BILLING ;; 21-MAR-94
+2 ;;Per VHA Directive 10-93-142, this routine should not be modified.
+3 ;
CANCEL ; -- cancel old ib and ar logic if going from non-exempt to exempt
+1 ; based on updated income testing.
+2 ; -- called whenever adding an exemption
+3 ; requires event driver variables.
+4 ;
+5 ; non-exempt patient
IF 'IBSTAT
QUIT
+6 NEW IBDT,IBEDT,IBCODA,IBCODP,IBSITE,IBAFY,IBATYP,IBCANDT,IBCHRG,IBCRES,IBERR,IBFAC,IBIL,IBL,IBLAST,IBLDT,IBN,IBND,IBNN,IBNOW,IBPARNT,IBPARNT1,IBSEQNO,IBUNIT,LST
+7 ;
+8 ; -- if new code is income < pension (120) and no prior code or
+9 ; prior code was no income data cancel charges
+10 ;
+11 SET IBCODP=$$ACODE^IBARXEU0(IBEVTP)
SET IBCODA=$$ACODE^IBARXEU0(IBEVTA)
+12 IF '$$NETW^IBARXEU1
IF IBCODA'=120
GOTO CANCELQ
IF $SELECT(IBCODP="":0,IBCODP=210:0,1:1)
GOTO CANCELQ
+13 IF $$NETW^IBARXEU1
IF $SELECT(IBCODA=120:$SELECT(IBCODP="":0,IBCODP=210:0,1:1),IBCODA=150:$SELECT(IBCODP=130:0,1:1),1:1)
GOTO CANCELQ
+14 ;
+15 ; -- set begin and end dates
+16 SET IBDT=+IBEVTP
+17 IF IBDT<$$STDATE^IBARXEU
SET IBDT=$$STDATE^IBARXEU
+18 ; -- if new exemption is most current, set begin date to dt, else set to exemption date
+19 SET IBEDT=$SELECT(+$$LST^IBARXEU0(DFN,DT)=+IBEVTA:DT,1:+IBEVTA)
+20 ;
+21 ; -- see if exemption prior to one being canceled same
+22 SET LST=$$LST^IBARXEU0(DFN,+IBEVTP-.01)
+23 IF +LST
IF $PIECE(IBEVTP,"^",5)=$PIECE(LST,"^",5)
SET IBDT=+LST
+24 DO CANDT^IBARXEU4
+25 ;
+26 ; -- See if patient has any bills
+27 SET X=$ORDER(^IB("APTDT",DFN,(IBDT-.01)))
IF 'X!(X>(IBEDT+.9))
GOTO CANCELQ
+28 ;
+29 ; -- cancel bills in IB
+30 DO ARPARM^IBAUTL
+31 SET IBBDT=$PIECE(IBCANDT,"^")-.0001
+32 FOR
SET IBBDT=$ORDER(^IB("APTDT",DFN,IBBDT))
IF 'IBBDT!((IBEDT+.9)<IBBDT)
QUIT
SET IBN=0
FOR
SET IBN=$ORDER(^IB("APTDT",DFN,IBBDT,IBN))
IF 'IBN
QUIT
DO BILL
+33 ;
+34 ; -- cancel bills in AR
+35 IF $PIECE(IBCANDT,"^",2)<$PIECE(IBCANDT,"^")
QUIT
DO ARCAN^IBARXEU4(DFN,IBSTAT,$PIECE(IBCANDT,"^"),$PIECE(IBCANDT,"^",2))
+36 ;
CANCELQ QUIT
+1 ;
BILL ; -- process cancelling one bill
+1 SET X=$GET(^IB(IBN,0))
IF X=""
QUIT
+2 ;quit if not pharmacy co-pay
IF +$PIECE(X,"^",4)'=52
QUIT
+3 ;
+4 ; -- find parent
+5 SET IBPARNT=$PIECE(X,"^",9)
+6 ;
+7 ; get date of parent charge
SET IBPARDT=$PIECE($GET(^IB(IBPARNT,1)),"^",2)
+8 ; ignore charges started before or after date range
IF $SELECT(IBPARDT="":1,IBPARDT<IBDT:1,IBPARDT>(IBEDT+.9):1,1:0)
QUIT
+9 ;
+10 ; -- get must recent ibaction
+11 ;gets parent of parents
SET IBPARNT1=IBPARNT
FOR
SET IBPARNT1=$PIECE($GET(^IB(IBPARNT,0)),"^",9)
IF IBPARNT1=IBPARNT
QUIT
SET IBPARNT=IBPARNT1
+12 DO LAST
+13 ;
+14 ;quit if already cancelled
IF $PIECE(^IBE(350.1,$PIECE(^IB(IBLAST,0),"^",3),0),"^",5)=2
QUIT
+15 ;
+16 ; get cancellation reason
SET IBCRES=$ORDER(^IBE(350.3,"B","RX COPAY INCOME EXEMPTION",0))
+17 ;
+18 DO CANRX
+19 QUIT
+20 ;
CANRX ; -- do acutal cancellation without calling ar
+1 ; input : iblast := last entry for parnt
+2 ; ibparnt := parent charge
+3 ; ibnd := ^(0) node of iblast
+4 ;
+5 ; returns: ibnn := entry number of new node
+6 ;
+7 NEW IBN
+8 ;return new node in ibnn
SET IBNN=""
+9 ;already cancelled
IF $DATA(^IB(IBLAST,0))
IF $PIECE(^IBE(350.1,$PIECE(^IB(IBLAST,0),"^",3),0),"^",5)=2
GOTO CANRXQ
+10 SET IBND=$GET(^IB(+IBLAST,0))
SET IBDUZ=DUZ
+11 ;
+12 ;cancellation action type for parent
SET IBATYP=$PIECE(^IBE(350.1,+$PIECE($GET(^IB(IBPARNT,0)),"^",3),0),"^",6)
+13 IF '$DATA(^IBE(350.1,+IBATYP,0))
GOTO CANRXQ
+14 SET IBSEQNO=$PIECE(^IBE(350.1,+IBATYP,0),"^",5)
IF 'IBSEQNO
GOTO CANRXQ
+15 SET IBIL=$PIECE($GET(^IB(IBPARNT,0)),"^",11)
+16 SET IBUNIT=$SELECT($PIECE(IBND,"^",6):$PIECE(IBND,"^",6),$DATA(^IB(IBPARNT,0)):$PIECE(^(0),"^",6),1:0)
IF IBUNIT<1
GOTO CANRXQ
+17 SET DA=IBATYP
DO COST^IBAUTL
SET IBCHRG=IBUNIT*X1
+18 ;
+19 DO ADD^IBAUTL
IF +Y<1
GOTO CANRXQ
+20 SET $PIECE(^IB(IBN,1),"^",1)=IBDUZ
SET $PIECE(^IB(IBN,0),"^",2,13)=DFN_"^"_IBATYP_"^"_$PIECE(IBND,"^",4)_"^11^"_IBUNIT_"^"_IBCHRG_"^"_$PIECE(IBND,"^",8)_"^"_IBPARNT_"^"_IBCRES_"^"_IBIL_"^^"_IBFAC
+21 KILL ^IB("AC",1,IBN)
+22 SET DA=IBN
SET DIK="^IB("
DO IX^DIK
+23 SET IBNN=IBN
+24 ;
+25 ; -- update parent to cancelled
+26 ; note: parent status=10, cancellation due to exemption reason only
+27 ; on charge cancelled so reports work right.
+28 SET DIE="^IB("
SET DA=IBPARNT
SET DR=".05////10;.1////"_IBCRES
DO ^DIE
KILL DIE,DA,DR
CANRXQ QUIT
+1 ;
LAST ; -- find most recent (the last) entry for a parent action
+1 SET IBLAST=""
+2 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
+3 IF IBLAST=""
SET IBLAST=IBPARNT
+4 QUIT
