Index: /VWGUIRegistration/trunk/VWREGIT.m
===================================================================
--- /VWGUIRegistration/trunk/VWREGIT.m	(revision 1779)
+++ /VWGUIRegistration/trunk/VWREGIT.m	(revision 1779)
@@ -0,0 +1,161 @@
+VWREGIT	;Portland,OR/Jim Bell, et al Patient Registration Utility August 2015
+	;;2.0;B/FProductions,LLC,WORLD VISTA;**LOCAL**;;Build 2
+	;*******************************************************************
+	;* VW Registration is designed for patient specific fields as      *
+	;* defined in Fileman Input Templates or ad hoc field selection.   *
+	;* Copyright Martius/MMXV ad infinitum (GNU License: See GPLv3.txt)*
+	;*******************************************************************
+	;;NO FALL THROUGH - JEB
+	Q
+	;
+TFM(XF)	;TemplateField Management
+	;***********************************************
+	;* Check primary field entries for "parentage" *
+	;* Add an "*" to gain all sub-fields of the    *
+	;* parent                                      *
+	;* REMEMBER: All fields pertain to file 2 only *
+	;***********************************************
+	N I,N,FIELD
+	K FARRAY
+	I '$L(XF),'$G(TNUM) Q ""
+	I '$L(XF),+$G(TNUM) S XF=^DIE(TNUM,"DR",1,2)
+	F I=1:1:$L(XF,";") S:$L($P(XF,";",I)) FARRAY(I)=+$P(XF,";",I)
+	S N=0 F I=1:1 S N=$O(FARRAY(N)) Q:'+N  D
+	. S FIELD=FARRAY(N)
+	. I +$P(^DD(2,FIELD,0),"^",2) S FIELD=FIELD_"*",FMARRAY(FIELD)=$P(^(0),"^",4) K FARRAY(N)
+	S XF="",N=0 F  S N=$O(FARRAY(N)) Q:'+N  S XF=XF_FARRAY(N)_";"
+	Q XF
+	;
+CHECK()	;
+	Q ""
+	;
+INR()	Q $O(RESULT(" "),-1)+1
+	;
+EN(RESULT)	   ;Template name and ID labels
+	;Get the input template list
+	;housekeeping
+	S DTIME=99999
+	ZSY "chmod 777 "_$ZD_"regparam/*.txt"
+	;end housekeeping
+	;
+	K AR,RESULT
+	N N,HD,FILE,LOC,P4,P5,%ZISHF,%ZISHO,DEFST,XTMP,X
+	S RESULT(0)=1
+	S DEFST="";
+	;S DEFTMP=$O(^DIE("B","FAU_EDU",0)) ;For Florida College only
+	S RESULT(0)=$$CONTROL^VWREGITU()
+	S RESULT(1)="-1^No templates found"
+	S DEFST=$$GET^XPAR("ALL","VW REG DEFAULT STATE")
+	S DEFTMP=$$GET^XPAR("ALL","VW REG RDNPT")
+	S HD=$$GET^XPAR("ALL","VW GUI REG TEMPLATE DIRECTORY")
+	I '$L(HD) K RESULT D  Q
+	. S RESULT($$INR)="-1^NO HOME DIRECTORY - refer to IT support, if necessary."
+	. S RESULT($$INR)="No home directory has been supplied which indicates"
+	. S RESULT($$INR)="the VWREG installation is incomplete. See the Help manual"
+	. S RESULT($$INR)="for installation and Enter/Editing parameter values."
+	. S RESULT($$INR)="Thank you,"
+	. S RESULT($$INR)="      The Management."
+	S FILE="regit.txt"
+	S P4=1
+	S P5=""
+	S X=$$FTG^%ZISH(HD,FILE,$NA(AR(1)),P4,P5)
+	D:+RESULT(0)
+	. S $P(RESULT(0),"^",2)=$G(HD)
+	. S $P(RESULT(0),"^",3)=$S(DEFST:$P(^DIC(5,DEFST,0),"^")_"("_DEFST_")",1:"")
+	. S $P(RESULT(0),"^",4)=$S(+DEFTMP:$P(^DIE(DEFTMP,0),"^")_"("_DEFTMP_")",1:DEFTMP)
+	. S $P(RESULT(0),"^",5)=DUZ
+	I $O(AR(0)) S RESULT(1)="[TEMPLATES]"
+	S N=0 F  S N=$O(AR(N)) Q:'+N  D
+	. Q:$E(AR(N))="*"
+	. Q:'+$P(AR(N),"(",2)
+	. Q:$P($G(^DIE(+$P(AR(N),"(",2),0)),"^",4)'=2  ;must be pat file
+	. S RESULT($$INR)=AR(N)
+	S RESULT($$INR)="[ID]"
+	;S N=0 F  S N=$O(^DIZ(64850003,N)) Q:'+N  S RESULT($$INR)=$P(^(N,0),"^",2)_"("_$P(^(0),"^")_")"
+	;S N=0 F  S N=$O(RESULT(N)) Q:'+N  K:RESULT(N)="" RESULT(N)
+	I '$O(RESULT(0)) S RESULT(1)="-1^No PATIENT FILE templates found"
+	K AR
+	Q
+	;
+NPT(RESULT,TNAME)	;
+	; *************************************************
+	; * Incoming: DFN^TEMPLATE NAME(IEN)              *
+	; * Process : Get template fields plus any help   *
+	; *           If +TNAME (a DFN), get DFN data for *
+	; *           the template fields (Put data in    *
+	; *           $P(RESULT(N),"^",3))                *
+	; * Return  : RESULT(N), etc                      *
+	; *************************************************
+	;W "  ;Intentional bust for debugging
+	N N,TNUM,FIELDS,F,FNAME,FVALUE,FHELP,FPSC,FNUM
+	S TNUM=+$P(TNAME,"(",2),DFN=+TNAME
+	I 'TNUM S RESULT(0)="0^new patient Template not found" Q
+	S TNAME=$P($P(TNAME,"^",2),"(")
+	S TNAME=$TR(TNAME,"$&*","")  ;Clean out TMENU chars
+	I TNAME="GENERIC INS. FRM [WorldVistA]" G GIF
+	S FIELDS=$G(^DIE(TNUM,"DR",1,2))
+	I '$L(FIELDS) Q
+	K RESULT S (FNUM,FCAP)=""
+	F I=1:1:$L(FIELDS,";")-1 D
+	. S F=$P(FIELDS,";",I)
+	. I F["~" S FNUM=+F,FNAME=$P($P(F,"~"),FNUM,2),F=FNUM K FNUM
+	. S FNAME=$S($L($G(FNAME)):FNAME,$L($G(^DD(2,F,.1))):$P(^(.1),"^"),1:$P(^DD(2,F,0),"^"))
+	. S FVALUE=""  ;Patient Data
+	. S FHELP=$G(^DD(2,F,3))
+	. 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)
+	. S FHELP=$TR(FHELP,"'","`")
+	. S FPSC=$P(^DD(2,F,0),"^",3)
+	. S SUBDIC=+$P(^DD(2,F,0),"^",2)
+	. S RESULT($$INR)=FNAME_"^"_F_"^"_FVALUE_"^"_FHELP_"^"_FPSC_$S(SUBDIC:"^1",1:"^0")
+	. S (FNAME,FVALUE,FHELP,FPSC)=""
+	G NPTX:'DFN
+	I DFN D GETS^DIQ(2,DFN_",","**","EN","AR")  ;,RESULT(0)=$$DFNID^VWREGITU
+	K FIELD S N=0 F  S N=$O(RESULT(N)) Q:'+N  S FIELD($P(RESULT(N),"^",2))=""
+	S X="AR" F  S X=$Q(@X) Q:X=""  D
+	. S FILE=+$P(X,"(",2)
+	. S FIELD=+$P(X,",",$L(X,",")-1)
+	. I $D(FIELD(FIELD)) S FIELD(FIELD)=@X
+	S N=0 F  S N=$O(FIELD(N)) Q:'+N  D
+	. S N2=0 F  S N2=$O(RESULT(N2)) Q:'+N2  I $P(RESULT(N2),"^",2)=N S $P(RESULT(N2),"^",3)=FIELD(N)
+	. S RESULT(0)=$$DFNID^VWREGITU()
+NPTX	K FIELD,AR,FCAP,FILE,SUBDIC,N,N2,DFN
+	Q
+	;
+PF(RESULT,XPF)	;Pointer file - get the stuff
+	K RESULT,AR
+	N X,N
+	I '$L(XPF) S RESULT(0)="???" Q
+	S XPF="^"_XPF
+	I +$P(XPF,"(",2)=.85 G NAUTPF  ;Naughty file!
+	S N=0 F  S N=$O(@(XPF_N_")")) Q:'+N  S X=$P(^(N,0),"^"),AR(X,N)=X_"("_N_")"
+	S X="AR" F  S X=$Q(@X) Q:X=""  S RESULT($$INR)=@X
+	K AR
+	Q
+	;
+NAUTPF	;The "NAUGHTY" pointer file - has a numeric .01 - Bad file !!!
+	S N=0 F  S N=$O(@(XPF_N_")")) Q:'+N  S X=$P(^(N,0),"^") D
+	. S LANG=$P(^(0),"^",2)
+	. S AR(LANG,N)=LANG_"("_N_")"
+	S X="AR" F  S X=$Q(@X) Q:X=""  S RESULT($$INR)=@X
+	Q
+GIF	;Generic Insurance form
+	K RESULT
+	S RESULT($$INR)="Insurance Company^2.312;.01^^^DIC(36,^0"
+	S RESULT($$INR)="Group Plan^2.312;.18^^^IBA(355.3,^0"
+	S RESULT($$INR)="Policy No.^2.312;1^^^^0"
+	;S RESULT($$INR)="Type of Plan^^^^^0"
+	S RESULT($$INR)="Coverage^355.33;40.09^^^IBE(355.1,^0"
+	S RESULT($$INR)="Effective Date^2.312;8^^^^0"
+	S RESULT($$INR)="Expiration Date^.3121;^^^^0"
+	S RESULT($$INR)="Guarantor^^^^^0"
+	S RESULT($$INR)="Signature on File^^^^0:NO;1:YES^0"
+	S RESULT($$INR)="Employer^2.312;2.015^^^^0"
+	S RESULT($$INR)="Billing Address^2.312;2.02^^^^0"
+	S RESULT($$INR)="Billing Address(cont)^2.312;2.03^^^^0"
+	S RESULT($$INR)="Postal Code^2.312;2.07^^^^0"
+	S RESULT($$INR)="City^2.312;2.05^^^^0"
+	S RESULT($$INR)="County/Region/Area^^^^^0"
+	S RESULT($$INR)="State/Province/Region^2.312;2.06^^^DIC(5,^0"
+	Q
+	;
+	
Index: /VWGUIRegistration/trunk/VWREGIT2.m
===================================================================
--- /VWGUIRegistration/trunk/VWREGIT2.m	(revision 1779)
+++ /VWGUIRegistration/trunk/VWREGIT2.m	(revision 1779)
@@ -0,0 +1,61 @@
+VWREGIT2	;Portland/WorldVista/BFP,LLC/Jim Bell, et al... - Post-Install for VWREG	
+	;;1.0;WORLD VISTA;**HOME **;;Build 2
+	;
+	;Continued from VWREGIT
+	;
+	;GNU License: See WVLIC.txt
+	;Modified FOIA VISTA,
+	;Copyright 2013 WorldVistA.  Licensed under the terms of the GNU
+	Q
+PRE	;Did this installation happen already? Avoid a re-do?
+	I $O(^XMB(3.8,"B","VW REG ERROR REPORT",0))&($D(^XTV(8989.51,"B","VW GUI REG TEMPLATE DIRECTORY",0))) W !?5,"Installation has already occurred"
+	W !,"Do you want to continue? NO//" R X:60 S:'$L(X) X="NO" S X=$$UP^XLFSTR(X)
+	I "NON"[X W !,"OK" D ^XUSCLEAN
+	Q
+	;
+PI	;Post Installation install
+	;Checking for a home directory & file
+	I $O(^XMB(3.8,"B","VW REG ERROR REPORT",0)) W !?5,"Installation has already occurred" Q
+	S AR=1,AR(1)="[TEMPLATES]"
+	S N=0 F  S N=$O(^DIE(N)) Q:'+N  S X=$P(^(N,0),"^") D
+	. I X["VW " S AR($I(AR))=X_"("_N_")"
+	. I X["[World" S AR($I(AR))=X_"("_N_")"
+	S AR($I(AR))="[ID]"
+	S P4=1,P5="",HD=$ZDIRECTORY_"regparam/",FILE="regit.txt"
+	S X=$$GTF^%ZISH($NA(AR(1)),1,HD,"regit.txt")
+	ZSY "chmod 777 "_$ZDIRECTORY_"regparam/"_FILE  ;No sensitive info here
+	Q:$G(TEST)  ;Straightening out regit.txt
+	;
+	;; NOTE: The parameter definition is installed but there is no installation for
+	;;the actual parameter and value. Do it here.
+	;parameter value attempt
+	;Set a home directory for editing; SYSTEM (DIC(4,) and DOMAIN (DIC(4.2,) only:"/home/vista/regparam/"
+	S PARD=$O(^XTV(8989.51,"B","VW GUI REG TEMPLATE DIRECTORY",0))
+	I PARD D
+	. L +^XTV(8989.5,0):1 D  L -^XTV(8989.5,0)
+	.. S NEW=$O(^XTV(8989.5," "),-1)+1
+	.. S $P(^XTV(8989.5,0),"^",3)=NEW
+	.. S $P(^XTV(8989.5,0),"^",4)=$P(^(0),"^",4)+1
+	.. S $P(^XTV(8989.5,NEW,0),"^")="1;DIC(4,"
+	.. S $P(^XTV(8989.5,NEW,0),"^",2)=PARD
+	.. S $P(^XTV(8989.5,NEW,0),"^",3)=1
+	.. S ^XTV(8989.5,NEW,1)=HD
+	.. S DA=NEW,DIK="^XTV(8989.5," D IX^DIK
+	.. S NEW2=$O(^XTV(8989.5," "),-1)+1
+	.. S $P(^XTV(8989.5,0),"^",3)=NEW2
+	.. S $P(^XTV(8989.5,0),"^",4)=$P(^(0),"^",4)+1
+	.. S $P(^XTV(8989.5,NEW2,0),"^")="9;DIC(4.2,"
+	.. S $P(^XTV(8989.5,NEW2,0),"^",2)=PARD
+	.. S $P(^XTV(8989.5,NEW2,0),"^",3)=1
+	.. S ^XTV(8989.5,NEW2,1)=HD
+	.. S DA=NEW2,DIK="^XTV(8989.5," D IX^DIK
+	;
+	;Mailgroup VW REG ERROR REPORT - add programmer's email
+	S DA(1)=$O(^XMB(3.8,"B","VW REG ERROR REPORT",0))
+	Q:'DA(1)
+	S DIC="^XMB(3.8,"_DA(1)_",6,"
+	S X="jbellco65@gmail.com"
+	S DIC(0)="LZ"
+	D FILE^DICN
+	Q
+	;
Index: /VWGUIRegistration/trunk/VWREGIT3.m
===================================================================
--- /VWGUIRegistration/trunk/VWREGIT3.m	(revision 1779)
+++ /VWGUIRegistration/trunk/VWREGIT3.m	(revision 1779)
@@ -0,0 +1,11 @@
+VWREGIT3	;VWEHR/BFProd-Jim Bell, et al - World VistA GUI Pat Reg Utility
+	;;1.0;WORLD VISTA;** **;;Build 2
+	;
+	;This routine utility is for patient specific fields and
+	;is used to build input templates for registration
+	;
+	;GNU License: See WVLIC.txt
+	;Modified FOIA VISTA,
+	;Copyright 2013 WorldVistA.  Licensed under the terms of the GNU
+	Q
+	;
Index: /VWGUIRegistration/trunk/VWREGITP.m
===================================================================
--- /VWGUIRegistration/trunk/VWREGITP.m	(revision 1779)
+++ /VWGUIRegistration/trunk/VWREGITP.m	(revision 1779)
@@ -0,0 +1,57 @@
+VWREGITP	;BFP/Portland,OR-Jim Bell,et al - Client Registration Utility
+	       ;2.0;BFP for WorldVistA;**LOCAL**;;;Build 2
+	; *******************************************
+	; * Copyright 2015 ad infinitum et ultra    *
+	; * Gets data for existing clients/patients *
+	; * GPL License: See License.txt            *
+	; *******************************************
+	Q  ;No fall through - jeb
+	;
+GPD(RESULT,DATA)	;Get patient data
+	; ********************************* 8888***
+	; * DATA_____TEMPLATE(IEN)^FIELDSET^DFN   *
+	; * TEMPLATE__The name(IEN) of a          *
+	; *            stored template            *
+	; * FIELDSET_Adhoc fields in a string     *
+	; *          as ".01;3;5;.131", etc       *
+	; * DFN______IEN of patient file(#2)      *
+	; * NOTE: TEMPLATE takes precedence       *
+	; *       over FIELDSET                   *
+	; *****************************************
+	;
+	K RESULT,AR
+	N VAR,TNUM,FSET,F,DFN
+	I '$L(DATA) S RESULT(0)="No information relayed. Please try again" Q
+	I $P(DATA,"^",3)="" S RESULT(0)="Patient info not relayed. Please try again" Q
+	S VAR="TNUM^ADHOC^DFN" F I=1:1:3 S @$P(VAR,"^",I)=$P(DATA,"^",I)
+	S TNUM=$S(TNUM["(":+$P(TNUM,"(",2),1:TNUM)
+	S DFN=+$P($P(DATA,"^",3),"(",2)
+	S FSET=$S(TNUM:^DIE(TNUM,"DR",1,2),'TNUM&($L(ADHOC)):ADHOC,1:"")
+	D GETS^DIQ(2,DFN_",","**","N","AR")
+	F I=1:1:$L(FSET,";") D
+	. Q:'$L($P(FSET,";",I))
+	. S F=+$P(FSET,";",I)
+	. S RESULT($$INR^VWREGIT)=F_"^"_$G(AR(2,DFN_",",F))
+	Q
+GPDM(RESULT,DATA)	;
+	; ****************************************************************
+	; * DATA____Parent Text^Parent field #^PATIENT IEN^TEMPLATE(IEN) *
+	; ****************************************************************
+	N F,SUBD,DFN,PIEN,X,RIND,FILE,X,Y,TNUM
+	K MX,MAR,RESULT,AR
+	S DFN=+$P(DATA,"^",3)
+	S F=+$P(DATA,"^",2)
+	S TNUM=+$P($P(DATA,"^",4),"(",2)
+	D GETS^DIQ(2,DFN_",",F_"*;","E","AR")
+	S SUBD=+$P(^DD(2,F,0),"^",2) D:+SUBD  ;Multiple field values
+	. S MX="AR("_SUBD_")" F  S MX=$Q(@MX) Q:MX=""!(+$P(MX,"(",2)'=SUBD)  D:$P(MX,",",$L(MX,",")-1)'=.01
+	.. S FILE=SUBD,PIEN=$P(MX,",",2,$L(MX,",")-1),PIEN=$TR(PIEN,"""","")
+	.. K MAR,IMAR
+	.. D GETS^DIQ(FILE,PIEN,"**","E","MAR")
+	.. D GETS^DIQ(FILE,PIEN,"**","I","IMAR")
+	.. S X=$Q(@"MAR"),Y=$Q(@"IMAR")
+	.. I @X'=@Y S @X=@X_"("_@Y_")"
+	.. S X="MAR"  ;,RIND=$$INR^VWREGIT
+	.. S RIND=$$INR^VWREGIT,RESULT(RIND)="" F  S X=$Q(@X) Q:X=""  S RESULT(RIND)=RESULT(RIND)_@X_"^"
+	K AR,MAR,IMAR,MX
+	Q
Index: /VWGUIRegistration/trunk/VWREGITS.m
===================================================================
--- /VWGUIRegistration/trunk/VWREGITS.m	(revision 1779)
+++ /VWGUIRegistration/trunk/VWREGITS.m	(revision 1779)
@@ -0,0 +1,115 @@
+VWREGITS	;Portland,OR/jeb et al Save utility for VWREG* routines 11/2015
+	;V.2;;**LOCAL**;;;Build 2
+	;c2014 ad infiniti, BellFelder Productions (BF Productions) & WorldVistA
+	;License: See License.txt that with install
+	;No fall thru - jeb
+	Q
+	;
+	;* *****************************************************************
+	;* Data coming in may be for a new case or existing case           *
+	;* Incoming: Array LDATA=                                          *
+	;*   LDATA(1)=Field^Field number^value^[optional]DFN               *
+	;*                       LDATA(N...)=Field^Field number^value      *
+	;* Exception for Multiples:                                        *
+	;*   LDATA(N)=Field(SUBDD;Field number):value(IEN)^...etc for every*
+	;*            field that is a dependent of the parent              *
+	;* Process:                                                        *
+	;*  1. call is at Label SAVE                                       *
+	;*  2. Some housekeeping that this programmer needs to do proper   *
+	;*     string evaluations.                                         *
+	;*  3. Filing of a new case with FILE^DICN.                        *
+	;*  4. Remaining major fields are filed with DIE                   *
+	;*  5. Multiples are filed with UPDATE^DIE                         *
+	;*  6. Existing entries will contain only edited data and will     *
+	;*     address those fields as in 4 & 5.                           *
+	;* Bon Appettit, et al.                                            *
+	;*******************************************************************
+SAVE(RESULT,LDATA)	;
+	K RESULT,^DIZ("DS",$J)
+	M ^DIZ("DS",$J)=LDATA
+	Q ;Testing
+	N DFN,DIC,DA,DR,VAR,FIELD,N,N1,X,Y,DIE,DIK
+	I $D(LDATA)<10 S RESULT(0)="-1: No data sent for filing. Please contact your IT dept." Q
+	;UPcase everyTHING
+	S XDAT="LDATA" F  S XDAT=$Q(@XDAT) Q:XDAT=""  S @XDAT=$$UP^XLFSTR(@XDAT)
+	;
+	;Incoming housekeeping
+	S X="LDATA" F I=1:1 S X=$Q(@X) Q:X=""  I @X[":",@X[";" S ^DIZ("DS",$J,I)=@X K @X
+	I +$P(@$Q(LDATA),"^",4)!(+$P(@$Q(LDATA),"(",2)) G EXP ;DFN sent by client
+	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)
+	S DFN=$$FIND1^DIC(2,"","M",$P(LDATA(1),"^",3),"","","ERR")
+	G EXP:DFN  ;Found patient/client
+	;End housekeeping;
+	;
+	S X=$P(LDATA(1),"^",3) D
+	. S DIC="^DPT(",DIC(0)="LZ" K D0 D FILE^DICN S (DA,DFN)=+Y
+	. S DIC="^AUPNPAT(",DIC(0)="LZ",X=DFN,DINUM=X,DIC(0)="L" D FILE^DICN
+	. S DIE=DIC,DR=.03_"////^S X=DT" D ^DIE
+	. S DR=.11_"////^S X=DUZ" D ^DIE
+LDPT	L +^DPT(DFN):1 G LDPT:'$T
+	S N=1 F  S N=$O(LDATA(N)) Q:'+N  D
+	. Q:$P(LDATA(N),"^",2)[";"
+	. Q:'+$P(LDATA(N),"^",2)  ;Marker of some kind
+	. S FIELD=$P(LDATA(N),"^",2)
+	. S VAR=$P(LDATA(N),"^",3)
+	. I FIELD=.03 D
+	.. S VAR=$$DC(VAR)
+	.. S VARTIME=$P(VAR,".",2),VAR=$P(VAR,".")
+	.. I $L(VARTIME) D
+	... N FDA
+	... S FDA(2,DFN_",",540000.1)=VARTIME
+	... D FILE^DIE("E","FDA")
+	... D CLEAN^DILF
+	. S:VAR["(" VAR=$S($L(VAR,"(")>2:+$P(VAR,"(",$L(VAR,"(")),1:+$P(VAR,"(",2))
+	. S DIE="^DPT(",DR=FIELD_"///"_$S(+VAR:"/",1:"")_"^S X=VAR" D ^DIE
+	L -^DPT(DFN)
+	D M  ;File any multiple fields
+	S RESULT(0)="Filed..."
+	K ^DIZ("DS",$J)
+	Q
+	;
+EXP	;Existing Patient
+	K X,FNAME,FFLD,FVALUE,AR,DIC,DA,DR,DIE,AR
+	S X="LDATA" F  S X=$Q(@X) Q:X=""  I @X[":" S AR($O(AR(" "),-1)+1)=@X K @X
+	S N=0 F  S N=$O(LDATA(N)) Q:'+N  S X=LDATA(N) D
+	. S FNAME=$P(X,"^")
+	. S FFLD=$P(X,"^",2)
+	. S FVALUE=$S($P(X,"^",3)["(":+$P(X,"(",2),1:$P(X,"^",3))
+	. S DFN=$P(X,"^",4)
+	. S DIE="^DPT(",DA=DFN,DR=FFLD_"///^S X=FVALUE" D ^DIE
+	D M
+	S RESULT($I(RESULT))="Filed..."
+	K X,FNAME,FFL,FVALUE,DFN,AR,DIE,DA,DR,DIC
+	Q
+	;
+M	;File any multiples values; DFN should be defined above
+	Q:'$D(^DIZ("DS",$J))
+	M MULTS=^DIZ("DS",$J)
+	K MAR S N=0 F  S N=$O(MULTS(N)) Q:'+N  D
+	. F J=1:1:$L(MULTS(N),"^")-1 S MAR(J)=$P(MULTS(N),"^",J)
+	. S MX=$O(MAR(0))
+	. S MXFILE=+$P(MAR(MX),"(",2)
+	. S MXFLD=+$P(MAR(MX),";",2)
+	. S MXVAL=$P($P(MAR(MX),":",2),"(")
+	. I MXFLD=.01 S MXDATA(MXFILE,"?+1,"_DFN_",",MXFLD)=MXVAL K IEN D UPDATE^DIE("E","MXDATA","IEN","ERROR") Q:$G(DIERR)  D
+	.. S RECORD=$G(IEN(1)),INC=$G(IEN(1,0))
+	.. S J=MX F  S J=$O(MAR(J)) Q:'+J  D
+	... s MXFILE=+$P(MAR(J),"(",2)
+	... S MXFLD=+$P(MAR(J),";",2)
+	... S MXVAL=$P(MAR(J),":",2),MXVAL=$S(MXVAL["(":$P(MXVAL,"("),1:MXVAL)
+	... S MXDATA(MXFILE,$S(MXFLD=.01:INC,1:"")_"1,"_RECORD_","_DFN_",",MXFLD)=MXVAL
+	... K IEN,ERROR D UPDATE^DIE("E","MXDATA","IEN","ERROR")
+	Q
+	;
+DC(XDATE)	;Convert DOB to internal
+	N %DT,X
+	S X=XDATE,%DT="T" D ^%DT
+	Q Y
+	;
+INSUR	;Insurance/Billing
+	Q
+	;
+K	S DA=$P(^DPT(0),"^",3),DIK="^DPT(" D ^DIK
+	S DIK="^AUPNPAT(" D ^DIK
+	Q
+	;
Index: /VWGUIRegistration/trunk/VWREGITT.m
===================================================================
--- /VWGUIRegistration/trunk/VWREGITT.m	(revision 1779)
+++ /VWGUIRegistration/trunk/VWREGITT.m	(revision 1779)
@@ -0,0 +1,190 @@
+VWREGITT	;Portland\Jim Bell, BFP,LLC Input Template Management 2016
+	;2.0**LOCAL** Copyright April 2016 ad infinitum;;;;;Build 2
+	;*****************************************************************
+	;* Licensed under GNU 2.0 or greater - see license.txt file      *
+	;* Program/application is for the management of input templates  *
+	;* owned by the user (DUZ).                                      *
+	;* REMINDER: All template fields pertain only to the Patient File*
+	;*  (#2)!                                                        *
+	;*****************************************************************
+	;
+	Q  ;No fall through
+	;
+AUTH(TUSER,TNUM)	;Can user edit or is IT CONTROL
+	N TMO
+	S TMO=$O(^DIC(19,"B","VW REG IT CONTROL",0)) I $D(^VA(200,TUSER,203,"B",TMO)) Q 1
+	S TMO=$O(^DIC(19,"B","VW PATIENT REGISTRATION",0))
+	I TMO,$P(^DIE(TNUM,0),"^",5)=TUSER Q 1
+	Q 0
+	;
+INR()	Q $O(RESULT(" "),-1)+1
+	;
+CF(FIELD)	;If a computed field, 0, else 1
+	I $P($G(^DD(2,FIELD,0)),"^",2)["C" Q 0
+	Q 1
+	;
+EGF(RESULT,TNAME)	;Get fields for client editing via TName
+	;*************************
+	;* Incoming___TNAME(IEN) *
+	;*************************
+	K RESULT  ;N TNUM,TNAME,PF,SF
+	S TNUM=+$P(TNAME,"(",2)
+	S TNAME=$P(TNAME,"(")
+	I 'TNUM!('$D(^DIE(TNUM))) S RESULT(0)="Template name or number not found in Template file" Q
+	;Check for authorization
+	I '$$AUTH(DUZ,TNUM) S RESULT(0)="Sorry, you are not authorized to edit this template." Q
+	S RESULT(0)="Editing "_TNAME_"("_TNUM_")"
+	S PF=$G(^DIE(TNUM,"DR",1,2))
+	F I=1:1:$L(PF,";") D:$P(PF,";",I) 
+	. S RESULT($$INR)=$P(^DD(2,$P(PF,";",I),0),"^")_"("_$P(PF,";",I)_")"
+	. S SDD=+$P(^DD(2,$P(PF,";",I),0),"^",2) D:SDD
+	.. S SDN=1 F  S SDN=$O(^DIE(TNUM,"DR",SDN)) Q:'SDN  S:$O(^(SDN,0))=SDD SF=^(SDD) D
+	... F J=1:1:$L(SF,";") D:$P(SF,";",J)
+	.... S SFF=$P(^DIE(TNUM,"DR",SDN,SDD),";",J)
+	.... S RESULT($$INR)="  SF  "_$P(^DD(SDD,SFF,0),"^")_"("_SFF_";"_SDD_")"
+	Q
+	;
+SFLDS	;Get sub-fields and dics
+	K MULT N N,X,I,Y
+	S Y="",N=0 F  S N=$O(TDATA(N)) Q:'+N  D
+	. Q:TDATA(N)'["  SF"  ;Still a major field
+	. F I=N:1:$O(TDATA(" "),-1) S X=TDATA(I) Q:X'["  SF"  S MULT(+$P(X,";",2),+$P(X,"(",2))=""
+	Q
+	;
+FIELDS()	;
+	N FLDLIST,N,X,FLD K MULT
+	S FLDLIST=""
+	S N=0 F  S N=$O(TDATA(N)) Q:'+N  D:TDATA(N)'["  SF"
+	. S FLD=+$P(TDATA(N),"(",2)
+	. Q:'$$CF(+$P(TDATA(N),"(",2))  ;Computed field
+	. S FLDLIST=FLDLIST_FLD_";"
+	;Collate thru for multiple fields:entry looks like "  SF  "
+	S N=0 F  S N=$O(TDATA(N)) Q:'+N  D:TDATA(N)["  SF"
+	. S X=$P(TDATA(N),"  ",3)
+	. S SDD=+$P(X,";",2)
+	. S SFL=+$P(X,"(",2)
+	. S MULT(SDD,SFL)=""
+	S N=0 F  S N=$O(MULT(N)) Q:'+N  D  S SUB(N)=MF
+	. S MF="",N2=0 F  S N2=$O(MULT(N,N2)) Q:'+N2  S MF=MF_N2_";"
+	K MULT
+	Q FLDLIST
+	;
+RTF(RESULT)	;Send a refresh of regit.txt to client
+	K AR,RESULT
+	D LTF
+	M RESULT=AR
+	K AR
+	Q
+	;
+LTF	;Load the regit.txt file into AR()
+	S HD=$$GET^XPAR("ALL","VW GUI REG TEMPLATE DIRECTORY")
+	S FILE="regit.txt"
+	S P4=1
+	S P5=""
+	S X=$$FTG^%ZISH(HD,FILE,$NA(AR(1)),P4,P5)
+	Q
+	;
+FTF	;File the AR() to regit.txt
+	ZSY "cp "_HD_"regit.txt "_HD_"regitbu.txt"
+	S P4=1,P5="",FILE="regit.txt"
+	S X=$$GTF^%ZISH($NA(AR(1)),1,HD,FILE)
+	Q
+	;
+ITCNTRL(USER)	;Check for control capability and user authorization
+	N ITCNTRL
+	S ITCNTRL=$O(^DIC(19,"B","VW REG IT CONTROL",0))
+	I 'ITCNTRL D  Q 0
+	. S VAL=0
+	. S RESULT(0)="-1^VW REGISTRATION does not appear to be complete."
+	. S RESULT(1)="Please contact your Supervisor or IT support."
+	. S RESULT(2)="Thank you,"
+	. S RESULT(3)="The Management"
+	I '$D(^VA(200,USER,203,"B",ITCNTRL)) D  Q 0
+	. S RESULT(0)="-1^User does not have authorization to modify/create"
+	. S RESULT(1)="input templates. Please contact your Supervisor or"
+	. S RESULT(2)="IT support. Or, questions can be referred to Jim"
+	. S RESULT(3)="Bell at jbellco65@gmail.com"
+	. S RESULT(4)="Thank you."
+	Q 1
+	;
+EN(RESULT,TDATA)	;
+	;************************************************
+	;* Call from Client                             *
+	;* TDATA Array:                                 *
+	;*   0____Template Name^DUZ^ACTION^WRITEACCESS  *
+	;*   1-n__Field name(number)                    *
+	;************************************************
+	; -- testing --
+	;M ^DIZ("TDATA",$J)=TDATA
+	;Q
+	; -- end testing --
+	;
+	N TNAME,TNUM,ITCNTRL,ACTION,FIELDS,CALLER
+	S CALLER=""
+	S X="TDATA" F  S X=$Q(@X) Q:X=""  S @X=$$UP^XLFSTR(@X)  ;Upcase everyTHING
+	I '$L($G(HD)) S HD=$$GET^XPAR("ALL","VW GUI REG TEMPLATE DIRECTORY")
+	S WHO=$P(TDATA(0),"^",2)
+	S ITCNTRL=$$ITCNTRL(WHO)  ;1=full action;0=create/edit own template(s)
+	S TNUM=+$P($P(TDATA(0),"^"),"(",2)
+	S TNAME=$P($P(TDATA(0),"^"),"(")
+	I TNAME["Editing" S SPEC("Editing ")="",TNAME=$$REPLACE^XLFSTR(TNAME,.SPEC)
+	S ACTION=$P(TDATA(0),"^",3)
+	S WRITEACC=$S($P(TDATA(0),"^",4)="SELF":$P(^VA(200,DUZ,0),"^",4),1:"")
+	S FIELDS=$$FIELDS
+	I '$L(ACTION) S RESULT(0)="-1^No action sent. I don't know what to do." Q
+	D @ACTION
+	Q
+	;
+CREATE	;Create a new input template
+	;******************************
+	;* Check for computed fields  *
+	;******************************
+	K RESULT N %DT,X,Y
+	S %DT="TS",X="NOW" D ^%DT S FDATE=Y
+	S X=TNAME,DIC="^DIE(",DIC(0)="LZ" D FILE^DICN
+	S $P(^DIE(+Y,0),"^",2)=FDATE,$P(^(0),"^",3)="",$P(^(0),"^",4)=2,$P(^(0),"^",5)=DUZ
+	S $P(^DIE(+Y,0),"^",6)=WRITEACC
+C2	S ^DIE(+Y,"DR",1,2)=FIELDS
+	;Do mult fields here
+	S N=0 F  S N=$O(SUB(N)) Q:'+N  D
+	. S UP=^DD(N,0,"UP")
+	. I UP=2 S ^DIE(+Y,"DR",$O(^DIE(+Y,"DR"," "),-1)+1,N)=SUB(N)
+	. E  S ^DIE(+Y,"DR",$O(^DIE(+Y,"DR"," "),-1),N)=SUB(N)
+	I $P(^DIE(+Y,0),"^")=$P(TDATA(0),"^") S RESULT(0)=$P(Y,"^",2)_" filed"
+	Q:CALLER="EDIT"
+	S TNUM=+Y,TNAME=$P(Y,"^",2)
+	K AR
+	D LTF  ;Get the regit.txt file loaded into AR()
+	S LAST=$O(AR(" "),-1)
+	S AR(LAST)=TNAME_"("_TNUM_")"
+	S AR(LAST+1)="[ID]"
+	;M ^DIZ("TDATA","AR",$J)=AR  ;Testing
+	D FTF  ;File AR() to regit.txt
+	K ^DIZ("TDATA",$J)
+	Q
+	;
+EDIT	;Edit existing. Check for allowability
+	S Y=TNUM_"^"_TNAME
+EL	L -^DIE(TNUM):1 G EL:'$T
+	S S=1 F  S S=$O(^DIE(TNUM,"DR",S)) Q:'+S  D
+	. S SUBD=0 F  S SUBD=$O(^DIE(TNUM,"DR",S,SUBD)) Q:'+SUBD  K ^DIE(TNUM,"DR",S,SUBD)
+	S CALLER="EDIT"
+	D C2
+	L +^DIE(TNUM)
+	S DA=TNUM,DIK="^DIE(" D IX^DIK  ;Re-index record just in case...
+	S RESULT(0)=Y_" modification filed..."
+	Q
+	;
+DELETE	;********************************************
+	;* 1. Get the regit.txt contents into AR()  *
+	;* 2. Remove the template from the list     *
+	;* 3. Refile regit.txt                      *
+	;********************************************
+	K AR
+	M AR=RESULT
+	K AR(0)  ;ID string for EN
+	D FTF
+	I X S RESULT(0)="Template menu list updated."
+	E  S RESULT(0)="Template list not updated. Advise Template manager to manually update "_HD_"regit.txt"
+	Q
+	
Index: /VWGUIRegistration/trunk/VWREGITU.m
===================================================================
--- /VWGUIRegistration/trunk/VWREGITU.m	(revision 1779)
+++ /VWGUIRegistration/trunk/VWREGITU.m	(revision 1779)
@@ -0,0 +1,160 @@
+VWREGITU	;Portland, OR/jeb et al World Vista Registration Utilities
+	;V.2;;**LOCAL**;; 2015;Build 2
+	;;c2014, BellFelder Productions(BF Productions)
+	;No Fall thru - jeb
+	Q
+	;
+DFNID()	;Set NAME(IEN),TAB,DOB(AGE),TAB,HRN,TAB,PHONE#
+	N DFNID,NAME,X,Y,DOB,HRN,PHONE
+	I 'DFN Q ""
+	S NAME=$P(^DPT(DFN,0),"^")
+	S Y=$$OUTPUT^VWTIME(DFN) X ^DD("DD") S DOB=Y
+	S HRN=$G(^DPT(DFN,540001.1))
+	S PHONE="Phone: "_$P(^DPT(DFN,.13),"^")
+	S DFNID=NAME_$C(9)_DOB_$C(9)_$S($L(HRN):"HRN: "_HRN_$C(9),1:"")_PHONE
+	Q DFNID
+	;
+HELP(XDIC,XFIELD)	;
+	N N
+	K FHELP
+	S FHELP=$G(^DD(XDIC,XFIELD,3))
+	G:'$L(FHELP) HELPX
+	S FHELP=FHELP_$S($E($L(FHELP))=".":" ",1:". ")
+	I XFIELD'=27.02,$D(^DD(XDIC,XFIELD,21)) S N=0 F  S N=$O(^DD(XDIC,XFIELD,21,N)) Q:'+N  S FHELP=FHELP_^(N,0)_" "
+	S FHELP=$TR(FHELP,"'","`")
+HELPX	  Q FHELP
+	;
+M(RESULT,XMF)	;
+	; **********************************************
+	; * XMF_____PARENT FIELD^DFN^TEMPLATE NAME(IEN)*
+	; **********************************************
+	;
+	;W "  ;Intentional break
+	K RESULT,AR,TEMPLATE
+	N XMFD,SUBD,SUBD3,SUBD4,SUBD5,F2,F3,F4,F5,DFN,N,X,SUBF,XT,FHELP
+	S TNUM=+$P(XMF,"(",2)  ;Template IEN, if any
+	S DFN=+$P(XMF,"^",2)   ;Client IEN, if any
+	S XMF=+XMF  ;Parent field
+	I '+$P(^DD(2,XMF,0),"^",2) S RESULT(0)=-1  ;Not a parent, eh?!
+	S XMFD=+$P(^(0),"^",2)
+	S F=0 F  S F=$O(^DD(XMFD,F)) Q:'+F  S RESULT($$INR)=$P(^(F,0),"^")_"^"_XMFD_";"_F_"^^"_$$HELP(XMFD,F)_"^"_$P(^(0),"^",3) D:+$P(^(0),"^",2)
+	. S SUBD=+$P(^(0),"^",2)
+	. S F2=0 F  S F2=$O(^DD(SUBD,F2)) Q:'+F2  S RESULT($$INR)=$P(^(F2,0),"^")_"^"_SUBD_";"_F2_"^^"_$$HELP(SUBD,F2)_"^"_$P(^(0),"^",3) D:+$P(^DD(SUBD,F2,0),"^",2)
+	.. S SUBD3=+$P(^(0),"^",2)
+	.. S F3=0 F  S F3=$O(^DD(SUBD3,F3)) Q:'+F3  S RESULT($$INR)=$P(^(F3,0),"^")_"^"_SUBD3_";"_F3_"^^"_$$HELP(SUBD3,F3)_"^"_$P(^(0),"^",3) D:+$P(^DD(SUBD3,F3,0),"^",2)
+	... S SUBD4=+$P(^DD(SUBD3,F3,0),"^",2)
+	... S F4=0 F  S F4=$O(^DD(SUBD4,F4)) Q:'+F4  S RESULT($$INR)=$P(^(F4,0),"^")_"^"_SUBD4_";"_F4_"^^"_$$HELP(SUBD4,F4)_"^"_$P(^(0),"^",3) D:+$P(^DD(SUBD4,F2,0),"^",2)
+	.... S SUBD5=+$P(^(0),"^",2)
+	.... S F5=0 F  S F5=$O(^DD(SUBD5,F5)) Q:'+F5  S RESULT($$INR)=$P(^(F5,0),"^")_"^"_SUBD5_";"_F5_"^^"_$$HELP(SUBD5,F5)_"^"_$P(^(0),"^",3)
+	;Clean up of parents IN multiple fields
+	M AR=RESULT K RESULT N DD,F
+	S N=0 F  S N=$O(AR(N)) Q:'+N  D
+	. S DD=+$P($P(AR(N),"^",2),";")  ;Is this a sub DD ?
+	. S F=+$P(AR(N),";",2)
+	. I +$P(^DD(DD,F,0),"^",2) K AR(N)
+	;Clean up fields not in template
+	M TEMPLATE=^DIE(TNUM,"DR")
+	S X=$Q(@"TEMPLATE") K @X  ;Remove top, non-multiple subscript
+	S X="AR" F  S X=$Q(@X) Q:X=""  D
+	. S SUBD=+$P($P(@X,"^",2),";")
+	. S SUBF=+$P(@X,";",2)
+	. F I=1:1:20 I $D(TEMPLATE(I,SUBD)) D
+	.. Q:TEMPLATE(I,SUBD)[SUBF
+	.. K @X
+	S N=0 F  S N=$O(AR(N)) Q:'+N  S RESULT($$INR)=AR(N)
+	K AR,TEMPLATE
+	Q
+	;
+DISV(RESULT,DFN)	;Set the Disv GLOBAL
+	K RESULT
+	I '$L(DFN) S RESULT=-1 Q
+	S ^DISV(DUZ,"^DPT(")=+$P(DFN,"(",2),RESULT=1
+	Q
+	;
+SR(FNAME,FNUM,FVALUE,FHELP,FSETPNTR,FMISC)	;Set values into RESULT()
+	;********************************************************
+	;* FNAME________Field Name                              *
+	;* FNUM_________Field Number                            *
+	;* FVALUE_______Data from existing client/patient       *
+	;* FHELP________Help text from field                    *
+	;* FSETPNTR_____Set of codes or Pointer reference       *
+	;* FMISC________Locally described designator (not used) *
+	;********************************************************
+	S RESULT($$INR)=FNAME_"^"_FNUM_"^"_FVALUE_"^"_FHELP_"^"_FSETPNTR_"^"_FMISC
+	Q
+	;	
+INR()	;Specific incrementer for RESULT array
+	Q $O(RESULT(" "),-1)+1
+	;
+ZPC(RESULT,ZIP)	;Get zip,county/area/region,state/province,preferred city
+	K RESULT N STP,CNTP,COUNTY,XZIP
+	S XZIP=ZIP S RESULT(0)="No return" Q:'$L(XZIP)
+	D POSTAL^XIPUTIL(XZIP,.ZIPDATA)
+	I $D(ZIPDATA("ERROR")) Q  ;Can't be found
+	S COUNTY=$G(ZIPDATA("COUNTY"))
+	S STP=$G(ZIPDATA("STATE POINTER"))
+	I STP,$L(COUNTY) S CNTP=$O(^DIC(5,STP,1,"B",COUNTY,0))
+	K RESULT(0)
+	S RESULT($$INR)=ZIPDATA("STATE")_"("_STP_")"
+	S RESULT($$INR)=ZIPDATA("COUNTY")_"("_CNTP_")"
+	S RESULT($$INR)=ZIPDATA("CITY")
+	S RESULT($$INR)=ZIPDATA("FIPS CODE")
+	K ZIPDATA
+	Q
+	;
+SPI(RESULT,DFN)	;Simple patient inquiry display
+	S LINE="----------"
+	S DIC="^DPT(",DA=DFN,DIQ(0)="E",DIQ="AR"
+	S DR=".01:.05;.111:.115;.1171:.1173;.117;.363"
+	D EN^DIQ1
+	S CITY=$G(AR(2,DFN,.114,"E"))
+	S STIEN="",STATE=$G(AR(2,DFN,.115,"E")) S:$L(STATE) STIEN=$O(^DIC(5,"B",STATE,0))
+	S XAGE=$G(AR(2,DFN,.033,"E"))
+	S XAGE=$S(+XAGE:XAGE_" y/o",1:"")
+	;;GET HRN
+HRN	S HRN="",N=$O(^AUPNPAT(DFN,41,0))
+	S HRN=$S('N:HRN,1:$P($G(^AUPNPAT(DFN,41,N,0)),"^",2))
+	S RESULT($$INR)=AR(2,DFN,.01,"E")_"  "_AR(2,DFN,.363,"E")_" HRN: "_HRN
+	S RESULT($$INR)="DOB: "_AR(2,DFN,.03,"E")_"  ("_XAGE_" "_AR(2,DFN,.02,"E")_")"
+	S RESULT($$INR)="ADDRESS"_LINE_LINE
+	S RESULT($$INR)=$G(AR(2,DFN,.111,"E"))_" "_$G(AR(2,DFN,.112,"E"))
+	S RESULT($$INR)=$G(AR(2,DFN,.114,"E"))_", "_$G(AR(2,DFN,.115,"E"))_"  "_$S($L($G(AR(2,DFN,.1172,"E"))):AR(2,DFN,.1172,"E"),1:$G(AR(2,DFN,.1112,"E")))
+	S RESULT($$INR)="Walk-ins"_LINE_LINE
+	S RESULT($$INR)="Appointments"_LINE_LINE
+	S RESULT($$INR)="Admissions"_LINE_LINE
+	Q
+	;
+CONTROL()	      ;Check for CONTROL status
+	       N X S X=$O(^DIC(19,"B","VW REG IT CONTROL",0))
+	       I 'X Q 0  ;Ain't no option there
+	       Q $S($D(^VA(200,DUZ,203,"B",X)):1,1:0)
+	       ;
+MISC(RESULT,VWDD)	;Get simple value from VWDD ID
+	;***************************************************
+	;* VWDD___________________(sub)-Dictionary number  *
+	;* Multiple delimiter_____;(Semicolon)             *
+	;***************************************************
+	;
+	I '$L(VWDD) S RESULT(0)="No value to evaluate" Q
+	K RESULT
+	N XDD,XDDLOC,N,X
+	G MISCSD:$G(^DD(VWDD,0,"UP"))
+	S CALLER=$S($P(VWDD,"^",2)="INS":1,1:0)
+	S VWDD=$P(VWDD,"^")
+	F I=1:1:$L(VWDD,";") S XDD=+$P(VWDD,";",I) S RESULT($$INR)="["_$P(^DIC(XDD,0),"^")_"]" D MISC1
+	I CALLER S RESULT($$INR)="[GUARANTOR]" D
+	. S X=$P(^DD(2.312,16,0),"^",3)
+	. F I=1:1:$L(X,";") S Y=$P(X,";",I),RESULT($$INR)=$P(Y,":",2)_"("_$P(Y,":")_")"
+	Q
+	;
+MISC1	S XDDLOC=$G(^DIC(XDD,0,"GL")) D:$L(XDDLOC)
+	. S N=0 F  S N=$O(@(XDDLOC_N_")")) Q:'+N  D
+	.. I XDDLOC["779.004" S XCNAME=$P(@(XDDLOC_N_",0)"),"^")_" "_$P(^(0),"^",2)_" "_+$G(^("SDS"))_"("_N_")",RESULT($$INR)=XCNAME Q
+	.. S X=$P(@(XDDLOC_N_",0)"),"^")_"("_N_")",RESULT($$INR)=X
+MX	Q
+	;
+MISCSD	;Sub-dictionary
+	W ^("UP")
+	Q
+	;
+	
Index: /VWGUIRegistration/trunk/VWREGITX.m
===================================================================
--- /VWGUIRegistration/trunk/VWREGITX.m	(revision 1779)
+++ /VWGUIRegistration/trunk/VWREGITX.m	(revision 1779)
@@ -0,0 +1,326 @@
+VWREGITX	;VWEHR/BFProd-Jim Bell, et al - World VistA GUI Pat Reg Utility
+	;;;;;;Build 2
+	;;1.0;WORLD VISTA;**LOCAL **;;Build 26
+	;
+	;This routine utility is for patient specific fields and
+	;is used to build input templates for registration
+	;
+	;GNU License: See WVLIC.txt
+	;Modified FOIA VISTA,
+	;Copyright 2013 WorldVistA.  Licensed under the terms of the GNU
+	Q
+	;
+1	;CallerID = HRN; value is at $P($P(CALLERID,":",2),"^")
+	S HRN=$P($P(CALLERID,":",2),"^")
+	S HRN=$$HRN(HRN)
+	I HRN="" S RESULT(0)="The Health Record Number (HRN) does not exist in this database"_$C(13,10)_"Please use NAME, DOB, or PHONE#."
+	Q
+	;
+2	;CallerID = NAME; in ^2@+CALLERID
+	K AR,ARR
+	N HRN,PHONE,DOB,N
+	S NAME=$P(CALLERID,"^",+CALLERID)
+	S XNAME=NAME F  S XNAME=$O(^DPT("B",XNAME)) Q:XNAME'[NAME  D
+	. S N=0 F  S N=$O(^DPT("B",XNAME,N)) Q:'+N  S AR($O(AR(" "),-1)+1)=N
+	I $O(AR(" "),-1)=1 D  Q
+	. S DFN=AR(1)
+	. S HRN=$$HRN(DFN),HRN=$S($L(HRN):HRN,'$L(HRN):"ID-"_$P($G(^DPT(DFN,.36)),"^",3),1:"------------")
+	. S DOB=$P(^DPT(DFN,0),"^",3),DOB=$E(DOB,4,5)_"/"_$E(DOB,6,7)_"/"_$E(DOB,2,3)
+	. S PHONE=$P($G(^DPT(DFN,.131)),"^"),PHONE=$S($L(PHONE):PHONE,1:"<No entry>")
+	. S RESULT($$INR)=HRN_"^"_$P(^DPT(DFN,0),"^")_"("_DFN_")^"_DOB_"^"_PHONE
+	S N=0 F  S N=$O(AR(N)) Q:'+N  S ARR($P(^DPT(+AR(N),0),"^"),N)=+AR(N)
+	S X="ARR" F  S X=$Q(@X) Q:X=""  S DFN=@X D
+	. S HRN=$$HRN(DFN),HRN=$S($L(HRN):HRN,'$L(HRN):"ID-"_$P($G(^DPT(DFN,.36)),"^",3),1:"------------")
+	. S DOB=$P(^DPT(DFN,0),"^",3),DOB=$E(DOB,4,5)_"/"_$E(DOB,6,7)_"/"_$E(DOB,2,3)
+	. S PHONE=$P($G(^DPT(DFN,.131)),"^"),PHONE=$S($L(PHONE):PHONE,1:"<No entry>")
+	. S RESULT($$INR)=HRN_"^"_$P(^DPT(DFN,0),"^")_"("_DFN_")^"_DOB_"^"_PHONE
+	K AR,ARR
+	Q
+	;
+3	;CallerID = DOB; in ^3@CALLERID
+	S X=$P(CALLERID,"^",+CALLERID)
+	K %DT,Y,AR
+	N HRN,PHONE,N
+	D ^%DT
+	S N=0 F  S N=$O(^DPT("ADOB",Y,N)) Q:'+N  S AR($O(AR(" "),-1)+1)=N_"^"_Y
+	I $O(AR(" "),-1)=1 D  Q  ;Only one find
+	. K RESULT
+	. S DFN=+AR(1)
+	. S HRN=$$HRN(DFN)
+	. I '$L(HRN) S HRN="ID-"_$P($G(^DPT(DFN,.36)),"^",3)
+	. I '$L(HRN) S HRN="------------"
+	       . S PHONE=$P($G(^DPT(DFN,.131)),"^"),PHONE=$S($L(PHONE)>0:PHONE,1:"<No entry>")
+	. S RESULT($$INR)=HRN_"^"_$P(^DPT(DFN,0),"^")_"("_DFN_")"_"^"_$P(CALLERID,"^",+CALLERID)_"^"_PHONE
+	K ARR S N=0 F  S N=$O(AR(N)) Q:'+N  S ARR($P(^DPT(+AR(N),0),"^"),N)=+AR(N)
+	S X="ARR" F  S X=$Q(@X) Q:X=""  S DFN=@X D
+	. S HRN=$$HRN(DFN)
+	. I '$L(HRN) S HRN=$P($G(^DPT(DFN,.36)),"^",3)_"(ID)"
+	. I '$L(HRN)!(HRN="(ID)") S HRN="------------"
+	. S PHONE=$P($G(^DPT(DFN,.131)),"^"),PHONE=$S($L(PHONE)>0:PHONE,1:"<No entry>")
+	. S RESULT($$INR)=HRN_"^"_$P(^DPT(DFN,0),"^")_"("_DFN_")"_"^"_$P(CALLERID,"^",+CALLERID)_"^"_PHONE
+	K ARR,AR
+	Q
+	;
+4	;CallerID = PHONE; IN ^4@+CALLERID
+	S CALLERID=$TR(CALLERID,"- ()","")
+	Q
+	;
+5	;CallerID = space-bar; IN ^2@+CALLERID
+	S X=$P(CALLERID,"^",+CALLERID)
+	S DFN=$G(^DISV(DUZ,"^DPT("))
+	I 'DFN S RESULT(0)="Patient-Client not found" Q
+	S AR(1)=DFN G 2+6  ;Direct call
+	Q
+	;
+DE(RESULT,DATA)	;Forced hard error
+	;W "
+	Q
+	;
+HRN(IEN)	;Health Record #s from IHS PATIENT
+	N N,HRNIEN,I
+	S HRNIEN=""
+	Q:'$D(^AUPNPAT(IEN)) HRNIEN
+	S N=0 F I=1:1 S N=$O(^AUPNPAT(IEN,41,N)) Q:'+N  S HRNIEN=HRNIEN_$P($G(^AUPNPAT(IEN,41,N,0)),"^",2)_"|"
+	I $E(HRNIEN,$L(HRNIEN))="|" S HRNIEN=$E(HRNIEN,1,$L(HRNIEN)-1)
+	Q HRNIEN
+	;
+ALIST(RESULT,ALPHA,CALLERID)	;Alpha request from client
+	;*****************************************************
+	;* ALPHA_____Letter to look up                       *
+	;* CALLERID__PIECE#:HRN^NAME(IEN)^DOB^PHONE look up  *
+	;* RETURN____HRN^NAME^DOB^PHONE(Field .131 in File 2)*
+	;*****************************************************	
+	I '$L(ALPHA),'+CALLERID S RESULT(0)="No Alphabetical letter or HRN,Name,DOB,Phone selection..." Q
+	S CALLERID=$$UP^XLFSTR(CALLERID)  ;Upcase EVERYTHING
+	I +CALLERID G @+CALLERID
+	N X,I,ANAME,HRN,ADOB,APHONE,Y
+	K RESULT,AR,ARR
+	S X="^DPT(""B"""_","_""""_ALPHA_""")"
+	F I=1:1 S X=$Q(@X) Q:$S($L(ALPHA)>1:$P(X,"""",4)'[ALPHA,1:$E($P(X,"""",4))'=ALPHA)  S AR(I)=+$P(X,",",$L(X,","))
+	S ARN=0 F  S ARN=$O(AR(ARN)) Q:'+ARN  D
+	. S HRN=$$HRN(ARN)
+	. S:'$L(HRN) HRN="---            "
+	. F JJ=$L(HRN):1:15 S HRN=HRN_" "
+	. S ANAME=$P(^DPT(AR(ARN),0),"^")
+	. S Y=$P(^(0),"^",3)_$S($G(^DPT(AR(ARN),540000)):^(540000),1:"")
+	. D DD^%DT S ADOB=Y
+	. S APHONE=$P($G(^DPT(AR(ARN),.13)),"^")
+	. S ARR(ANAME,ARN)=HRN_"^"_ANAME_"("_AR(ARN)_")^"_ADOB_"^"_APHONE
+	S X="ARR" F  S X=$Q(@X) Q:X=""  S RESULT($$INR)=@X
+	Q
+	;
+PLID(IEN)	;Primary Long ID, used with or in absence of HRN.
+	Q $P($G(^DPT(IEN,.36)),"^",3)
+	;
+INR()	Q $O(RESULT(" "),-1)+1
+	;
+	
+FIXNAME	;
+	N N,X,Y,XIEN,NLENGTH,I
+	S NLENGTH=0,X="AR" F  S X=$Q(@X) Q:X=""  D
+	. S Y=@X,N=$P(Y,"(")_"("_+$P(Y,"(",2)_")",STR=$P(Y,")",2)
+	. S NLENGTH=$S($L(N)>NLENGTH:$L(N),1:NLENGTH)
+	. F I=NLENGTH:-1:$L(N) S N=N_" "
+	. S Y=N_" "_STR
+	. S @X=Y
+	Q
+GPL(RESULT,IDDATA)	;Partial patient lists
+	;***********************************************
+	;* IDDATA_____Contains Start^Stop alpha chars  *
+	;* RESULT_____Return of results                *
+	;***********************************************
+	K RESULT,AR
+	N N,DFN,SSN,DOB,START,STOP,NAME,XDOB ;; ,NL
+	;;Get user's last patient ID
+	S DFN=$G(^DISV(DUZ,"^DPT(")) D:DFN
+	. S NAME=$P(^DPT(DFN,0),"^")
+	. ;S SSN=$P(^(0),"^",9)
+	. S HRN="HRN: "_$$HRN(DFN)  ;Health record number
+	. S PLID="ID: "_$$PLID(DFN)  ;Primary Long ID
+	. S DOB=$P(^(0),"^",3)
+	. S XDOB=$E(DOB,4,5)_"/"_$E(DOB,6,7)_"/"_$S($E(DOB)<3:19,1:20)_$E(DOB,2,3)
+	. S AR(0)=NAME_"("_DFN_")"_" "_XDOB_" "_$S($L($P(HRN,": ",2)):HRN,$L($P(PLID,": ",2)):PLID,1:"<NO ID ON FILE>")
+	S START=$P(IDDATA,"^")
+	S STOP=$P(IDDATA,"^",2)
+	S STOP=STOP_"z"
+	S STOP=$E($O(^DPT("B",STOP)))
+	S STOP=$S('$L(STOP):$P(IDDATA,"^",2)_"z",1:STOP)
+	S NL=0
+	S N=START F  S N=$O(^DPT("B",N)) Q:N=""!($E(N)=STOP)  D
+	. S DFN=$O(^(N,0))
+	. S NAME=$P(^DPT(DFN,0),"^")_"("_DFN_")"
+	. ;S SSN=$P(^(0),"^",9),SSN=$S('$L(SSN):"     ????",1:SSN)
+	. S HRN="HRN: "_$$HRN(DFN)
+	       . S PLID="ID: "_$$PLID(DFN)  ;Primary Long ID
+	. S DOB=$P(^DPT(DFN,0),"^",3)
+	. S XDOB=$E(DOB,4,5)_"/"_$E(DOB,6,7)_"/"_$S($E(DOB)<3:19,1:20)_$E(DOB,2,3)
+	. ;W !,$J(DFN,5)," ",$J($E(NAME,1,12),12)," ",$J(SSN,10)," ",XDOB
+	. S AR(NAME,DFN)=NAME_" "_XDOB_" "_$S($L($P(HRN,": ",2)):HRN,$L($P(PLID,": ",2)):PLID,1:"<NO ID ON FILE>")
+	. S (DFN,NAME,SSN,DOB,XDOB)=""
+	D FIXNAME
+	S X="AR" F  S X=$Q(@X) Q:X=""  S RESULT($$INR)=@X
+	K AR
+	Q
+	;
+REJECT(FIELD,IEN,SUBDIC)	;Reject Asterisked,Amis,Computed fields,VA specific fields
+	;This subroutine left in for possible future use
+	I $L(IEN),$D(^DIZ(64850001,IEN)) Q 1  ;VA specific data field
+	I FIELD["COMPONENT" Q 1  ;Pain in the butt!
+	I FIELD["(VA)"!(FIELD["(CIVIL)") Q 1  ;VA fields
+	I FIELD["AMIS",FIELD["SEGMENT" Q 1
+	I FIELD["ELIG VERIF" Q 1
+	I FIELD["ENCOUNTER CONVERSION" Q 1
+	I FIELD["PROGRAMMERS U" Q 1
+	I FIELD["WHO " Q 1
+	I FIELD["SC AT"!(FIELD["SC%") Q 1
+	I $E(FIELD)="*" Q 1  ;field marked for deletion
+	I FIELD["10-10" Q 1
+	I $L(IEN),$E($P($G(^DD(2,IEN,0)),"^",2))="C" Q 1  ;computed field
+	I $L($G(SUBDIC)),$E($P($G(^DD(SUBDIC,IEN,0)),"^",2))="C" Q 1 ;computet in sub-dic
+	Q 0  ;Passed
+	;
+LF(RESULT,FTYPE)	;List of assumed civilian type fields from 
+	;                Patient file(#2)
+	;*******************************************************************
+	;*The author (me) arbitarily selected fields from the patient file *
+	;* that he (me) considers to be usable by civilian VistA/CPRS users*
+	;* the field count is 284 out of the 700+ fields available in the  *
+	;* full patient DD. File is located at ^DIZ(64850002,              *
+	;*******************************************************************
+	;
+	S FTYPE=$TR(FTYPE,"*&^%$#@!:;>?/., ","")  ;TMenuItem inclusions/jeb
+	;S:$L(FTYPE) FTYPE=$P(^DIZ(64850003,+$P(FTYPE,"(",2),0),"^")
+	S FTYPE=$$UP^XLFSTR(FTYPE)
+	K RESULT
+	N N,X,FIELD,FLDNO,FGRP,M,MX,MF,MFNO,MFGP,MN
+	G FG:$L(FTYPE)
+	; Add patient file fields
+	S N=0 F  S N=$O(^DIZ(64850002,N)) Q:'+N  D
+	. S X=^(N,0)
+	. S FIELD=$P(X,"^")
+	. S FLDNO=$P(X,"^",2)
+	. S FGRP=$P(X,"^",3)
+	. S RESULT($$INR)=FIELD_"("_FLDNO_")"_":"_FGRP
+	. I $O(^DIZ(64850002,N,"M",0)) D
+	.. S M=0 F  S M=$O(^DIZ(64850002,N,"M",M)) Q:'+M  D
+	... S MX=^(M,0)
+	... S MF=$P(MX,"^")
+	... S MFNO=$P(MX,"^",2)
+	... S MFGP=$P(MX,"^",3)
+	... S RESULT($$INR)=" SF "_MF_"("_MFNO_")"_":"_MFGP
+	S X="RESULT" F I=1:1 S X=$Q(@X) Q:X=""
+	S RESULT(0)="Field count: "_(I-1)
+	Q
+	;
+FG	;Fields by GROUP
+	Q:'$L(FTYPE)
+	K RESULT,AHF N LABEL,F,N,I
+	S N=$S(+$P(FTYPE,"(",2):+$P(FTYPE,"(",2),1:$O(^DIZ(64850003,"B",FTYPE,0)))
+	I 'N S RESULT($$INR)="Group not found." G FGX
+	S F=0 F I=1:1  S F=$O(^DIZ(64850003,N,"F","B",F)) Q:'+F  S RESULT($$INR)=$P(^DD(2,F,0),"^")_"("_F_")"
+FGX	Q
+	;
+FGNA(RESULT,KIND)	;Fields by sort designator
+	;**********************************
+	;* KIND                           *
+	;*    G____Group,Field            *
+	;*    N____Field#                 *
+	;*    A____Alphabetical (Default) *   
+	;* RESULT__Returned array         *
+	;**********************************
+	K RESULT
+	I KIND="G" D  G FGNAX
+	. K AR
+	. S N=0 F  S N=$O(^DIZ(64850002,N)) Q:'+N  S X=^(N,0) D
+	.. S GRP=$P(X,"^",3)
+	.. S FN=$P(X,"^",2)
+	.. S FIELD=$P(X,"^")
+	.. S AR(GRP,FN)=FIELD_"("_FN_")"
+	.. I $O(^DIZ(64850002,N,"M",0)) D
+	... S MN=0 F  S MN=$O(^DIZ(64850002,N,"M",MN)) Q:'+MN  D
+	.... S MX=^(MN,0)
+	.... S MFN=+$P(MX,"^",2)
+	.... S MFLD=$P(MX,"^")
+	.... S AR(GRP,FN,MFN)="  SF  "_$P(MX,"^")_"("_$P(MX,"^",2)_")"
+	. S G="" F  S G=$O(AR(G)) Q:G=""  S RESULT($$INR)="--- "_G_" ---" D
+	.. S FN=0 F  S FN=$O(AR(G,FN)) Q:'+FN  S X=AR(G,FN),RESULT($$INR)=$P(X,"^") I $O(AR(G,FN,0)) S SFN=0 F  S SFN=$O(AR(G,FN,SFN)) Q:'+SFN  S RESULT($$INR)=AR(G,FN,SFN)
+	I KIND="N" D  G FGNAX
+	. K AR,RESULT
+	. S N=0 F  S N=$O(^DIZ(64850002,N)) Q:'+N  S X=^(N,0) D
+	.. S GRP=$P(X,"^",3)
+	.. S FN=$P(X,"^",2)
+	.. S FIELD=$P(X,"^")
+	.. S AR(FN)=FIELD_"("_FN_")"
+	.. I $O(^DIZ(64850002,N,"M",0)) D
+	       ... S MN=0 F  S MN=$O(^DIZ(64850002,N,"M",MN)) Q:'+MN  D
+	       .... S MX=^(MN,0)
+	       .... S MFN=+$P(MX,"^",2)
+	       .... S MFLD=$P(MX,"^")
+	       .... S AR(FN,MFN)="  SF  "_$P(MX,"^")_"("_$P(MX,"^",2)_")"
+	. S X="AR" F  S X=$Q(@X) Q:X=""  S RESULT($$INR)=@X
+	;Kind = alphabetical
+	S N=0 F  S N=$O(^DIZ(64850002,N)) Q:'+N  S X=^(N,0) D
+	. S AR($P(X,"^"))=$P(X,"^")_"("_$P(X,"^",2)_")"
+	. I $O(^DIZ(64850002,N,"M",0)) D
+	       .. S MN=0 F  S MN=$O(^DIZ(64850002,N,"M",MN)) Q:'+MN  D
+	       ... S MX=^(MN,0)
+	       ... S MFN=+$P(MX,"^",2)
+	       ... S MFLD=$P(MX,"^")
+	... S AR($P(X,"^"),MFLD)="  SF  "_$P(MX,"^")_"("_$P(MX,"^",2)_")"
+	S X="AR" F  S X=$Q(@X) Q:X=""  S RESULT($$INR)=@X
+FGNAX	;K AR
+	Q
+	;
+RETGRP(RESULT)	;Return Group IDs
+	K RESULT
+	S N=0 F  S N=$O(^DIZ(64850003,N)) Q:'+N  S RESULT($$INR)=$P(^(N,0),"^",2)_"("_N_")"
+	Q
+	;
+AHF(RESULT,AHF)	;Ad hoc field selection "Finished" pressed/jeb
+	;*****************************************************
+	;* AFH ARRAY:                                        *
+	;*   AHF(0)____DFN                                   *
+	;*   AHF ARRAY_FIELD(NO) OR FIELD(NO;SUB-DIC)        *
+	;*****************************************************
+	;W "  ;the END
+	K ^DIZ("AHF") M ^DIZ("AHF")=AHF
+	K RESULT
+	N FIELD,FNO,DFNDR
+	S DFNDR=""
+	S DFN=+AHF(0) K AHF(0)
+	S X="AHF" F  S X=$Q(@X) Q:X=""  S Y=@X D
+	. S FIELD=$P(Y,"(")
+	. S FNO=+$P(Y,"(",2)
+	. D GFA(FNO)
+	. S RESULT($$INR)=FIELD_"^"_FNO_"^^"_FHELP_"^"_FPSC_"^"_$$MF(FNO)
+	. S DFNDR=DFNDR_FNO_";"
+	I DFN D
+	. K AR N N,Y,F
+	. D GETS^DIQ(2,DFN_",",DFNDR,"E","AR","ERR")
+	. S X="AR" F  S X=$Q(@X) Q:X=""  D
+	.. S Y=@X
+	.. S F=+$P(X,",",$L(X,",")-1)
+	.. S N=0 F  S N=$O(RESULT(N)) Q:'+N  I $P(RESULT(N),"^",2)=F S $P(RESULT(N),"^",3)=Y
+	;ToDo: write fill in for the multiple fields
+	K FHELP,FPSC
+	Q
+	;
+GFA(FNO)	;Get field attributes at piece3 and help
+	S (FHELP,FPSC)=""
+	S FHELP=$G(^DD(2,FNO,3))
+	I FNO'=27.02 S N=0 F  S N=$O(^DD(2,FNO,21,N)) Q:'+N  S FHELP=FHELP_^(N,0)
+	S FHELP=$TR(FHELP,"'","`")
+	S FPSC=$P(^DD(2,FNO,0),"^",3)
+	Q
+	;
+MF(X)	;Check for multiple field
+	;*****************************************************
+	;* Reminder: This data set is Patient file only (#2) *
+	;* MYESNO____=1 is a parent                          *
+	;*           =0 is a primary field                   *
+	;*****************************************************
+	;
+	S MYESNO=$S(+$P(^DD(2,X,0),"^",2):1,1:0)
+	Q MYESNO
+	;
+