70 lines
2.9 KiB
Mathematica
70 lines
2.9 KiB
Mathematica
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
|