source: FOIAVistA/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGMTR.m@ 1397

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

initial load of FOIAVistA 6/30/08 version
File size: 9.2 KB
Line 
1DGMTR ;ALB/RMO,CAW,SCG,AEG,SCG,AEG,LBD - Check Means Test Requirements ; 7/8/05 2:30pm
2 ;;5.3;Registration;**45,93,114,137,141,147,177,182,146,305,326,314,344,402,426,456,495,672**;Aug 13, 1993
3 ;A patient requires a means test under the following conditions:
4 ; - Primary Eligibility is NSC OR patient is SC 0% non-compensable
5 ; - who is NOT receiving disability retirement from the military
6 ; - who is NOT eligible for medicaid
7 ; - who is NOT on a DOM ward
8 ; - who has NOT been means tested in the past year
9 ; - who is NOT a Purple Heart recipient
10 ; Input -- DFN Patient IEN
11 ; DGADDF Means Test Add Flag (Optional- default none)
12 ; (1 if using the 'Add a New Means Test' option)
13 ; DGMSGF Means Test Msg Flag (Optional- default none)
14 ; (1 to suppress messages)
15 ; Output -- DGREQF Means Test Require Flag
16 ; (1 if required and 0 if not required)
17 ; DGDOM1 DOM Patient Flag (defined and set to 1 if
18 ; patient currently on a DOM ward)
19 ; DGNOCOPF = 1 to suppress copay test prompt 0 otherwise
20 ; used in CP^DG10. Killed there as well.
21 ; If NOT using the 'Add a New Means Test' option,
22 ; a REQUIRED date of test will be added for the
23 ; patient if it is required.
24 ; If a means test is required and the current
25 ; status is NO LONGER REQUIRED, the last date of
26 ; test and current means test status will be
27 ; updated to REQUIRED.
28 ; If a means test is no longer required the
29 ; last date of test and the current means test
30 ; status will also be updated to NO LONGER REQUIRED.
31EN N DGCS,DGDOM,DGMT0,DGMTI,DGMTYPT,OLD,DGRGAUTO,DGQSENT,DGMTLTD,DGMDOD,DGMTDT
32 ;DG*5.3*146 change to exit if during patient merge process
33 Q:$G(VAFCA08)=1
34 ;DGMTCOR is needed if uploading copay test
35 I $G(RXPRIME)'="DGMTU4" N DGMTCOR
36 S (DGQSENT,DGREQF)=0,(OLD,DGMTYPT)=1
37 I $D(^DPT(DFN,.36)) S X=^(.36) D
38 . I $P($G(^DIC(8,+X,0)),"^",9)=5!($$SC(DFN)) S DGREQF=1
39 . I $P(X,"^",12)=1 S DGREQF=0 ;new field, DG 672
40 . I $P(X,"^",13)=1 S DGREQF=0 ;new field, DG 672
41 S (DGMTI,DGMT0)="",DGMTI=+$$LST^DGMTU(DFN)
42 S:DGMTI DGMT0=$G(^DGMT(408.31,DGMTI,0))
43 ;Added with DG*5.3*344
44 S:DGMTI DGMTDT=$P(DGMT0,U)
45 S DGMDOD=$P($G(^DPT(DFN,.35)),U)
46 I 'DGMTI,$G(DGMDOD) D EN^DGMTCOR S DGREQF=0 Q
47 I DGREQF S:$G(^DPT(DFN,.38)) DGREQF=0
48 I DGREQF D DOM S:$G(DGDOM) DGREQF=0
49 S DGCS=$P(DGMT0,"^",3)
50 S DGMTLTD=+DGMT0,DGNOCOPF=0
51 I +$G(DGMDOD) S DGNOCOPF=1
52 I DGCS S OLD=$$OLD^DGMTU4(+DGMT0)
53 ;Purple Heart Recipient ;brm 10/02/00 added 1 line below
54 I $P($G(^DPT(DFN,.53)),U)="Y" S DGREQF=0
55 D
56 .I DGREQF,DGCS=3,'OLD D REQ Q
57 .I DGREQF,'$G(DGADDF),((DGCS=6)!(DGCS=2)),$P(DGMT0,U,11)=1,DGMTLTD>2991005 S DGREQF=0,DGNOCOPF=1 Q
58 .; next line added 2/19/02 - DG*5.3*426
59 .I DGREQF,'$G(DGADDF),$G(DGCS)=6,+$P(DGMT0,U,14),+$P(DGMT0,U,11) S DGREQF=0,DGNOCOPF=1 Q
60 .I DGREQF,'$G(DGADDF),(('DGCS)!(OLD)),'$G(DGMDOD) D ADD Q
61 .I 'DGREQF,DGCS,DGCS'=3,'$G(DGDOM),'$G(DGMDOD),'+$G(IVMZ10F) D NOL Q
62 ;be sure to check whether or not patient is subject to RX copay!
63 D EN^DGMTCOR
64 Q
65 ;Check if patient is in a DOM
66 ; call to DOM checks if patient currently on a DOM ward
67 ; (called from EN)
68 ; call to DOM1 checks if patient on a DOM ward for a specific date
69 ; before call to DOM1 - N VAINDT,VADMVT,DGDOM,DGDOM1
70 ; S VAINDT=specific date
71 ; S DFN=Patient IEN
72 ; output - DGDOM & DGDOM1 (defined and set to 1 if
73 ; patient on a DOM ward for specific date)
74DOM N VAINDT,VADMVT
75DOM1 D ADM^VADPT2
76 I VADMVT,$P($G(^DG(43,1,0)),"^",21),$D(^DIC(42,+$P($G(^DGPM(VADMVT,0)),"^",6),0)),$P(^(0),"^",3)="D" S (DGDOM,DGDOM1)=1
77 Q
78SC(DFN) ;Check if patient is SC 0% non-compensable
79 ; Input -- DFN Patient IEN
80 ; Output -- 1=Yes and 0=No
81 ; No if:
82 ; No total annual VA check amount
83 ; POW STATUS INDICATOR is yes
84 ; Secondary Eligibility is one of the following:
85 ; A&A, NSC, VA PENSION
86 ; HOUSEBOUND, MEXICAN BORDER WAR, WWI, POW
87 N DG,DGE,DGF,Y
88 S Y=0
89 ;Primary eligibility is SC LESS THAN 50%
90 I $D(^DPT(DFN,.36)),$P($G(^DIC(8,+^(.36),0)),"^",9)=3 S Y=1
91 G:'Y SCQ
92 ;Service connected percentage is 0
93 I $P($G(^DPT(DFN,.3)),"^",2)'=0 S Y=0 G SCQ
94 ;No Total annual VA check amount
95 I $P($G(^DPT(DFN,.362)),"^",20) S Y=0 G SCQ
96 ;POW STATUS INDICATOR
97 I $P($G(^DPT(DFN,.52)),"^",5)="Y" S Y=0 G SCQ
98 ;Purple Heart Indicator
99 I $P($G(^DPT(DFN,.53)),"^")="Y" S Y=0 G SCQ
100 ;Secondary Eligibility
101 F DG=2,4,15:1:18 S DGE(DG)=""
102 S DG=0 F S DG=$O(^DPT(DFN,"E","B",DG)) Q:'DG D SELIG I DGF,$D(DGE(+DGF)) S Y=0 Q
103SCQ Q +$G(Y)
104ADD ;Add a required means test
105 N DGMTA,DGMTACT,DGMTDT,DGMTI,DGMTP,ERROR
106 W:'$G(DGMSGF) !,"MEANS TEST REQUIRED"
107 S DGMTACT="ADD" D PRIOR^DGMTEVT
108 S DGMTDT=DT D ADD^DGMTA
109 I DGMTI>0 S DGMTYPT=1 D
110 .N DATA S DATA(.03)=$$GETSTAT^DGMTH("R",1) I $$UPD^DGENDBS(408.31,DGMTI,.DATA)
111 .D GETINCOM^DGMTU4(DFN,DT)
112 .D QUE
113 I $G(IVMZ10)'="UPLOAD IN PROGRESS",'$$OPEN^IVMCQ2(DFN),'$$SENT^IVMCQ2(DFN) D QRYQUE2^IVMCQ2(DFN,$G(DUZ),0,$G(XQY)) S DGQSENT=1 I '$D(ZTQUEUED),'$G(DGMSGF) W !!,"Financial query queued to be sent to HEC..."
114 Q
115REQ ;Update means test status to REQUIRED
116 N DGMTA,AUTOCOMP,DGMTE,ERROR
117 ;may have set prior MT for means test upload
118 I $G(MTPRIME)'="DGMTU4" N DGMTP,DGMTACT S DGMTACT="STA" D PRIOR^DGMTEVT
119 S AUTOCOMP=$$AUTOCOMP(DGMTI)
120 ;if a test were auto-completed, don't want another being added inadvertently
121 I AUTOCOMP,$G(DGADDF) S DGADDF=0
122 I AUTOCOMP S DGCS=$P($G(^DGMT(408.31,DGMTI,0)),"^",3)
123 I $G(IVMZ10)'="UPLOAD IN PROGRESS",'AUTOCOMP,'$$OPEN^IVMCQ2(DFN),'$$SENT^IVMCQ2(DFN) D QRYQUE2^IVMCQ2(DFN,$G(DUZ),0,$G(XQY)) S DGQSENT=1 I '$D(ZTQUEUED),'$G(DGMSGF) W !!,"Financial query queued to be sent to HEC..."
124 I ('AUTOCOMP),('$G(DGMSGF)) W !,"MEANS TEST REQUIRED"
125 I (AUTOCOMP),('$G(DGMSGF)) W !,"CURRENT MEANS TEST STATUS IS ",$$GETNAME^DGMTH(DGCS)
126 S DGMTYPT=1
127 D QUE
128 Q
129AUTOCOMP(DGMTI) ;
130 ;Will either automatically complete the test (RX copay or means test)
131 ;based on the Test Determined Status, or will change the status to
132 ;Required for means tests or Incomplete for Rx copay tests
133 ;Input:
134 ; DGMTI - the ien of the test
135 ;Output:
136 ; Function value - 1 if the test was completed, 0 otherwise
137 N NODE0,NODE2,DATA,RET,LINKIEN,DGINR,DGINI,ERROR,CODE,TYPE,DFN,TDATE
138 S RET=0
139 Q:'$G(DGMTI) RET
140 S NODE0=$G(^DGMT(408.31,DGMTI,0))
141 Q:(NODE0="") RET
142 S TYPE=$P(NODE0,"^",19)
143 S DFN=$P(NODE0,"^",2)
144 S TDATE=+NODE0
145 S NODE2=$G(^DGMT(408.31,DGMTI,2))
146 ;get test-determined status code
147 S CODE=$$GETCODE^DGMTH($P(NODE2,"^",3))
148 ;if means test
149 I TYPE=1 D
150 .S DATA(.03)=$$GETSTAT^DGMTH("R",1),DATA(.17)=""
151 .I (CODE'=""),"ACGP"[CODE D
152 ..S RET=1
153 ..S DATA(.03)=$P(NODE2,"^",3)
154 ..;determine status if there is a hardship
155 ..I $P(NODE0,"^",20) D
156 ...S DATA(.03)=$$GETSTAT^DGMTH($S(CODE="P":"P",CODE="C"&($P(NODE0,U,27)>$P(NODE0,U,12)):"G",1:"A"),1)
157 ;RX copay test
158 I TYPE=2 D
159 .S DATA(.03)=$$GETSTAT^DGMTH("I",2),DATA(.17)=""
160 .I (CODE'=""),"EM"[CODE D
161 ..S RET=1
162 ..S DATA(.03)=$P(NODE2,"^",3)
163 I '$$UPD^DGENDBS(408.31,DGMTI,.DATA,.ERROR) W:'$G(DGMSGF) ERROR
164 ;restore the pointers from the Income Relation file (408.22) to this
165 ;test, using the linked test
166 S LINKIEN=$P(NODE2,"^",6)
167 I LINKIEN D
168 .S DGINI=0 F S DGINI=$O(^DGMT(408.22,"AMT",LINKIEN,DFN,DGINI)) Q:'DGINI S DGINR=$O(^DGMT(408.22,"AMT",LINKIEN,DFN,DGINI,"")) I $P($G(^DGMT(408.22,+DGINR,"MT")),"^")]"" D
169 ..K DATA
170 ..S DATA(31)=DGMTI
171 ..I $$UPD^DGENDBS(408.22,+DGINR,.DATA)
172 D GETINCOM^DGMTU4(DFN,TDATE)
173 Q RET
174NOL ;Update means test status to NO LONGER REQUIRED
175 N DGMTA,DGINI,DGINR,DGMTDT,DATA
176 W:'$G(DGMSGF) !,"MEANS TEST NO LONGER REQUIRED"
177 ;may have set prior MT for means test upload
178 I $G(MTPRIME)'="DGMTU4" N DGMTP,DGMTACT S DGMTACT="STA" D PRIOR^DGMTEVT
179 ;save the Test Determined Status
180 D SAVESTAT^DGMTU4(DGMTI)
181 S DATA(.03)=3,DATA(.17)=DT I $$UPD^DGENDBS(408.31,DGMTI,.DATA)
182 D QUE
183 ;create a Rx copay test based on MT if needed
184 D COPYRX^DGMTR1(DFN,DGMTI)
185NOLQ Q
186SET ;Set Cross-reference
187 N D0,DA,DIV,DGIX,X
188 S DA=DGIEN,X=DGVAL,DGIX=0
189 F S DGIX=$O(^DD(DGFL,DGFLD,1,DGIX)) Q:'DGIX X ^(DGIX,1) S X=DGVAL
190 Q
191KILL ;Kill Cross-reference
192 N D0,DA,DIV,DGIX,X
193 S DA=DGIEN,X=DGVAL,DGIX=0
194 F S DGIX=$O(^DD(DGFL,DGFLD,1,DGIX)) Q:'DGIX X ^(DGIX,2) S X=DGVAL
195 Q
196QUE ;Queue means test event driver
197 D AFTER^DGMTEVT
198 S ZTDESC="MEANS TEST EVENT DRIVER",ZTDTH=$H,ZTRTN="EN^DGMTEVT"
199 F I="DFN","DGMTACT","DGMTI","DGMTP","DGMTA","DGMTYPT" S ZTSAVE(I)=""
200 S ZTSAVE("DGMTINF")=1
201 I $D(IVMZ10) S ZTSAVE("IVMZ10")=""
202 I $D(DGENUPLD) S ZTSAVE("DGENUPLD")=""
203 S ZTIO="" D ^%ZTLOAD
204 K ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE,ZTSK
205 Q
206SELIG ;Check if secondary eligibility code missing from ELIGIBILITY CODE
207 ;file (#8) or entry in file #8 not pointing to MAS ELIGIBILITY
208 ;CODE file (#8.1)
209 N DGTXT
210 S DGF=$G(^DIC(8,+DG,0)) I DGF="" D Q
211 .S DGTXT(4)="Entry with an IEN OF "_DG_" missing from"
212 .S DGTXT(5)="the ELIGIBILITY CODE file (#8)"
213 .D MAIL^DGMTR1
214 .Q
215 S DGF=$P(DGF,"^",9) I DGF=""!('$D(^DIC(8.1,+DGF,0))) D
216 .S DGTXT(4)="ELIGIBILITY CODE file (#8) entry with an IEN OF "_DG_" doesn't"
217 .S DGTXT(5)="have a valid pointer to the MAS ELIGIBILITY CODE file (#8.1)"
218 .D MAIL^DGMTR1
219 .S DGF=""
220 .Q
221 Q
Note: See TracBrowser for help on using the repository browser.