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

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

initial load of FOIAVistA 6/30/08 version

File size: 9.0 KB
Line 
1DGMTU4 ;ALB/CJM,SCG,LBD,EG,PHH MEANS TEST UTILITES ; 06/07/2005
2 ;;5.3;Registration;**182,267,285,347,454,456,476,610,658**;Aug 13, 1993
3 ;
4GETSITE(DUZ) ;
5 ;Descripition: Gets the users station number. If not found, it will
6 ;return the station number of the primary facility.
7 ;
8 ;Input:
9 ; DUZ array, pass by reference
10 ;Output:
11 ; Function Value - station number with suffix
12 N FACILITY,STATION,CURSTN,CHILD,CIEN
13 S FACILITY=""
14 S:($G(DUZ)'=.5) FACILITY=$G(DUZ(2))
15 I 'FACILITY S FACILITY=+$$SITE^VASITE()
16 S:FACILITY STATION=$$STA^XUAF4(FACILITY)
17 S CURSTN=$P($$SITE^VASITE,"^",3)
18 I $D(STATION) D
19 .I STATION']"" D
20 ..D CHILDREN^XUAF4("CHILD","`"_FACILITY,"PARENT FACILITY")
21 ..S CIEN=0 F S CIEN=$O(CHILD("C",CIEN)) Q:'CIEN I CIEN=CURSTN S STATION=$$STA^XUAF4(CIEN) Q
22 ..I STATION']"" D
23 ...D CHILDREN^XUAF4("CHILD","`"_FACILITY,"VISN")
24 ...S CIEN=0 F S CIEN=$O(CHILD("C",CIEN)) Q:'CIEN I CIEN=CURSTN S STATION=$$STA^XUAF4(CIEN) Q
25 Q $G(STATION)
26 ;
27DATETIME(MTIEN) ;
28 ;Writes date/time stamp to means test record
29 N DATA
30 Q:$G(IVMZ10)="UPLOAD IN PROGRESS"
31 S DATA(2.02)=$$NOW^XLFDT
32 I $G(MTIEN),$D(^DGMT(408.31,MTIEN,0)) I $$UPD^DGENDBS(408.31,MTIEN,.DATA)
33 Q
34SAVESTAT(MTIEN,DGERR) ;
35 ;Save the Test Determined Status (#2.03) in the ANNUAL MEANS TEST file
36 ;(#408.31)
37 ;
38 ;Input:
39 ; MTIEN - IEN of 408.31
40 ; DGERR - (optional) 1 - Means or Copay Test is incomplete
41 ; 0 - Means or Copay Test is complete
42 ;
43 ;only current statuses of P, A, or C for Means Tests and
44 ;current status of M, or E for Copay Tests will be stored.
45 ;
46 ;if test is incomplete the Test Determined Status will be deleted.
47 ;
48 Q:('$G(MTIEN))
49 ;
50 N CODE,DATA,NODE0,TYPE
51 I $G(DGERR) S DATA(2.03)="" G SET
52 S NODE0=$G(^DGMT(408.31,MTIEN,0))
53 S TYPE=$P(NODE0,"^",19)
54 S CODE=$$GETCODE^DGMTH($P(NODE0,"^",3))
55 S:CODE="A" (DATA(.11),DATA(.14))=""
56 S DATA(2.03)=""
57 I TYPE=1,(CODE="N") Q
58 I TYPE=2,(CODE="L") Q
59 I TYPE=1,(CODE'=""),"CPAG"[CODE D
60 .S DATA(2.03)=$P(NODE0,"^",3)
61 .I $P(NODE0,"^",20) D
62 ..S DATA(2.03)=$$GETSTAT^DGMTH($S(CODE="P":"P",CODE="A"&(($P(NODE0,U,4)-$P(NODE0,U,15))'>$P(NODE0,U,27)):"G",1:"C"),1)
63 I TYPE=2,(CODE'=""),"ME"[CODE S DATA(2.03)=$P(NODE0,"^",3)
64SET I $$UPD^DGENDBS(408.31,MTIEN,.DATA)
65 Q
66MTPRIME(MTIEN) ;
67 ;Makes the means test MTIEN primary
68 ;
69 N DGREQF,DGDOM1,DGADDF,DGMSGF,DGMTACT,DGMTI,DGMTINF,DGMTP,DGMTA,TRIES,DATA,NODE,DFN,MTDATE,YREND,DGMTDC,IBPRIOR,MTPRIME,LSTNODE
70 Q:('$G(MTIEN))
71 S MTPRIME="DGMTU4"
72 S NODE=$G(^DGMT(408.31,MTIEN,0))
73 Q:(NODE="")
74 S DFN=$P($G(^DGMT(408.31,MTIEN,0)),"^",2)
75 Q:'DFN
76 Q:+$G(^DGMT(408.31,MTIEN,"PRIM")) ;already marked as primary!
77 S MTDATE=+NODE
78 Q:'MTDATE
79 Q:($P(NODE,"^",19)'=1)
80 ;
81 S DGMTACT="ADD"
82 D PRIOR^DGMTEVT
83 ;
84 ;marks any existing tests as non-primary - shouldn't be more than
85 ;one such test, but give it two tries
86 I '$$OLD(MTDATE) D
87 .S YREND=DT_.2359
88 E D
89 .S YREND=$E(MTDATE,1,3)_1231.9999
90 F TRIES=1,2 S NODE=$$LST^DGMTU(DFN,YREND,1) Q:'(+NODE) Q:($E($P(NODE,"^",2),1,3)'=$E(MTDATE,1,3)) D
91 .N DATA
92 .;set up for the event driver - should be treated as an edit
93 .S:(TRIES=1) DGMTACT="EDT",DGMTI=+NODE D PRIOR^DGMTEVT
94 .;set the old test to non-primary
95 .S DATA(2)=0 I $$UPD^DGENDBS(408.31,+NODE,.DATA)
96 ;
97 ;don't want any old RX copay tests as primary either - if needed, they can be auto-created based on the means test
98 F TRIES=1,2 S NODE=$$LST^DGMTU(DFN,YREND,2) Q:'(+NODE) Q:($E($P(NODE,"^",2),1,3)'=$E(MTDATE,1,3)) D
99 .N DATA
100 .;set the old test to non-primary
101 .S DATA(2)=0 I $$UPD^DGENDBS(408.31,+NODE,.DATA)
102 ;
103 ;mark this test as primary
104 K DATA S DATA(2)=1 I $$UPD^DGENDBS(408.31,MTIEN,.DATA)
105 ;
106 ; Get Last Primary Means Test irrespective of income year
107 S LSTNODE=$$LST^DGMTU(DFN)
108 ;if STATUS is REQUIRED & test is PRIMARY, then set it to NOT PRIMARY
109 ;if the uploaded test is MT COPAY REQUIRED
110 ; MT COPAY (CAT C) doesn't expire, which is why you have to
111 ; flip the test to Not Primary eg 02/01/2005
112 I $P(LSTNODE,U,4)="R",+$G(^DGMT(408.31,+LSTNODE,"PRIM")),$P(^DGMT(408.31,MTIEN,0),U,3)=6 D
113 . N DATA S DATA(2)=0 I $$UPD^DGENDBS(408.31,+LSTNODE,.DATA)
114 ;if means test is required and test is primary and not a CAT C,
115 ;and it hasn't expired, flip the test to Not Primary eg 02/23/2005
116 I $P(LSTNODE,U,4)="R",+$G(^DGMT(408.31,+LSTNODE,"PRIM")),$P(^DGMT(408.31,MTIEN,0),U,3)'=6,'$$OLD(MTDATE) D
117 . N DATA S DATA(2)=0 I $$UPD^DGENDBS(408.31,+LSTNODE,.DATA)
118 ;
119 ;If this is a Z10 upload, call the means test event driver and quit.
120 ;
121 I $G(IVMZ10)="UPLOAD IN PROGRESS" D Q
122 .S DGMTI=MTIEN
123 .S DGMTINF=1
124 .D QUE^DGMTR
125 ;
126 ;If the test is still in effect, need to do additional checks
127 ;and call event driver
128 ;
129 I '$$OLD(MTDATE) D
130 .;Mark this test as NO LONGER REQUIRED - calling EN^DGMTR will
131 .;change it back to its old status if required and will que the event
132 .;driver
133 .K DATA
134 .S DATA(.03)=$$GETSTAT^DGMTH("N",1)
135 .I $$UPD^DGENDBS(408.31,MTIEN,.DATA)
136 .S (DGADDF,DGMSGF)=1 ;don't want new test added or messages
137 .S DGMTI=MTIEN
138 .S DGMTINF=1
139 .;
140 .D EN^DGMTR
141 .;if the test wasn't required, maybe a Rx copay test is needed
142 .I '$G(DGREQF),'$G(DGDOM1) D COPYRX^DGMTR1(DFN,MTIEN)
143 Q
144 ;
145RXPRIME(RXIEN) ;
146 ;Makes phramacy copay test =RXIEN the primary test
147 ;
148 N DGREQF,DGDOM1,DGADDF,DGMSGF,DGMTACT,DGMTI,DGMTINF,DGMTP,DGMTA,TRIES,DATA,NODE,DFN,MTIEN,DGRAUTO,DGADDF,DGMTE,DGMTCOR,DGMT,YREND,RXPRIME,QUIT
149 ;
150 Q:('$G(RXIEN))
151 S RXPRIME="DGMTU4"
152 S QUIT=0
153 S NODE=$G(^DGMT(408.31,RXIEN,0))
154 Q:(NODE="")
155 S DFN=$P($G(^DGMT(408.31,RXIEN,0)),"^",2)
156 Q:'DFN
157 Q:+$G(^DGMT(408.31,RXIEN,"PRIM")) ;already marked as primary!
158 S MTDATE=+NODE
159 Q:'MTDATE
160 Q:($P(NODE,"^",19)'=2)
161 ;
162 S DGMTINF=1
163 ;
164 ;marks any existing tests as non-primary - shouldn't be more than
165 ;one such test, but give it two tries
166 ;
167 I '$$OLD(MTDATE) D
168 .S YREND=DT_.2359
169 E D
170 .S YREND=$E(MTDATE,1,3)_1231.9999
171 F TRIES=1,2 S NODE=$$LST^DGMTU(DFN,YREND,2) Q:'(+NODE) Q:($E($P(NODE,"^",2),1,3)'=$E(MTDATE,1,3)) D
172 .N DATA
173 .;set up for the event driver - should be treated as an edit
174 .S:(TRIES=1) DGMTACT="EDT",DGMTI=+NODE D PRIOR^DGMTEVT
175 .;set the old test to non-primary
176 .S DATA(2)=0 I $$UPD^DGENDBS(408.31,+NODE,.DATA)
177 ;
178 ;don't want any old means tests marked as primary - unless they are actually needed! In which case, do not make this Rx test primary.
179 F TRIES=1,2 S NODE=$$LST^DGMTU(DFN,YREND,1) Q:'(+NODE) Q:($E($P(NODE,"^",2),1,3)'=$E(MTDATE,1,3)) D
180 .N DATA
181 .I '$$OLD($P(NODE,"^",2)),$P(NODE,"^",4)'="","ACGP"[$P(NODE,"^",4) S QUIT=1 Q
182 .;set the old test to non-primary
183 .S DATA(2)=0 I $$UPD^DGENDBS(408.31,+NODE,.DATA)
184 ;
185 I QUIT G QRXPRIME
186 ;mark this test as primary - calling
187 ;EN^DGMTCOR will change it to NO LONGER APPLICABLE if appropriate
188 ;
189 K DATA
190 S DATA(2)=1 I $$UPD^DGENDBS(408.31,RXIEN,.DATA)
191 ;
192 ;If the test is still in effect, need to do additional checks
193 ;and call event driver
194 ;
195 I '$$OLD(MTDATE) D
196 .S DGMSGF=1,DGADDF=0 ;don't want new test added or messages
197 .;
198 .;EN^DGMTR will first create a stub for a required MT if needed, then
199 .;call ^DGMTCOR to set the status of the copay test
200 .D EN^DGMTR
201 .;
202 .;if the pharmacy copay test was determined to be required, than
203 .;que the event driver
204 .I DGMTCOR D
205 ..S DGMTACT="ADD"
206 ..D PRIOR^DGMTEVT
207 ..S DGMTI=RXIEN
208 ..D QUE^DGMTR
209QRXPRIME ;
210 Q
211 ;
212OLD(TESTDATE) ;
213 ;Checks if the date is older than 365 days. Returns 0 for no, 1 for yes
214 ;if the test is exactly 365 days,
215 ;it is considered expired eg 03/09/2005
216 I ($$FMDIFF^XLFDT(DT,TESTDATE)'<365) Q 1
217 Q 0
218 ;
219TRANSFER(DFN,FROM,TO) ;
220 ;transfers the Income Relations from the test=FROM to test=TO
221 ;
222 N DGINI,DGINR,DATA,ERROR
223 Q:'$G(DFN)
224 Q:'$G(FROM)
225 Q:'$G(TO)
226 Q:(FROM=TO)
227 S DGINI=0 F S DGINI=$O(^DGMT(408.22,"AMT",FROM,DFN,DGINI)) Q:'DGINI S DGINR=$O(^DGMT(408.22,"AMT",FROM,DFN,DGINI,"")) I $P($G(^DGMT(408.22,+DGINR,"MT")),"^")]"" D
228 .K DATA
229 .S DATA(31)=TO
230 .I $$UPD^DGENDBS(408.22,+DGINR,.DATA,.ERROR)
231 Q
232 ;
233GETINCOM(DFN,TDATE) ;
234 ;Makes sure Income Relations point to the right test
235 ;
236 ;Input:
237 ; DFN
238 ; TDATE -income year of test (uses $E(IVMMTDT,1,3))
239 ;Output: none. Repoints Income Relations if necessary
240 ;
241 N MTNODE,RXNODE,IVMMTDT,CODE,ACTVIEN
242 Q:'$G(TDATE)
243 Q:'$G(DFN)
244 ;
245 S IVMMTDT=$E(TDATE,1,3)_"1231.9"
246 S (CODE,ACTVIEN)=""
247 S MTNODE=$$LST^DGMTU(DFN,IVMMTDT,1) I $E($P(MTNODE,"^",2),1,3)'=$E(IVMMTDT,1,3) S MTNODE=""
248 S RXNODE=$$LST^DGMTU(DFN,IVMMTDT,2) I $E($P(RXNODE,"^",2),1,3)'=$E(IVMMTDT,1,3) S RXNODE=""
249 ;
250 D
251 .;determine which test has the associated income relations
252 .;
253 .I +MTNODE S CODE=$P(MTNODE,"^",4) I CODE'="",("ACGPR"[CODE) S ACTVIEN=+MTNODE Q
254 .I +RXNODE S CODE=$P(RXNODE,"^",4) I CODE'="",("EMI"[CODE) S ACTVIEN=+RXNODE Q
255 .I +MTNODE S ACTVIEN=+MTNODE Q
256 .I +RXNODE S ACTVIEN=+RXNODE Q
257 I ACTVIEN,+MTNODE,+RXNODE D TRANSFER^DGMTU4(DFN,$S((ACTVIEN=+MTNODE):+RXNODE,1:+MTNODE),ACTVIEN)
258 Q
259 ;
260CHKPT(DFN) ;
261 ; Cross check the CURRENT MEANS TEST STATUS in the PATIENT File (#2) with the
262 ; primary means test in the ANNUAL MEANS TEST File (#408.31). Update the
263 ; CURRENT MEANS TEST STATUS if the fields are out of synch.
264 ;
265 N PATMT,DGMTI,DATA
266 ;
267 Q:$G(DFN)'>0
268 Q:'$D(^DPT(DFN))
269 S PATMT=$$GET1^DIQ(2,DFN,.14,"I")
270 S DGMTI=+$$LST^DGMTU(DFN)
271 S DATA(.14)=$P($G(^DGMT(408.31,DGMTI,0)),U,3)
272 Q:DATA(.14)=PATMT
273 ;
274 I $$UPD^DGENDBS(2,DFN,.DATA)
275 Q
Note: See TracBrowser for help on using the repository browser.