source: WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBARXEU5.m@ 1259

Last change on this file since 1259 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR

File size: 4.2 KB
Line 
1IBARXEU5 ;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 ;
5DIFF ; -- 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 ;
39DIFFQ Q
40 ;
41MTCOMP(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 ;
68MTDONE I IBEXREA S $P(STATUS,"^",3)=$O(^IBE(354.2,"ACODE",+IBEXREA,0))
69 ;
70MTCOMPQ Q $P(STATUS,"^",3)_"^"_$P(STATUS,"^",2)
71 ;
72MOSTR(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 ;
95REGAUTO ; -- 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)
113REGQ Q
Note: See TracBrowser for help on using the repository browser.