IBARXEU1 ;ALB/AAS - RX EXEMPTION UTILITY ROUTINE (CONT.);3/27/07 3:10pm ; 31 Jan 2019 3:51 PM
;;2.0;INTEGRATED BILLING;**26,112,74,275,367,449,385,627,700**;21-MAR-94;Build 81
;;Per VHA Directive 2004-038, this routine should not be modified.
;
STATUS(DFN,IBDT) ; -- Determine medication copayment exemption status
; -- requests data from MAS
;
; returns : = exemption reason (pointer to 354.2) ^ date
;
N X,Y
I $G(IBDT)="" S IBDT=DT
S X=$$AUTOST(DFN,IBDT)
I X'="" G STATUSQ
S X=$$INCST(DFN,IBDT)
STATUSQ Q X
;
AUTOST(DFN,IBDT) ; -- Determine automatically exempt patients.
; input : dfn = patient file pointer
; ibdt = internal form of effective date
;
; returns : = exemption reason (pointer to 354.2) ^ date
; null if no autostatus
;
N IBEXREA,IBEXMT,I
S (IBEXREA,IBEXMT)=""
I $G(IBDT)="" S IBDT=DT
;
; -- ask mas if in receipt of pension/a&a/hb, etc.
; the automatic determinations
; returns:
; sc>50%^rec a&a^rec hb^rec pen^n/a^non-vet^^POW^Unempl.^cd^moh
; 1 1 1 1 1 1 1 1 1
; pieces =1 if true
S IBEXMT=$$AUTOINFO^DGMTCOU1(DFN) I IBEXMT="" G AUTOSTQ
I IBEXMT[1 F I=1,2,3,4,6,8,9,10,11 I $P(IBEXMT,"^",I)=1 S IBEXREA=I*10 Q ;lookup code is piece position time 10
;
; -- need to move CD patinet's to 70 which is ignored by IB, used to
; keep other stuff working, auto-exempt stuff relies on a 2 digit
; code to work properly
; -- added moh code to move to 50 to keep at 2 digit
I IBEXREA=100 S IBEXREA=70 ;not used above
I IBEXREA=110 S IBEXREA=50 ;not used above
;
AUTOSTQ I IBEXREA="" Q IBEXREA
Q $O(^IBE(354.2,"ACODE",+IBEXREA,0))_"^"_IBDT
;
;
INCST(DFN,IBDT) ; -- return medication copayment exemption reason/date
; -- ask mas for income data
;
; returns : = exemption reason (pointer to 354.2) ^ date
;
N IBDATA,X,DGMT,CLN,CONV
S IBDATA=$G(^DGMT(408.31,+$$LST^DGMTCOU1(DFN,IBDT,3),0)) ;get any test
;
; -- is the mt too old even under VFA rules - no data
I $$PLUS^IBARXEU0(+IBDATA)<IBDT,'$$VFAOK^IBARXEU($$LST^IBARXEU0(DFN,+IBDATA)) S X=$O(^IBE(354.2,"ACODE",210,0))_"^"_IBDT G INCSTQ
;
I $P(IBDATA,U,23)=2 D G:CONV INCSTQ ;skip Edb conv. tests
.;Loop through the MT comments, Check for EDB converted test
.;No comments to check
.S (CLN,CONV)=0,DGMT=$$LST^DGMTCOU1(DFN,IBDT,3)
.F S CLN=$O(^DGMT(408.31,+DGMT,"C",CLN)) Q:'CLN!(CONV) D
..;If most recent test is a converted test use current info from IBA(354
..I $G(^DGMT(408.31,+DGMT,"C",CLN,0))["Z06 MT via Edb" S CONV=1,X=$P($G(^IBA(354,DFN,0)),"^",5)_"^"_$P($G(^IBA(354,DFN,0)),"^",3)
;
I $$NETW S X=$$MTCOMP^IBARXEU5($$INCDT(IBDATA),IBDATA)
I '$$NETW S X=$$INCDT(IBDATA),X=$P(X,"^",3)_"^"_$P(X,"^",2)
INCSTQ Q X
;
INCDT(IBDATA) ; -- calcualtes copay exemption status based on income
; and net worth
; input := zeroth node from 408.31
; output := 1 = exempt ^date of test^ exemption reason
; 2 = non-exempt^...
; 3 = pending adjudication (if active)^...
;
N X,IBDT,IBINCOM,IBEXREA,IBDEPEN,IBNETW,IBTABLE,IBLEVEL,IBTHRES
I '$D(DFN) N DFN S DFN=$P(IBDATA,"^",2)
S IBEXREA=""
;
; -- if test incomplete, no longer required, no longer applicable, or
; required set to no income data
; autoexempt test should be done first before getting to here
S X=$P(IBDATA,"^",3) I X=1!(X=3)!(X=10)!(X=9)!($P(IBDATA,"^",14)) S IBEXREA=$S($P(IBDATA,"^",14):110,1:210) G NO
;
S IBDT=+IBDATA
S IBINCOM=$P(IBDATA,"^",4)-$P(IBDATA,"^",15) I IBINCOM<0 S IBINCOM=0
S IBDEPEN=$P(IBDATA,"^",18),IBNETW=$P(IBDATA,"^",5)
;
; -- get A&A income level
;S IBLEVEL=$$THRES(IBDT,2,IBDEPEN)
S IBLEVEL=$$THRES(IBDT,$S($E(IBDT,1,5)'<29612:1,1:2),IBDEPEN)
I $P(IBLEVEL,"^",3) S IBPRIOR=$P(IBLEVEL,"^",3)
;
S IBEXREA=120 ; low income
I IBINCOM>+IBLEVEL S IBEXREA=110 G NO ;high income not exempt
;
I '$$NETW G NO
;
; -- get networth threshold amount
S IBTHRES=+$$THRES(IBDT,4,0)
; -- low income check for net worth
S IBEXREA=$S((IBINCOM+IBNETW)>IBTHRES:130,1:120)
;
NO ; -- not enough information
I IBEXREA="" S IBEXREA=210
;
I $$NETW S Y=$S(IBEXREA=110:2,IBEXREA=120:1,IBEXREA=130:3,1:2)
I '$$NETW S Y=$S(IBEXREA=120:1,1:2)
;
INCDTQ Q Y_"^"_+IBDATA_"^"_$O(^IBE(354.2,"ACODE",+IBEXREA,0))
;
THRES(DATE,TYPE,DEPEND) ; -- return threshold amount
;
; -- if date is less than 12/1/92 will use 12/1 92 rates
; date =: fileman format of effective date
; type =: 2= pension plus A&A 1992 thru 1995
; type =: 1= basic pension 1996 to present
; depend =: number of dependents
;
; -- returns rate^effective date^prior year
;
I DATE<2921201 S DATE=2921201 ; use threshold rates from 12/1/92
N IBTABLE,IBLEVEL,IBPRIOR
S (IBLEVEL,IBPRIOR)=""
; -- get entry to determine income amounts
S IBTABLE=$G(^IBE(354.3,+$O(^(+$O(^IBE(354.3,"AIVDT",TYPE,-(DATE+.000001))),0)),0))
G:IBTABLE="" THRESQ
I TYPE=4 S DEPEND=0
;
; --see if rate is for prior year
I $$PLUS^IBARXEU0(+IBTABLE)<DATE S IBPRIOR=+IBTABLE
;
; -- rates begin in piece 3 for veteran alone, piece 4 for 1 dependent..
S IBLEVEL=$S(DEPEND<9:$P(IBTABLE,"^",DEPEND+3),1:"")
I IBLEVEL="" S IBLEVEL=$P(IBTABLE,"^",4)+((DEPEND-1)*$P(IBTABLE,"^",12))
THRESQ Q IBLEVEL_"^"_+IBTABLE_"^"_IBPRIOR
;
NETW() ; -- use networth in determining copay exemptions - specs keep changing
; returns 1 if should use networth in exemption determination
; returns 0 if should not use networth in exemption
Q 0
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBARXEU1 5625 printed Apr 09, 2024@21:12:04 Page 2
IBARXEU1 ;ALB/AAS - RX EXEMPTION UTILITY ROUTINE (CONT.);3/27/07 3:10pm ; 31 Jan 2019 3:51 PM
+1 ;;2.0;INTEGRATED BILLING;**26,112,74,275,367,449,385,627,700**;21-MAR-94;Build 81
+2 ;;Per VHA Directive 2004-038, this routine should not be modified.
+3 ;
STATUS(DFN,IBDT) ; -- Determine medication copayment exemption status
+1 ; -- requests data from MAS
+2 ;
+3 ; returns : = exemption reason (pointer to 354.2) ^ date
+4 ;
+5 NEW X,Y
+6 IF $GET(IBDT)=""
SET IBDT=DT
+7 SET X=$$AUTOST(DFN,IBDT)
+8 IF X'=""
GOTO STATUSQ
+9 SET X=$$INCST(DFN,IBDT)
STATUSQ QUIT X
+1 ;
AUTOST(DFN,IBDT) ; -- Determine automatically exempt patients.
+1 ; input : dfn = patient file pointer
+2 ; ibdt = internal form of effective date
+3 ;
+4 ; returns : = exemption reason (pointer to 354.2) ^ date
+5 ; null if no autostatus
+6 ;
+7 NEW IBEXREA,IBEXMT,I
+8 SET (IBEXREA,IBEXMT)=""
+9 IF $GET(IBDT)=""
SET IBDT=DT
+10 ;
+11 ; -- ask mas if in receipt of pension/a&a/hb, etc.
+12 ; the automatic determinations
+13 ; returns:
+14 ; sc>50%^rec a&a^rec hb^rec pen^n/a^non-vet^^POW^Unempl.^cd^moh
+15 ; 1 1 1 1 1 1 1 1 1
+16 ; pieces =1 if true
+17 SET IBEXMT=$$AUTOINFO^DGMTCOU1(DFN)
IF IBEXMT=""
GOTO AUTOSTQ
+18 ;lookup code is piece position time 10
IF IBEXMT[1
FOR I=1,2,3,4,6,8,9,10,11
IF $PIECE(IBEXMT,"^",I)=1
SET IBEXREA=I*10
QUIT
+19 ;
+20 ; -- need to move CD patinet's to 70 which is ignored by IB, used to
+21 ; keep other stuff working, auto-exempt stuff relies on a 2 digit
+22 ; code to work properly
+23 ; -- added moh code to move to 50 to keep at 2 digit
+24 ;not used above
IF IBEXREA=100
SET IBEXREA=70
+25 ;not used above
IF IBEXREA=110
SET IBEXREA=50
+26 ;
AUTOSTQ IF IBEXREA=""
QUIT IBEXREA
+1 QUIT $ORDER(^IBE(354.2,"ACODE",+IBEXREA,0))_"^"_IBDT
+2 ;
+3 ;
INCST(DFN,IBDT) ; -- return medication copayment exemption reason/date
+1 ; -- ask mas for income data
+2 ;
+3 ; returns : = exemption reason (pointer to 354.2) ^ date
+4 ;
+5 NEW IBDATA,X,DGMT,CLN,CONV
+6 ;get any test
SET IBDATA=$GET(^DGMT(408.31,+$$LST^DGMTCOU1(DFN,IBDT,3),0))
+7 ;
+8 ; -- is the mt too old even under VFA rules - no data
+9 IF $$PLUS^IBARXEU0(+IBDATA)<IBDT
IF '$$VFAOK^IBARXEU($$LST^IBARXEU0(DFN,+IBDATA))
SET X=$ORDER(^IBE(354.2,"ACODE",210,0))_"^"_IBDT
GOTO INCSTQ
+10 ;
+11 ;skip Edb conv. tests
IF $PIECE(IBDATA,U,23)=2
Begin DoDot:1
+12 ;Loop through the MT comments, Check for EDB converted test
+13 ;No comments to check
+14 SET (CLN,CONV)=0
SET DGMT=$$LST^DGMTCOU1(DFN,IBDT,3)
+15 FOR
SET CLN=$ORDER(^DGMT(408.31,+DGMT,"C",CLN))
if 'CLN!(CONV)
QUIT
Begin DoDot:2
+16 ;If most recent test is a converted test use current info from IBA(354
+17 IF $GET(^DGMT(408.31,+DGMT,"C",CLN,0))["Z06 MT via Edb"
SET CONV=1
SET X=$PIECE($GET(^IBA(354,DFN,0)),"^",5)_"^"_$PIECE($GET(^IBA(354,DFN,0)),"^",3)
End DoDot:2
End DoDot:1
if CONV
GOTO INCSTQ
+18 ;
+19 IF $$NETW
SET X=$$MTCOMP^IBARXEU5($$INCDT(IBDATA),IBDATA)
+20 IF '$$NETW
SET X=$$INCDT(IBDATA)
SET X=$PIECE(X,"^",3)_"^"_$PIECE(X,"^",2)
INCSTQ QUIT X
+1 ;
INCDT(IBDATA) ; -- calcualtes copay exemption status based on income
+1 ; and net worth
+2 ; input := zeroth node from 408.31
+3 ; output := 1 = exempt ^date of test^ exemption reason
+4 ; 2 = non-exempt^...
+5 ; 3 = pending adjudication (if active)^...
+6 ;
+7 NEW X,IBDT,IBINCOM,IBEXREA,IBDEPEN,IBNETW,IBTABLE,IBLEVEL,IBTHRES
+8 IF '$DATA(DFN)
NEW DFN
SET DFN=$PIECE(IBDATA,"^",2)
+9 SET IBEXREA=""
+10 ;
+11 ; -- if test incomplete, no longer required, no longer applicable, or
+12 ; required set to no income data
+13 ; autoexempt test should be done first before getting to here
+14 SET X=$PIECE(IBDATA,"^",3)
IF X=1!(X=3)!(X=10)!(X=9)!($PIECE(IBDATA,"^",14))
SET IBEXREA=$SELECT($PIECE(IBDATA,"^",14):110,1:210)
GOTO NO
+15 ;
+16 SET IBDT=+IBDATA
+17 SET IBINCOM=$PIECE(IBDATA,"^",4)-$PIECE(IBDATA,"^",15)
IF IBINCOM<0
SET IBINCOM=0
+18 SET IBDEPEN=$PIECE(IBDATA,"^",18)
SET IBNETW=$PIECE(IBDATA,"^",5)
+19 ;
+20 ; -- get A&A income level
+21 ;S IBLEVEL=$$THRES(IBDT,2,IBDEPEN)
+22 SET IBLEVEL=$$THRES(IBDT,$SELECT($EXTRACT(IBDT,1,5)'<29612:1,1:2),IBDEPEN)
+23 IF $PIECE(IBLEVEL,"^",3)
SET IBPRIOR=$PIECE(IBLEVEL,"^",3)
+24 ;
+25 ; low income
SET IBEXREA=120
+26 ;high income not exempt
IF IBINCOM>+IBLEVEL
SET IBEXREA=110
GOTO NO
+27 ;
+28 IF '$$NETW
GOTO NO
+29 ;
+30 ; -- get networth threshold amount
+31 SET IBTHRES=+$$THRES(IBDT,4,0)
+32 ; -- low income check for net worth
+33 SET IBEXREA=$SELECT((IBINCOM+IBNETW)>IBTHRES:130,1:120)
+34 ;
NO ; -- not enough information
+1 IF IBEXREA=""
SET IBEXREA=210
+2 ;
+3 IF $$NETW
SET Y=$SELECT(IBEXREA=110:2,IBEXREA=120:1,IBEXREA=130:3,1:2)
+4 IF '$$NETW
SET Y=$SELECT(IBEXREA=120:1,1:2)
+5 ;
INCDTQ QUIT Y_"^"_+IBDATA_"^"_$ORDER(^IBE(354.2,"ACODE",+IBEXREA,0))
+1 ;
THRES(DATE,TYPE,DEPEND) ; -- return threshold amount
+1 ;
+2 ; -- if date is less than 12/1/92 will use 12/1 92 rates
+3 ; date =: fileman format of effective date
+4 ; type =: 2= pension plus A&A 1992 thru 1995
+5 ; type =: 1= basic pension 1996 to present
+6 ; depend =: number of dependents
+7 ;
+8 ; -- returns rate^effective date^prior year
+9 ;
+10 ; use threshold rates from 12/1/92
IF DATE<2921201
SET DATE=2921201
+11 NEW IBTABLE,IBLEVEL,IBPRIOR
+12 SET (IBLEVEL,IBPRIOR)=""
+13 ; -- get entry to determine income amounts
+14 SET IBTABLE=$GET(^IBE(354.3,+$ORDER(^(+$ORDER(^IBE(354.3,"AIVDT",TYPE,-(DATE+.000001))),0)),0))
+15 if IBTABLE=""
GOTO THRESQ
+16 IF TYPE=4
SET DEPEND=0
+17 ;
+18 ; --see if rate is for prior year
+19 IF $$PLUS^IBARXEU0(+IBTABLE)<DATE
SET IBPRIOR=+IBTABLE
+20 ;
+21 ; -- rates begin in piece 3 for veteran alone, piece 4 for 1 dependent..
+22 SET IBLEVEL=$SELECT(DEPEND<9:$PIECE(IBTABLE,"^",DEPEND+3),1:"")
+23 IF IBLEVEL=""
SET IBLEVEL=$PIECE(IBTABLE,"^",4)+((DEPEND-1)*$PIECE(IBTABLE,"^",12))
THRESQ QUIT IBLEVEL_"^"_+IBTABLE_"^"_IBPRIOR
+1 ;
NETW() ; -- use networth in determining copay exemptions - specs keep changing
+1 ; returns 1 if should use networth in exemption determination
+2 ; returns 0 if should not use networth in exemption
+3 QUIT 0
