| [613] | 1 | IBARXEU5 ;AAS/ALB - RX EXEMPTION UTILITY ROUTINE (CONT.) ; 2-NOV-92
|
|---|
| 2 | ;;2.0;INTEGRATED BILLING;**20,112,153**;21-MAR-94
|
|---|
| 3 | ;;Per VHA Directive 10-93-142, this routine should not be modified.
|
|---|
| 4 | ;
|
|---|
| 5 | DIFF ; -- supported call for mas
|
|---|
| 6 | ; -- compare current exemption reason and date with what currently
|
|---|
| 7 | ; computes from the patient record. Automatically update if needed.
|
|---|
| 8 | ; input: dfn = patient to update
|
|---|
| 9 | ; Ibdt = date of change (optional, default is dt)
|
|---|
| 10 | ; output: none
|
|---|
| 11 | ;
|
|---|
| 12 | N I,J,X,Y,IBADDE,IBEXDA,IBMESS,IBDT,IBX,IBEXREAN,IBEXREAO,IBFORCE,IBOLDAUT,IBJOB,IBWHER
|
|---|
| 13 | S IBJOB=16,IBWHER=14
|
|---|
| 14 | G:'$G(DFN) DIFFQ
|
|---|
| 15 | I $G(IBDT)'?7N S IBDT=DT
|
|---|
| 16 | ;
|
|---|
| 17 | ; -- if not already in file, wait until an rx is issued
|
|---|
| 18 | I '$G(^IBA(354,DFN,0)) G DIFFQ
|
|---|
| 19 | ;
|
|---|
| 20 | ; -- compute old exemption reason, exemption date
|
|---|
| 21 | S IBX=$G(^IBA(354,DFN,0)),IBEXREAO=$P(IBX,"^",5)_"^"_$P(IBX,"^",3)
|
|---|
| 22 | I $P($G(^IBE(354.2,+IBEXREAO,0)),"^",5)=2010 G DIFFQ ; is hardship don't update
|
|---|
| 23 | ; -- compute new exemption reason
|
|---|
| 24 | S IBEXREAN=$$STATUS^IBARXEU1(DFN,IBDT)
|
|---|
| 25 | ;
|
|---|
| 26 | ; -- quit if not current exemption
|
|---|
| 27 | I $$PLUS^IBARXEU0($P(IBEXREAN,"^",2))<DT G DIFFQ
|
|---|
| 28 | ;
|
|---|
| 29 | ; -- quit if same exemption reason
|
|---|
| 30 | I +IBEXREAN=+IBEXREAO G DIFFQ
|
|---|
| 31 | ;
|
|---|
| 32 | ; -- not same so update
|
|---|
| 33 | D UP1^IBARXEPV
|
|---|
| 34 | ;I $L($P($G(^IBE(354.2,+IBEXREAN,0)),"^",5))>2 D OLDAUT^IBARXEX1(IBEXREAN)
|
|---|
| 35 | ;S IBFORCE=$P(IBEXREAN,"^",2)
|
|---|
| 36 | ;D MOSTR($P(IBEXREAN,"^",2),+IBEXREAN)
|
|---|
| 37 | ;D ADDEX^IBAUTL6(+IBEXREAN,$P(IBEXREAN,"^",2),1,1,IBOLDAUT)
|
|---|
| 38 | ;
|
|---|
| 39 | DIFFQ Q
|
|---|
| 40 | ;
|
|---|
| 41 | MTCOMP(STATUS,IBDATA) ; -- compare income determination with current mt status
|
|---|
| 42 | ;
|
|---|
| 43 | I '$$NETW^IBARXEU1 G MTCOMP ; don't use net worth in computation
|
|---|
| 44 | ;
|
|---|
| 45 | N IBEXREA,CODE S IBEXREA=""
|
|---|
| 46 | ;
|
|---|
| 47 | ; -- incomplete and required tests are no data
|
|---|
| 48 | ;I CODE="I"!(CODE="R") S IBEXREA=210 G MTDONE
|
|---|
| 49 | S X=$P(IBDATA,"^",3) I X=1!(X=3)!(X=9)!(X=10)!($P(IBDATA,"^",14)) S IBEXREA=$S($P(IBDATA,"^",14):110,1:210) G MTDONE
|
|---|
| 50 | ;
|
|---|
| 51 | ; -- quit if not pending adjuducation
|
|---|
| 52 | I +STATUS'=3 G MTCOMPQ
|
|---|
| 53 | ;
|
|---|
| 54 | S CODE=$$CODE^IBAMTED1(IBDATA)
|
|---|
| 55 | ;
|
|---|
| 56 | ; -- see if mt or income test was adjudicated
|
|---|
| 57 | ; if not sent to ajudication is non-exempt
|
|---|
| 58 | ; if made exempt or cat a is hardship
|
|---|
| 59 | I $P(IBDATA,"^",10)="",$P(IBDATA,"^",19)=1 S IBEXREA=$S(CODE="P":130,CODE="C":110,CODE="A":2010,1:"") ; means test logic
|
|---|
| 60 | ;
|
|---|
| 61 | I $P(IBDATA,"^",10)="",$P(IBDATA,"^",19)=2 S IBEXREA=$S(CODE="P":130,CODE="N":110,CODE="E":2010,1:"") ; income test logic
|
|---|
| 62 | ;
|
|---|
| 63 | ; -- if adjudicated cat a set to exempt if means test set to non-exempt
|
|---|
| 64 | I 'IBEXREA,$P(IBDATA,"^",19)=1 S IBEXREA=$S($$CODE^IBAMTED1(IBDATA)="A":150,$$CODE^IBAMTED1(IBDATA)="C":140,1:"") ; means test logic
|
|---|
| 65 | ;
|
|---|
| 66 | I 'IBEXREA,$P(IBDATA,"^",19)=2 S IBEXREA=$S($$CODE^IBAMTED1(IBDATA)="E":150,$$CODE^IBAMTED1(IBDATA)="N":140,1:"") ; income test logic
|
|---|
| 67 | ;
|
|---|
| 68 | MTDONE I IBEXREA S $P(STATUS,"^",3)=$O(^IBE(354.2,"ACODE",+IBEXREA,0))
|
|---|
| 69 | ;
|
|---|
| 70 | MTCOMPQ Q $P(STATUS,"^",3)_"^"_$P(STATUS,"^",2)
|
|---|
| 71 | ;
|
|---|
| 72 | MOSTR(X1,IBEXREA) ; -- if status date is most recent but last exemption date
|
|---|
| 73 | ; is later, inactivate last exemption
|
|---|
| 74 | ;
|
|---|
| 75 | ; -- input X1 = date of most recent status (+dgmta from event driver)
|
|---|
| 76 | ; IBEXREA= point to 354.2 for new exemption
|
|---|
| 77 | ;
|
|---|
| 78 | ; -- will define IBOLDAUT if not already defined
|
|---|
| 79 | ;
|
|---|
| 80 | Q:+$G(X1)'?7N
|
|---|
| 81 | Q:$G(IBOLDAUT)?7N
|
|---|
| 82 | Q:$L($P($G(^IBE(354.2,+IBEXREA,0)),"^",5))'=3 ; only for income exemptions
|
|---|
| 83 | N X
|
|---|
| 84 | S X=$$LSTAC^IBARXEU0(DFN) ; x =most recent exemption reason ^ date
|
|---|
| 85 | Q:+X1'<$P(X,"^",2) ;test date is less than most recent exemption date
|
|---|
| 86 | Q:+X1'>$$MINUS^IBARXEU0(DT) ; exemption date > year ago - don't inactivate more recent exemptions
|
|---|
| 87 | ;
|
|---|
| 88 | ; -- get last test date
|
|---|
| 89 | S Y=$G(^DGMT(408.31,+$$LST^DGMTCOU1(DFN,DT,3),0))
|
|---|
| 90 | ;
|
|---|
| 91 | ; -- if most recent test date is this test inactivate exemption
|
|---|
| 92 | I +X1=+Y S IBOLDAUT=$P(X,"^",2)
|
|---|
| 93 | Q
|
|---|
| 94 | ;
|
|---|
| 95 | REGAUTO ; -- will automatically update in background autoexempt
|
|---|
| 96 | ; called from registration
|
|---|
| 97 | ;
|
|---|
| 98 | S ZTREQ="@" ; always called as task, delete task
|
|---|
| 99 | G:'$G(DFN) REGQ
|
|---|
| 100 | N I,J,X,Y,IBEXREA,IBNSTAT,IBFORCE,IBOLDAUT,IBJOB
|
|---|
| 101 | S IBJOB=16
|
|---|
| 102 | S IBEXREA=$P($G(^IBA(354,DFN,0)),"^",5)
|
|---|
| 103 | I $P($G(^IBE(354.2,+IBEXREA,0)),"^",5)=2010 G REGQ ; don't overwrite hardships
|
|---|
| 104 | S IBNSTAT=$$STATUS^IBARXEU1(DFN,DT)
|
|---|
| 105 | I IBEXREA=+IBNSTAT G REGQ ; computes to same as on file
|
|---|
| 106 | ;
|
|---|
| 107 | ; -- not same must force new entry
|
|---|
| 108 | L +^IBA(354,DFN)
|
|---|
| 109 | D OLDAUT^IBARXEX1(IBNSTAT)
|
|---|
| 110 | S IBFORCE=$P(IBNSTAT,"^",2)
|
|---|
| 111 | D ADDEX^IBAUTL6(+IBNSTAT,$P(IBNSTAT,"^",2),1,1,$G(IBOLDAUT))
|
|---|
| 112 | L -^IBA(354,DFN)
|
|---|
| 113 | REGQ Q
|
|---|
