source: FOIAVistA/trunk/r/ENROLLMENT_APPLICATION_SYSTEM-EAS/EASECCAL.m@ 1757

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

initial load of FOIAVistA 6/30/08 version

File size: 4.1 KB
Line 
1EASECCAL ;ALB/LBD - Calculate LTC copayment ;27 AUG 2001
2 ;;1.0;ENROLLMENT APPLICATION SYSTEM;**5,7,19,34,39,40**;Mar 15, 2001
3 ;
4 ; Input -- DFN Patient IEN
5 ; MNTH Last day of month for the LTC copay calculation
6 ; in FM format (e.g. 3020131)
7 ; LOS (Length of stay) The number of days in the patient's
8 ; LTC episode
9 ; Output -- COPAY String containing copayment calculation
10 ; = 0: no completed LTC copay test on file
11 ; piece 1: LTC copay test status
12 ; (1=Exempt; 2=Non-Exempt)
13 ; 2: If Exempt, Reason for Exemption
14 ; (IEN to file #714.1)
15 ; 3: Calculated LTC copayment for IP
16 ; (1-180 days)
17 ; 4: Calculated LTC copayment for IP
18 ; (181+ days)
19 ; 5: Calculated LTC copayment for OP
20 ;
21COPAY(DFN,MNTH,LOS) ;
22 N COPAY,DAYS,MX,IPDR,OPDR,IPMAX,OPMAX,LST,DGMT,DGMTI,DGMTDT,DGSTA,DGEXR
23 N ERR,X1,X2,INC,EXP,AST,ALLOW,DGSP,SRIC
24 S COPAY=0
25 I 'DFN!('MNTH) G Q
26 S LOS=+$G(LOS),DAYS=$E(MNTH,6,7)
27 ; Get maximum daily rate for LTC copayments
28 ; DBIA #3717
29 S MX=$$MAXRATE^IBAECU(MNTH),OPDR=$P(MX,U),IPDR=$P(MX,U,2) I 'OPDR!('IPDR) G Q
30 ; Calculate maximum copayment for the month
31 S OPMAX=DAYS*OPDR,IPMAX=DAYS*IPDR
32 ; Get last completed LTC copay test
33 S LST=$$LST^EASECU(DFN,MNTH,3) I +LST=0 G Q
34 S DGMTI=$P(LST,U),DGMT(0)=$G(^DGMT(408.31,DGMTI,0)) I 'DGMT(0) G Q
35 S DGMTDT=+DGMT(0),DGSTA=$P($G(^DG(408.32,+$P(DGMT(0),U,3),0)),U,1)
36 S DGEXR=$P($G(^DGMT(408.31,DGMTI,2)),U,7)
37 ; If LTC copay test status is neither NON-EXEMPT nor EXEMPT, quit
38 I DGSTA'="NON-EXEMPT",DGSTA'="EXEMPT" G Q
39 ; If LTC copay test is more than a year old and the veteran does
40 ; not have an exemption for eligibility (Compensable SC) or LTC
41 ; before 11/30/99, quit (Added for LTC Phase III - EAS*1*34)
42 ;S X1=MNTH,X2=DGMTDT D ^%DTC I X>365,"^1^4^"'[(U_DGEXR_U) G Q
43 S COPAY=$S(DGSTA="EXEMPT":1,1:2)_U
44 ; If test status = 'EXEMPT', get Reason for Exemption
45 I DGSTA="EXEMPT" S COPAY=COPAY_DGEXR
46 ; If veteran declined to give financial info, copay = max monthly copay
47 I $P(DGMT(0),U,14) S COPAY=COPAY_U_IPMAX_U_IPMAX_U_OPMAX G Q
48 ; Get total income, assets and expenses for veteran (and spouse)
49 D FINTOT I $G(ERR) D G Q
50 .I +COPAY=1 Q
51 .;no financial data but veteran agreed to pay copayments, copay = max
52 .I $P(DGMT(0),U,11) S COPAY=COPAY_U_IPMAX_U_IPMAX_U_OPMAX Q
53 .S COPAY=0
54 ; Calculate copayments
55 D CALC
56Q ; Quit and return COPAY
57 Q COPAY
58 ;
59FINTOT ; Get total income, assets and expenses for veteran (and spouse)
60 N DGDC,DGDEP,DGDET,DGERR,DGIN0,DGIN1,DGIN2,DGINI,DGINT,DGINTF,DGIRI
61 N DGNC,DGND,DGNWT,DGNWTF,DGPRI,DGVINI,DGVIR0,DGVIRI
62 S ERR=0
63 S DGPRI=$O(^DGPR(408.12,"C",DFN_";DPT(",0)) I 'DGPRI S ERR=1 Q
64 D GETIENS^EASECU2(DFN,DGPRI,DGMTDT) I '$G(DGIRI),'$G(DGINI) S ERR=1 Q
65 S DGVIRI=DGIRI,DGVINI=DGINI
66 D DEP^EASECSU3
67 D INC^EASECSU3
68 I DGINT=0,DGDET=0,DGNWT=0 S ERR=1 Q
69 ; Does spouse reside in community?
70 S SRIC=$P(DGVIR0,U,16)
71 ; Divide income and expense totals by 12 to get monthly amounts
72 S INC=DGINT/12,EXP=DGDET/12,AST=DGNWT
73 ; Calculate total monthly allowance:
74 ; 20*number of days in month*(veteran+spouse(if married and spouse
75 ; resides in the community))
76 S ALLOW=20*DAYS*(1+SRIC)
77 Q
78 ;
79CALC ; Calculate copayments
80 N CCPY,OPCPY,IPCPY1,IPCPY2,TINC,TEXP,TAST,OVR180,IPRPT,CPYFLG,EASADM
81 ; Calculation for IP services up to 180 days and OP services:
82 ; Income-Allowance-Expenses
83 S CCPY=INC-ALLOW-EXP
84 S (OPCPY,IPCPY1)=$S(CCPY>0:(CCPY+.5)\1,1:0)
85 ; Calculation for IP services 181+ days, add in assets
86 S IPCPY2=0 I LOS>180 D
87 . S TEXP=0 I DGSP,SRIC S TEXP=TEXP+EXP
88 . S TINC=INC,TAST=AST,(OVR180,IPRPT)=1,CPYFLG=0
89 . S EASADM=$$FMADD^XLFDT(MNTH,-LOS)
90 . ; Get value of assets after spenddown is applied
91 . S TAST=$$ASSET^EASECPC1
92 . S CCPY=CCPY+TAST
93 . ;If veteran is single or spouse does not reside in the community,
94 . ;add expenses back in
95 . I 'DGSP!('SRIC) S CCPY=CCPY+EXP
96 . S IPCPY2=(CCPY+.5)\1 I IPCPY2<0 S IPCPY2=0
97 S COPAY=COPAY_U_IPCPY1_U_IPCPY2_U_OPCPY
98 Q
Note: See TracBrowser for help on using the repository browser.