IBARXEU1.m

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 ---IBARXEU1   5625     printed  Feb 18, 2025@23:33:48                                                                                                                                                                                                    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