source: WorldVistAEHR/trunk/r/ENROLLMENT_APPLICATION_SYSTEM-EAS/EASECSCC.m@ 837

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

initial load of WorldVistAEHR
File size: 6.6 KB
Line 
1EASECSCC ;ALB/LBD - LTC Co-Pay Test Screen Completion;13 AUG 2001 ; 3/20/03 2:24pm
2 ;;1.0;ENROLLMENT APPLICATION SYSTEM;**5,7,34,40**;Mar 15, 2001
3 ;
4 ;NOTE: This routine was modified from DGMTSCC for LTC Co-pay
5 ; Input -- DFN Patient IEN
6 ; DGMTACT Menu Action
7 ; DGMTDT Date of Test
8 ; DGMTYPT Type of Test 3=LTC COPAY
9 ; DGMTPAR Annual Means Test Parameters
10 ; DGMTI Annual Means Test IEN
11 ; DGVINI Veteran Individual Annual Income IEN
12 ; DGVIRI Veteran Income Relation IEN
13 ; DGVPRI Veteran Patient Relation IEN
14 ; Output -- DGERR 1=INCOMPLETE and 0=COMPLETE
15 ;
16EN N DGCAT,DGCOMF,DGDC,DGDET,DGIN0,DGIN1,DGIN2,DGINT,DGINTF,DGMTS,DGNC,DGND,DGNWT,DGNWTF,DGREF1,DGSP,DGTYC,DGTHA,DGTHB,DGVIR0,DGCOPS,DGCOST,DGRE,DGSTA,DGAGR
17 S DGERR=0
18 S DGCOMF=1 D DEP^EASECSU3,INC^EASECSU3
19 ; If veteran's income is below the threshold then exempt from LTC copay
20 ; LTC III (EAS*1*34) modified to make vet with $0 income exempt
21 I DGINT'>+$$THRES^IBARXEU1(DGMTDT,1,0) D G Q
22 .D EXMPT(DFN,DGMTI,12)
23 .D PRT
24 ; Check if test can be completed
25 D CHK I DGERR W !?3,*7,"LTC copay test cannot be completed." G Q
26 ; Did vet refuse to give income info
27 I 'DGINTF,'DGNWTF S DGREF1="" D G Q:$D(DTOUT)!($D(DUOUT))
28 .D REF
29 .I $D(DGREF) S DGSTA="NON-EXEMPT"
30 ; Get test status (Exempt or Non-Exempt)
31 D STA G Q:$D(DTOUT)!($D(DUOUT))
32 ; Does vet agree to pay co-payments
33 I $G(DGSTA)="NON-EXEMPT" D AGREE G Q:$D(DTOUT)!($D(DUOUT))
34UPD S DA=DGMTI,DIE="^DGMT(408.31,",DIE("NO^")="",DR="[EASEC COMPLETE LTC CO-PAY TEST]" D ^DIE K DA,DIE,DR I '$D(DGFIN) S DGERR=1 G Q
35 W !?3,"...The LTC copay test has been completed with a status of ",DGSTA,"..."
36 D PRT
37 ;
38Q K DGFIN,DGREF,DTOUT,DUOUT,Y
39 Q
40 ;
41COM ;Check if user wants to complete the LTC co-pay test
42 N DIR
43 S DIR("A")="Do you wish to complete the LTC copay test"
44 S DIR("B")="YES",DIR(0)="Y" D ^DIR
45 Q
46 ;
47REF ;Check if patient declines to provide income information
48 N DIR,Y
49 S DIR("A")="Does veteran decline to give income information"
50 I $P($G(^DGMT(408.31,DGMTI,0)),"^",14)]"" S DIR("B")=$$YN^DGMTSCU1($P(^(0),"^",14))
51 S:'$D(DIR("B")) DIR("B")="NO"
52 S DIR("?")="Answer 'Y' or 'N'."
53 S DIR("?",1)="Enter whether the veteran declines to provide current income information."
54 S DIR(0)="Y" D ^DIR K DIR G REFQ:$D(DTOUT)!($D(DUOUT))
55 S:Y DGREF=""
56REFQ Q
57 ;
58CHK ;Check if LTC copay test can be completed
59 ; For LTC III (EAS*1*34) removed check if expenses greater than income
60 N DGA,DGD,DGDEP,DGREL,DGL,DGM,I
61 D GETREL^DGMTU11(DFN,"CS",$E(DGMTDT,1,3)_"0000",$S($G(DGMTI):DGMTI,1:""))
62 S DGM=$P(DGVIR0,"^",14),DGL=$P(DGVIR0,"^",17),DGD=$P(DGVIR0,"^",8)
63 I DGM="" W !?3,"Marital section must be completed." S DGERR=1
64 ; For LTC IV (EAS*1*40) added check for legally separated
65 I DGM,'DGL,'$D(DGREL("S")) W !?3,"Married is 'YES'. An active spouse for this LTC copay test does not exist." S DGERR=1
66 I 'DGM,$D(DGREL("S")) W !?3,"An active spouse exists for this LTC copay test. Married should be 'YES'." S DGERR=1
67 I DGD']"" W !?3,"Dependent Children section must be completed." S DGERR=1
68 I DGD,'$D(DGREL("C")) W !?3,"Dependent Children is 'YES'. No active children exist." S DGERR=1
69 I 'DGD,$D(DGREL("C")) W !?3,"Active children exist. Dependent Children should be 'YES'." S DGERR=1
70 Q:$G(DGERR)
71 N CNT,ACT,DGDEP,FLAG,DGINCP
72 D INIT^EASECDEP S CNT=0 D
73 .F S CNT=$O(DGDEP(CNT)) Q:'CNT I $P(DGDEP(CNT),U,2)="SPOUSE" D Q:$G(DGERR)
74 ..D GETIENS^EASECU2(DFN,$P(DGDEP(CNT),U,20),DGMTDT)
75 ..S DGINCP=$G(^DGMT(408.22,+DGIRI,"MT")) S:DGINCP FLAG=$G(FLAG)+1
76 ..I $G(FLAG)>1 W !?3,"Patient has more than one spouse for this LTC copay test." S DGERR=1
77 Q
78 ;
79STA ;Ask test status
80 N DIR,Y,SCRN
81 S DGMTS=$P($G(^DGMT(408.31,DGMTI,0)),U,3)
82 S DGRE=$P($G(^DGMT(408.31,DGMTI,2)),U,7)
83 I DGMTS S DGSTA=$P($G(^DG(408.32,DGMTS,0)),U)
84 I '$D(DGSTA) S DGSTA="NON-EXEMPT"
85 I DGSTA="EXEMPT",("12"[DGRE),$G(DGINT)>+$$THRES^IBARXEU1(DGMTDT,1,0) S DGSTA="NON-EXEMPT"
86 I DGSTA="EXEMPT",$G(DGNSTA)="NON-EXEMPT" S DGSTA="NON-EXEMPT"
87 S DIR("A")="LTC Copay Test Status" S DIR("B")=DGSTA
88 S DIR(0)="P^408.32:EM",DIR("S")="I $P(^(0),U,19)=3"
89 D ^DIR K DIR Q:'Y!($D(DTOUT))!($D(DUOUT))
90 S DGMTS=+Y,DGSTA=$P(Y,U,2) Q:DGSTA="NON-EXEMPT"
91 ;If Exempt, ask reason for exemption
92 S DIR("A")="Reason for Exemption"
93 I DGRE S DIR("B")=$P($G(^EAS(714.1,DGRE,0)),U)
94 ; Screen the look-up on file #714.1. Exemption reasons 1, 2 and 12
95 ; will be screened out unless this is the call from the Edit option
96 ; (DGEFLG=1) and only reason 1 is screened out.
97 S SCRN="2^12^" S:$G(DGEFLG) SCRN=""
98 S DIR("S")="I $P(^(0),U,2),""^1^"_SCRN_"""'[(U_Y_U)"
99 S DIR(0)="P^714.1:EM" D ^DIR K DIR I 'Y!($D(DTOUT))!($D(DUOUT)) D G STA
100 .W !!,"A reason for exemption must be entered for an Exempt status.",!
101 S DGRE=+Y
102 Q
103AGREE ;Ask if vet agrees to pay co-payment
104 N DIR,Y
105 S DIR("A")="Does the veteran agree to pay copayments"
106 I $P($G(^DGMT(408.31,DGMTI,0)),U,11)]"" S DIR("B")=$$YN^DGMTSCU1($P(^(0),U,11))
107 S:'$D(DIR("B")) DIR("B")="YES"
108 S DIR("?")="Answer 'Y' or 'N'."
109 S DIR("?",1)="Enter in this field whether the veteran agrees to pay the"
110 S DIR("?",2)="LTC copayments. The veteran must also sign the 1010-EC form"
111 S DIR("?",3)="agreeing to pay the copayments. If the veteran does not agree"
112 S DIR("?",4)="to pay the copayments, the veteran becomes ineligible to"
113 S DIR("?",5)="receive extended care services."
114 S DIR(0)="Y" D ^DIR K DIR Q:$D(DTOUT)!($D(DUOUT))
115 S DGAGR=Y
116 Q
117PRT ;Print Extended Care Services test (1010EC)
118 N DIR,Y,X,ZTSK
119 S DIR("A")="PRINT 10-10EC"
120 S DIR("B")="YES",DIR(0)="Y" D ^DIR G PRTQ:'Y!($D(DTOUT))!($D(DUOUT))
121 S ZTSK=$$QUE^EASEC10E(DFN,DGMTI)
122PRTQ Q
123 ;
124EXMPT(DFN,DGMTI,EX) ; Veteran is exempt from LTC co-payments
125 ; Complete LTC co-pay test in Annual Means Test file (#408.31)
126 ; Input -- DFN Patient IEN
127 ; DGMTI Annual Means Test IEN
128 ; EX Copay exemption code
129 ; 1 = SC compensable disability
130 ; 2 = NSC, single, receiving VA pension (no A&A, HB)
131 ; or
132 ; Income (last year) is below single pension threshold
133 ; 12 = Income (current year) is below single pension threshold
134 Q:'DGMTI Q:'EX
135 N DATA,I
136 W !! F I=1:1:80 W "="
137 W !!,?10,"Veteran is EXEMPT from Long Term Care copayments."
138 W !,?10,"Reason for Exemption: ",$P($G(^EAS(714.1,EX,0)),U)
139 W !! F I=1:1:80 W "="
140 W !!
141 S DATA(.03)=$O(^DG(408.32,"C","X","")),DATA(2.07)=EX,DATA(.06)=DUZ
142 S (DATA(.07),DATA(2.02))=$$NOW^XLFDT
143 S DATA(.04)=$G(DGINT),DATA(.05)=$G(DGNWT),DATA(.15)=$G(DGDET)
144 S DATA(.18)=$G(DGND),DATA(2.08)=$P($$GETLTC4^EASECMT(DFN),U,1)
145 S DATA(.14)=$S($D(DGREF):1,1:0) ;LTC III (EAS*1*34)
146 I $$UPD^DGENDBS(408.31,DGMTI,.DATA) Q
147 W !,"ERROR: COULD NOT UPDATE LTC COPAY TEST",!!
148 Q
Note: See TracBrowser for help on using the repository browser.