KIDS Distribution saved on Mar 08, 2017@13:41:25
Patch 3 to WorldVistA GUI Registration 03/08/2017
**KIDS**:VWREG_03082017*2.04T3*2^

**INSTALL NAME**
VWREG_03082017*2.04T3*2
"BLD",8570,0)
VWREG_03082017*2.04T3*2^^0^3170308^n
"BLD",8570,1,0)
^^6^6^3170308^^^^
"BLD",8570,1,1,0)
3 Repairs found in Alpha Testing:
"BLD",8570,1,2,0)
  Removing a testing stub that prevented filing of patient data
"BLD",8570,1,3,0)
   in VWREGITS
"BLD",8570,1,4,0)
  Adding a field 540001.1 HEALTH RECORD NUMBER to the PATIENT
"BLD",8570,1,5,0)
   file (#2)
"BLD",8570,1,6,0)
  Removed field 540001.1 from VW PT REGISTRATION template
"BLD",8570,4,0)
^9.64PA^2^1
"BLD",8570,4,2,0)
2
"BLD",8570,4,2,2,0)
^9.641^2^1
"BLD",8570,4,2,2,2,0)
PATIENT  (File-top level)
"BLD",8570,4,2,2,2,1,0)
^9.6411^540001.1^1
"BLD",8570,4,2,2,2,1,540001.1,0)
HEALTH RECORD NUMBER
"BLD",8570,4,2,222)
y^n^p^^^^n^^n
"BLD",8570,4,2,224)

"BLD",8570,4,"APDD",2,2)

"BLD",8570,4,"APDD",2,2,540001.1)

"BLD",8570,4,"B",2,2)

"BLD",8570,6.3)
2
"BLD",8570,"KRN",0)
^9.67PA^779.2^20
"BLD",8570,"KRN",.4,0)
.4
"BLD",8570,"KRN",.401,0)
.401
"BLD",8570,"KRN",.402,0)
.402
"BLD",8570,"KRN",.402,"NM",0)
^9.68A^1^1
"BLD",8570,"KRN",.402,"NM",1,0)
VW PT REGISTRATION    FILE #2^2^0
"BLD",8570,"KRN",.402,"NM","B","VW PT REGISTRATION    FILE #2",1)

"BLD",8570,"KRN",.403,0)
.403
"BLD",8570,"KRN",.5,0)
.5
"BLD",8570,"KRN",.84,0)
.84
"BLD",8570,"KRN",3.6,0)
3.6
"BLD",8570,"KRN",3.8,0)
3.8
"BLD",8570,"KRN",9.2,0)
9.2
"BLD",8570,"KRN",9.8,0)
9.8
"BLD",8570,"KRN",9.8,"NM",0)
^9.68A^2^2
"BLD",8570,"KRN",9.8,"NM",1,0)
VWREGIT^^0^B34467909
"BLD",8570,"KRN",9.8,"NM",2,0)
VWREGITS^^0^B15352111
"BLD",8570,"KRN",9.8,"NM","B","VWREGIT",1)

"BLD",8570,"KRN",9.8,"NM","B","VWREGITS",2)

"BLD",8570,"KRN",19,0)
19
"BLD",8570,"KRN",19.1,0)
19.1
"BLD",8570,"KRN",101,0)
101
"BLD",8570,"KRN",409.61,0)
409.61
"BLD",8570,"KRN",771,0)
771
"BLD",8570,"KRN",779.2,0)
779.2
"BLD",8570,"KRN",870,0)
870
"BLD",8570,"KRN",8989.51,0)
8989.51
"BLD",8570,"KRN",8989.52,0)
8989.52
"BLD",8570,"KRN",8994,0)
8994
"BLD",8570,"KRN","B",.4,.4)

"BLD",8570,"KRN","B",.401,.401)

"BLD",8570,"KRN","B",.402,.402)

"BLD",8570,"KRN","B",.403,.403)

"BLD",8570,"KRN","B",.5,.5)

"BLD",8570,"KRN","B",.84,.84)

"BLD",8570,"KRN","B",3.6,3.6)

"BLD",8570,"KRN","B",3.8,3.8)

"BLD",8570,"KRN","B",9.2,9.2)

"BLD",8570,"KRN","B",9.8,9.8)

"BLD",8570,"KRN","B",19,19)

"BLD",8570,"KRN","B",19.1,19.1)

"BLD",8570,"KRN","B",101,101)

"BLD",8570,"KRN","B",409.61,409.61)

"BLD",8570,"KRN","B",771,771)

"BLD",8570,"KRN","B",779.2,779.2)

"BLD",8570,"KRN","B",870,870)

"BLD",8570,"KRN","B",8989.51,8989.51)

"BLD",8570,"KRN","B",8989.52,8989.52)

"BLD",8570,"KRN","B",8994,8994)

"BLD",8570,"QDEF")
^^^^NO^^^^NO^^NO
"BLD",8570,"QUES",0)
^9.62^^
"BLD",8570,"REQB",0)
^9.611^^
"FIA",2)
PATIENT
"FIA",2,0)
^DPT(
"FIA",2,0,0)
2I
"FIA",2,0,1)
y^n^p^^^^n^^n
"FIA",2,0,10)

"FIA",2,0,11)

"FIA",2,0,"RLRO")

"FIA",2,2)
1
"FIA",2,2,540001.1)

"KRN",.402,1773,-1)
0^1
"KRN",.402,1773,0)
VW PT REGISTRATION^3170308.0946^^2^^^3170308
"KRN",.402,1773,"%D",0)
^^1^1^3160416^
"KRN",.402,1773,"%D",1,0)
Created via registration client
"KRN",.402,1773,"DIAB",5,0,2,0)
.363;"ID NUMBER"
"KRN",.402,1773,"DR",1,2)
.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;
"KRN",.402,1773,"DR",2,2.001)
.01;1;
"KRN",.402,1773,"DR",2,2.312)
.01;
"KRN",.402,1773,"DR",3,2.011)
.01;1;
"MBREQ")
0
"ORD",7,.402)
.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,"",%)
"ORD",7,.402,0)
INPUT TEMPLATE
"QUES","XPF1",0)
Y
"QUES","XPF1","??")
^D REP^XPDH
"QUES","XPF1","A")
Shall I write over your |FLAG| File
"QUES","XPF1","B")
YES
"QUES","XPF1","M")
D XPF1^XPDIQ
"QUES","XPF2",0)
Y
"QUES","XPF2","??")
^D DTA^XPDH
"QUES","XPF2","A")
Want my data |FLAG| yours
"QUES","XPF2","B")
YES
"QUES","XPF2","M")
D XPF2^XPDIQ
"QUES","XPI1",0)
YO
"QUES","XPI1","??")
^D INHIBIT^XPDH
"QUES","XPI1","A")
Want KIDS to INHIBIT LOGONs during the install
"QUES","XPI1","B")
NO
"QUES","XPI1","M")
D XPI1^XPDIQ
"QUES","XPM1",0)
PO^VA(200,:EM
"QUES","XPM1","??")
^D MG^XPDH
"QUES","XPM1","A")
Enter the Coordinator for Mail Group '|FLAG|'
"QUES","XPM1","B")

"QUES","XPM1","M")
D XPM1^XPDIQ
"QUES","XPO1",0)
Y
"QUES","XPO1","??")
^D MENU^XPDH
"QUES","XPO1","A")
Want KIDS to Rebuild Menu Trees Upon Completion of Install
"QUES","XPO1","B")
NO
"QUES","XPO1","M")
D XPO1^XPDIQ
"QUES","XPZ1",0)
Y
"QUES","XPZ1","??")
^D OPT^XPDH
"QUES","XPZ1","A")
Want to DISABLE Scheduled Options, Menu Options, and Protocols
"QUES","XPZ1","B")
NO
"QUES","XPZ1","M")
D XPZ1^XPDIQ
"QUES","XPZ2",0)
Y
"QUES","XPZ2","??")
^D RTN^XPDH
"QUES","XPZ2","A")
Want to MOVE routines to other CPUs
"QUES","XPZ2","B")
NO
"QUES","XPZ2","M")
D XPZ2^XPDIQ
"RTN")
2
"RTN","VWREGIT")
0^1^B34467909
"RTN","VWREGIT",1,0)
VWREGIT ;Portland,OR/Jim Bell, et al Patient Registration Utility August 2015
"RTN","VWREGIT",2,0)
 ;;2.0;B/FProductions,LLC,WORLD VISTA;**LOCAL**;;Build 2
"RTN","VWREGIT",3,0)
 ;*******************************************************************
"RTN","VWREGIT",4,0)
 ;* VW Registration is designed for patient specific fields as      *
"RTN","VWREGIT",5,0)
 ;* defined in Fileman Input Templates or ad hoc field selection.   *
"RTN","VWREGIT",6,0)
 ;* Copyright Martius/MMXV ad infinitum (GNU License: See GPLv3.txt)*
"RTN","VWREGIT",7,0)
 ;*******************************************************************
"RTN","VWREGIT",8,0)
 ;;NO FALL THROUGH - JEB
"RTN","VWREGIT",9,0)
 Q
"RTN","VWREGIT",10,0)
 ;
"RTN","VWREGIT",11,0)
TFM(XF) ;TemplateField Management
"RTN","VWREGIT",12,0)
 ;***********************************************
"RTN","VWREGIT",13,0)
 ;* Check primary field entries for "parentage" *
"RTN","VWREGIT",14,0)
 ;* Add an "*" to gain all sub-fields of the    *
"RTN","VWREGIT",15,0)
 ;* parent                                      *
"RTN","VWREGIT",16,0)
 ;* REMEMBER: All fields pertain to file 2 only *
"RTN","VWREGIT",17,0)
 ;***********************************************
"RTN","VWREGIT",18,0)
 N I,N,FIELD
"RTN","VWREGIT",19,0)
 K FARRAY
"RTN","VWREGIT",20,0)
 I '$L(XF),'$G(TNUM) Q ""
"RTN","VWREGIT",21,0)
 I '$L(XF),+$G(TNUM) S XF=^DIE(TNUM,"DR",1,2)
"RTN","VWREGIT",22,0)
 F I=1:1:$L(XF,";") S:$L($P(XF,";",I)) FARRAY(I)=+$P(XF,";",I)
"RTN","VWREGIT",23,0)
 S N=0 F I=1:1 S N=$O(FARRAY(N)) Q:'+N  D
"RTN","VWREGIT",24,0)
 . S FIELD=FARRAY(N)
"RTN","VWREGIT",25,0)
 . I +$P(^DD(2,FIELD,0),"^",2) S FIELD=FIELD_"*",FMARRAY(FIELD)=$P(^(0),"^",4) K FARRAY(N)
"RTN","VWREGIT",26,0)
 S XF="",N=0 F  S N=$O(FARRAY(N)) Q:'+N  S XF=XF_FARRAY(N)_";"
"RTN","VWREGIT",27,0)
 Q XF
"RTN","VWREGIT",28,0)
 ;
"RTN","VWREGIT",29,0)
CHECK() ;
"RTN","VWREGIT",30,0)
 Q ""
"RTN","VWREGIT",31,0)
 ;
"RTN","VWREGIT",32,0)
INR() Q $O(RESULT(" "),-1)+1
"RTN","VWREGIT",33,0)
 ;
"RTN","VWREGIT",34,0)
EN(RESULT)    ;Template name and ID labels
"RTN","VWREGIT",35,0)
 ;Get the input template list
"RTN","VWREGIT",36,0)
 ;housekeeping
"RTN","VWREGIT",37,0)
 S DTIME=99999
"RTN","VWREGIT",38,0)
 ;ZSY "chmod 777 "_$ZD_"regparam/*.txt" ;Moved to post-install
"RTN","VWREGIT",39,0)
 ;end housekeeping
"RTN","VWREGIT",40,0)
 ;
"RTN","VWREGIT",41,0)
 K AR,RESULT
"RTN","VWREGIT",42,0)
 N N,HD,FILE,LOC,P4,P5,%ZISHF,%ZISHO,DEFST,XTMP,X
"RTN","VWREGIT",43,0)
 S RESULT(0)=1
"RTN","VWREGIT",44,0)
 S DEFST="";
"RTN","VWREGIT",45,0)
 ;S DEFTMP=$O(^DIE("B","FAU_EDU",0)) ;For Florida College only
"RTN","VWREGIT",46,0)
 S RESULT(0)=$$CONTROL^VWREGITU()
"RTN","VWREGIT",47,0)
 S RESULT(1)="-1^No templates found"
"RTN","VWREGIT",48,0)
 S DEFST=$$GET^XPAR("ALL","VW REG DEFAULT STATE")
"RTN","VWREGIT",49,0)
 S DEFTMP=$$GET^XPAR("ALL","VW REG RDNPT")
"RTN","VWREGIT",50,0)
 S HD=$$GET^XPAR("ALL","VW GUI REG TEMPLATE DIRECTORY")
"RTN","VWREGIT",51,0)
 I '$L(HD) K RESULT D  Q
"RTN","VWREGIT",52,0)
 . S RESULT($$INR)="-1^NO HOME DIRECTORY - refer to IT support, if necessary."
"RTN","VWREGIT",53,0)
 . S RESULT($$INR)="No home directory has been supplied which indicates"
"RTN","VWREGIT",54,0)
 . S RESULT($$INR)="the VWREG installation is incomplete. See the Help manual"
"RTN","VWREGIT",55,0)
 . S RESULT($$INR)="for installation and Enter/Editing parameter values."
"RTN","VWREGIT",56,0)
 . S RESULT($$INR)="Thank you,"
"RTN","VWREGIT",57,0)
 . S RESULT($$INR)="      The Management."
"RTN","VWREGIT",58,0)
 S FILE="regit.txt"
"RTN","VWREGIT",59,0)
 S P4=1
"RTN","VWREGIT",60,0)
 S P5=""
"RTN","VWREGIT",61,0)
 S X=$$FTG^%ZISH(HD,FILE,$NA(AR(1)),P4,P5)
"RTN","VWREGIT",62,0)
 D:+RESULT(0)
"RTN","VWREGIT",63,0)
 . S $P(RESULT(0),"^",2)=$G(HD)
"RTN","VWREGIT",64,0)
 . S $P(RESULT(0),"^",3)=$S(DEFST:$P(^DIC(5,DEFST,0),"^")_"("_DEFST_")",1:"")
"RTN","VWREGIT",65,0)
 . S $P(RESULT(0),"^",4)=$S(+DEFTMP:$P(^DIE(DEFTMP,0),"^")_"("_DEFTMP_")",1:DEFTMP)
"RTN","VWREGIT",66,0)
 . S $P(RESULT(0),"^",5)=DUZ
"RTN","VWREGIT",67,0)
 I $O(AR(0)) S RESULT(1)="[TEMPLATES]"
"RTN","VWREGIT",68,0)
 S N=0 F  S N=$O(AR(N)) Q:'+N  D
"RTN","VWREGIT",69,0)
 . Q:$E(AR(N))="*"
"RTN","VWREGIT",70,0)
 . Q:'+$P(AR(N),"(",2)
"RTN","VWREGIT",71,0)
 . Q:$P($G(^DIE(+$P(AR(N),"(",2),0)),"^",4)'=2  ;must be pat file
"RTN","VWREGIT",72,0)
 . S RESULT($$INR)=AR(N)
"RTN","VWREGIT",73,0)
 S RESULT($$INR)="[ID]"
"RTN","VWREGIT",74,0)
 ;S N=0 F  S N=$O(^DIZ(64850003,N)) Q:'+N  S RESULT($$INR)=$P(^(N,0),"^",2)_"("_$P(^(0),"^")_")"
"RTN","VWREGIT",75,0)
 ;S N=0 F  S N=$O(RESULT(N)) Q:'+N  K:RESULT(N)="" RESULT(N)
"RTN","VWREGIT",76,0)
 I '$O(RESULT(0)) S RESULT(1)="-1^No PATIENT FILE templates found"
"RTN","VWREGIT",77,0)
 K AR
"RTN","VWREGIT",78,0)
 Q
"RTN","VWREGIT",79,0)
 ;
"RTN","VWREGIT",80,0)
NPT(RESULT,TNAME) ;
"RTN","VWREGIT",81,0)
 ; *************************************************
"RTN","VWREGIT",82,0)
 ; * Incoming: DFN^TEMPLATE NAME(IEN)              *
"RTN","VWREGIT",83,0)
 ; * Process : Get template fields plus any help   *
"RTN","VWREGIT",84,0)
 ; *           If +TNAME (a DFN), get DFN data for *
"RTN","VWREGIT",85,0)
 ; *           the template fields (Put data in    *
"RTN","VWREGIT",86,0)
 ; *           $P(RESULT(N),"^",3))                *
"RTN","VWREGIT",87,0)
 ; * Return  : RESULT(N), etc                      *
"RTN","VWREGIT",88,0)
 ; *************************************************
"RTN","VWREGIT",89,0)
 ;W "  ;Intentional bust for debugging
"RTN","VWREGIT",90,0)
 N N,TNUM,FIELDS,F,FNAME,FVALUE,FHELP,FPSC,FNUM
"RTN","VWREGIT",91,0)
 S TNUM=+$P(TNAME,"(",2),DFN=+TNAME
"RTN","VWREGIT",92,0)
 I 'TNUM S RESULT(0)="0^new patient Template not found" Q
"RTN","VWREGIT",93,0)
 S TNAME=$P($P(TNAME,"^",2),"(")
"RTN","VWREGIT",94,0)
 S TNAME=$TR(TNAME,"$&*","")  ;Clean out TMENU chars
"RTN","VWREGIT",95,0)
 I TNAME="GENERIC INS. FRM [WorldVistA]" G GIF
"RTN","VWREGIT",96,0)
 S FIELDS=$G(^DIE(TNUM,"DR",1,2))
"RTN","VWREGIT",97,0)
 I '$L(FIELDS) Q
"RTN","VWREGIT",98,0)
 K RESULT S (FNUM,FCAP)=""
"RTN","VWREGIT",99,0)
 F I=1:1:$L(FIELDS,";")-1 D
"RTN","VWREGIT",100,0)
 . S F=$P(FIELDS,";",I)
"RTN","VWREGIT",101,0)
 . Q:'$D(^DD(2,F))  ;Not existing in this patient file
"RTN","VWREGIT",102,0)
 . I F["~" S FNUM=+F,FNAME=$P($P(F,"~"),FNUM,2),F=FNUM K FNUM
"RTN","VWREGIT",103,0)
 . S FNAME=$S($L($G(FNAME)):FNAME,$L($G(^DD(2,F,.1))):$P(^(.1),"^"),1:$P(^DD(2,F,0),"^"))
"RTN","VWREGIT",104,0)
 . S FVALUE=""  ;Patient Data
"RTN","VWREGIT",105,0)
 . S FHELP=$G(^DD(2,F,3))
"RTN","VWREGIT",106,0)
 . 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)
"RTN","VWREGIT",107,0)
 . S FHELP=$TR(FHELP,"'","`")
"RTN","VWREGIT",108,0)
 . S FPSC=$P(^DD(2,F,0),"^",3)
"RTN","VWREGIT",109,0)
 . S SUBDIC=+$P(^DD(2,F,0),"^",2)
"RTN","VWREGIT",110,0)
 . S RESULT($$INR)=FNAME_"^"_F_"^"_FVALUE_"^"_FHELP_"^"_FPSC_$S(SUBDIC:"^1",1:"^0")
"RTN","VWREGIT",111,0)
 . S (FNAME,FVALUE,FHELP,FPSC)=""
"RTN","VWREGIT",112,0)
 G NPTX:'DFN
"RTN","VWREGIT",113,0)
 I DFN D GETS^DIQ(2,DFN_",","**","EN","AR")  ;,RESULT(0)=$$DFNID^VWREGITU
"RTN","VWREGIT",114,0)
 K FIELD S N=0 F  S N=$O(RESULT(N)) Q:'+N  S FIELD($P(RESULT(N),"^",2))=""
"RTN","VWREGIT",115,0)
 S X="AR" F  S X=$Q(@X) Q:X=""  D
"RTN","VWREGIT",116,0)
 . S FILE=+$P(X,"(",2)
"RTN","VWREGIT",117,0)
 . S FIELD=+$P(X,",",$L(X,",")-1)
"RTN","VWREGIT",118,0)
 . I $D(FIELD(FIELD)) S FIELD(FIELD)=@X
"RTN","VWREGIT",119,0)
 S N=0 F  S N=$O(FIELD(N)) Q:'+N  D
"RTN","VWREGIT",120,0)
 . S N2=0 F  S N2=$O(RESULT(N2)) Q:'+N2  I $P(RESULT(N2),"^",2)=N S $P(RESULT(N2),"^",3)=FIELD(N)
"RTN","VWREGIT",121,0)
 . S RESULT(0)=$$DFNID^VWREGITU()
"RTN","VWREGIT",122,0)
NPTX K FIELD,AR,FCAP,FILE,SUBDIC,N,N2,DFN
"RTN","VWREGIT",123,0)
 Q
"RTN","VWREGIT",124,0)
 ;
"RTN","VWREGIT",125,0)
PF(RESULT,XPF) ;Pointer file - get the stuff
"RTN","VWREGIT",126,0)
 K RESULT,AR
"RTN","VWREGIT",127,0)
 N X,N
"RTN","VWREGIT",128,0)
 I '$L(XPF) S RESULT(0)="???" Q
"RTN","VWREGIT",129,0)
 S XPF="^"_XPF
"RTN","VWREGIT",130,0)
 I +$P(XPF,"(",2)=.85 G NAUTPF  ;Naughty file!
"RTN","VWREGIT",131,0)
 S N=0 F  S N=$O(@(XPF_N_")")) Q:'+N  S X=$P(^(N,0),"^"),AR(X,N)=X_"("_N_")"
"RTN","VWREGIT",132,0)
 S X="AR" F  S X=$Q(@X) Q:X=""  S RESULT($$INR)=@X
"RTN","VWREGIT",133,0)
 K AR
"RTN","VWREGIT",134,0)
 Q
"RTN","VWREGIT",135,0)
 ;
"RTN","VWREGIT",136,0)
NAUTPF ;The "NAUGHTY" pointer file - has a numeric .01 - Bad file !!!
"RTN","VWREGIT",137,0)
 S N=0 F  S N=$O(@(XPF_N_")")) Q:'+N  S X=$P(^(N,0),"^") D
"RTN","VWREGIT",138,0)
 . S LANG=$P(^(0),"^",2)
"RTN","VWREGIT",139,0)
 . S AR(LANG,N)=LANG_"("_N_")"
"RTN","VWREGIT",140,0)
 S X="AR" F  S X=$Q(@X) Q:X=""  S RESULT($$INR)=@X
"RTN","VWREGIT",141,0)
 Q
"RTN","VWREGIT",142,0)
GIF ;Generic Insurance form
"RTN","VWREGIT",143,0)
 K RESULT
"RTN","VWREGIT",144,0)
 S RESULT($$INR)="Insurance Company^2.312;.01^^^DIC(36,^0"
"RTN","VWREGIT",145,0)
 S RESULT($$INR)="Group Plan^2.312;.18^^^IBA(355.3,^0"
"RTN","VWREGIT",146,0)
 S RESULT($$INR)="Policy No.^2.312;1^^^^0"
"RTN","VWREGIT",147,0)
 ;S RESULT($$INR)="Type of Plan^^^^^0"
"RTN","VWREGIT",148,0)
 S RESULT($$INR)="Coverage^355.33;40.09^^^IBE(355.1,^0"
"RTN","VWREGIT",149,0)
 S RESULT($$INR)="Effective Date^2.312;8^^^^0"
"RTN","VWREGIT",150,0)
 S RESULT($$INR)="Expiration Date^.3121;^^^^0"
"RTN","VWREGIT",151,0)
 S RESULT($$INR)="Guarantor^^^^^0"
"RTN","VWREGIT",152,0)
 S RESULT($$INR)="Signature on File^^^^0:NO;1:YES^0"
"RTN","VWREGIT",153,0)
 S RESULT($$INR)="Employer^2.312;2.015^^^^0"
"RTN","VWREGIT",154,0)
 S RESULT($$INR)="Billing Address^2.312;2.02^^^^0"
"RTN","VWREGIT",155,0)
 S RESULT($$INR)="Billing Address(cont)^2.312;2.03^^^^0"
"RTN","VWREGIT",156,0)
 S RESULT($$INR)="Postal Code^2.312;2.07^^^^0"
"RTN","VWREGIT",157,0)
 S RESULT($$INR)="City^2.312;2.05^^^^0"
"RTN","VWREGIT",158,0)
 S RESULT($$INR)="County/Region/Area^^^^^0"
"RTN","VWREGIT",159,0)
 S RESULT($$INR)="State/Province/Region^2.312;2.06^^^DIC(5,^0"
"RTN","VWREGIT",160,0)
 Q
"RTN","VWREGIT",161,0)
 ;
"RTN","VWREGIT",162,0)
 
"RTN","VWREGITS")
0^2^B15352111
"RTN","VWREGITS",1,0)
VWREGITS ;Portland,OR/jeb et al Save utility for VWREG* routines 11/2015
"RTN","VWREGITS",2,0)
 ;V.2;;**LOCAL**;;;Build 2
"RTN","VWREGITS",3,0)
 ;c2014 ad infiniti, BellFelder Productions (BF Productions) & WorldVistA
"RTN","VWREGITS",4,0)
 ;License: See License.txt that with install
"RTN","VWREGITS",5,0)
 ;No fall thru - jeb
"RTN","VWREGITS",6,0)
 Q
"RTN","VWREGITS",7,0)
 ;
"RTN","VWREGITS",8,0)
 ;* *****************************************************************
"RTN","VWREGITS",9,0)
 ;* Data coming in may be for a new case or existing case           *
"RTN","VWREGITS",10,0)
 ;* Incoming: Array LDATA=                                          *
"RTN","VWREGITS",11,0)
 ;*   LDATA(1)=Field^Field number^value^[optional]DFN               *
"RTN","VWREGITS",12,0)
 ;*                       LDATA(N...)=Field^Field number^value      *
"RTN","VWREGITS",13,0)
 ;* Exception for Multiples:                                        *
"RTN","VWREGITS",14,0)
 ;*   LDATA(N)=Field(SUBDD;Field number):value(IEN)^...etc for every*
"RTN","VWREGITS",15,0)
 ;*            field that is a dependent of the parent              *
"RTN","VWREGITS",16,0)
 ;* Process:                                                        *
"RTN","VWREGITS",17,0)
 ;*  1. call is at Label SAVE                                       *
"RTN","VWREGITS",18,0)
 ;*  2. Some housekeeping that this programmer needs to do proper   *
"RTN","VWREGITS",19,0)
 ;*     string evaluations.                                         *
"RTN","VWREGITS",20,0)
 ;*  3. Filing of a new case with FILE^DICN.                        *
"RTN","VWREGITS",21,0)
 ;*  4. Remaining major fields are filed with DIE                   *
"RTN","VWREGITS",22,0)
 ;*  5. Multiples are filed with UPDATE^DIE                         *
"RTN","VWREGITS",23,0)
 ;*  6. Existing entries will contain only edited data and will     *
"RTN","VWREGITS",24,0)
 ;*     address those fields as in 4 & 5.                           *
"RTN","VWREGITS",25,0)
 ;* Bon Appettit, et al.                                            *
"RTN","VWREGITS",26,0)
 ;*******************************************************************
"RTN","VWREGITS",27,0)
SAVE(RESULT,LDATA) ;
"RTN","VWREGITS",28,0)
 K RESULT,^DIZ("DS",$J)
"RTN","VWREGITS",29,0)
 M ^DIZ("DS",$J)=LDATA
"RTN","VWREGITS",30,0)
 ;Q ;Testing
"RTN","VWREGITS",31,0)
 N DFN,DIC,DA,DR,VAR,FIELD,N,N1,X,Y,DIE,DIK
"RTN","VWREGITS",32,0)
 I $D(LDATA)<10 S RESULT(0)="-1: No data sent for filing. Please contact your IT dept." Q
"RTN","VWREGITS",33,0)
 ;UPcase everyTHING
"RTN","VWREGITS",34,0)
 S XDAT="LDATA" F  S XDAT=$Q(@XDAT) Q:XDAT=""  S @XDAT=$$UP^XLFSTR(@XDAT)
"RTN","VWREGITS",35,0)
 ;
"RTN","VWREGITS",36,0)
 ;Incoming housekeeping
"RTN","VWREGITS",37,0)
 S X="LDATA" F I=1:1 S X=$Q(@X) Q:X=""  I @X[":",@X[";" S ^DIZ("DS",$J,I)=@X K @X
"RTN","VWREGITS",38,0)
 I +$P(@$Q(LDATA),"^",4)!(+$P(@$Q(LDATA),"(",2)) G EXP ;DFN sent by client
"RTN","VWREGITS",39,0)
 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)
"RTN","VWREGITS",40,0)
 S DFN=$$FIND1^DIC(2,"","M",$P(LDATA(1),"^",3),"","","ERR")
"RTN","VWREGITS",41,0)
 G EXP:DFN  ;Found patient/client
"RTN","VWREGITS",42,0)
 ;End housekeeping;
"RTN","VWREGITS",43,0)
 ;
"RTN","VWREGITS",44,0)
 S X=$P(LDATA(1),"^",3) D
"RTN","VWREGITS",45,0)
 . S DIC="^DPT(",DIC(0)="LZ" K D0 D FILE^DICN S (DA,DFN)=+Y
"RTN","VWREGITS",46,0)
 . S DIC="^AUPNPAT(",DIC(0)="LZ",X=DFN,DINUM=X,DIC(0)="L" D FILE^DICN
"RTN","VWREGITS",47,0)
 . S DIE=DIC,DR=.03_"////^S X=DT" D ^DIE
"RTN","VWREGITS",48,0)
 . S DR=.11_"////^S X=DUZ" D ^DIE
"RTN","VWREGITS",49,0)
LDPT L +^DPT(DFN):1 G LDPT:'$T
"RTN","VWREGITS",50,0)
 S N=1 F  S N=$O(LDATA(N)) Q:'+N  D
"RTN","VWREGITS",51,0)
 . Q:$P(LDATA(N),"^",2)[";"
"RTN","VWREGITS",52,0)
 . Q:'+$P(LDATA(N),"^",2)  ;Marker of some kind
"RTN","VWREGITS",53,0)
 . S FIELD=$P(LDATA(N),"^",2)
"RTN","VWREGITS",54,0)
 . S VAR=$P(LDATA(N),"^",3)
"RTN","VWREGITS",55,0)
 . I FIELD=.03 D
"RTN","VWREGITS",56,0)
 .. S VAR=$$DC(VAR)
"RTN","VWREGITS",57,0)
 .. S VARTIME=$P(VAR,".",2),VAR=$P(VAR,".")
"RTN","VWREGITS",58,0)
 .. I $L(VARTIME) D
"RTN","VWREGITS",59,0)
 ... N FDA
"RTN","VWREGITS",60,0)
 ... S FDA(2,DFN_",",540000.1)=VARTIME
"RTN","VWREGITS",61,0)
 ... D FILE^DIE("E","FDA")
"RTN","VWREGITS",62,0)
 ... D CLEAN^DILF
"RTN","VWREGITS",63,0)
 . S:VAR["(" VAR=$S($L(VAR,"(")>2:+$P(VAR,"(",$L(VAR,"(")),1:+$P(VAR,"(",2))
"RTN","VWREGITS",64,0)
 . S DIE="^DPT(",DR=FIELD_"///"_$S(+VAR:"/",1:"")_"^S X=VAR" D ^DIE
"RTN","VWREGITS",65,0)
 L -^DPT(DFN)
"RTN","VWREGITS",66,0)
 D M  ;File any multiple fields
"RTN","VWREGITS",67,0)
 S RESULT(0)="Filed..."
"RTN","VWREGITS",68,0)
 K ^DIZ("DS",$J)
"RTN","VWREGITS",69,0)
 Q
"RTN","VWREGITS",70,0)
 ;
"RTN","VWREGITS",71,0)
EXP ;Existing Patient
"RTN","VWREGITS",72,0)
 K X,FNAME,FFLD,FVALUE,AR,DIC,DA,DR,DIE,AR
"RTN","VWREGITS",73,0)
 S X="LDATA" F  S X=$Q(@X) Q:X=""  I @X[":" S AR($O(AR(" "),-1)+1)=@X K @X
"RTN","VWREGITS",74,0)
 S N=0 F  S N=$O(LDATA(N)) Q:'+N  S X=LDATA(N) D
"RTN","VWREGITS",75,0)
 . S FNAME=$P(X,"^")
"RTN","VWREGITS",76,0)
 . S FFLD=$P(X,"^",2)
"RTN","VWREGITS",77,0)
 . S FVALUE=$S($P(X,"^",3)["(":+$P(X,"(",2),1:$P(X,"^",3))
"RTN","VWREGITS",78,0)
 . S DFN=$P(X,"^",4)
"RTN","VWREGITS",79,0)
 . S DIE="^DPT(",DA=DFN,DR=FFLD_"///^S X=FVALUE" D ^DIE
"RTN","VWREGITS",80,0)
 D M
"RTN","VWREGITS",81,0)
 S RESULT($I(RESULT))="Filed..."
"RTN","VWREGITS",82,0)
 K X,FNAME,FFL,FVALUE,DFN,AR,DIE,DA,DR,DIC
"RTN","VWREGITS",83,0)
 Q
"RTN","VWREGITS",84,0)
 ;
"RTN","VWREGITS",85,0)
M ;File any multiples values; DFN should be defined above
"RTN","VWREGITS",86,0)
 Q:'$D(^DIZ("DS",$J))
"RTN","VWREGITS",87,0)
 M MULTS=^DIZ("DS",$J)
"RTN","VWREGITS",88,0)
 K MAR S N=0 F  S N=$O(MULTS(N)) Q:'+N  D
"RTN","VWREGITS",89,0)
 . F J=1:1:$L(MULTS(N),"^")-1 S MAR(J)=$P(MULTS(N),"^",J)
"RTN","VWREGITS",90,0)
 . S MX=$O(MAR(0))
"RTN","VWREGITS",91,0)
 . S MXFILE=+$P(MAR(MX),"(",2)
"RTN","VWREGITS",92,0)
 . S MXFLD=+$P(MAR(MX),";",2)
"RTN","VWREGITS",93,0)
 . S MXVAL=$P($P(MAR(MX),":",2),"(")
"RTN","VWREGITS",94,0)
 . I MXFLD=.01 S MXDATA(MXFILE,"?+1,"_DFN_",",MXFLD)=MXVAL K IEN D UPDATE^DIE("E","MXDATA","IEN","ERROR") Q:$G(DIERR)  D
"RTN","VWREGITS",95,0)
 .. S RECORD=$G(IEN(1)),INC=$G(IEN(1,0))
"RTN","VWREGITS",96,0)
 .. S J=MX F  S J=$O(MAR(J)) Q:'+J  D
"RTN","VWREGITS",97,0)
 ... s MXFILE=+$P(MAR(J),"(",2)
"RTN","VWREGITS",98,0)
 ... S MXFLD=+$P(MAR(J),";",2)
"RTN","VWREGITS",99,0)
 ... S MXVAL=$P(MAR(J),":",2),MXVAL=$S(MXVAL["(":$P(MXVAL,"("),1:MXVAL)
"RTN","VWREGITS",100,0)
 ... S MXDATA(MXFILE,$S(MXFLD=.01:INC,1:"")_"1,"_RECORD_","_DFN_",",MXFLD)=MXVAL
"RTN","VWREGITS",101,0)
 ... K IEN,ERROR D UPDATE^DIE("E","MXDATA","IEN","ERROR")
"RTN","VWREGITS",102,0)
 Q
"RTN","VWREGITS",103,0)
 ;
"RTN","VWREGITS",104,0)
DC(XDATE) ;Convert DOB to internal
"RTN","VWREGITS",105,0)
 N %DT,X
"RTN","VWREGITS",106,0)
 S X=XDATE,%DT="T" D ^%DT
"RTN","VWREGITS",107,0)
 Q Y
"RTN","VWREGITS",108,0)
 ;
"RTN","VWREGITS",109,0)
INSUR ;Insurance/Billing
"RTN","VWREGITS",110,0)
 Q
"RTN","VWREGITS",111,0)
 ;
"RTN","VWREGITS",112,0)
K S DA=$P(^DPT(0),"^",3),DIK="^DPT(" D ^DIK
"RTN","VWREGITS",113,0)
 S DIK="^AUPNPAT(" D ^DIK
"RTN","VWREGITS",114,0)
 Q
"RTN","VWREGITS",115,0)
 ;
"VER")
8.0^22.2
"^DD",2,2,540001.1,0)
HEALTH RECORD NUMBER^F^^648HRN;1^K:$L(X)>30!($L(X)<1) X
"^DD",2,2,540001.1,3)
Enter patient/client's health record number (HRN), up to 30 characters
"^DD",2,2,540001.1,"DT")
3160309
**END**
**END**