Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: IBARXEU5

IBARXEU5.m

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