IBARXECA ;ALB/AAS -RX CO-PAY INCOME EXEMPTION CANCEL OLD BILLS ; 2-NOV-92
;;Version 2.0 ; INTEGRATED BILLING ;; 21-MAR-94
;;Per VHA Directive 10-93-142, this routine should not be modified.
;
% ; -- count variables
; Patient Totals Represents
; ------- ------ ----------
; 5 ibcnt ibtcnt = : total patient count checked
; 6 ibecnt ibtecnt = : total exempt patients
; 7 ibncnt ibtncnt = : total non-exempt patients
; 8 ibcecnt ibtcecnt = : total count of exempt charges (rx's)
; 9 ibamt ibtamt = : total dollar amount checked
; 10 ibeamt ibteamt = : total exempt dollar amount
; 11 ibnamt ibtnamt = : total non-exempt dollar amount
; 12 ibceamt ibtceamt = : total cancelled charges amount
; 15 ibnecnt ibtnecnt = : total non-exempt count
; 16 ibbcnt ibtbcnt = : total bills checked
; 17 ibcbcnt ibtcbcnt = : total number of cancelled bills
;
CANCEL(DFN,IBDT,IBEDT) ; -- cancel all charges for a patient for a date range
; do not pass to ar as its done, call all at once later.
;
D ARPARM^IBAUTL
S IBBDT=IBDT-.00001
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
;
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) Q:$D(^TMP($J,"IBARRY",DFN,IBPARNT)) ;don't keep checking modifications to charge already checked
;
S ^TMP($J,"IBARRY",DFN,IBPARNT)=""
S IBPARDT=$P($G(^IB(IBPARNT,1)),"^",2) ; get date of parent charge
I $S(IBPARDT="":1,IBPARDT<IBDT:1,IBPARDT>IBEDT:1,1:0) ; ignore charges started before or after date range
;
; -- get exemption status on date of charge
; (NOT NECESSARY, conversion will use only current exemption
;S IBSTAT=$$RXEXMT^IBARXEU0(DFN,IBPARDT)
;
; -- 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, makes sure old bug where parents get lost isn't a problem
D LAST
;
; -- add charge amounts to corrct variable
S IBND=$G(^IB(IBLAST,0)),IBBCNT=IBBCNT+1,IBAMT=IBAMT+$P(IBND,"^",7)
S:IBSTAT IBCECNT=IBCECNT+1,IBEAMT=IBEAMT+$P(IBND,"^",7)
S:'IBSTAT IBNECNT=IBNECNT+1,IBNAMT=IBNAMT+$P(IBND,"^",7)
;
Q:'IBSTAT ;quit if non-exempt
Q:$P(^IBE(350.1,$P(^IB(IBLAST,0),"^",3),0),"^",5)=2 ;quit if already cancelled
;
; -- add cancellation charge for amount
S IBCEAMT=IBCEAMT+$P(IBND,"^",7),IBCBCNT=IBCBCNT+1 ;counts of amount of actual cancellations
S IBCRES=$O(^IBE(350.3,"B","RX COPAY INCOME EXEMPTION",0)) ; get cancellation reason
;
D CANRX^IBARXEU3
Q
;
END ;K VARIABLES
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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBARXECA 3046 printed Oct 16, 2024@18:07:53 Page 2
IBARXECA ;ALB/AAS -RX CO-PAY INCOME EXEMPTION CANCEL OLD BILLS ; 2-NOV-92
+1 ;;Version 2.0 ; INTEGRATED BILLING ;; 21-MAR-94
+2 ;;Per VHA Directive 10-93-142, this routine should not be modified.
+3 ;
% ; -- count variables
+1 ; Patient Totals Represents
+2 ; ------- ------ ----------
+3 ; 5 ibcnt ibtcnt = : total patient count checked
+4 ; 6 ibecnt ibtecnt = : total exempt patients
+5 ; 7 ibncnt ibtncnt = : total non-exempt patients
+6 ; 8 ibcecnt ibtcecnt = : total count of exempt charges (rx's)
+7 ; 9 ibamt ibtamt = : total dollar amount checked
+8 ; 10 ibeamt ibteamt = : total exempt dollar amount
+9 ; 11 ibnamt ibtnamt = : total non-exempt dollar amount
+10 ; 12 ibceamt ibtceamt = : total cancelled charges amount
+11 ; 15 ibnecnt ibtnecnt = : total non-exempt count
+12 ; 16 ibbcnt ibtbcnt = : total bills checked
+13 ; 17 ibcbcnt ibtcbcnt = : total number of cancelled bills
+14 ;
CANCEL(DFN,IBDT,IBEDT) ; -- cancel all charges for a patient for a date range
+1 ; do not pass to ar as its done, call all at once later.
+2 ;
+3 DO ARPARM^IBAUTL
+4 SET IBBDT=IBDT-.00001
+5 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
+6 ;
+7 QUIT
+8 ;
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 ; find parent
+4 ;don't keep checking modifications to charge already checked
SET IBPARNT=$PIECE(X,"^",9)
if $DATA(^TMP($JOB,"IBARRY",DFN,IBPARNT))
QUIT
+5 ;
+6 SET ^TMP($JOB,"IBARRY",DFN,IBPARNT)=""
+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:1,1:0)
+9 ;
+10 ; -- get exemption status on date of charge
+11 ; (NOT NECESSARY, conversion will use only current exemption
+12 ;S IBSTAT=$$RXEXMT^IBARXEU0(DFN,IBPARDT)
+13 ;
+14 ; -- get must recent ibaction
+15 ;gets parent of parents, makes sure old bug where parents get lost isn't a problem
SET IBPARNT1=IBPARNT
FOR
SET IBPARNT1=$PIECE($GET(^IB(IBPARNT,0)),"^",9)
if IBPARNT1=IBPARNT
QUIT
SET IBPARNT=IBPARNT1
+16 DO LAST
+17 ;
+18 ; -- add charge amounts to corrct variable
+19 SET IBND=$GET(^IB(IBLAST,0))
SET IBBCNT=IBBCNT+1
SET IBAMT=IBAMT+$PIECE(IBND,"^",7)
+20 if IBSTAT
SET IBCECNT=IBCECNT+1
SET IBEAMT=IBEAMT+$PIECE(IBND,"^",7)
+21 if 'IBSTAT
SET IBNECNT=IBNECNT+1
SET IBNAMT=IBNAMT+$PIECE(IBND,"^",7)
+22 ;
+23 ;quit if non-exempt
if 'IBSTAT
QUIT
+24 ;quit if already cancelled
if $PIECE(^IBE(350.1,$PIECE(^IB(IBLAST,0),"^",3),0),"^",5)=2
QUIT
+25 ;
+26 ; -- add cancellation charge for amount
+27 ;counts of amount of actual cancellations
SET IBCEAMT=IBCEAMT+$PIECE(IBND,"^",7)
SET IBCBCNT=IBCBCNT+1
+28 ; get cancellation reason
SET IBCRES=$ORDER(^IBE(350.3,"B","RX COPAY INCOME EXEMPTION",0))
+29 ;
+30 DO CANRX^IBARXEU3
+31 QUIT
+32 ;
END ;K VARIABLES
+1 QUIT
+2 ;
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
