- IBARXEU5 ;AAS/ALB - RX EXEMPTION UTILITY ROUTINE (CONT.) ; 2-NOV-92
- ;;2.0;INTEGRATED BILLING;**20,112,153**;21-MAR-94
- ;;Per VHA Directive 10-93-142, this routine should not be modified.
- ;
- DIFF ; -- supported call for mas
- ; -- compare current exemption reason and date with what currently
- ; computes from the patient record. Automatically update if needed.
- ; input: dfn = patient to update
- ; Ibdt = date of change (optional, default is dt)
- ; output: none
- ;
- N I,J,X,Y,IBADDE,IBEXDA,IBMESS,IBDT,IBX,IBEXREAN,IBEXREAO,IBFORCE,IBOLDAUT,IBJOB,IBWHER
- S IBJOB=16,IBWHER=14
- G:'$G(DFN) DIFFQ
- I $G(IBDT)'?7N S IBDT=DT
- ;
- ; -- if not already in file, wait until an rx is issued
- I '$G(^IBA(354,DFN,0)) G DIFFQ
- ;
- ; -- compute old exemption reason, exemption date
- S IBX=$G(^IBA(354,DFN,0)),IBEXREAO=$P(IBX,"^",5)_"^"_$P(IBX,"^",3)
- I $P($G(^IBE(354.2,+IBEXREAO,0)),"^",5)=2010 G DIFFQ ; is hardship don't update
- ; -- compute new exemption reason
- S IBEXREAN=$$STATUS^IBARXEU1(DFN,IBDT)
- ;
- ; -- quit if not current exemption
- I $$PLUS^IBARXEU0($P(IBEXREAN,"^",2))<DT G DIFFQ
- ;
- ; -- quit if same exemption reason
- I +IBEXREAN=+IBEXREAO G DIFFQ
- ;
- ; -- not same so update
- D UP1^IBARXEPV
- ;I $L($P($G(^IBE(354.2,+IBEXREAN,0)),"^",5))>2 D OLDAUT^IBARXEX1(IBEXREAN)
- ;S IBFORCE=$P(IBEXREAN,"^",2)
- ;D MOSTR($P(IBEXREAN,"^",2),+IBEXREAN)
- ;D ADDEX^IBAUTL6(+IBEXREAN,$P(IBEXREAN,"^",2),1,1,IBOLDAUT)
- ;
- DIFFQ Q
- ;
- MTCOMP(STATUS,IBDATA) ; -- compare income determination with current mt status
- ;
- I '$$NETW^IBARXEU1 G MTCOMP ; don't use net worth in computation
- ;
- N IBEXREA,CODE S IBEXREA=""
- ;
- ; -- incomplete and required tests are no data
- ;I CODE="I"!(CODE="R") S IBEXREA=210 G MTDONE
- 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
- ;
- ; -- quit if not pending adjuducation
- I +STATUS'=3 G MTCOMPQ
- ;
- S CODE=$$CODE^IBAMTED1(IBDATA)
- ;
- ; -- see if mt or income test was adjudicated
- ; if not sent to ajudication is non-exempt
- ; if made exempt or cat a is hardship
- I $P(IBDATA,"^",10)="",$P(IBDATA,"^",19)=1 S IBEXREA=$S(CODE="P":130,CODE="C":110,CODE="A":2010,1:"") ; means test logic
- ;
- I $P(IBDATA,"^",10)="",$P(IBDATA,"^",19)=2 S IBEXREA=$S(CODE="P":130,CODE="N":110,CODE="E":2010,1:"") ; income test logic
- ;
- ; -- if adjudicated cat a set to exempt if means test set to non-exempt
- I 'IBEXREA,$P(IBDATA,"^",19)=1 S IBEXREA=$S($$CODE^IBAMTED1(IBDATA)="A":150,$$CODE^IBAMTED1(IBDATA)="C":140,1:"") ; means test logic
- ;
- I 'IBEXREA,$P(IBDATA,"^",19)=2 S IBEXREA=$S($$CODE^IBAMTED1(IBDATA)="E":150,$$CODE^IBAMTED1(IBDATA)="N":140,1:"") ; income test logic
- ;
- MTDONE I IBEXREA S $P(STATUS,"^",3)=$O(^IBE(354.2,"ACODE",+IBEXREA,0))
- ;
- MTCOMPQ Q $P(STATUS,"^",3)_"^"_$P(STATUS,"^",2)
- ;
- MOSTR(X1,IBEXREA) ; -- if status date is most recent but last exemption date
- ; is later, inactivate last exemption
- ;
- ; -- input X1 = date of most recent status (+dgmta from event driver)
- ; IBEXREA= point to 354.2 for new exemption
- ;
- ; -- will define IBOLDAUT if not already defined
- ;
- Q:+$G(X1)'?7N
- Q:$G(IBOLDAUT)?7N
- Q:$L($P($G(^IBE(354.2,+IBEXREA,0)),"^",5))'=3 ; only for income exemptions
- N X
- S X=$$LSTAC^IBARXEU0(DFN) ; x =most recent exemption reason ^ date
- Q:+X1'<$P(X,"^",2) ;test date is less than most recent exemption date
- Q:+X1'>$$MINUS^IBARXEU0(DT) ; exemption date > year ago - don't inactivate more recent exemptions
- ;
- ; -- get last test date
- S Y=$G(^DGMT(408.31,+$$LST^DGMTCOU1(DFN,DT,3),0))
- ;
- ; -- if most recent test date is this test inactivate exemption
- I +X1=+Y S IBOLDAUT=$P(X,"^",2)
- Q
- ;
- REGAUTO ; -- will automatically update in background autoexempt
- ; called from registration
- ;
- S ZTREQ="@" ; always called as task, delete task
- G:'$G(DFN) REGQ
- N I,J,X,Y,IBEXREA,IBNSTAT,IBFORCE,IBOLDAUT,IBJOB
- S IBJOB=16
- S IBEXREA=$P($G(^IBA(354,DFN,0)),"^",5)
- I $P($G(^IBE(354.2,+IBEXREA,0)),"^",5)=2010 G REGQ ; don't overwrite hardships
- S IBNSTAT=$$STATUS^IBARXEU1(DFN,DT)
- I IBEXREA=+IBNSTAT G REGQ ; computes to same as on file
- ;
- ; -- not same must force new entry
- L +^IBA(354,DFN)
- D OLDAUT^IBARXEX1(IBNSTAT)
- S IBFORCE=$P(IBNSTAT,"^",2)
- D ADDEX^IBAUTL6(+IBNSTAT,$P(IBNSTAT,"^",2),1,1,$G(IBOLDAUT))
- L -^IBA(354,DFN)
- REGQ Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBARXEU5 4407 printed Feb 18, 2025@23:33:51 Page 2
- IBARXEU5 ;AAS/ALB - RX EXEMPTION UTILITY ROUTINE (CONT.) ; 2-NOV-92
- +1 ;;2.0;INTEGRATED BILLING;**20,112,153**;21-MAR-94
- +2 ;;Per VHA Directive 10-93-142, this routine should not be modified.
- +3 ;
- DIFF ; -- supported call for mas
- +1 ; -- compare current exemption reason and date with what currently
- +2 ; computes from the patient record. Automatically update if needed.
- +3 ; input: dfn = patient to update
- +4 ; Ibdt = date of change (optional, default is dt)
- +5 ; output: none
- +6 ;
- +7 NEW I,J,X,Y,IBADDE,IBEXDA,IBMESS,IBDT,IBX,IBEXREAN,IBEXREAO,IBFORCE,IBOLDAUT,IBJOB,IBWHER
- +8 SET IBJOB=16
- SET IBWHER=14
- +9 if '$GET(DFN)
- GOTO DIFFQ
- +10 IF $GET(IBDT)'?7N
- SET IBDT=DT
- +11 ;
- +12 ; -- if not already in file, wait until an rx is issued
- +13 IF '$GET(^IBA(354,DFN,0))
- GOTO DIFFQ
- +14 ;
- +15 ; -- compute old exemption reason, exemption date
- +16 SET IBX=$GET(^IBA(354,DFN,0))
- SET IBEXREAO=$PIECE(IBX,"^",5)_"^"_$PIECE(IBX,"^",3)
- +17 ; is hardship don't update
- IF $PIECE($GET(^IBE(354.2,+IBEXREAO,0)),"^",5)=2010
- GOTO DIFFQ
- +18 ; -- compute new exemption reason
- +19 SET IBEXREAN=$$STATUS^IBARXEU1(DFN,IBDT)
- +20 ;
- +21 ; -- quit if not current exemption
- +22 IF $$PLUS^IBARXEU0($PIECE(IBEXREAN,"^",2))<DT
- GOTO DIFFQ
- +23 ;
- +24 ; -- quit if same exemption reason
- +25 IF +IBEXREAN=+IBEXREAO
- GOTO DIFFQ
- +26 ;
- +27 ; -- not same so update
- +28 DO UP1^IBARXEPV
- +29 ;I $L($P($G(^IBE(354.2,+IBEXREAN,0)),"^",5))>2 D OLDAUT^IBARXEX1(IBEXREAN)
- +30 ;S IBFORCE=$P(IBEXREAN,"^",2)
- +31 ;D MOSTR($P(IBEXREAN,"^",2),+IBEXREAN)
- +32 ;D ADDEX^IBAUTL6(+IBEXREAN,$P(IBEXREAN,"^",2),1,1,IBOLDAUT)
- +33 ;
- DIFFQ QUIT
- +1 ;
- MTCOMP(STATUS,IBDATA) ; -- compare income determination with current mt status
- +1 ;
- +2 ; don't use net worth in computation
- IF '$$NETW^IBARXEU1
- GOTO MTCOMP
- +3 ;
- +4 NEW IBEXREA,CODE
- SET IBEXREA=""
- +5 ;
- +6 ; -- incomplete and required tests are no data
- +7 ;I CODE="I"!(CODE="R") S IBEXREA=210 G MTDONE
- +8 SET X=$PIECE(IBDATA,"^",3)
- IF X=1!(X=3)!(X=9)!(X=10)!($PIECE(IBDATA,"^",14))
- SET IBEXREA=$SELECT($PIECE(IBDATA,"^",14):110,1:210)
- GOTO MTDONE
- +9 ;
- +10 ; -- quit if not pending adjuducation
- +11 IF +STATUS'=3
- GOTO MTCOMPQ
- +12 ;
- +13 SET CODE=$$CODE^IBAMTED1(IBDATA)
- +14 ;
- +15 ; -- see if mt or income test was adjudicated
- +16 ; if not sent to ajudication is non-exempt
- +17 ; if made exempt or cat a is hardship
- +18 ; means test logic
- IF $PIECE(IBDATA,"^",10)=""
- IF $PIECE(IBDATA,"^",19)=1
- SET IBEXREA=$SELECT(CODE="P":130,CODE="C":110,CODE="A":2010,1:"")
- +19 ;
- +20 ; income test logic
- IF $PIECE(IBDATA,"^",10)=""
- IF $PIECE(IBDATA,"^",19)=2
- SET IBEXREA=$SELECT(CODE="P":130,CODE="N":110,CODE="E":2010,1:"")
- +21 ;
- +22 ; -- if adjudicated cat a set to exempt if means test set to non-exempt
- +23 ; means test logic
- IF 'IBEXREA
- IF $PIECE(IBDATA,"^",19)=1
- SET IBEXREA=$SELECT($$CODE^IBAMTED1(IBDATA)="A":150,$$CODE^IBAMTED1(IBDATA)="C":140,1:"")
- +24 ;
- +25 ; income test logic
- IF 'IBEXREA
- IF $PIECE(IBDATA,"^",19)=2
- SET IBEXREA=$SELECT($$CODE^IBAMTED1(IBDATA)="E":150,$$CODE^IBAMTED1(IBDATA)="N":140,1:"")
- +26 ;
- MTDONE IF IBEXREA
- SET $PIECE(STATUS,"^",3)=$ORDER(^IBE(354.2,"ACODE",+IBEXREA,0))
- +1 ;
- MTCOMPQ QUIT $PIECE(STATUS,"^",3)_"^"_$PIECE(STATUS,"^",2)
- +1 ;
- MOSTR(X1,IBEXREA) ; -- if status date is most recent but last exemption date
- +1 ; is later, inactivate last exemption
- +2 ;
- +3 ; -- input X1 = date of most recent status (+dgmta from event driver)
- +4 ; IBEXREA= point to 354.2 for new exemption
- +5 ;
- +6 ; -- will define IBOLDAUT if not already defined
- +7 ;
- +8 if +$GET(X1)'?7N
- QUIT
- +9 if $GET(IBOLDAUT)?7N
- QUIT
- +10 ; only for income exemptions
- if $LENGTH($PIECE($GET(^IBE(354.2,+IBEXREA,0)),"^",5))'=3
- QUIT
- +11 NEW X
- +12 ; x =most recent exemption reason ^ date
- SET X=$$LSTAC^IBARXEU0(DFN)
- +13 ;test date is less than most recent exemption date
- if +X1'<$PIECE(X,"^",2)
- QUIT
- +14 ; exemption date > year ago - don't inactivate more recent exemptions
- if +X1'>$$MINUS^IBARXEU0(DT)
- QUIT
- +15 ;
- +16 ; -- get last test date
- +17 SET Y=$GET(^DGMT(408.31,+$$LST^DGMTCOU1(DFN,DT,3),0))
- +18 ;
- +19 ; -- if most recent test date is this test inactivate exemption
- +20 IF +X1=+Y
- SET IBOLDAUT=$PIECE(X,"^",2)
- +21 QUIT
- +22 ;
- REGAUTO ; -- will automatically update in background autoexempt
- +1 ; called from registration
- +2 ;
- +3 ; always called as task, delete task
- SET ZTREQ="@"
- +4 if '$GET(DFN)
- GOTO REGQ
- +5 NEW I,J,X,Y,IBEXREA,IBNSTAT,IBFORCE,IBOLDAUT,IBJOB
- +6 SET IBJOB=16
- +7 SET IBEXREA=$PIECE($GET(^IBA(354,DFN,0)),"^",5)
- +8 ; don't overwrite hardships
- IF $PIECE($GET(^IBE(354.2,+IBEXREA,0)),"^",5)=2010
- GOTO REGQ
- +9 SET IBNSTAT=$$STATUS^IBARXEU1(DFN,DT)
- +10 ; computes to same as on file
- IF IBEXREA=+IBNSTAT
- GOTO REGQ
- +11 ;
- +12 ; -- not same must force new entry
- +13 LOCK +^IBA(354,DFN)
- +14 DO OLDAUT^IBARXEX1(IBNSTAT)
- +15 SET IBFORCE=$PIECE(IBNSTAT,"^",2)
- +16 DO ADDEX^IBAUTL6(+IBNSTAT,$PIECE(IBNSTAT,"^",2),1,1,$GET(IBOLDAUT))
- +17 LOCK -^IBA(354,DFN)
- REGQ QUIT