source: FOIAVistA/tag/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XUPSPAID.m@ 628

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

initial load of FOIAVistA 6/30/08 version
File size: 9.2 KB
Line 
1XUPSPAID ;CS/GRR/RAM/DW - New Person file Update & Report ; 1 Jan 2004
2 ;;8.0;KERNEL;**309,343**; Jul 10, 1995;
3 ;
4 Q
5 ;
6EN ; - entry point
7 ;
8 N DIRUT,X,Y
9 ;
10 I $E(XUPSACT,1)="U" D
11 . W !!," *********************************************"
12 . W !," *This option will UPDATE eligible New Person*"
13 . W !," *file (#200) entries with missing DOB or SEX*"
14 . W !," *********************************************"
15 ;
16 W !!,"The reports will be sent to you via MailMan",!
17 ;
18 S DIR(0)="YA",DIR("B")="Yes",DIR("A")="Do you wish to continue? "
19 S DIR("?")="Enter 'Yes' to continue or 'No' to quit"
20 D ^DIR K DIR ;ask user if they want to continue with option
21 Q:'Y!($D(DIRUT)) ;user responded No or with '^' to exit
22 ;
23 D QUE
24 ;
25 K XUPSACT
26 Q
27 ;
28QUE ;Que the task
29 N ZTDESC,ZTIO,ZTRTN,ZTSAVE,ZTSK,ZUSR,POP,X,ERR,IOP
30 W !
31 S ZTIO=""
32 S ZTRTN="EN1^XUPSPAID"
33 S ZTSAVE("XUPSACT")=""
34 I $E(XUPSACT,1)="U" S ZTDESC="XUPS NPF UPDATE"
35 I $E(XUPSACT,1)="P" S ZTDESC="XUPS NPF PREUPDATE REPORT"
36 D ^%ZTLOAD
37 D ^%ZISC,HOME^%ZIS
38 W !,$S($D(ZTSK):"REQUEST QUEUED AS TASK#"_ZTSK,1:"REQUEST CANCELLED!")
39 ;
40 Q
41 ;
42EN1 ;
43 N IEN,XUPSDIFF,XUPSUPD,XUT,XUNPFT,XUUPDT
44 S (XUNPFT,XUUPDT)=0
45 ;
46 K ^TMP("XUPS PAID",$J)
47 K ^TMP("XUPS DIFF",$J)
48 K ^TMP("XUPS UPD",$J)
49 ;
50 S XUPSDIFF("SSN")=0
51 S XUPSDIFF("NAME")=0
52 S XUPSDIFF("SEX")=0
53 S XUPSDIFF("DOB")=0
54 ;
55 S XUPSUPD("SEX")=0
56 S XUPSUPD("DOB")=0
57 ;
58 S IEN=0
59 F S IEN=$O(^PRSPC(IEN)) Q:'IEN D RECORD
60 ;
61 S XUT(1)=$G(XUNPFT)
62 S XUT(2)=$G(XUUPDT)
63 I $E(XUPSACT,1)="U" D NOTICE^XUPSPD1(.XUT)
64 ;
65 D REPORT
66 ;
67 Q
68 ;
69REPORT ;Pre-update reports
70 ;
71 N CNTG,DATA,DATA1,IEN,CNT,CNTU,CNTD
72 S (CNTG,CNT,CNTU,CNTD)=0
73 ;
74 ;The difference report
75 D HD("XUPS DIFF")
76 S IEN=0
77 F S IEN=$O(^TMP("XUPS PAID",$J,"DIFF",IEN)) Q:'IEN D
78 .S DATA=^TMP("XUPS PAID",$J,"DIFF",IEN)
79 .D FL("XUPS DIFF",DATA)
80 .S CNTD=$G(CNTD)+1
81 S CNT=$G(CNT)+1
82 S ^TMP("XUPS DIFF",$J,CNT)=""
83 S CNT=$G(CNT)+1
84 S ^TMP("XUPS DIFF",$J,CNT)=" Totals"
85 S CNT=$G(CNT)+1
86 S ^TMP("XUPS DIFF",$J,CNT)=" Different LastName,FirstName: "_$G(XUPSDIFF("NAME"))
87 S CNT=$G(CNT)+1
88 S ^TMP("XUPS DIFF",$J,CNT)=" Same LastName,FirstName, different Sex: "_$G(XUPSDIFF("SEX"))
89 S CNT=$G(CNT)+1
90 S ^TMP("XUPS DIFF",$J,CNT)=" Same LastName,FirstName, different DOB: "_$G(XUPSDIFF("DOB"))
91 S CNT=$G(CNT)+1
92 S ^TMP("XUPS DIFF",$J,CNT)=" New Person file entries: "_$G(CNTD)
93 ;
94 ;The update report
95 S CNT=0
96 D HD1("XUPS UPD")
97 S IEN=0
98 F S IEN=$O(^TMP("XUPS PAID",$J,"UPD",IEN)) Q:'IEN D
99 .S DATA=^TMP("XUPS PAID",$J,"UPD",IEN)
100 .D FL1("XUPS UPD",DATA)
101 .S CNTU=$G(CNTU)+1
102 S CNT=$G(CNT)+1
103 S ^TMP("XUPS UPD",$J,CNT)=""
104 S CNT=$G(CNT)+1
105 S ^TMP("XUPS UPD",$J,CNT)=" Totals"
106 S CNT=$G(CNT)+1
107 S ^TMP("XUPS UPD",$J,CNT)=" Sex fields: "_XUPSUPD("SEX")
108 S CNT=$G(CNT)+1
109 S ^TMP("XUPS UPD",$J,CNT)=" DOB fields: "_XUPSUPD("DOB")
110 S CNT=$G(CNT)+1
111 S ^TMP("XUPS UPD",$J,CNT)=" New Person entries: "_$G(CNTU)
112 ;
113 D XM("Update NPF with PAID data - Sex and DOB","XUPS UPD")
114 D XM("Differences between NPF and PAID files","XUPS DIFF")
115 ;
116 K ^TMP("XUPS PAID",$J)
117 K ^TMP("XUPS DIFF",$J)
118 K ^TMP("XUPS UPD",$J)
119 ;
120 Q
121 ;
122RECORD ;Process the record
123 ;
124 N IEN200,DATA,DATA1
125 N PAIDNM,PAIDOB,PAIDSSN,PAIDSEX
126 N NPFNM,NPFSEX,NPFDOB,NPFSSN
127 ;
128 ; NPF IEN
129 S IEN200=$P($G(^PRSPC(IEN,200)),"^",1)
130 ;
131 Q:'IEN200
132 S XUNPFT=$G(XUNPFT)+1
133 ;
134 ; PAID file
135 S DATA=$G(^PRSPC(IEN,0))
136 S PAIDNM=$P(DATA,"^",1)
137 S PAIDDOB=$P(DATA,"^",33)
138 S PAIDSSN=$P(DATA,"^",9)
139 S PAIDSEX=$P(DATA,"^",32)
140 ; transform SEX code PAID to NPF
141 S PAIDSEX=$S(PAIDSEX="":"",PAIDSEX=1:"M",PAIDSEX=2:"F",1:"")
142 ;
143 ; New Person File
144 S DATA=$G(^VA(200,IEN200,1))
145 S NPFNM=$P($G(^VA(200,IEN200,0)),U)
146 S NPFSEX=$P(DATA,"^",2)
147 S NPFDOB=$P(DATA,"^",3)
148 S NPFSSN=$P(DATA,"^",9)
149 ;
150 Q:NPFSSN'=PAIDSSN
151 ;
152 S DATA=NPFNM_U_NPFSEX_U_NPFDOB_U_NPFSSN
153 S DATA=DATA_U_PAIDNM_U_PAIDSEX_U_PAIDDOB_U_PAIDSSN_U_IEN200
154 ;
155 S DATA1=NPFSSN_U_NPFNM_U_U_U_IEN200
156 ;
157 I $$NAME(NPFNM)'=$$NAME(PAIDNM) D Q
158 .S XUPSDIFF("NAME")=XUPSDIFF("NAME")+1
159 .S ^TMP("XUPS PAID",$J,"DIFF",IEN200)=DATA
160 ;
161 I PAIDSEX'="" D
162 .I NPFSEX="" D Q
163 ..S $P(DATA1,U,3)=PAIDSEX
164 ..S XUPSUPD("SEX")=XUPSUPD("SEX")+1
165 ..S ^TMP("XUPS PAID",$J,"UPD",IEN200)=DATA1
166 ..I $E(XUPSACT,1)="U" D
167 ... D UPDSEX
168 ... S XUUPDT=$G(XUUPDT)+1
169 .I NPFSEX'=PAIDSEX D Q
170 ..S XUPSDIFF("SEX")=XUPSDIFF("SEX")+1
171 ..S ^TMP("XUPS PAID",$J,"DIFF",IEN200)=DATA
172 ;
173 I PAIDDOB'="" D
174 .I NPFDOB="" D Q
175 ..S $P(DATA1,U,4)=PAIDDOB
176 ..S XUPSUPD("DOB")=XUPSUPD("DOB")+1
177 ..S ^TMP("XUPS PAID",$J,"UPD",IEN200)=DATA1
178 ..I $E(XUPSACT,1)="U" D
179 ... D UPDDOB
180 ... S XUUPDT=$G(XUUPDT)+1
181 .I NPFDOB'=PAIDDOB D Q
182 ..S XUPSDIFF("DOB")=XUPSDIFF("DOB")+1
183 ..S ^TMP("XUPS PAID",$J,"DIFF",IEN200)=DATA
184 ;
185 Q
186 ;
187HD(NODE) ; -- Report header
188 N C1,C2,C3,C4,C5
189 ;
190 S CNT=$G(CNT)+1
191 S ^TMP(NODE,$J,CNT)=""
192 ;
193 I NODE="XUPS DIFF" D
194 . S CNT=$G(CNT)+1
195 . S ^TMP(NODE,$J,CNT)="The following New Person File entries have different LastName,FirstName,"
196 . S CNT=$G(CNT)+1
197 . S ^TMP(NODE,$J,CNT)="or same LastName,FirstName but different Sex or DOB with their linked PAID"
198 . S CNT=$G(CNT)+1
199 . S ^TMP(NODE,$J,CNT)="Employee entries."
200 ;
201 S CNT=$G(CNT)+1
202 S ^TMP(NODE,$J,CNT)=""
203 ;
204 S C1=$$LJ^XLFSTR("NPF - Name",30," ")
205 S C2=$$CJ^XLFSTR("SEX",3," ")
206 S C3=$$LJ^XLFSTR("DOB",11," ")
207 S C4=$$LJ^XLFSTR("SSN",9," ")
208 S C5=$$RJ^XLFSTR("IEN",14," ")
209 ;
210 S CNT=$G(CNT)+1
211 S ^TMP(NODE,$J,CNT)=C1_C2_" "_C3_" "_C4_" "_C5
212 ;
213 S C1=$$LJ^XLFSTR("PAID -",30," ")
214 S C2=$$CJ^XLFSTR("",3," ")
215 S C3=$$LJ^XLFSTR("",11," ")
216 S C4=$$LJ^XLFSTR("",9," ")
217 S C5=$$RJ^XLFSTR("",14," ")
218 ;
219 S CNT=$G(CNT)+1
220 S ^TMP(NODE,$J,CNT)=C1_C2_" "_C3_" "_C4_" "_C5
221 ;
222 S C1=$$LJ^XLFSTR("=================",30," ")
223 S C2=$$CJ^XLFSTR("===",3," ")
224 S C3=$$LJ^XLFSTR("==========",11," ")
225 S C4=$$LJ^XLFSTR("=========",9," ")
226 S C5=$$RJ^XLFSTR("===",14," ")
227 ;
228 S CNT=$G(CNT)+1
229 S ^TMP(NODE,$J,CNT)=C1_C2_" "_C3_" "_C4_" "_C5
230 ;
231 S CNT=$G(CNT)+1
232 S ^TMP(NODE,$J,CNT)=""
233 ;
234 Q
235 ;
236FL(NODE,DATA) ; -- format line
237 ;
238 N NPFNM,NPFSEX,NPFDOB,NPFSSN,NPFIEN
239 N PAIDNM,PAIDSEX,PAIDDOB,PAIDSSN
240 ;
241 S NPFNM=$P(DATA,U,1)
242 S NPFSEX=$P(DATA,U,2)
243 S NPFDOB=$P(DATA,U,3)
244 S NPFSSN=$P(DATA,U,4)
245 S NPFIEN=$P(DATA,U,9)
246 S PAIDNM=$P(DATA,U,5)
247 S PAIDSEX=$P(DATA,U,6)
248 S PAIDDOB=$P(DATA,U,7)
249 S PAIDSSN=$P(DATA,U,8)
250 ;
251 N C1,C2,C3,C4,C5
252 ;
253 ;NPF values
254 S C1=$$LJ^XLFSTR(NPFNM,30," ")
255 S C2=$$CJ^XLFSTR(NPFSEX,3," ")
256 S C3=$$LJ^XLFSTR($$DOB(NPFDOB),11," ")
257 S C4=$$LJ^XLFSTR(NPFSSN,9," ")
258 S C5=$$RJ^XLFSTR(NPFIEN,14," ")
259 ;
260 S CNT=$G(CNT)+1
261 S ^TMP(NODE,$J,CNT)=C1_C2_" "_C3_" "_C4_" "_C5
262 ;
263 ;PAID values
264 S C1=$$LJ^XLFSTR(PAIDNM,30," ")
265 S C2=$$CJ^XLFSTR(PAIDSEX,3," ")
266 S C3=$$LJ^XLFSTR($$DOB(PAIDDOB),11," ")
267 S C4=$$LJ^XLFSTR(PAIDSSN,9," ")
268 S C5=$$RJ^XLFSTR(" ",14," ")
269 ;
270 S CNT=$G(CNT)+1
271 S ^TMP(NODE,$J,CNT)=C1_C2_" "_C3_" "_C4_" "_C5
272 ;
273 S CNT=$G(CNT)+1
274 S ^TMP(NODE,$J,CNT)=""
275 ;
276 Q
277 ;
278HD1(NODE) ; -- Report header
279 ;
280 N C1,C2,C3,C4,C5
281 ;
282 S CNT=$G(CNT)+1
283 S ^TMP(NODE,$J,CNT)=""
284 ;
285 I NODE="XUPS UPD" D
286 . S CNT=$G(CNT)+1
287 . S ^TMP(NODE,$J,CNT)="The following New Person File entries will be updated."
288 . S CNT=$G(CNT)+1
289 . S ^TMP(NODE,$J,CNT)="The DOB or Sex fields to be updated are shown with the PAID values;"
290 . S CNT=$G(CNT)+1
291 . S ^TMP(NODE,$J,CNT)="The DOB or Sex fields not to be updated are shown with ""-""."
292 ;
293 S CNT=$G(CNT)+1
294 S ^TMP(NODE,$J,CNT)=""
295 ;
296 S C1=$$LJ^XLFSTR("SSN",9," ")
297 S C2=$$LJ^XLFSTR("NPF Name",30," ")
298 S C3=$$LJ^XLFSTR("SEX",3," ")
299 S C4=$$LJ^XLFSTR("DOB",11," ")
300 S C5=$$RJ^XLFSTR("IEN",14," ")
301 ;
302 S CNT=$G(CNT)+1
303 S ^TMP(NODE,$J,CNT)=C1_" "_C2_" "_C3_" "_C4_" "_C5
304 ;
305 S C1=$$LJ^XLFSTR("=========",9," ")
306 S C2=$$LJ^XLFSTR("=================",30," ")
307 S C3=$$CJ^XLFSTR("===",3," ")
308 S C4=$$LJ^XLFSTR("==========",11," ")
309 S C5=$$RJ^XLFSTR("===",14," ")
310 ;
311 S CNT=$G(CNT)+1
312 S ^TMP(NODE,$J,CNT)=C1_" "_C2_" "_C3_" "_C4_" "_C5
313 ;
314 S CNT=$G(CNT)+1
315 S ^TMP(NODE,$J,CNT)=""
316 ;
317 Q
318 ;
319FL1(NODE,DATA) ; -- format line
320 ;
321 N NPFSSN,NPFNM,NPFSEX,NPFDOB,NPFIEN
322 ;
323 S NPFSSN=$P(DATA,U,1)
324 S NPFNM=$P(DATA,U,2)
325 S NPFSEX=$P(DATA,U,3)
326 I NPFSEX="" S NPFSEX="-"
327 S NPFDOB=$P(DATA,U,4)
328 S NPFIEN=$P(DATA,U,5)
329 ;
330 N C1,C2,C3,C4,C5
331 ;
332 ;NPF values
333 S C1=$$LJ^XLFSTR(NPFSSN,9," ")
334 S C2=$$LJ^XLFSTR(NPFNM,30," ")
335 S C3=$$CJ^XLFSTR(NPFSEX,3," ")
336 I NPFDOB="" S C4="---------- "
337 I NPFDOB'="" S C4=$$LJ^XLFSTR($$DOB(NPFDOB),11," ")
338 S C5=$$RJ^XLFSTR(NPFIEN,14," ")
339 ;
340 S CNT=$G(CNT)+1
341 S ^TMP(NODE,$J,CNT)=C1_" "_C2_" "_C3_" "_C4_" "_C5
342 ;
343 S CNT=$G(CNT)+1
344 S ^TMP(NODE,$J,CNT)=""
345 ;
346 Q
347 ;
348UPDSEX ;Update SEX if NPF SEX is null
349 I $E(XUPSACT,1)'="U" Q
350 ;
351 N DIE,DA,DR
352 S DIE=200,DA=IEN200
353 I NPFSEX="" D
354 . S DR="4///^S X=PAIDSEX"
355 . D ^DIE
356 Q
357 ;
358UPDDOB ;Update DOB if NPF DOB is null
359 I $E(XUPSACT,1)'="U" Q
360 ;
361 N DIE,DA,DR
362 S DIE=200,DA=IEN200
363 I NPFDOB="" D
364 . S DR="5///^S X=PAIDDOB"
365 . D ^DIE
366 Q
367 ;
368NAME(NAME) ; Return "LastName,FirstName".
369 ;
370 N RESULT,STDNM
371 ;
372 S RESULT=""
373 ;
374 ; CALL FORMAT^XLFNAME7
375 S STDNM=$$FORMAT^XLFNAME7(.NAME,3,35)
376 ;
377 ; Return LastName,FirstName
378 S RESULT=$P($G(STDNM)," ",1)
379 ;
380 Q RESULT
381 ;
382DOB(DOB) ; format DOB
383 ;
384 Q:DOB="" ""
385 ;
386 Q $E(DOB,4,5)_"/"_$E(DOB,6,7)_"/"_(1700+$E(DOB,1,3))
387 ;
388PSDT() ; format date
389 ;
390 N %
391 ;
392 D NOW^%DTC S Y=% D DD^%DT
393 ;
394 Q Y
395 ;
396XM(XMSUB,X) ;Email the report
397 ;If called within a task, protect variables
398 I $D(ZTQUEUED) N %,DIFROM
399 ;
400 N XMY,XMTEXT,XMDUZ
401 S XMY(DUZ)="",XMDUZ=.5
402 S XMTEXT="^TMP("""_X_""",$J,"
403 D ^XMD
404 ;
405 Q
406 ;
Note: See TracBrowser for help on using the repository browser.