source: VWGUIRegistration/tag/2.0/VWREG_03082017_P3T3_0.KID@ 1791

Last change on this file since 1791 was 1791, checked in by Jim B., 7 years ago
File size: 21.9 KB
Line 
1KIDS Distribution saved on Mar 08, 2017@13:41:25
2Patch 3 to WorldVistA GUI Registration 03/08/2017
3**KIDS**:VWREG_03082017*2.04T3*2^
4
5**INSTALL NAME**
6VWREG_03082017*2.04T3*2
7"BLD",8570,0)
8VWREG_03082017*2.04T3*2^^0^3170308^n
9"BLD",8570,1,0)
10^^6^6^3170308^^^^
11"BLD",8570,1,1,0)
123 Repairs found in Alpha Testing:
13"BLD",8570,1,2,0)
14 Removing a testing stub that prevented filing of patient data
15"BLD",8570,1,3,0)
16 in VWREGITS
17"BLD",8570,1,4,0)
18 Adding a field 540001.1 HEALTH RECORD NUMBER to the PATIENT
19"BLD",8570,1,5,0)
20 file (#2)
21"BLD",8570,1,6,0)
22 Removed field 540001.1 from VW PT REGISTRATION template
23"BLD",8570,4,0)
24^9.64PA^2^1
25"BLD",8570,4,2,0)
262
27"BLD",8570,4,2,2,0)
28^9.641^2^1
29"BLD",8570,4,2,2,2,0)
30PATIENT (File-top level)
31"BLD",8570,4,2,2,2,1,0)
32^9.6411^540001.1^1
33"BLD",8570,4,2,2,2,1,540001.1,0)
34HEALTH RECORD NUMBER
35"BLD",8570,4,2,222)
36y^n^p^^^^n^^n
37"BLD",8570,4,2,224)
38
39"BLD",8570,4,"APDD",2,2)
40
41"BLD",8570,4,"APDD",2,2,540001.1)
42
43"BLD",8570,4,"B",2,2)
44
45"BLD",8570,6.3)
462
47"BLD",8570,"KRN",0)
48^9.67PA^779.2^20
49"BLD",8570,"KRN",.4,0)
50.4
51"BLD",8570,"KRN",.401,0)
52.401
53"BLD",8570,"KRN",.402,0)
54.402
55"BLD",8570,"KRN",.402,"NM",0)
56^9.68A^1^1
57"BLD",8570,"KRN",.402,"NM",1,0)
58VW PT REGISTRATION FILE #2^2^0
59"BLD",8570,"KRN",.402,"NM","B","VW PT REGISTRATION FILE #2",1)
60
61"BLD",8570,"KRN",.403,0)
62.403
63"BLD",8570,"KRN",.5,0)
64.5
65"BLD",8570,"KRN",.84,0)
66.84
67"BLD",8570,"KRN",3.6,0)
683.6
69"BLD",8570,"KRN",3.8,0)
703.8
71"BLD",8570,"KRN",9.2,0)
729.2
73"BLD",8570,"KRN",9.8,0)
749.8
75"BLD",8570,"KRN",9.8,"NM",0)
76^9.68A^2^2
77"BLD",8570,"KRN",9.8,"NM",1,0)
78VWREGIT^^0^B34467909
79"BLD",8570,"KRN",9.8,"NM",2,0)
80VWREGITS^^0^B15352111
81"BLD",8570,"KRN",9.8,"NM","B","VWREGIT",1)
82
83"BLD",8570,"KRN",9.8,"NM","B","VWREGITS",2)
84
85"BLD",8570,"KRN",19,0)
8619
87"BLD",8570,"KRN",19.1,0)
8819.1
89"BLD",8570,"KRN",101,0)
90101
91"BLD",8570,"KRN",409.61,0)
92409.61
93"BLD",8570,"KRN",771,0)
94771
95"BLD",8570,"KRN",779.2,0)
96779.2
97"BLD",8570,"KRN",870,0)
98870
99"BLD",8570,"KRN",8989.51,0)
1008989.51
101"BLD",8570,"KRN",8989.52,0)
1028989.52
103"BLD",8570,"KRN",8994,0)
1048994
105"BLD",8570,"KRN","B",.4,.4)
106
107"BLD",8570,"KRN","B",.401,.401)
108
109"BLD",8570,"KRN","B",.402,.402)
110
111"BLD",8570,"KRN","B",.403,.403)
112
113"BLD",8570,"KRN","B",.5,.5)
114
115"BLD",8570,"KRN","B",.84,.84)
116
117"BLD",8570,"KRN","B",3.6,3.6)
118
119"BLD",8570,"KRN","B",3.8,3.8)
120
121"BLD",8570,"KRN","B",9.2,9.2)
122
123"BLD",8570,"KRN","B",9.8,9.8)
124
125"BLD",8570,"KRN","B",19,19)
126
127"BLD",8570,"KRN","B",19.1,19.1)
128
129"BLD",8570,"KRN","B",101,101)
130
131"BLD",8570,"KRN","B",409.61,409.61)
132
133"BLD",8570,"KRN","B",771,771)
134
135"BLD",8570,"KRN","B",779.2,779.2)
136
137"BLD",8570,"KRN","B",870,870)
138
139"BLD",8570,"KRN","B",8989.51,8989.51)
140
141"BLD",8570,"KRN","B",8989.52,8989.52)
142
143"BLD",8570,"KRN","B",8994,8994)
144
145"BLD",8570,"QDEF")
146^^^^NO^^^^NO^^NO
147"BLD",8570,"QUES",0)
148^9.62^^
149"BLD",8570,"REQB",0)
150^9.611^^
151"FIA",2)
152PATIENT
153"FIA",2,0)
154^DPT(
155"FIA",2,0,0)
1562I
157"FIA",2,0,1)
158y^n^p^^^^n^^n
159"FIA",2,0,10)
160
161"FIA",2,0,11)
162
163"FIA",2,0,"RLRO")
164
165"FIA",2,2)
1661
167"FIA",2,2,540001.1)
168
169"KRN",.402,1773,-1)
1700^1
171"KRN",.402,1773,0)
172VW PT REGISTRATION^3170308.0946^^2^^^3170308
173"KRN",.402,1773,"%D",0)
174^^1^1^3160416^
175"KRN",.402,1773,"%D",1,0)
176Created via registration client
177"KRN",.402,1773,"DIAB",5,0,2,0)
178.363;"ID NUMBER"
179"KRN",.402,1773,"DR",1,2)
180.01;.02;.03;.05;.363ID NUMBER~;27.02;.111;.112;.1112;.114;.115;.117;.131;.132;.134;.133;.331;.339;.3121;.091;3;250043.1;
181"KRN",.402,1773,"DR",2,2.001)
182.01;1;
183"KRN",.402,1773,"DR",2,2.312)
184.01;
185"KRN",.402,1773,"DR",3,2.011)
186.01;1;
187"MBREQ")
1880
189"ORD",7,.402)
190.402;7;;;EDEOUT^DIFROMSO(.402,DA,"",XPDA);FPRE^DIFROMSI(.402,"",XPDA);EPRE^DIFROMSI(.402,DA,$E("N",$G(XPDNEW)),XPDA,"",OLDA);;EPOST^DIFROMSI(.402,DA,"",XPDA);DEL^DIFROMSK(.402,"",%)
191"ORD",7,.402,0)
192INPUT TEMPLATE
193"QUES","XPF1",0)
194Y
195"QUES","XPF1","??")
196^D REP^XPDH
197"QUES","XPF1","A")
198Shall I write over your |FLAG| File
199"QUES","XPF1","B")
200YES
201"QUES","XPF1","M")
202D XPF1^XPDIQ
203"QUES","XPF2",0)
204Y
205"QUES","XPF2","??")
206^D DTA^XPDH
207"QUES","XPF2","A")
208Want my data |FLAG| yours
209"QUES","XPF2","B")
210YES
211"QUES","XPF2","M")
212D XPF2^XPDIQ
213"QUES","XPI1",0)
214YO
215"QUES","XPI1","??")
216^D INHIBIT^XPDH
217"QUES","XPI1","A")
218Want KIDS to INHIBIT LOGONs during the install
219"QUES","XPI1","B")
220NO
221"QUES","XPI1","M")
222D XPI1^XPDIQ
223"QUES","XPM1",0)
224PO^VA(200,:EM
225"QUES","XPM1","??")
226^D MG^XPDH
227"QUES","XPM1","A")
228Enter the Coordinator for Mail Group '|FLAG|'
229"QUES","XPM1","B")
230
231"QUES","XPM1","M")
232D XPM1^XPDIQ
233"QUES","XPO1",0)
234Y
235"QUES","XPO1","??")
236^D MENU^XPDH
237"QUES","XPO1","A")
238Want KIDS to Rebuild Menu Trees Upon Completion of Install
239"QUES","XPO1","B")
240NO
241"QUES","XPO1","M")
242D XPO1^XPDIQ
243"QUES","XPZ1",0)
244Y
245"QUES","XPZ1","??")
246^D OPT^XPDH
247"QUES","XPZ1","A")
248Want to DISABLE Scheduled Options, Menu Options, and Protocols
249"QUES","XPZ1","B")
250NO
251"QUES","XPZ1","M")
252D XPZ1^XPDIQ
253"QUES","XPZ2",0)
254Y
255"QUES","XPZ2","??")
256^D RTN^XPDH
257"QUES","XPZ2","A")
258Want to MOVE routines to other CPUs
259"QUES","XPZ2","B")
260NO
261"QUES","XPZ2","M")
262D XPZ2^XPDIQ
263"RTN")
2642
265"RTN","VWREGIT")
2660^1^B34467909
267"RTN","VWREGIT",1,0)
268VWREGIT ;Portland,OR/Jim Bell, et al Patient Registration Utility August 2015
269"RTN","VWREGIT",2,0)
270 ;;2.0;B/FProductions,LLC,WORLD VISTA;**LOCAL**;;Build 2
271"RTN","VWREGIT",3,0)
272 ;*******************************************************************
273"RTN","VWREGIT",4,0)
274 ;* VW Registration is designed for patient specific fields as *
275"RTN","VWREGIT",5,0)
276 ;* defined in Fileman Input Templates or ad hoc field selection. *
277"RTN","VWREGIT",6,0)
278 ;* Copyright Martius/MMXV ad infinitum (GNU License: See GPLv3.txt)*
279"RTN","VWREGIT",7,0)
280 ;*******************************************************************
281"RTN","VWREGIT",8,0)
282 ;;NO FALL THROUGH - JEB
283"RTN","VWREGIT",9,0)
284 Q
285"RTN","VWREGIT",10,0)
286 ;
287"RTN","VWREGIT",11,0)
288TFM(XF) ;TemplateField Management
289"RTN","VWREGIT",12,0)
290 ;***********************************************
291"RTN","VWREGIT",13,0)
292 ;* Check primary field entries for "parentage" *
293"RTN","VWREGIT",14,0)
294 ;* Add an "*" to gain all sub-fields of the *
295"RTN","VWREGIT",15,0)
296 ;* parent *
297"RTN","VWREGIT",16,0)
298 ;* REMEMBER: All fields pertain to file 2 only *
299"RTN","VWREGIT",17,0)
300 ;***********************************************
301"RTN","VWREGIT",18,0)
302 N I,N,FIELD
303"RTN","VWREGIT",19,0)
304 K FARRAY
305"RTN","VWREGIT",20,0)
306 I '$L(XF),'$G(TNUM) Q ""
307"RTN","VWREGIT",21,0)
308 I '$L(XF),+$G(TNUM) S XF=^DIE(TNUM,"DR",1,2)
309"RTN","VWREGIT",22,0)
310 F I=1:1:$L(XF,";") S:$L($P(XF,";",I)) FARRAY(I)=+$P(XF,";",I)
311"RTN","VWREGIT",23,0)
312 S N=0 F I=1:1 S N=$O(FARRAY(N)) Q:'+N D
313"RTN","VWREGIT",24,0)
314 . S FIELD=FARRAY(N)
315"RTN","VWREGIT",25,0)
316 . I +$P(^DD(2,FIELD,0),"^",2) S FIELD=FIELD_"*",FMARRAY(FIELD)=$P(^(0),"^",4) K FARRAY(N)
317"RTN","VWREGIT",26,0)
318 S XF="",N=0 F S N=$O(FARRAY(N)) Q:'+N S XF=XF_FARRAY(N)_";"
319"RTN","VWREGIT",27,0)
320 Q XF
321"RTN","VWREGIT",28,0)
322 ;
323"RTN","VWREGIT",29,0)
324CHECK() ;
325"RTN","VWREGIT",30,0)
326 Q ""
327"RTN","VWREGIT",31,0)
328 ;
329"RTN","VWREGIT",32,0)
330INR() Q $O(RESULT(" "),-1)+1
331"RTN","VWREGIT",33,0)
332 ;
333"RTN","VWREGIT",34,0)
334EN(RESULT) ;Template name and ID labels
335"RTN","VWREGIT",35,0)
336 ;Get the input template list
337"RTN","VWREGIT",36,0)
338 ;housekeeping
339"RTN","VWREGIT",37,0)
340 S DTIME=99999
341"RTN","VWREGIT",38,0)
342 ;ZSY "chmod 777 "_$ZD_"regparam/*.txt" ;Moved to post-install
343"RTN","VWREGIT",39,0)
344 ;end housekeeping
345"RTN","VWREGIT",40,0)
346 ;
347"RTN","VWREGIT",41,0)
348 K AR,RESULT
349"RTN","VWREGIT",42,0)
350 N N,HD,FILE,LOC,P4,P5,%ZISHF,%ZISHO,DEFST,XTMP,X
351"RTN","VWREGIT",43,0)
352 S RESULT(0)=1
353"RTN","VWREGIT",44,0)
354 S DEFST="";
355"RTN","VWREGIT",45,0)
356 ;S DEFTMP=$O(^DIE("B","FAU_EDU",0)) ;For Florida College only
357"RTN","VWREGIT",46,0)
358 S RESULT(0)=$$CONTROL^VWREGITU()
359"RTN","VWREGIT",47,0)
360 S RESULT(1)="-1^No templates found"
361"RTN","VWREGIT",48,0)
362 S DEFST=$$GET^XPAR("ALL","VW REG DEFAULT STATE")
363"RTN","VWREGIT",49,0)
364 S DEFTMP=$$GET^XPAR("ALL","VW REG RDNPT")
365"RTN","VWREGIT",50,0)
366 S HD=$$GET^XPAR("ALL","VW GUI REG TEMPLATE DIRECTORY")
367"RTN","VWREGIT",51,0)
368 I '$L(HD) K RESULT D Q
369"RTN","VWREGIT",52,0)
370 . S RESULT($$INR)="-1^NO HOME DIRECTORY - refer to IT support, if necessary."
371"RTN","VWREGIT",53,0)
372 . S RESULT($$INR)="No home directory has been supplied which indicates"
373"RTN","VWREGIT",54,0)
374 . S RESULT($$INR)="the VWREG installation is incomplete. See the Help manual"
375"RTN","VWREGIT",55,0)
376 . S RESULT($$INR)="for installation and Enter/Editing parameter values."
377"RTN","VWREGIT",56,0)
378 . S RESULT($$INR)="Thank you,"
379"RTN","VWREGIT",57,0)
380 . S RESULT($$INR)=" The Management."
381"RTN","VWREGIT",58,0)
382 S FILE="regit.txt"
383"RTN","VWREGIT",59,0)
384 S P4=1
385"RTN","VWREGIT",60,0)
386 S P5=""
387"RTN","VWREGIT",61,0)
388 S X=$$FTG^%ZISH(HD,FILE,$NA(AR(1)),P4,P5)
389"RTN","VWREGIT",62,0)
390 D:+RESULT(0)
391"RTN","VWREGIT",63,0)
392 . S $P(RESULT(0),"^",2)=$G(HD)
393"RTN","VWREGIT",64,0)
394 . S $P(RESULT(0),"^",3)=$S(DEFST:$P(^DIC(5,DEFST,0),"^")_"("_DEFST_")",1:"")
395"RTN","VWREGIT",65,0)
396 . S $P(RESULT(0),"^",4)=$S(+DEFTMP:$P(^DIE(DEFTMP,0),"^")_"("_DEFTMP_")",1:DEFTMP)
397"RTN","VWREGIT",66,0)
398 . S $P(RESULT(0),"^",5)=DUZ
399"RTN","VWREGIT",67,0)
400 I $O(AR(0)) S RESULT(1)="[TEMPLATES]"
401"RTN","VWREGIT",68,0)
402 S N=0 F S N=$O(AR(N)) Q:'+N D
403"RTN","VWREGIT",69,0)
404 . Q:$E(AR(N))="*"
405"RTN","VWREGIT",70,0)
406 . Q:'+$P(AR(N),"(",2)
407"RTN","VWREGIT",71,0)
408 . Q:$P($G(^DIE(+$P(AR(N),"(",2),0)),"^",4)'=2 ;must be pat file
409"RTN","VWREGIT",72,0)
410 . S RESULT($$INR)=AR(N)
411"RTN","VWREGIT",73,0)
412 S RESULT($$INR)="[ID]"
413"RTN","VWREGIT",74,0)
414 ;S N=0 F S N=$O(^DIZ(64850003,N)) Q:'+N S RESULT($$INR)=$P(^(N,0),"^",2)_"("_$P(^(0),"^")_")"
415"RTN","VWREGIT",75,0)
416 ;S N=0 F S N=$O(RESULT(N)) Q:'+N K:RESULT(N)="" RESULT(N)
417"RTN","VWREGIT",76,0)
418 I '$O(RESULT(0)) S RESULT(1)="-1^No PATIENT FILE templates found"
419"RTN","VWREGIT",77,0)
420 K AR
421"RTN","VWREGIT",78,0)
422 Q
423"RTN","VWREGIT",79,0)
424 ;
425"RTN","VWREGIT",80,0)
426NPT(RESULT,TNAME) ;
427"RTN","VWREGIT",81,0)
428 ; *************************************************
429"RTN","VWREGIT",82,0)
430 ; * Incoming: DFN^TEMPLATE NAME(IEN) *
431"RTN","VWREGIT",83,0)
432 ; * Process : Get template fields plus any help *
433"RTN","VWREGIT",84,0)
434 ; * If +TNAME (a DFN), get DFN data for *
435"RTN","VWREGIT",85,0)
436 ; * the template fields (Put data in *
437"RTN","VWREGIT",86,0)
438 ; * $P(RESULT(N),"^",3)) *
439"RTN","VWREGIT",87,0)
440 ; * Return : RESULT(N), etc *
441"RTN","VWREGIT",88,0)
442 ; *************************************************
443"RTN","VWREGIT",89,0)
444 ;W " ;Intentional bust for debugging
445"RTN","VWREGIT",90,0)
446 N N,TNUM,FIELDS,F,FNAME,FVALUE,FHELP,FPSC,FNUM
447"RTN","VWREGIT",91,0)
448 S TNUM=+$P(TNAME,"(",2),DFN=+TNAME
449"RTN","VWREGIT",92,0)
450 I 'TNUM S RESULT(0)="0^new patient Template not found" Q
451"RTN","VWREGIT",93,0)
452 S TNAME=$P($P(TNAME,"^",2),"(")
453"RTN","VWREGIT",94,0)
454 S TNAME=$TR(TNAME,"$&*","") ;Clean out TMENU chars
455"RTN","VWREGIT",95,0)
456 I TNAME="GENERIC INS. FRM [WorldVistA]" G GIF
457"RTN","VWREGIT",96,0)
458 S FIELDS=$G(^DIE(TNUM,"DR",1,2))
459"RTN","VWREGIT",97,0)
460 I '$L(FIELDS) Q
461"RTN","VWREGIT",98,0)
462 K RESULT S (FNUM,FCAP)=""
463"RTN","VWREGIT",99,0)
464 F I=1:1:$L(FIELDS,";")-1 D
465"RTN","VWREGIT",100,0)
466 . S F=$P(FIELDS,";",I)
467"RTN","VWREGIT",101,0)
468 . Q:'$D(^DD(2,F)) ;Not existing in this patient file
469"RTN","VWREGIT",102,0)
470 . I F["~" S FNUM=+F,FNAME=$P($P(F,"~"),FNUM,2),F=FNUM K FNUM
471"RTN","VWREGIT",103,0)
472 . S FNAME=$S($L($G(FNAME)):FNAME,$L($G(^DD(2,F,.1))):$P(^(.1),"^"),1:$P(^DD(2,F,0),"^"))
473"RTN","VWREGIT",104,0)
474 . S FVALUE="" ;Patient Data
475"RTN","VWREGIT",105,0)
476 . S FHELP=$G(^DD(2,F,3))
477"RTN","VWREGIT",106,0)
478 . I F'=27.02,'$L(FHELP) S N=0 F S N=$O(^DD(2,F,21,N)) Q:'+N S FHELP=FHELP_^(N,0)
479"RTN","VWREGIT",107,0)
480 . S FHELP=$TR(FHELP,"'","`")
481"RTN","VWREGIT",108,0)
482 . S FPSC=$P(^DD(2,F,0),"^",3)
483"RTN","VWREGIT",109,0)
484 . S SUBDIC=+$P(^DD(2,F,0),"^",2)
485"RTN","VWREGIT",110,0)
486 . S RESULT($$INR)=FNAME_"^"_F_"^"_FVALUE_"^"_FHELP_"^"_FPSC_$S(SUBDIC:"^1",1:"^0")
487"RTN","VWREGIT",111,0)
488 . S (FNAME,FVALUE,FHELP,FPSC)=""
489"RTN","VWREGIT",112,0)
490 G NPTX:'DFN
491"RTN","VWREGIT",113,0)
492 I DFN D GETS^DIQ(2,DFN_",","**","EN","AR") ;,RESULT(0)=$$DFNID^VWREGITU
493"RTN","VWREGIT",114,0)
494 K FIELD S N=0 F S N=$O(RESULT(N)) Q:'+N S FIELD($P(RESULT(N),"^",2))=""
495"RTN","VWREGIT",115,0)
496 S X="AR" F S X=$Q(@X) Q:X="" D
497"RTN","VWREGIT",116,0)
498 . S FILE=+$P(X,"(",2)
499"RTN","VWREGIT",117,0)
500 . S FIELD=+$P(X,",",$L(X,",")-1)
501"RTN","VWREGIT",118,0)
502 . I $D(FIELD(FIELD)) S FIELD(FIELD)=@X
503"RTN","VWREGIT",119,0)
504 S N=0 F S N=$O(FIELD(N)) Q:'+N D
505"RTN","VWREGIT",120,0)
506 . S N2=0 F S N2=$O(RESULT(N2)) Q:'+N2 I $P(RESULT(N2),"^",2)=N S $P(RESULT(N2),"^",3)=FIELD(N)
507"RTN","VWREGIT",121,0)
508 . S RESULT(0)=$$DFNID^VWREGITU()
509"RTN","VWREGIT",122,0)
510NPTX K FIELD,AR,FCAP,FILE,SUBDIC,N,N2,DFN
511"RTN","VWREGIT",123,0)
512 Q
513"RTN","VWREGIT",124,0)
514 ;
515"RTN","VWREGIT",125,0)
516PF(RESULT,XPF) ;Pointer file - get the stuff
517"RTN","VWREGIT",126,0)
518 K RESULT,AR
519"RTN","VWREGIT",127,0)
520 N X,N
521"RTN","VWREGIT",128,0)
522 I '$L(XPF) S RESULT(0)="???" Q
523"RTN","VWREGIT",129,0)
524 S XPF="^"_XPF
525"RTN","VWREGIT",130,0)
526 I +$P(XPF,"(",2)=.85 G NAUTPF ;Naughty file!
527"RTN","VWREGIT",131,0)
528 S N=0 F S N=$O(@(XPF_N_")")) Q:'+N S X=$P(^(N,0),"^"),AR(X,N)=X_"("_N_")"
529"RTN","VWREGIT",132,0)
530 S X="AR" F S X=$Q(@X) Q:X="" S RESULT($$INR)=@X
531"RTN","VWREGIT",133,0)
532 K AR
533"RTN","VWREGIT",134,0)
534 Q
535"RTN","VWREGIT",135,0)
536 ;
537"RTN","VWREGIT",136,0)
538NAUTPF ;The "NAUGHTY" pointer file - has a numeric .01 - Bad file !!!
539"RTN","VWREGIT",137,0)
540 S N=0 F S N=$O(@(XPF_N_")")) Q:'+N S X=$P(^(N,0),"^") D
541"RTN","VWREGIT",138,0)
542 . S LANG=$P(^(0),"^",2)
543"RTN","VWREGIT",139,0)
544 . S AR(LANG,N)=LANG_"("_N_")"
545"RTN","VWREGIT",140,0)
546 S X="AR" F S X=$Q(@X) Q:X="" S RESULT($$INR)=@X
547"RTN","VWREGIT",141,0)
548 Q
549"RTN","VWREGIT",142,0)
550GIF ;Generic Insurance form
551"RTN","VWREGIT",143,0)
552 K RESULT
553"RTN","VWREGIT",144,0)
554 S RESULT($$INR)="Insurance Company^2.312;.01^^^DIC(36,^0"
555"RTN","VWREGIT",145,0)
556 S RESULT($$INR)="Group Plan^2.312;.18^^^IBA(355.3,^0"
557"RTN","VWREGIT",146,0)
558 S RESULT($$INR)="Policy No.^2.312;1^^^^0"
559"RTN","VWREGIT",147,0)
560 ;S RESULT($$INR)="Type of Plan^^^^^0"
561"RTN","VWREGIT",148,0)
562 S RESULT($$INR)="Coverage^355.33;40.09^^^IBE(355.1,^0"
563"RTN","VWREGIT",149,0)
564 S RESULT($$INR)="Effective Date^2.312;8^^^^0"
565"RTN","VWREGIT",150,0)
566 S RESULT($$INR)="Expiration Date^.3121;^^^^0"
567"RTN","VWREGIT",151,0)
568 S RESULT($$INR)="Guarantor^^^^^0"
569"RTN","VWREGIT",152,0)
570 S RESULT($$INR)="Signature on File^^^^0:NO;1:YES^0"
571"RTN","VWREGIT",153,0)
572 S RESULT($$INR)="Employer^2.312;2.015^^^^0"
573"RTN","VWREGIT",154,0)
574 S RESULT($$INR)="Billing Address^2.312;2.02^^^^0"
575"RTN","VWREGIT",155,0)
576 S RESULT($$INR)="Billing Address(cont)^2.312;2.03^^^^0"
577"RTN","VWREGIT",156,0)
578 S RESULT($$INR)="Postal Code^2.312;2.07^^^^0"
579"RTN","VWREGIT",157,0)
580 S RESULT($$INR)="City^2.312;2.05^^^^0"
581"RTN","VWREGIT",158,0)
582 S RESULT($$INR)="County/Region/Area^^^^^0"
583"RTN","VWREGIT",159,0)
584 S RESULT($$INR)="State/Province/Region^2.312;2.06^^^DIC(5,^0"
585"RTN","VWREGIT",160,0)
586 Q
587"RTN","VWREGIT",161,0)
588 ;
589"RTN","VWREGIT",162,0)
590
591"RTN","VWREGITS")
5920^2^B15352111
593"RTN","VWREGITS",1,0)
594VWREGITS ;Portland,OR/jeb et al Save utility for VWREG* routines 11/2015
595"RTN","VWREGITS",2,0)
596 ;V.2;;**LOCAL**;;;Build 2
597"RTN","VWREGITS",3,0)
598 ;c2014 ad infiniti, BellFelder Productions (BF Productions) & WorldVistA
599"RTN","VWREGITS",4,0)
600 ;License: See License.txt that with install
601"RTN","VWREGITS",5,0)
602 ;No fall thru - jeb
603"RTN","VWREGITS",6,0)
604 Q
605"RTN","VWREGITS",7,0)
606 ;
607"RTN","VWREGITS",8,0)
608 ;* *****************************************************************
609"RTN","VWREGITS",9,0)
610 ;* Data coming in may be for a new case or existing case *
611"RTN","VWREGITS",10,0)
612 ;* Incoming: Array LDATA= *
613"RTN","VWREGITS",11,0)
614 ;* LDATA(1)=Field^Field number^value^[optional]DFN *
615"RTN","VWREGITS",12,0)
616 ;* LDATA(N...)=Field^Field number^value *
617"RTN","VWREGITS",13,0)
618 ;* Exception for Multiples: *
619"RTN","VWREGITS",14,0)
620 ;* LDATA(N)=Field(SUBDD;Field number):value(IEN)^...etc for every*
621"RTN","VWREGITS",15,0)
622 ;* field that is a dependent of the parent *
623"RTN","VWREGITS",16,0)
624 ;* Process: *
625"RTN","VWREGITS",17,0)
626 ;* 1. call is at Label SAVE *
627"RTN","VWREGITS",18,0)
628 ;* 2. Some housekeeping that this programmer needs to do proper *
629"RTN","VWREGITS",19,0)
630 ;* string evaluations. *
631"RTN","VWREGITS",20,0)
632 ;* 3. Filing of a new case with FILE^DICN. *
633"RTN","VWREGITS",21,0)
634 ;* 4. Remaining major fields are filed with DIE *
635"RTN","VWREGITS",22,0)
636 ;* 5. Multiples are filed with UPDATE^DIE *
637"RTN","VWREGITS",23,0)
638 ;* 6. Existing entries will contain only edited data and will *
639"RTN","VWREGITS",24,0)
640 ;* address those fields as in 4 & 5. *
641"RTN","VWREGITS",25,0)
642 ;* Bon Appettit, et al. *
643"RTN","VWREGITS",26,0)
644 ;*******************************************************************
645"RTN","VWREGITS",27,0)
646SAVE(RESULT,LDATA) ;
647"RTN","VWREGITS",28,0)
648 K RESULT,^DIZ("DS",$J)
649"RTN","VWREGITS",29,0)
650 M ^DIZ("DS",$J)=LDATA
651"RTN","VWREGITS",30,0)
652 ;Q ;Testing
653"RTN","VWREGITS",31,0)
654 N DFN,DIC,DA,DR,VAR,FIELD,N,N1,X,Y,DIE,DIK
655"RTN","VWREGITS",32,0)
656 I $D(LDATA)<10 S RESULT(0)="-1: No data sent for filing. Please contact your IT dept." Q
657"RTN","VWREGITS",33,0)
658 ;UPcase everyTHING
659"RTN","VWREGITS",34,0)
660 S XDAT="LDATA" F S XDAT=$Q(@XDAT) Q:XDAT="" S @XDAT=$$UP^XLFSTR(@XDAT)
661"RTN","VWREGITS",35,0)
662 ;
663"RTN","VWREGITS",36,0)
664 ;Incoming housekeeping
665"RTN","VWREGITS",37,0)
666 S X="LDATA" F I=1:1 S X=$Q(@X) Q:X="" I @X[":",@X[";" S ^DIZ("DS",$J,I)=@X K @X
667"RTN","VWREGITS",38,0)
668 I +$P(@$Q(LDATA),"^",4)!(+$P(@$Q(LDATA),"(",2)) G EXP ;DFN sent by client
669"RTN","VWREGITS",39,0)
670 S N=0 F S N=$O(LDATA(N)) Q:'+N I +$P($G(^DD(2,+$P(LDATA(N),"^",2),0)),"^",2) K LDATA(N)
671"RTN","VWREGITS",40,0)
672 S DFN=$$FIND1^DIC(2,"","M",$P(LDATA(1),"^",3),"","","ERR")
673"RTN","VWREGITS",41,0)
674 G EXP:DFN ;Found patient/client
675"RTN","VWREGITS",42,0)
676 ;End housekeeping;
677"RTN","VWREGITS",43,0)
678 ;
679"RTN","VWREGITS",44,0)
680 S X=$P(LDATA(1),"^",3) D
681"RTN","VWREGITS",45,0)
682 . S DIC="^DPT(",DIC(0)="LZ" K D0 D FILE^DICN S (DA,DFN)=+Y
683"RTN","VWREGITS",46,0)
684 . S DIC="^AUPNPAT(",DIC(0)="LZ",X=DFN,DINUM=X,DIC(0)="L" D FILE^DICN
685"RTN","VWREGITS",47,0)
686 . S DIE=DIC,DR=.03_"////^S X=DT" D ^DIE
687"RTN","VWREGITS",48,0)
688 . S DR=.11_"////^S X=DUZ" D ^DIE
689"RTN","VWREGITS",49,0)
690LDPT L +^DPT(DFN):1 G LDPT:'$T
691"RTN","VWREGITS",50,0)
692 S N=1 F S N=$O(LDATA(N)) Q:'+N D
693"RTN","VWREGITS",51,0)
694 . Q:$P(LDATA(N),"^",2)[";"
695"RTN","VWREGITS",52,0)
696 . Q:'+$P(LDATA(N),"^",2) ;Marker of some kind
697"RTN","VWREGITS",53,0)
698 . S FIELD=$P(LDATA(N),"^",2)
699"RTN","VWREGITS",54,0)
700 . S VAR=$P(LDATA(N),"^",3)
701"RTN","VWREGITS",55,0)
702 . I FIELD=.03 D
703"RTN","VWREGITS",56,0)
704 .. S VAR=$$DC(VAR)
705"RTN","VWREGITS",57,0)
706 .. S VARTIME=$P(VAR,".",2),VAR=$P(VAR,".")
707"RTN","VWREGITS",58,0)
708 .. I $L(VARTIME) D
709"RTN","VWREGITS",59,0)
710 ... N FDA
711"RTN","VWREGITS",60,0)
712 ... S FDA(2,DFN_",",540000.1)=VARTIME
713"RTN","VWREGITS",61,0)
714 ... D FILE^DIE("E","FDA")
715"RTN","VWREGITS",62,0)
716 ... D CLEAN^DILF
717"RTN","VWREGITS",63,0)
718 . S:VAR["(" VAR=$S($L(VAR,"(")>2:+$P(VAR,"(",$L(VAR,"(")),1:+$P(VAR,"(",2))
719"RTN","VWREGITS",64,0)
720 . S DIE="^DPT(",DR=FIELD_"///"_$S(+VAR:"/",1:"")_"^S X=VAR" D ^DIE
721"RTN","VWREGITS",65,0)
722 L -^DPT(DFN)
723"RTN","VWREGITS",66,0)
724 D M ;File any multiple fields
725"RTN","VWREGITS",67,0)
726 S RESULT(0)="Filed..."
727"RTN","VWREGITS",68,0)
728 K ^DIZ("DS",$J)
729"RTN","VWREGITS",69,0)
730 Q
731"RTN","VWREGITS",70,0)
732 ;
733"RTN","VWREGITS",71,0)
734EXP ;Existing Patient
735"RTN","VWREGITS",72,0)
736 K X,FNAME,FFLD,FVALUE,AR,DIC,DA,DR,DIE,AR
737"RTN","VWREGITS",73,0)
738 S X="LDATA" F S X=$Q(@X) Q:X="" I @X[":" S AR($O(AR(" "),-1)+1)=@X K @X
739"RTN","VWREGITS",74,0)
740 S N=0 F S N=$O(LDATA(N)) Q:'+N S X=LDATA(N) D
741"RTN","VWREGITS",75,0)
742 . S FNAME=$P(X,"^")
743"RTN","VWREGITS",76,0)
744 . S FFLD=$P(X,"^",2)
745"RTN","VWREGITS",77,0)
746 . S FVALUE=$S($P(X,"^",3)["(":+$P(X,"(",2),1:$P(X,"^",3))
747"RTN","VWREGITS",78,0)
748 . S DFN=$P(X,"^",4)
749"RTN","VWREGITS",79,0)
750 . S DIE="^DPT(",DA=DFN,DR=FFLD_"///^S X=FVALUE" D ^DIE
751"RTN","VWREGITS",80,0)
752 D M
753"RTN","VWREGITS",81,0)
754 S RESULT($I(RESULT))="Filed..."
755"RTN","VWREGITS",82,0)
756 K X,FNAME,FFL,FVALUE,DFN,AR,DIE,DA,DR,DIC
757"RTN","VWREGITS",83,0)
758 Q
759"RTN","VWREGITS",84,0)
760 ;
761"RTN","VWREGITS",85,0)
762M ;File any multiples values; DFN should be defined above
763"RTN","VWREGITS",86,0)
764 Q:'$D(^DIZ("DS",$J))
765"RTN","VWREGITS",87,0)
766 M MULTS=^DIZ("DS",$J)
767"RTN","VWREGITS",88,0)
768 K MAR S N=0 F S N=$O(MULTS(N)) Q:'+N D
769"RTN","VWREGITS",89,0)
770 . F J=1:1:$L(MULTS(N),"^")-1 S MAR(J)=$P(MULTS(N),"^",J)
771"RTN","VWREGITS",90,0)
772 . S MX=$O(MAR(0))
773"RTN","VWREGITS",91,0)
774 . S MXFILE=+$P(MAR(MX),"(",2)
775"RTN","VWREGITS",92,0)
776 . S MXFLD=+$P(MAR(MX),";",2)
777"RTN","VWREGITS",93,0)
778 . S MXVAL=$P($P(MAR(MX),":",2),"(")
779"RTN","VWREGITS",94,0)
780 . I MXFLD=.01 S MXDATA(MXFILE,"?+1,"_DFN_",",MXFLD)=MXVAL K IEN D UPDATE^DIE("E","MXDATA","IEN","ERROR") Q:$G(DIERR) D
781"RTN","VWREGITS",95,0)
782 .. S RECORD=$G(IEN(1)),INC=$G(IEN(1,0))
783"RTN","VWREGITS",96,0)
784 .. S J=MX F S J=$O(MAR(J)) Q:'+J D
785"RTN","VWREGITS",97,0)
786 ... s MXFILE=+$P(MAR(J),"(",2)
787"RTN","VWREGITS",98,0)
788 ... S MXFLD=+$P(MAR(J),";",2)
789"RTN","VWREGITS",99,0)
790 ... S MXVAL=$P(MAR(J),":",2),MXVAL=$S(MXVAL["(":$P(MXVAL,"("),1:MXVAL)
791"RTN","VWREGITS",100,0)
792 ... S MXDATA(MXFILE,$S(MXFLD=.01:INC,1:"")_"1,"_RECORD_","_DFN_",",MXFLD)=MXVAL
793"RTN","VWREGITS",101,0)
794 ... K IEN,ERROR D UPDATE^DIE("E","MXDATA","IEN","ERROR")
795"RTN","VWREGITS",102,0)
796 Q
797"RTN","VWREGITS",103,0)
798 ;
799"RTN","VWREGITS",104,0)
800DC(XDATE) ;Convert DOB to internal
801"RTN","VWREGITS",105,0)
802 N %DT,X
803"RTN","VWREGITS",106,0)
804 S X=XDATE,%DT="T" D ^%DT
805"RTN","VWREGITS",107,0)
806 Q Y
807"RTN","VWREGITS",108,0)
808 ;
809"RTN","VWREGITS",109,0)
810INSUR ;Insurance/Billing
811"RTN","VWREGITS",110,0)
812 Q
813"RTN","VWREGITS",111,0)
814 ;
815"RTN","VWREGITS",112,0)
816K S DA=$P(^DPT(0),"^",3),DIK="^DPT(" D ^DIK
817"RTN","VWREGITS",113,0)
818 S DIK="^AUPNPAT(" D ^DIK
819"RTN","VWREGITS",114,0)
820 Q
821"RTN","VWREGITS",115,0)
822 ;
823"VER")
8248.0^22.2
825"^DD",2,2,540001.1,0)
826HEALTH RECORD NUMBER^F^^648HRN;1^K:$L(X)>30!($L(X)<1) X
827"^DD",2,2,540001.1,3)
828Enter patient/client's health record number (HRN), up to 30 characters
829"^DD",2,2,540001.1,"DT")
8303160309
831**END**
832**END**
Note: See TracBrowser for help on using the repository browser.