source: GUIRegistration/tag/1.0/VWGUIREG_UPDATE_03232014.KID@ 1635

KIDS Distribution saved on Mar 23, 2014@10:18:31
World VistA 
**KIDS**:VWGUIR_UPDATE_03232014*1.0T*1^

**INSTALL NAME**
VWGUIR_UPDATE_03232014*1.0T*1
"BLD",8495,0)
VWGUIR_UPDATE_03232014*1.0T*1^^0^3140323^n
"BLD",8495,1,0)
^^2^2^3140323^
"BLD",8495,1,1,0)
Contains routine updates, pat inquiry display, enables making an
"BLD",8495,1,2,0)
input template through the GUI.
"BLD",8495,4,0)
^9.64PA^^
"BLD",8495,6.3)
1
"BLD",8495,"KRN",0)
^9.67PA^779.2^20
"BLD",8495,"KRN",.4,0)
.4
"BLD",8495,"KRN",.401,0)
.401
"BLD",8495,"KRN",.402,0)
.402
"BLD",8495,"KRN",.402,"NM",0)
^9.68A^^0
"BLD",8495,"KRN",.403,0)
.403
"BLD",8495,"KRN",.5,0)
.5
"BLD",8495,"KRN",.84,0)
.84
"BLD",8495,"KRN",3.6,0)
3.6
"BLD",8495,"KRN",3.8,0)
3.8
"BLD",8495,"KRN",3.8,"NM",0)
^9.68A^^0
"BLD",8495,"KRN",9.2,0)
9.2
"BLD",8495,"KRN",9.8,0)
9.8
"BLD",8495,"KRN",9.8,"NM",0)
^9.68A^11^4
"BLD",8495,"KRN",9.8,"NM",8,0)
VWREGIT^^0^B129809193
"BLD",8495,"KRN",9.8,"NM",9,0)
VWREGIT2^^0^B100003944
"BLD",8495,"KRN",9.8,"NM",10,0)
VWREGIT3^^0^B43452100
"BLD",8495,"KRN",9.8,"NM",11,0)
VWREGIT4^^0^B43791810
"BLD",8495,"KRN",9.8,"NM","B","VWREGIT",8)

"BLD",8495,"KRN",9.8,"NM","B","VWREGIT2",9)

"BLD",8495,"KRN",9.8,"NM","B","VWREGIT3",10)

"BLD",8495,"KRN",9.8,"NM","B","VWREGIT4",11)

"BLD",8495,"KRN",19,0)
19
"BLD",8495,"KRN",19,"NM",0)
^9.68A^^0
"BLD",8495,"KRN",19.1,0)
19.1
"BLD",8495,"KRN",101,0)
101
"BLD",8495,"KRN",101,"NM",0)
^9.68A^^0
"BLD",8495,"KRN",409.61,0)
409.61
"BLD",8495,"KRN",771,0)
771
"BLD",8495,"KRN",771,"NM",0)
^9.68A^^0
"BLD",8495,"KRN",779.2,0)
779.2
"BLD",8495,"KRN",870,0)
870
"BLD",8495,"KRN",8989.51,0)
8989.51
"BLD",8495,"KRN",8989.51,"NM",0)
^9.68A^^0
"BLD",8495,"KRN",8989.52,0)
8989.52
"BLD",8495,"KRN",8994,0)
8994
"BLD",8495,"KRN",8994,"NM",0)
^9.68A^10^1
"BLD",8495,"KRN",8994,"NM",10,0)
VW REG PATINQ^^0
"BLD",8495,"KRN",8994,"NM","B","VW REG PATINQ",10)

"BLD",8495,"KRN","B",.4,.4)

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

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

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

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

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

"BLD",8495,"KRN","B",3.6,3.6)

"BLD",8495,"KRN","B",3.8,3.8)

"BLD",8495,"KRN","B",9.2,9.2)

"BLD",8495,"KRN","B",9.8,9.8)

"BLD",8495,"KRN","B",19,19)

"BLD",8495,"KRN","B",19.1,19.1)

"BLD",8495,"KRN","B",101,101)

"BLD",8495,"KRN","B",409.61,409.61)

"BLD",8495,"KRN","B",771,771)

"BLD",8495,"KRN","B",779.2,779.2)

"BLD",8495,"KRN","B",870,870)

"BLD",8495,"KRN","B",8989.51,8989.51)

"BLD",8495,"KRN","B",8989.52,8989.52)

"BLD",8495,"KRN","B",8994,8994)

"BLD",8495,"QDEF")
^^^^NO^^^^NO^^NO
"BLD",8495,"QUES",0)
^9.62^^
"BLD",8495,"REQB",0)
^9.611^^
"KRN",8994,2596,-1)
0^10
"KRN",8994,2596,0)
VW REG PATINQ^DEMOG^VWREGIT4^2^P^^^0^1
"KRN",8994,2596,1,0)
^8994.01^1^1^3140313^^
"KRN",8994,2596,1,1,0)
Returns all existing demographic (non-clinical) data on a patient
"KRN",8994,2596,2,0)
^8994.02A^1^1
"KRN",8994,2596,2,1,0)
IDATA^1^^1^1
"KRN",8994,2596,2,"B","IDATA",1)

"KRN",8994,2596,2,"PARAMSEQ",1,1)

"MBREQ")
0
"ORD",16,8994)
8994;16;1;;;;;;;RPCDEL^XPDIA1
"ORD",16,8994,0)
REMOTE PROCEDURE
"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")
4
"RTN","VWREGIT")
0^8^B129809193
"RTN","VWREGIT",1,0)
VWREGIT ;VWEHR/BFProd - Jim Bell, et al... - World VistA Patient Registration Utility
"RTN","VWREGIT",2,0)
 ;;1.0;WORLD VISTA;** **;;Build 1
"RTN","VWREGIT",3,0)
 ;
"RTN","VWREGIT",4,0)
 ;This routine utility is for Patient specific fields and
"RTN","VWREGIT",5,0)
 ; calls a Fileman input template.
"RTN","VWREGIT",6,0)
 ;
"RTN","VWREGIT",7,0)
 ;GNU License: See WVLIC.txt
"RTN","VWREGIT",8,0)
 ;Modified FOIA VISTA,
"RTN","VWREGIT",9,0)
 ;Copyright 2013 WorldVistA.  Licensed under the terms of the GNU
"RTN","VWREGIT",10,0)
 Q
"RTN","VWREGIT",11,0)
 ;
"RTN","VWREGIT",12,0)
 ;S IDSTR="REG(1733)^^L^^"
"RTN","VWREGIT",13,0)
 ;
"RTN","VWREGIT",14,0)
MV(PAT,SUBD,FLDS) ;Get the listing of multiple values in external format
"RTN","VWREGIT",15,0)
 S VAL=""
"RTN","VWREGIT",16,0)
 Q
"RTN","VWREGIT",17,0)
 ;
"RTN","VWREGIT",18,0)
GDOBT(PATIENT) ;Get date of birth with time
"RTN","VWREGIT",19,0)
 N DOB,Y
"RTN","VWREGIT",20,0)
 S Y=$P(^DPT(PATIENT,0),"^",3)+$G(^DPT(PATIENT,540000))
"RTN","VWREGIT",21,0)
 X ^DD("DD")
"RTN","VWREGIT",22,0)
 Q Y
"RTN","VWREGIT",23,0)
 ;
"RTN","VWREGIT",24,0)
MM ;Mis-match IDs belong to someone other than client input
"RTN","VWREGIT",25,0)
 S RESULT(0)="MM^-1"
"RTN","VWREGIT",26,0)
 S RESULT(1)="ID belongs to "_ARR("DILIST",1,1)
"RTN","VWREGIT",27,0)
 Q
"RTN","VWREGIT",28,0)
 ;
"RTN","VWREGIT",29,0)
FIELDS ;Get field numbers/labels/titles at ^DIE(TNUM...
"RTN","VWREGIT",30,0)
 K XR
"RTN","VWREGIT",31,0)
 S RESULT($$INR)="[FLDS]"
"RTN","VWREGIT",32,0)
 S FSET=$G(^DIE(TNUM,"DR",1,2))
"RTN","VWREGIT",33,0)
 S C=0 ;Keep order of template
"RTN","VWREGIT",34,0)
 F I=1:1:$L(FSET,";")-1 D
"RTN","VWREGIT",35,0)
 . S MF=+$P(^DD(XFILE,+$P(FSET,";",I),0),"^",2)
"RTN","VWREGIT",36,0)
 . D:MF
"RTN","VWREGIT",37,0)
 .. S MFS=$G(^DIE(TNUM,"DR",2,MF))
"RTN","VWREGIT",38,0)
 .. I $L(MFS) F J=1:1:$L(MFS,";")-1 D
"RTN","VWREGIT",39,0)
 ... S C=C+1
"RTN","VWREGIT",40,0)
 ... S XR(C,MF,+$P(MFS,";",J))=$P(^DD(MF,+$P(MFS,";",J),0),"^")_"^"_MF_";"_+$P(MFS,";",J)_"^^^"
"RTN","VWREGIT",41,0)
 ... I $P(^DD(MF,+$P(MFS,";",J),0),"^",2)["P" S $P(XR(C,MF,+$P(MFS,";",J)),"^",5)=$P(^DD(MF,+$P(MFS,";",J),0),"^",3)
"RTN","VWREGIT",42,0)
 . Q:MF
"RTN","VWREGIT",43,0)
 . S C=C+1,XR(C,+$P(FSET,";",I))=$P(^DD(XFILE,+$P(FSET,";",I),0),"^")_"^"_+$P(FSET,";",I)_"^^"_$$HINT(XFILE,+$P(FSET,";",I))_"^"_$P(^DD(XFILE,+$P(FSET,";",I),0),"^",3)
"RTN","VWREGIT",44,0)
 S X="XR" F  S X=$Q(@X) Q:X=""  S RESULT($$INR)=@X
"RTN","VWREGIT",45,0)
 ;For county help listing until DB is fixed /jeb 9/15/2013 @ 08:43
"RTN","VWREGIT",46,0)
 S N=0 F  S N=$O(RESULT(N)) Q:'+N  I $P(RESULT(N),"^",2)=.117 S $P(RESULT(N),"^",5)="VIC(5.1,"
"RTN","VWREGIT",47,0)
 K XR
"RTN","VWREGIT",48,0)
 S DIET=TNUM D GET^DIETED("AR"),PREFLAB^VWREGIT3
"RTN","VWREGIT",49,0)
 Q
"RTN","VWREGIT",50,0)
 ;
"RTN","VWREGIT",51,0)
GETTD(RESULT,XDESC) ;Get template description
"RTN","VWREGIT",52,0)
 K RESULT
"RTN","VWREGIT",53,0)
 N N,TNUM
"RTN","VWREGIT",54,0)
 S TNUM=+$P(XDESC,"(",2)
"RTN","VWREGIT",55,0)
 I '$O(^DIE(TNUM,"%D",0)) S RESULT(0)="No description on file" Q
"RTN","VWREGIT",56,0)
 S N=0 F  S N=$O(^DIE(TNUM,"%D",N)) Q:'+N  S RESULT($$INR)=^(N,0)
"RTN","VWREGIT",57,0)
 Q
"RTN","VWREGIT",58,0)
 ;
"RTN","VWREGIT",59,0)
ME(X) ;mail to group
"RTN","VWREGIT",60,0)
 S GROUP=$O(^XMB(3.8,"B","VW REG ERROR REPORT",0))
"RTN","VWREGIT",61,0)
 S TITLE=X
"RTN","VWREGIT",62,0)
 S INFO=1
"RTN","VWREGIT",63,0)
 S FM=DUZ
"RTN","VWREGIT",64,0)
 D MSG^BFPMAIL
"RTN","VWREGIT",65,0)
 Q
"RTN","VWREGIT",66,0)
 ;
"RTN","VWREGIT",67,0)
COUNTY ;Special listing for county (re: Saturday 9/14/2013 WV discussion)
"RTN","VWREGIT",68,0)
 K RESULT,XR
"RTN","VWREGIT",69,0)
 S RESULT(0)=0
"RTN","VWREGIT",70,0)
 S PFILE="^"_PFILE
"RTN","VWREGIT",71,0)
 S N=0 F  S N=$O(@(PFILE_N_")")) Q:'+N  S X=^(N,0) D
"RTN","VWREGIT",72,0)
 . S STATE=$P(X,"^",2)
"RTN","VWREGIT",73,0)
 . S COUNTY=$P(X,"^")
"RTN","VWREGIT",74,0)
 . S STATE=$P($G(^DIC(5,STATE,0)),"^")
"RTN","VWREGIT",75,0)
 . S STATE=$S(STATE="":"UNKNOWN",1:STATE)
"RTN","VWREGIT",76,0)
 . S XR(STATE,COUNTY)=COUNTY_"~"_STATE
"RTN","VWREGIT",77,0)
 S X="XR" F  S X=$Q(@X) Q:X=""  S Y=@X,RESULT($$INR)=Y
"RTN","VWREGIT",78,0)
 S RESULT(0)=$O(RESULT(" "),-1)_" Items:"
"RTN","VWREGIT",79,0)
 K XR
"RTN","VWREGIT",80,0)
 Q
"RTN","VWREGIT",81,0)
 ;
"RTN","VWREGIT",82,0)
PSF(RESULT,XLINE) ;Pointer/Set of Codes values
"RTN","VWREGIT",83,0)
 ;W "  ;Intentionally "instantiated" hard failure - jeb
"RTN","VWREGIT",84,0)
 K RESULT
"RTN","VWREGIT",85,0)
 N XFILE,XFIELD,XDATA,XIT,PFILE
"RTN","VWREGIT",86,0)
 S RESULT(0)=0
"RTN","VWREGIT",87,0)
 S DFN=$P(XLINE,"^",7)
"RTN","VWREGIT",88,0)
 S PFILE=$P(XLINE,"^",6) ;POINTED TO FILE
"RTN","VWREGIT",89,0)
 I PFILE="VIC(5.1," D COUNTY Q  ;Work around until DB is fixed /jeb 9/15/2013
"RTN","VWREGIT",90,0)
 S XIT=+$P(XLINE,"(",2) Q:'XIT
"RTN","VWREGIT",91,0)
 S XFILE=$S($P(XLINE,"^",3)[";":$P($P(XLINE,"^",3),";"),1:$P(^DIE(XIT,0),"^",4))
"RTN","VWREGIT",92,0)
 S XFIELD=$S($P(XLINE,"^",3)[";":$P($P(XLINE,"^",3),";",2),1:$P(XLINE,"^",3))
"RTN","VWREGIT",93,0)
 S XFIELD=$S($L(XFIELD):XFIELD,1:+$P(XLINE,"^",3)) Q:'XFIELD
"RTN","VWREGIT",94,0)
 Q:$P(^DD(XFILE,XFIELD,0),"^",2)'["S"&($P(^DD(XFILE,XFIELD,0),"^",2)'["P")
"RTN","VWREGIT",95,0)
 I $P(^DD(XFILE,XFIELD,0),"^",2)["S" D  S RESULT(0)=$O(RESULT(" "),-1) Q
"RTN","VWREGIT",96,0)
 . S XDATA=$P(^(0),"^",3)
"RTN","VWREGIT",97,0)
 . S XDATA=$E(XDATA,1,$L(XDATA)-1)
"RTN","VWREGIT",98,0)
 . F I=1:1:$L(XDATA,";") S RESULT($$INR)=$P($P(XDATA,";",I),":",2)
"RTN","VWREGIT",99,0)
 Q:'$L(PFILE)  ;No pointer to reference
"RTN","VWREGIT",100,0)
 S PFILE="^"_PFILE
"RTN","VWREGIT",101,0)
 S N=0 F  S N=$O(@(PFILE_N_")")) Q:'+N  S RESULT($$INR)=$S(PFILE[779.004:$P(^(N,0),"^")_"~"_$P(^(0),"^",2),1:$P(^(N,0),"^"))
"RTN","VWREGIT",102,0)
 S RESULT(0)=$O(RESULT(" "),-1)_" Items:"
"RTN","VWREGIT",103,0)
 Q
"RTN","VWREGIT",104,0)
 ;
"RTN","VWREGIT",105,0)
HINT(FILE,FLD) ;
"RTN","VWREGIT",106,0)
 N X,N,Y
"RTN","VWREGIT",107,0)
 Q:'$L(FLD)  ;...hmmmm...
"RTN","VWREGIT",108,0)
 S X="",N=0 F  S N=$O(^DD(FILE,FLD,21,N)) Q:'+N  D
"RTN","VWREGIT",109,0)
 . S Y=$G(^DD(FILE,FLD,21,N,0))_$S($O(^DD(FILE,FLD,21,N)):" ",1:"")
"RTN","VWREGIT",110,0)
 . S X=X_$TR(Y,"'","")
"RTN","VWREGIT",111,0)
 I X="" S X="<No hint for this field. Press the ? at the top of the form for full demographic data>"
"RTN","VWREGIT",112,0)
 Q X
"RTN","VWREGIT",113,0)
 ;
"RTN","VWREGIT",114,0)
GETMULTS(MN) ;
"RTN","VWREGIT",115,0)
 Q:'MN
"RTN","VWREGIT",116,0)
 F I=1:1:$L(FSETM(MN),";")-1 D
"RTN","VWREGIT",117,0)
 . S MNF=$P(FSETM(MN),";",I)
"RTN","VWREGIT",118,0)
 . S RESULT($$INR)=$P(^DD(MN,MNF,0),"^")_"^"_MN_";"_MNF
"RTN","VWREGIT",119,0)
 Q
"RTN","VWREGIT",120,0)
 ;
"RTN","VWREGIT",121,0)
VPAR(SUBD) ;
"RTN","VWREGIT",122,0)
 N X
"RTN","VWREGIT",123,0)
 S X=""
"RTN","VWREGIT",124,0)
 I $D(PAR(SUBD)) S X=@$Q(PAR(SUBD))
"RTN","VWREGIT",125,0)
 Q X
"RTN","VWREGIT",126,0)
 ;
"RTN","VWREGIT",127,0)
INC(C) Q C=C+1
"RTN","VWREGIT",128,0)
 ;
"RTN","VWREGIT",129,0)
INR() Q $O(RESULT(" "),-1)+1
"RTN","VWREGIT",130,0)
 ;
"RTN","VWREGIT",131,0)
CLNNUM(NUM) ;Clean NUM
"RTN","VWREGIT",132,0)
 Q $TR(NUM," -^/~|\[]{}@!#$%&*()-_=+';:<>,.?")
"RTN","VWREGIT",133,0)
 ;
"RTN","VWREGIT",134,0)
ALABEL(FL,FI) ;
"RTN","VWREGIT",135,0)
 Q $S($D(^DIE(TNUM,"DIAB",FL,0,FI,0)):$TR($P(^(0),";",2),"""",""),1:$P(^DD(FI,$P(FSET,";",FL),0),"^"))
"RTN","VWREGIT",136,0)
 ;
"RTN","VWREGIT",137,0)
SETMULTS ;
"RTN","VWREGIT",138,0)
 K FSETM
"RTN","VWREGIT",139,0)
 S FSET=$g(^DIE(TNUM,"DR",1,2))
"RTN","VWREGIT",140,0)
 Q:FSET=""
"RTN","VWREGIT",141,0)
 ;S N=1 F  S N=$O(^DIE(TNUM,"DR",N)) Q:'+N  S N1=0 F  S N1=$O(^DIE(TNUM,"DR",N,N1)) Q:'+N1  S FSETM(N1)=$E(^(N1),1,$L(^(N1))-1)
"RTN","VWREGIT",142,0)
 S N=0 F  S N=$O(^DIE(TNUM,"DR",2,N)) Q:'+N  S X=^(N) S:$E(X,$L(X))=";" X=$E(X,1,$L(X)-1) S FSETM(N)=X
"RTN","VWREGIT",143,0)
 ;S FSET=$E(FSET,1,$L(FSET)-1)
"RTN","VWREGIT",144,0)
 F I=1:1:$L(FSET,";") S XF=$P(FSET,";",I) D
"RTN","VWREGIT",145,0)
 . S FSETNUM(+XF)=$P(^DD(XFILE,+XF,0),"^")_"^"_$TR($P($G(^DIE(TNUM,"DIAB",I,0,XFILE,0)),";",2),"""","")
"RTN","VWREGIT",146,0)
 . I +$P(^DD(2,+XF,0),"^",2) S $P(FSETNUM(+XF),"^",2)=+$P(^(0),"^",2)
"RTN","VWREGIT",147,0)
 S N=0 F  S N=$O(FSETNUM(N)) Q:'+N  S FSETMAT($P(FSETNUM(N),"^"))=""
"RTN","VWREGIT",148,0)
 S N=0 F  S N=$O(FSETM(N)) Q:'+N  S FSTRING=FSETM(N) D
"RTN","VWREGIT",149,0)
 . F I=1:1:$L(FSTRING,";") S MF=$P(FSTRING,";",I),FSETMM(N,$P(^DD(N,MF,0),"^"))=""
"RTN","VWREGIT",150,0)
 Q
"RTN","VWREGIT",151,0)
 ;
"RTN","VWREGIT",152,0)
PID(DFN,TID,XID) ;Patient ID
"RTN","VWREGIT",153,0)
 N C,XHRN
"RTN","VWREGIT",154,0)
 K PAR
"RTN","VWREGIT",155,0)
 D FIND^DIC(XFILE,"",".01;.02;.03;.09;.363;391","CM",$S($G(DFN):"`"_DFN,1:$G(XID)),"","B^AVWPID^SSN","","","ARR","LUERR")
"RTN","VWREGIT",156,0)
 I '$O(ARR("DILIST",0)) S RESULT(1)="-1^NEW" Q
"RTN","VWREGIT",157,0)
PIDS I '$O(ARR("DILIST",2,1)) D  Q
"RTN","VWREGIT",158,0)
 . S:'DFN DFN=$G(ARR("DILIST",2,1)) D RECALL^DILFD(2,DFN_",",DUZ)
"RTN","VWREGIT",159,0)
 . S NAME=$G(ARR("DILIST",1,1))
"RTN","VWREGIT",160,0)
 . S XSSN=$G(ARR("DILIST","ID",1,.09)) D:'$L(XSSN)
"RTN","VWREGIT",161,0)
 .. S DA=DFN
"RTN","VWREGIT",162,0)
 .. D PSEU^DGRPDD1
"RTN","VWREGIT",163,0)
 .. S (XSSN,$P(^DPT(DFN,0),"^",9))=L,^DPT("SSN",L,DFN)=""
"RTN","VWREGIT",164,0)
 . ;S DOB=$G(ARR("DILIST","ID",1,.03))
"RTN","VWREGIT",165,0)
 . S DOB=$$GDOBT(DFN)
"RTN","VWREGIT",166,0)
 . S SEX=$E($G(ARR("DILIST","ID",1,.02)))
"RTN","VWREGIT",167,0)
 . S XID=$G(ARR("DILIST","ID",1,.363))
"RTN","VWREGIT",168,0)
 . I '$L($G(XHRN)),TID="HRN" S XHRN=$P($G(^AUPNPAT(DFN,41,1,0)),"^",2)
"RTN","VWREGIT",169,0)
 . ;D GETS^DIQ(XFILE,DFN_",",FSET,"NIER","PAR","ERR") ;unused code
"RTN","VWREGIT",170,0)
 . ;Note: "**" used to gain all fields in multiples in the file - shotgun technique .vs focused/jeb 2013
"RTN","VWREGIT",171,0)
 . D GETS^DIQ(XFILE,DFN_",","**","NIER","PAR","ERR")
"RTN","VWREGIT",172,0)
 . D:$D(PAR(2,DFN_",","COUNTY","I"))
"RTN","VWREGIT",173,0)
 .. S COUNTY=$G(PAR(2,DFN_",","COUNTY","I")),STATE=$G(PAR(2,DFN_",","STATE","I"))
"RTN","VWREGIT",174,0)
 .. I STATE S PAR(2,DFN_",","COUNTY","E")=$P(^DIC(5,STATE,1,COUNTY,0),"^")
"RTN","VWREGIT",175,0)
 . S RESULT($$INR)=DFN_"^"_XID_"^"_$P(NAME,",",2)_"^"_$P(NAME,",")_"^"_DOB_"^"_$E(SEX)_"^"_$G(^DPT(DFN,.1))_$S($L($G(^DPT(DFN,.101))):" in room-bed "_^(.101),1:"")
"RTN","VWREGIT",176,0)
 . D FIELDS
"RTN","VWREGIT",177,0)
 . S N=2 F  S N=$O(RESULT(N)) Q:'+N  S F=$P(RESULT(N),"^",2) I $D(FSETNUM(F)),$L($P(FSETNUM(F),"^",2)) S $P(RESULT(N),"^")=$P(FSETNUM(F),"^",2)
"RTN","VWREGIT",178,0)
 . S N=2 F  S N=$O(RESULT(N)) Q:'+N  D
"RTN","VWREGIT",179,0)
 .. S F=$P(RESULT(N),"^")
"RTN","VWREGIT",180,0)
 .. S FDATA=$G(PAR(XFILE,DFN_",",F,"E"))
"RTN","VWREGIT",181,0)
 .. S $P(RESULT(N),"^",3)=FDATA
"RTN","VWREGIT",182,0)
 .. S $P(RESULT(N),"^",4)=$$HINT(XFILE,$P(RESULT(N),"^",2))
"RTN","VWREGIT",183,0)
 . S N=2 F  S N=$O(RESULT(N)) Q:'+N  D:+RESULT(N)
"RTN","VWREGIT",184,0)
 .. S SN=+RESULT(N) Q:'$D(FSETM(SN))
"RTN","VWREGIT",185,0)
 .. S SNFLDS=FSETM(SN)
"RTN","VWREGIT",186,0)
 .. S IX=.1
"RTN","VWREGIT",187,0)
 .. F I=1:1:$L(SNFLDS,";") S SNFN=$P(SNFLDS,";",I) S:SNFN RESULT(N+IX)=$P(^DD(SN,SNFN,0),"^")_"^"_SN_";"_SNFN_"^"_$$VPAR(SN)_"^^",IX=IX+.1
"RTN","VWREGIT",188,0)
 . S N=2 F  S N=$O(RESULT(N)) Q:'+N  K:+RESULT(N) RESULT(N)
"RTN","VWREGIT",189,0)
 . S N=2 F  S N=$O(RESULT(N)) Q:'+N  D
"RTN","VWREGIT",190,0)
 .. I $P(RESULT(N),"^",4)="" S $P(RESULT(N),"^",4)="<No Hint>"
"RTN","VWREGIT",191,0)
 .. I $P(RESULT(N),"^",2)[";",$P($P(RESULT(N),"^",2),";")=2.101,+$P(RESULT(N),";",2)=.01,'$L($G(^DPT(DFN,.1))) S $P(RESULT(N),"^",3)=$$MV(DFN,$P($P(RESULT(N),"^",2),";"),$G(^DIE(TNUM,"DR",2,$P($P(RESULT(N),"^",2),";"))
"RTN","VWREGIT",192,0)
 . S MATCH=1,$P(RESULT(0),"^",2)=1
"RTN","VWREGIT",193,0)
 ;Below - list of possibles found
"RTN","VWREGIT",194,0)
PIDM S (C,N)=0 F  S N=$O(ARR("DILIST",1,N)) Q:'+N  D
"RTN","VWREGIT",195,0)
 . S DFN=ARR("DILIST",2,N),C=C+1
"RTN","VWREGIT",196,0)
 . S XID=$P($G(^DPT(DFN,.36)),"^",3)
"RTN","VWREGIT",197,0)
 . S XSSN=ARR("DILIST","ID",N,.09)
"RTN","VWREGIT",198,0)
 . S XHRN=$P($G(^AUPNPAT(DFN,41,1,0)),"^",2)
"RTN","VWREGIT",199,0)
 . S XNAME=ARR("DILIST",1,N)
"RTN","VWREGIT",200,0)
 . S XDOB=ARR("DILIST","ID",N,.03)
"RTN","VWREGIT",201,0)
 . S XID=$S($L(XID):XID,$L(XSSN):XSSN,1:"")
"RTN","VWREGIT",202,0)
 . S RESULT($$INR)=$S($L(XID):XID,1:$L(XHRN),1:"")_"~"_XNAME_"~"_XDOB_"~"_$P(^DPT(DFN,0),"^",2)_"~"_DFN
"RTN","VWREGIT",203,0)
 . S $P(RESULT(0),"^",2)=C
"RTN","VWREGIT",204,0)
 Q
"RTN","VWREGIT",205,0)
 ;
"RTN","VWREGIT",206,0)
EN(RESULT)    ;Template name and ID labels
"RTN","VWREGIT",207,0)
 ;Parse stuff into Fileman-ese
"RTN","VWREGIT",208,0)
 ;Testing  - D EN^VWREGIT(.RESULT,"REG(1767)^^LEMON^^")
"RTN","VWREGIT",209,0)
 ;;M ^TMP("IDSTR",1)=IDSTR
"RTN","VWREGIT",210,0)
 ;;S RESULT(0)="[ID]"
"RTN","VWREGIT",211,0)
 ;;S RESULT(1)="-1^NEW"
"RTN","VWREGIT",212,0)
 ;;Q
"RTN","VWREGIT",213,0)
 ;end testing
"RTN","VWREGIT",214,0)
 ;
"RTN","VWREGIT",215,0)
 ;Get the input template list
"RTN","VWREGIT",216,0)
 ;housekeeping
"RTN","VWREGIT",217,0)
 S DTIME=99999
"RTN","VWREGIT",218,0)
 ;end housekeeping
"RTN","VWREGIT",219,0)
 ;
"RTN","VWREGIT",220,0)
 K AR,RESULT
"RTN","VWREGIT",221,0)
 N N,HD,FILE,LOC,P4,P5,%ZISHF,%ZISHO
"RTN","VWREGIT",222,0)
 S RESULT(0)=$$CONTROL^VWREGIT2()
"RTN","VWREGIT",223,0)
 S RESULT(1)="-1^No templates found"
"RTN","VWREGIT",224,0)
 S HD=$$GET^XPAR("ALL","VW GUI REG TEMPLATE DIRECTORY")
"RTN","VWREGIT",225,0)
 S FILE="regit.txt"
"RTN","VWREGIT",226,0)
 S P4=1
"RTN","VWREGIT",227,0)
 S P5=""
"RTN","VWREGIT",228,0)
 S X=$$FTG^%ZISH(HD,FILE,$NA(AR(1)),P4,P5)
"RTN","VWREGIT",229,0)
 I 'X K T,TITLE D  Q  ;Error report - home dir not found
"RTN","VWREGIT",230,0)
 . S TITLE=$P(RESULT(1),"^")
"RTN","VWREGIT",231,0)
 . S T(1)="The home directory could not be located."
"RTN","VWREGIT",232,0)
 . S T(2)="End of data error message"
"RTN","VWREGIT",233,0)
 . D ME(X)
"RTN","VWREGIT",234,0)
 . K T,X
"RTN","VWREGIT",235,0)
 S:+RESULT(0) $P(RESULT(0),"^",2)=HD
"RTN","VWREGIT",236,0)
 I $O(AR(0)) S RESULT(1)="[TEMPLATES]"
"RTN","VWREGIT",237,0)
 S N=0 F  S N=$O(AR(N)) Q:'+N  D
"RTN","VWREGIT",238,0)
 . Q:$E(AR(N))="*"
"RTN","VWREGIT",239,0)
 . Q:'+$P(AR(N),"(",2)
"RTN","VWREGIT",240,0)
 . Q:$P(^DIE(+$P(AR(N),"(",2),0),"^",4)'=2  ;must be pat file
"RTN","VWREGIT",241,0)
 . S RESULT($$INR)=AR(N)
"RTN","VWREGIT",242,0)
 S RESULT($$INR)="[ID]"
"RTN","VWREGIT",243,0)
 S N=0 F  S N=$O(RESULT(N)) Q:'+N  K:RESULT(N)="" RESULT(N)
"RTN","VWREGIT",244,0)
 I '$O(RESULT(0)) S RESULT(1)="-1^No PATIENT FILE templates found"
"RTN","VWREGIT",245,0)
 K AR
"RTN","VWREGIT",246,0)
 Q
"RTN","VWREGIT",247,0)
 ;
"RTN","VWREGIT",248,0)
PAT(RESULT,IDSTR) ;
"RTN","VWREGIT",249,0)
        ; **********************************************************
"RTN","VWREGIT",250,0)
        ; *IDSTR____Template(IEN)^ID/HRN/SSN:ID#^NAME^DOB^GENDER   *
"RTN","VWREGIT",251,0)
        ; *         ^NEW<-EMPTY IF NOT NEW PT                      *
"RTN","VWREGIT",252,0)
        ; *Action___Execute patient look up first with HRN/ID,     *
"RTN","VWREGIT",253,0)
        ; *         then NAME; DOB is confirming ID if found       *
"RTN","VWREGIT",254,0)
        ; *         If not found RESULT(0)="-1^NEW"                *
"RTN","VWREGIT",255,0)
        ; **********************************************************
"RTN","VWREGIT",256,0)
        ;
"RTN","VWREGIT",257,0)
 N DFN,FN,FSET,J,LABEL,MATCH,N,PID,TNUM,XAID,XDOB,XF,XFILE,XFLD,XHRN,XLABEL,XNAME,XUNM,XUMOV,XUFAM,XUOUT,XUREST,XUSP
"RTN","VWREGIT",258,0)
 N NAME,XDOB,SEX,FAIL,STR,TID,FAIL,TID,IEN
"RTN","VWREGIT",259,0)
 K RESULT,PAR,ARR,SPAR,LUERR,ERR
"RTN","VWREGIT",260,0)
 S RESULT(0)="[ID]^0"
"RTN","VWREGIT",261,0)
 S TNUM=+$P(IDSTR,"(",2)
"RTN","VWREGIT",262,0)
 Q:'TNUM  ;No template name from client
"RTN","VWREGIT",263,0)
 I '$D(^DIE(TNUM)) S RESULT(0)="-1^Template not found" G XOUT
"RTN","VWREGIT",264,0)
 S XFILE=$P(^DIE(TNUM,0),"^",4)
"RTN","VWREGIT",265,0)
 S MATCH=0
"RTN","VWREGIT",266,0)
 S DFN=0
"RTN","VWREGIT",267,0)
 ;D SETMULTS
"RTN","VWREGIT",268,0)
 S XEC=$$CFDFN^VWREGIT2(IDSTR)
"RTN","VWREGIT",269,0)
 I $L(XEC) D:XEC'="XOUT" @XEC G XOUT  ;Found DFN(s)...
"RTN","VWREGIT",270,0)
 S DFN=+$P($P(IDSTR,"^",3),"(",2)
"RTN","VWREGIT",271,0)
 I 'DFN,$P(IDSTR,"^",6) D  D NEWPAT,FIELDS Q
"RTN","VWREGIT",272,0)
 . S TID=$P($P(IDSTR,"^",2),":"),ID=$P($P(IDSTR,"^",2),":",2)
"RTN","VWREGIT",273,0)
 . K:TID="SSN" VWREG  ;Allow triggers and xfrs for the USA | jeb 2013
"RTN","VWREGIT",274,0)
 . S ID=$S($L(ID):$$CLNNUM(ID),1:"")
"RTN","VWREGIT",275,0)
 . S NAME=$$UP^XLFSTR($P(IDSTR,"^",3))
"RTN","VWREGIT",276,0)
 . S XDOB=$P(IDSTR,"^",4)
"RTN","VWREGIT",277,0)
 . S GENDER=$$UP^XLFSTR($P(IDSTR,"^",5))
"RTN","VWREGIT",278,0)
 . ;1901,.301,391 From Sam Habiel's UJOPTREG c 2010,2011 by permission
"RTN","VWREGIT",279,0)
 . S DATA(XFILE,"+1,",1901)="NO" ; Veteran?
"RTN","VWREGIT",280,0)
 . S DATA(XFILE,"+1,",.301)="NO" ; Service Connected
"RTN","VWREGIT",281,0)
 . S DATA(XFILE,"+1,",391)="NON-VETERAN (OTHER)"  ; Type of Patient
"RTN","VWREGIT",282,0)
 . S DATA(XFILE,"+1,",.01)=NAME
"RTN","VWREGIT",283,0)
 . S DATA(XFILE,"+1,",.02)=GENDER
"RTN","VWREGIT",284,0)
 . S DATA(XFILE,"+1,",.03)=XDOB
"RTN","VWREGIT",285,0)
 . S DATA(XFILE,"+1,",.09)=$S(TID="SSN":ID,1:"")
"RTN","VWREGIT",286,0)
 . S DATA(XFILE,"+1,",.363)=ID
"RTN","VWREGIT",287,0)
 . D UPDATE^DIE("E","DATA","IEN","VWERR")
"RTN","VWREGIT",288,0)
 . Q:$D(VWERR)
"RTN","VWREGIT",289,0)
 . S DFN=IEN(1) D RECALL^DILFD(2,DFN_",",DUZ)
"RTN","VWREGIT",290,0)
 . ;Set up IHS Patient file (9000001)
"RTN","VWREGIT",291,0)
 . D NOW^%DTC
"RTN","VWREGIT",292,0)
 . S AUPN=IEN(1),$P(AUPN,"^",2)=X,$P(AUPN,"^",11)=DUZ,$P(AUPN,"^",12)=X
"RTN","VWREGIT",293,0)
 . S ^AUPNPAT(+IEN(1))=AUPN,^AUPNPAT("B",+IEN(1),+IEN(1))=""
"RTN","VWREGIT",294,0)
 . I TID="HRN",'$O(^AUPNPAT("D",+IEN(1),ID,0)) D
"RTN","VWREGIT",295,0)
 .. S ^AUPNPAT(+IEN(1),41,1,0)="1^"_ID
"RTN","VWREGIT",296,0)
 .. S $P(^AUPNPAT(+IEN(1),41,0),"^",3)=ID,$P(^(0),"^",4)=$P(^(0),"^",4)+1
"RTN","VWREGIT",297,0)
LAUP . L ^AUPNPAT(0):1 G LAUP:'$T D  L
"RTN","VWREGIT",298,0)
 .. S $P(^AUPNPAT(0),"^",3)=+IEN(1)
"RTN","VWREGIT",299,0)
 .. S $P(^AUPNPAT(0),"^",4)=$P(^(0),"^",4)+1
"RTN","VWREGIT",300,0)
 D PID(DFN,$P($P(IDSTR,"^",2),":"),$P($P(IDSTR,"^",2),":",2))
"RTN","VWREGIT",301,0)
 ;D:'MATCH&($P(RESULT(0),"^",2)<2) FIELDS
"RTN","VWREGIT",302,0)
XOUT K PAR,ARR,ERR,SPAR,LUERR Q
"RTN","VWREGIT",303,0)
 ;
"RTN","VWREGIT",304,0)
NEWPAT ;Set up new patient data return
"RTN","VWREGIT",305,0)
 S $P(RESULT(0),"^",2)=1
"RTN","VWREGIT",306,0)
 ;S DFN=$G(IEN(1))
"RTN","VWREGIT",307,0)
 I TID'="SSN" D
"RTN","VWREGIT",308,0)
 . S DA=DFN
"RTN","VWREGIT",309,0)
 . D PSEU^DGRPDD1
"RTN","VWREGIT",310,0)
 . S (XSSN,$P(^DPT(DFN,0),"^",9))=L,^DPT("SSN",L,DFN)=""        
"RTN","VWREGIT",311,0)
 S RESULT($$INR)=DFN_"^"_ID_"^"_NAME_"^"_XDOB_"^"_GENDER_"^"_$G(^DPT(DFN,.1))_$S($L($G(^DPT(DFN,.101))):" in room-bed "_^(.101),1:"N/A")
"RTN","VWREGIT",312,0)
 Q
"RTN","VWREGIT",313,0)
 ;
"RTN","VWREGIT2")
0^9^B100003944
"RTN","VWREGIT2",1,0)
VWREGIT2 ;VWEHR/Jim Bell, et al... - World VistA Input Template Utility
"RTN","VWREGIT2",2,0)
 ;;1.0;WORLD VISTA;** **;;Build 1
"RTN","VWREGIT2",3,0)
 ;
"RTN","VWREGIT2",4,0)
 ;Continued from VWREGIT
"RTN","VWREGIT2",5,0)
 ;
"RTN","VWREGIT2",6,0)
 ;GNU License: See WVLIC.txt
"RTN","VWREGIT2",7,0)
 ;Modified FOIA VISTA,
"RTN","VWREGIT2",8,0)
 ;Copyright 2013 WorldVistA.  Licensed under the terms of the GNU
"RTN","VWREGIT2",9,0)
 Q
"RTN","VWREGIT2",10,0)
 ;
"RTN","VWREGIT2",11,0)
PI ;Post Installation install
"RTN","VWREGIT2",12,0)
 ;; NOTE: The parameter definition is installed but there is no installation for
"RTN","VWREGIT2",13,0)
 ;;the actual parameter and value. Do it here.
"RTN","VWREGIT2",14,0)
 ;parameter value attempt
"RTN","VWREGIT2",15,0)
 ;Set a home directory for editing; SYSTEM (DIC(4,) and DOMAIN (DIC(4.2,) only:"/home/vista/regparam/"
"RTN","VWREGIT2",16,0)
 S PARD=$O(^XTV(8989.51,"B","VW GUI REG TEMPLATE DIRECTORY",0))
"RTN","VWREGIT2",17,0)
 I PARD D
"RTN","VWREGIT2",18,0)
 . L +^XTV(8989.5,0):1 D  L -^XTV(8989.5,0)
"RTN","VWREGIT2",19,0)
 .. S NEW=$O(^XTV(8989.5," "),-1)+1
"RTN","VWREGIT2",20,0)
 .. S $P(^XTV(8989.5,0),"^",3)=NEW
"RTN","VWREGIT2",21,0)
 .. S $P(^XTV(8989.5,0),"^",4)=$P(^(0),"^",4)+1
"RTN","VWREGIT2",22,0)
 .. S $P(^XTV(8989.5,NEW,0),"^")="1;DIC(4,"
"RTN","VWREGIT2",23,0)
 .. S $P(^XTV(8989.5,NEW,0),"^",2)=PARD
"RTN","VWREGIT2",24,0)
 .. S $P(^XTV(8989.5,NEW,0),"^",3)=1
"RTN","VWREGIT2",25,0)
 .. S ^XTV(8989.5,NEW,1)="/home/vista/regparam/"
"RTN","VWREGIT2",26,0)
 .. S DA=NEW,DIK="^XTV(8989.5," D IX^DIK
"RTN","VWREGIT2",27,0)
 .. S NEW2=$O(^XTV(8989.5," "),-1)+1
"RTN","VWREGIT2",28,0)
 .. S $P(^XTV(8989.5,0),"^",3)=NEW2
"RTN","VWREGIT2",29,0)
 .. S $P(^XTV(8989.5,0),"^",4)=$P(^(0),"^",4)+1
"RTN","VWREGIT2",30,0)
 .. S $P(^XTV(8989.5,NEW2,0),"^")="9;DIC(4.2,"
"RTN","VWREGIT2",31,0)
 .. S $P(^XTV(8989.5,NEW2,0),"^",2)=PARD
"RTN","VWREGIT2",32,0)
 .. S $P(^XTV(8989.5,NEW2,0),"^",3)=1
"RTN","VWREGIT2",33,0)
 .. S ^XTV(8989.5,NEW2,1)="/home/vista/regparam/"
"RTN","VWREGIT2",34,0)
 .. S DA=NEW2,DIK="^XTV(8989.5," D IX^DIK
"RTN","VWREGIT2",35,0)
 .. ;S ^XTV(8989.5,"AC",PARD,"1;DIC(4,",1)="/home/vista/regparam/"
"RTN","VWREGIT2",36,0)
 .. ;S ^XTV(8989.5,"AC",PARD,"1;DIC(4,",1,NE)=""
"RTN","VWREGIT2",37,0)
 .. ;S ^XTV(8989.5,"B","1;DIC(4,",NE)=""
"RTN","VWREGIT2",38,0)
 ;
"RTN","VWREGIT2",39,0)
 ;Mailgroup VW REG ERROR REPORT - add programmer's email
"RTN","VWREGIT2",40,0)
 S DA(1)=$O(^XMB(3.8,"B","VW REG ERROR REPORT",0))
"RTN","VWREGIT2",41,0)
 Q:'DA(1)
"RTN","VWREGIT2",42,0)
 S DIC="^XMB(3.8,"_DA(1)_",6,"
"RTN","VWREGIT2",43,0)
 S X="jbellco65@gmail.com"
"RTN","VWREGIT2",44,0)
 S DIC(0)="LZ"
"RTN","VWREGIT2",45,0)
 D FILE^DICN
"RTN","VWREGIT2",46,0)
 Q
"RTN","VWREGIT2",47,0)
 ;
"RTN","VWREGIT2",48,0)
ABSDFN(RESULT,IDSTR) ;Absolute DFN
"RTN","VWREGIT2",49,0)
 N TNUM,DFN,XFILE
"RTN","VWREGIT2",50,0)
 K ERR,RESULT,PAR,FSET,FSETMAT
"RTN","VWREGIT2",51,0)
 S RESULT(0)="ID^-1"
"RTN","VWREGIT2",52,0)
 S TNUM=+$P($P(IDSTR,"^"),"(",2) I 'TNUM S RESULT(1)="Template not supplied. Please retry..." Q
"RTN","VWREGIT2",53,0)
 S DFN=$P(IDSTR,"^",2) I 'DFN S RESULT(1)="Patient not supplied. Please try again..." Q
"RTN","VWREGIT2",54,0)
 S XFILE=$P(^DIE(TNUM,0),"^",4)
"RTN","VWREGIT2",55,0)
 ;D SETMULTS^VWREGIT
"RTN","VWREGIT2",56,0)
 D RECALL^DILFD(2,DFN_",",DUZ)
"RTN","VWREGIT2",57,0)
 D GETS^DIQ(XFILE,DFN_",","**","NIER","PAR","ERR")
"RTN","VWREGIT2",58,0)
 S $P(RESULT(0),"^",2)=1
"RTN","VWREGIT2",59,0)
 S $P(RESULT(1),"^",1)=DFN
"RTN","VWREGIT2",60,0)
 S $P(RESULT(1),"^",2)=$G(ARR("DILIST","ID",1,.363))
"RTN","VWREGIT2",61,0)
 S $P(RESULT(1),"^",3)=$G(ARR("DILIST","ID",1,.01))
"RTN","VWREGIT2",62,0)
 ;S $P(RESULT(1),"^",4)=$G(ARR("DILIST","ID",1,.03))
"RTN","VWREGIT2",63,0)
 S $P(RESULT(1),"^",4)=$$GDOBT^VWREGIT(DFN)
"RTN","VWREGIT2",64,0)
 S $P(RESULT(1),"^",5)=$E($G(ARR("DILIST","ID",1,.02)))
"RTN","VWREGIT2",65,0)
 S $P(RESULT(1),"^",6)=$S($G(^DPT(DFN,.1)):^(.1),1:"N/A")_$S($L($G(^DPT(DFN,.101))):" in room-bed "_^(.101),1:"")
"RTN","VWREGIT2",66,0)
 S $P(RESULT(1),"^",7)=$G(ARR("DILIST",1,.09))
"RTN","VWREGIT2",67,0)
 D FIELDS^VWREGIT
"RTN","VWREGIT2",68,0)
 S N=2 F  S N=$O(RESULT(N)) Q:'+N  S F=$P(RESULT(N),"^",2) I $D(FSETNUM(F)),$L($P(FSETNUM(F),"^",2)) S $P(RESULT(N),"^")=$P(FSETNUM(F),"^",2)
"RTN","VWREGIT2",69,0)
 S N=2 F  S N=$O(RESULT(N)) Q:'+N  D
"RTN","VWREGIT2",70,0)
 . S F=$P(RESULT(N),"^")
"RTN","VWREGIT2",71,0)
 . S FDATA=$G(PAR(XFILE,DFN_",",F,"E"))
"RTN","VWREGIT2",72,0)
 . S $P(RESULT(N),"^",3)=FDATA
"RTN","VWREGIT2",73,0)
 . S $P(RESULT(N),"^",4)=$$HINT^VWREGIT(XFILE,$P(RESULT(N),"^",2))
"RTN","VWREGIT2",74,0)
 S N=2 F  S N=$O(RESULT(N)) Q:'+N  D:+RESULT(N)
"RTN","VWREGIT2",75,0)
 . S SN=+RESULT(N) Q:'$D(FSETM(SN))
"RTN","VWREGIT2",76,0)
 . S SNFLDS=FSETM(SN)
"RTN","VWREGIT2",77,0)
 . S IX=.1
"RTN","VWREGIT2",78,0)
 . F I=1:1:$L(SNFLDS,";") S SNFN=$P(SNFLDS,";",I) S:SNFN RESULT(N+IX)=$P(^DD(SN,SNFN,0),"^")_"^"_SN_";"_SNFN_"^"_$$VPAR^VWREGIT(SN)_"^^",IX=IX+.1
"RTN","VWREGIT2",79,0)
 S N=2 F  S N=$O(RESULT(N)) Q:'+N  K:+RESULT(N) RESULT(N)
"RTN","VWREGIT2",80,0)
 S N=2 F  S N=$O(RESULT(N)) Q:'+N  D
"RTN","VWREGIT2",81,0)
 . I $P(RESULT(N),"^",4)="" S $P(RESULT(N),"^",4)="<No Hint>"
"RTN","VWREGIT2",82,0)
 . I $P(RESULT(N),"^",2)[";",$P($P(RESULT(N),"^",2),";")=2.101,+$P(RESULT(N),";",2)=.01,'$L($G(^DPT(DFN,.1))) S $P(RESULT(N),"^",3)="NOW"
"RTN","VWREGIT2",83,0)
 Q
"RTN","VWREGIT2",84,0)
 ;
"RTN","VWREGIT2",85,0)
CFDFN(STRING) ;Check for a DFN
"RTN","VWREGIT2",86,0)
 ; ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
"RTN","VWREGIT2",87,0)
 ; | STRING___TEMPLATE(IEN)^ID^NAME^DOB^GENDER   |
"RTN","VWREGIT2",88,0)
 ; ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
"RTN","VWREGIT2",89,0)
 ;
"RTN","VWREGIT2",90,0)
 N NAME,ID
"RTN","VWREGIT2",91,0)
 S ID=$$CLNNUM^VWREGIT($P($P(STRING,"^",2),":",2))
"RTN","VWREGIT2",92,0)
 S TID=$P($P(STRING,"^",2),":")
"RTN","VWREGIT2",93,0)
 I TID="HRN" S DFN=$O(^AUPNPAT("D",ID,0)) S $P(IDSTR,"^",2)=DFN D ABSDFN(.RESULT,IDSTR) Q "XOUT"
"RTN","VWREGIT2",94,0)
 S NAME=$$UP^XLFSTR($P(STRING,"^",3))
"RTN","VWREGIT2",95,0)
 D FIND^DIC(2,"",".01;.02;.03;.09;.363","CM",$S(+ID:ID,1:NAME),"","B^SSN^AVWPID","","","ARR","LUERR")
"RTN","VWREGIT2",96,0)
 I '$O(ARR("DILIST",0)) Q ""
"RTN","VWREGIT2",97,0)
 ;I '$O(ARR("DILIST",1,1)),$L(NAME),ARR("DILIST",1,1)'=NAME Q "MM"
"RTN","VWREGIT2",98,0)
 I $O(ARR("DILIST",1,1)) Q "PIDM"   ;multiple found
"RTN","VWREGIT2",99,0)
 I '$O(ARR("DILIST",1,1)) D  D ABSDFN(.RESULT,IDSTR) Q "XOUT"  ;Single found
"RTN","VWREGIT2",100,0)
 . S $P(IDSTR,"^",2)=ARR("DILIST",2,1)
"RTN","VWREGIT2",101,0)
 Q ""
"RTN","VWREGIT2",102,0)
 ;
"RTN","VWREGIT2",103,0)
ST(TN) ;Screen these templates for PATIENT FILE(#2):1,1:0
"RTN","VWREGIT2",104,0)
 I $E($P(^DIE(TN,0),"^"))="*" Q 0
"RTN","VWREGIT2",105,0)
 I $P(^DIE(TN,0),"^",4)'=2 Q 0
"RTN","VWREGIT2",106,0)
 Q 1
"RTN","VWREGIT2",107,0)
 ;
"RTN","VWREGIT2",108,0)
INR() Q $O(RESULT(" "),-1)+1
"RTN","VWREGIT2",109,0)
 ;
"RTN","VWREGIT2",110,0)
CLNNUM(NUM) ;Clean NUM
"RTN","VWREGIT2",111,0)
 Q $TR(NUM," -^/~|\[]{}@!#$%&*()-_=+';:<>,.?")
"RTN","VWREGIT2",112,0)
 ;
"RTN","VWREGIT2",113,0)
CONTROL() ;Check for CONTROL status
"RTN","VWREGIT2",114,0)
 N X S X=$O(^DIC(19,"B","VW REG IT CONTROL",0))
"RTN","VWREGIT2",115,0)
 I 'X Q 0  ;Ain't no option there
"RTN","VWREGIT2",116,0)
 Q $S($D(^VA(200,DUZ,203,"B",X)):1,1:0)
"RTN","VWREGIT2",117,0)
 ;
"RTN","VWREGIT2",118,0)
GETHD(RESULT) ;Get home directory for set up
"RTN","VWREGIT2",119,0)
 S RESULT(0)=$$GET^XPAR("ALL","VW GUI REG TEMPLATE DIRECTORY")
"RTN","VWREGIT2",120,0)
 Q
"RTN","VWREGIT2",121,0)
 ;
"RTN","VWREGIT2",122,0)
SAVEHD(RESULT,NHD) ;Saves Home Directory changes to PARAMETER file
"RTN","VWREGIT2",123,0)
 ; Called from Remote Procedure VW REG SAVE HD
"RTN","VWREGIT2",124,0)
 ; NHD_____New Home Directory
"RTN","VWREGIT2",125,0)
 ;
"RTN","VWREGIT2",126,0)
 I NHD="" S RESULT(0)="-1^No data from client" Q
"RTN","VWREGIT2",127,0)
 K RESULT,SCRATCH
"RTN","VWREGIT2",128,0)
 N HDIEN,N
"RTN","VWREGIT2",129,0)
 S HDIEN=$O(^XTV(8989.51,"B","VW GUI REG TEMPLATE DIRECTORY",0))
"RTN","VWREGIT2",130,0)
 I 'HDIEN D  Q
"RTN","VWREGIT2",131,0)
 . S T(1)="Error reported from routine SAVEHD^VWREGIT:"
"RTN","VWREGIT2",132,0)
 . S T(2)="The PARAMETER DEFINITION ""VW GUI REG TEMPLATE DIRECTORY"" was"
"RTN","VWREGIT2",133,0)
 . S T(3)="not found."
"RTN","VWREGIT2",134,0)
 . D ME^VWREGIT("NO PARAMETER DEFINITION")
"RTN","VWREGIT2",135,0)
 . S RESULT(0)="-1^Error sent to VW REG mail group"
"RTN","VWREGIT2",136,0)
 S X="^XTV(8989.5,""AC"","_HDIEN_")" F  S X=$Q(@X) Q:+$P(X,",",3)'=HDIEN  S:$L(X,",")>6 SCRATCH(+$P(X,",",7))=""
"RTN","VWREGIT2",137,0)
 S N=0 F  S N=$O(SCRATCH(N)) Q:'+N  D  S RESULT(0)=1
"RTN","VWREGIT2",138,0)
 . S ^XTV(8989.5,N,1)=NHD
"RTN","VWREGIT2",139,0)
 . S DA=N,DIK="^XTV(8989.5," D IX^DIK
"RTN","VWREGIT2",140,0)
 . K DIC,DA,DIK
"RTN","VWREGIT2",141,0)
 Q
"RTN","VWREGIT2",142,0)
 ;
"RTN","VWREGIT2",143,0)
SAVE(RESULT,FLDS)       ;Template fields being returned with values
"RTN","VWREGIT2",144,0)
 ;UPCASE everything!
"RTN","VWREGIT2",145,0)
 ;;Testing
"RTN","VWREGIT2",146,0)
 ;;S RESULT(0)="-1 Q
"RTN","VWREGIT2",147,0)
 ;;End Testing
"RTN","VWREGIT2",148,0)
 K AR,ERR,MFLD,DIERR
"RTN","VWREGIT2",149,0)
 N N,TNUM,XFILE,C,PLID,COUNTY,PSSN,DA,DIE,DIC,DR,STR,VAFCA08
"RTN","VWREGIT2",150,0)
 ;W "  ;Used for "instantiating" a hard error
"RTN","VWREGIT2",151,0)
 S C=0,RESULT(0)=""
"RTN","VWREGIT2",152,0)
 S X="FLDS" F  S X=$Q(@X) Q:X=""  S STR=@X,@X=$$UP^XLFSTR(STR)
"RTN","VWREGIT2",153,0)
 S VWREG=$S($P(FLDS(0),"^",2)="VWRGUI":1,1:0)
"RTN","VWREGIT2",154,0)
 S VAFCA08=1  ;Prevents execution xfrs 991 and 992 of field 1901 and related other fields
"RTN","VWREGIT2",155,0)
 S TNUM=+$P(FLDS(0),"(",2)
"RTN","VWREGIT2",156,0)
 S XFILE=$P(^DIE(TNUM,0),"^",4)
"RTN","VWREGIT2",157,0)
 S $P(FLDS(4),"^",2)=$$CLNNUM($P(FLDS(4),"^",2))
"RTN","VWREGIT2",158,0)
 ;VA abnormal anomalies not experienced in the outside world
"RTN","VWREGIT2",159,0)
 S N=0 F  S N=$O(FLDS(N)) Q:'+N  D
"RTN","VWREGIT2",160,0)
 . S LFILE=$S($P(FLDS(N),"^")[";":+FLDS(N),1:XFILE)
"RTN","VWREGIT2",161,0)
 . S LFLD=$P(FLDS(N),"^")
"RTN","VWREGIT2",162,0)
 . S LFLD=$S(LFLD[";":$P($P(LFLD,"^"),";",2),1:LFLD)
"RTN","VWREGIT2",163,0)
 . I $P(^DD(LFILE,+LFLD,0),"^")="PRIMARY LONG ID" S PLID=1
"RTN","VWREGIT2",164,0)
 . I $P(^DD(LFILE,+LFLD,0),"^")["COUNTY" S COUNTY=FLDS(N) K FLDS(N)
"RTN","VWREGIT2",165,0)
 ;End VA abnormal anomalies
"RTN","VWREGIT2",166,0)
 S DFN=+$P(FLDS(1),"(",2)
"RTN","VWREGIT2",167,0)
DFN ;
"RTN","VWREGIT2",168,0)
 ;Check standard ID fields (ID = NOT in the VA meaning): .01,.02,.03,.36^3 for outside the U.S. or 0^9 in the U.S.
"RTN","VWREGIT2",169,0)
 I $P(^DPT(DFN,0),"^")'=$P($P(FLDS(1),"^",2),"(") S AR(XFILE,DFN_",",$P(FLDS(1),"^"))=$P($P(FLDS(1),"^",2),"(")
"RTN","VWREGIT2",170,0)
 I $P(^DPT(DFN,0),"^",2)'=$P(FLDS(2),"^") S AR(XFILE,DFN_",",$P(FLDS(2),"^"))=$S($P(FLDS(2),"^",2)="F":"FEMALE",1:"MALE")
"RTN","VWREGIT2",171,0)
 S X=$P(FLDS(3),"^",2) D ^%DT I $P(^DPT(DFN,0),"^",3)'=Y S AR(XFILE,DFN_",",$P(FLDS(3),"^"))=$P(FLDS(3),"^",2)
"RTN","VWREGIT2",172,0)
 ;S FLD=$P(FLDS(4),"^"),PIECE=$S(FLD=.363:3,1:9),SUBS=$S(FLD=.363:.36,1:0)
"RTN","VWREGIT2",173,0)
 ;I $P(^DPT(DFN,SUBS),"^",PIECE)'=$P(FLDS(4),"^",2) S AR(XFILE,DFN_",",FLD)=$P(FLDS(4),"^",2)
"RTN","VWREGIT2",174,0)
 S N=4 F  S N=$O(FLDS(N)) Q:'+N  S:FLDS(N)'[";" AR(XFILE,DFN_",",$P(FLDS(N),"^"))=$P(FLDS(N),"^",2) D:FLDS(N)[";"
"RTN","VWREGIT2",175,0)
 . I '$D(MFLD($P(FLDS(N),";"))) S MFLD=$P(FLDS(N),";"),MFLD(MFLD)=FLDS(N)
"RTN","VWREGIT2",176,0)
 . E  S MFLD($P(FLDS(N),";"))=MFLD($P(FLDS(N),";"))_"~"_$P(FLDS(N),";",2)
"RTN","VWREGIT2",177,0)
 I $D(MFLD) S C=1,N=0 F  S N=$O(MFLD(N)) Q:'+N  S C=C+1,CN=0 F I=1:1:$L(MFLD(N),"~") S CN=CN+1,X=$P($P(MFLD(N),";",2),"~",I),AR(N,"+"_C_","_DFN_",",$P(X,"^"))=$P(X,"^",2)
"RTN","VWREGIT2",178,0)
 D UPDATE^DIE("E","AR","","ERR")  ;Edit existing entries noted by $D(DFN)
"RTN","VWREGIT2",179,0)
 N Y,X,% D NOW^%DTC S Y=% X ^DD("DD")
"RTN","VWREGIT2",180,0)
 S RESULT(0)=1_"^"_Y
"RTN","VWREGIT2",181,0)
SOUT Q
"RTN","VWREGIT2",182,0)
 ;
"RTN","VWREGIT2",183,0)
UTF(RESULT,UTFLIST) ;Update Linux Template file (regit.txt)
"RTN","VWREGIT2",184,0)
 I $O(UTFLIST(" "),-1)=0 S RESULT(0)="-1" Q
"RTN","VWREGIT2",185,0)
 K RESULT
"RTN","VWREGIT2",186,0)
 N HD,DOTHIS,N,NF
"RTN","VWREGIT2",187,0)
 S HD=$$GET^XPAR("ALL","VW GUI REG TEMPLATE DIRECTORY")
"RTN","VWREGIT2",188,0)
 I +$P($G(^%ZOSF("OS")),"^",2)=19 D
"RTN","VWREGIT2",189,0)
 . S DOTHIS="rm -f "_HD_"regit2.txt" ZSYSTEM DOTHIS  ;Remove the prior copy
"RTN","VWREGIT2",190,0)
 . S DOTHIS="cp "_HD_"regit.txt"_" "_HD_"regit2.txt" ZSYSTEM DOTHIS  ;Copy the main regit file for safekeeping
"RTN","VWREGIT2",191,0)
 . S DOTHIS="rm -f "_HD_"regit.txt" ZSYSTEM DOTHIS  ;Kill the main regit template file
"RTN","VWREGIT2",192,0)
 S RESULT(1)="[TEMPLATES]",N=0 F  S N=$O(UTFLIST(N)) Q:'+N  S RESULT($$INR)=UTFLIST(N)
"RTN","VWREGIT2",193,0)
 S RESULT($$INR)="[ID]"
"RTN","VWREGIT2",194,0)
 S X=$$GTF^%ZISH($NA(RESULT(1)),1,HD,"regit.txt")
"RTN","VWREGIT2",195,0)
 Q
"RTN","VWREGIT2",196,0)
 ;
"RTN","VWREGIT2",197,0)
GT(RESULT,XHOW) ;Get Templates from INPUT TEMPLATE FILE (.402)
"RTN","VWREGIT2",198,0)
 ; *********************************************
"RTN","VWREGIT2",199,0)
 ; * XHOW____ALL, DUZ, NAMESPACE, USER/NUM     *
"RTN","VWREGIT2",200,0)
 ; * RETURN ARRAY__List of template names(IEN) *
"RTN","VWREGIT2",201,0)
 ; *********************************************
"RTN","VWREGIT2",202,0)
 K RESULT,AR
"RTN","VWREGIT2",203,0)
 N IEN,NAME,N,USER
"RTN","VWREGIT2",204,0)
 S XHOW=$$UP^XLFSTR(XHOW) ;UPCASE EVERYTHING!
"RTN","VWREGIT2",205,0)
 I XHOW="" D  Q
"RTN","VWREGIT2",206,0)
 . S RESULT(0)="I could not complete your request."
"RTN","VWREGIT2",207,0)
 . S RESULT(1)="Ensure that one of the check boxes is checked."
"RTN","VWREGIT2",208,0)
 . S RESULT(2)="Thank you, the Management."
"RTN","VWREGIT2",209,0)
 I XHOW="ALL" D  Q
"RTN","VWREGIT2",210,0)
 . S RESULT(0)="Number of Templates: "
"RTN","VWREGIT2",211,0)
 . S (C,N)=0 F I=1:1 S N=$O(^DIE(N)) Q:'+N  S X=$P(^(N,0),"^") S:$$ST(N) AR(X,I)=X_"("_N_")"
"RTN","VWREGIT2",212,0)
 . S X="AR" F  S X=$Q(@X) Q:X=""  S RESULT($$INR)=@X,C=C+1
"RTN","VWREGIT2",213,0)
 . K AR
"RTN","VWREGIT2",214,0)
 . S $P(RESULT(0),": ",2)=C K C
"RTN","VWREGIT2",215,0)
 I XHOW="DUZ" D  Q
"RTN","VWREGIT2",216,0)
 . S RESULT(0)="Number of templates: "
"RTN","VWREGIT2",217,0)
 . S (C,IEN)=0 F  S IEN=$O(^DIE(IEN)) Q:'+IEN  I $P(^(IEN,0),"^",5)=DUZ,$$ST(IEN) D
"RTN","VWREGIT2",218,0)
 .. S C=C+1
"RTN","VWREGIT2",219,0)
 .. S NAME=$P(^(0),"^")_"("_IEN_")"
"RTN","VWREGIT2",220,0)
 .. S RESULT($$INR)=NAME
"RTN","VWREGIT2",221,0)
 . S $P(RESULT(0),":",2)=C
"RTN","VWREGIT2",222,0)
 I +XHOW D  Q
"RTN","VWREGIT2",223,0)
 . S RESULT(0)="Number of templates: "
"RTN","VWREGIT2",224,0)
 . S N=0 F I=1:1 S N=$O(^DIE(N)) Q:'+N  S X=^(N,0) D
"RTN","VWREGIT2",225,0)
 .. Q:$P(X,"^",5)'=XHOW
"RTN","VWREGIT2",226,0)
 .. Q:'$$ST(N)
"RTN","VWREGIT2",227,0)
 .. S AR($P(X,"^"),I)=$P(X,"^")_"("_N_")"
"RTN","VWREGIT2",228,0)
 . S X="AR" F  S X=$Q(@X) Q:X=""  S RESULT($$INR)=@X
"RTN","VWREGIT2",229,0)
 . K AR
"RTN","VWREGIT2",230,0)
 . S $P(RESULT(0),": ",2)=$O(RESULT(" "),-1)
"RTN","VWREGIT2",231,0)
 I $L(XHOW,"^")>1,$P(XHOW,"^")="NS" D  Q
"RTN","VWREGIT2",232,0)
 . S RESULT(0)="Templates by Namespace: "
"RTN","VWREGIT2",233,0)
 . S N=$P(XHOW,"^",2) F I=1:1 S N=$O(^DIE("B",N)) Q:N'[$P(XHOW,"^",2)  S AR(N,I)=N_"("_$O(^DIE("B",N,0))_")"
"RTN","VWREGIT2",234,0)
 . S X="AR" F  S X=$Q(@X) Q:X=""  S Y=@X S:$$ST(+$P(Y,"(",2)) RESULT($$INR)=Y
"RTN","VWREGIT2",235,0)
 . S $P(RESULT(0),": ",2)=$O(RESULT(" "),-1)
"RTN","VWREGIT2",236,0)
 I $L(XHOW,"^")>1,$P(XHOW,"^")="U",+$P(XHOW,"^",2) D  Q
"RTN","VWREGIT2",237,0)
 . S RESULT(0)="Templates from: "
"RTN","VWREGIT2",238,0)
 . S USER=+$P(XHOW,"^",2)
"RTN","VWREGIT2",239,0)
 . I '$D(^VA(200,USER)) S RESULT(0)="I Cannot ID that user number." Q
"RTN","VWREGIT2",240,0)
 . S N=0 F I=1:1 S N=$O(^DIE(N)) Q:'+N  S NAME=$P(^(N,0),"^") I $P(^(0),"^",5)=USER S AR(NAME,I)=NAME_"("_N_")"
"RTN","VWREGIT2",241,0)
 . S X="AR" F  S X=$Q(@X) Q:X=""  S RESULT($$INR)=@X
"RTN","VWREGIT2",242,0)
 . S $P(RESULT(0),": ",2)=$P(^VA(200,USER,0),"^")_" - "_$O(RESULT(" "),-1)
"RTN","VWREGIT2",243,0)
 . K AR
"RTN","VWREGIT2",244,0)
 I $L(XHOW,"^")>1,$P(XHOW,"^")="U",'+$P(XHOW,"^",2) D  Q
"RTN","VWREGIT2",245,0)
 . S NAME=$P(XHOW,"^",2)
"RTN","VWREGIT2",246,0)
 . K LUERR,ARR D FIND^DIC(200,"",".01;","CM",NAME,"","B","","","ARR","LUERR")
"RTN","VWREGIT2",247,0)
 . I $O(ARR("DILIST",2,1)) D  Q
"RTN","VWREGIT2",248,0)
 .. S RESULT(0)="LIST"
"RTN","VWREGIT2",249,0)
 .. S RESULT(1)="[Instruction: double-click to select; right-click to close]"
"RTN","VWREGIT2",250,0)
 .. S N=0 F  S N=$O(ARR("DILIST",1,N)) Q:'+N  S RESULT($$INR)=ARR("DILIST",2,N)_"^"_ARR("DILIST",1,N)
"RTN","VWREGIT2",251,0)
 . S IEN=ARR("DILIST",2,1) K ARR
"RTN","VWREGIT2",252,0)
 . S RESULT(0)="Templates from: "
"RTN","VWREGIT2",253,0)
 . S N=0 F I=1:1  S N=$O(^DIE(N)) Q:'+N!('$$ST(N))  S X=^(N,0) S:$P(X,"^",5)=IEN AR($P(X,"^"),I)=$P(X,"^")_"("_N_")"
"RTN","VWREGIT2",254,0)
 . S X="AR" F  S X=$Q(@X) Q:X=""  S RESULT($$INR)=@X
"RTN","VWREGIT2",255,0)
 . S $P(RESULT(0),": ",2)=$O(RESULT(" "),-1)
"RTN","VWREGIT2",256,0)
 . K AR
"RTN","VWREGIT2",257,0)
 Q
"RTN","VWREGIT2",258,0)
 ;
"RTN","VWREGIT2",259,0)
 
"RTN","VWREGIT3")
0^10^B43452100
"RTN","VWREGIT3",1,0)
VWREGIT ;VWEHR/BFProd-Jim Bell, et al - World VistA GUI Pat Reg Utility
"RTN","VWREGIT3",2,0)
 ;;1.0;WORLD VISTA;** **;;Build 1
"RTN","VWREGIT3",3,0)
 ;
"RTN","VWREGIT3",4,0)
 ;This routine utility is for patient specific fields and
"RTN","VWREGIT3",5,0)
 ;is used to build input templates for registration
"RTN","VWREGIT3",6,0)
 ;
"RTN","VWREGIT3",7,0)
 ;GNU License: See WVLIC.txt
"RTN","VWREGIT3",8,0)
 ;Modified FOIA VISTA,
"RTN","VWREGIT3",9,0)
 ;Copyright 2013 WorldVistA.  Licensed under the terms of the GNU
"RTN","VWREGIT3",10,0)
 Q
"RTN","VWREGIT3",11,0)
 ;
"RTN","VWREGIT3",12,0)
PREFLAB ;Preferred label extract
"RTN","VWREGIT3",13,0)
 N FIELD,LABEL,N,I,CUSLAB
"RTN","VWREGIT3",14,0)
 S N=0 F  S N=$O(RESULT(N)) Q:'+N  D
"RTN","VWREGIT3",15,0)
 . S LABEL=$P(RESULT(N),"^")
"RTN","VWREGIT3",16,0)
 . S FIELD=$P(RESULT(N),"^",2)
"RTN","VWREGIT3",17,0)
 . S I=0 F  S I=$O(AR(I)) Q:'+I  D:RESULT(N)'[";"
"RTN","VWREGIT3",18,0)
 .. Q:AR(I)'[";"
"RTN","VWREGIT3",19,0)
 .. I $P(AR(I),";")=LABEL!($P(AR(I),";")=FIELD) D
"RTN","VWREGIT3",20,0)
 ... S CUSLAB=$P(AR(I),";",2)
"RTN","VWREGIT3",21,0)
 ... S CUSLAB=$TR(CUSLAB,"""","")
"RTN","VWREGIT3",22,0)
 ... S $P(RESULT(N),"^")=CUSLAB
"RTN","VWREGIT3",23,0)
 Q
"RTN","VWREGIT3",24,0)
 ;
"RTN","VWREGIT3",25,0)
PARSE(STRING) ;Extract necessary data components in the string
"RTN","VWREGIT3",26,0)
 N VAL,PIECE,LABEL,PREFLAB,FLDSN
"RTN","VWREGIT3",27,0)
 S VAL=-1 I STRING="" G POUT
"RTN","VWREGIT3",28,0)
 ;I $E(STRING)=">" S VAL="" G POUT
"RTN","VWREGIT3",29,0)
 S PIECE=$S(STRING["(Multiple)":2,$L(STRING,"(")>2:3,1:2)
"RTN","VWREGIT3",30,0)
        I $E(STRING)=">" D  G POUT
"RTN","VWREGIT3",31,0)
        . S SUBF=+$P(STRING,";",2),MAR(SUBF)=""
"RTN","VWREGIT3",32,0)
        . S MAR(SUBF)=MAR(SUBF)_+$P(STRING,"(",PIECE)
"RTN","VWREGIT3",33,0)
 . S VAL=""
"RTN","VWREGIT3",34,0)
 S LABEL=$P(STRING,"~")
"RTN","VWREGIT3",35,0)
 S PREFLAB=$S($P(STRING,"~",2)="(Multiple)":"",1:$P(STRING,"~",2))
"RTN","VWREGIT3",36,0)
 S FLDN=+$P(STRING,"(",PIECE)
"RTN","VWREGIT3",37,0)
 I '+FLDN,$G(DUZ(0))="@" S VAL=STRING G POUT
"RTN","VWREGIT3",38,0)
 S VAL=FLDN_PREFLAB_"~"_$S('$L(PREFLAB):"",1:$P(LABEL,"(",1,PIECE-1)_"^"_PREFLAB)
"RTN","VWREGIT3",39,0)
POUT Q VAL
"RTN","VWREGIT3",40,0)
 ;
"RTN","VWREGIT3",41,0)
NEXT(XAR) ;Get next subscript
"RTN","VWREGIT3",42,0)
 Q $O(XAR(" "),-1)+1
"RTN","VWREGIT3",43,0)
 ;
"RTN","VWREGIT3",44,0)
REJECT(FIELD,IEN) ;Reject Asterisked and Computed fields
"RTN","VWREGIT3",45,0)
 I FIELD["COMPONENTS" Q 1  ;Pain in the butt!
"RTN","VWREGIT3",46,0)
 I $E(FIELD)="*" Q 1  ;field marked for deletion
"RTN","VWREGIT3",47,0)
 I $E($P($G(^DD(2,IEN,0)),"^",2))="C" Q 1  ;computed field
"RTN","VWREGIT3",48,0)
 Q 0  ;Passed
"RTN","VWREGIT3",49,0)
 ;
"RTN","VWREGIT3",50,0)
GTNUM ;
"RTN","VWREGIT3",51,0)
 K AR,RESULT S RESULT(0)=-1
"RTN","VWREGIT3",52,0)
 M AR=^DIE(TNUM)
"RTN","VWREGIT3",53,0)
 Q:'$D(AR(0))  ;Huh, no template?
"RTN","VWREGIT3",54,0)
 S RESULT(0)=TNAME
"RTN","VWREGIT3",55,0)
 S FLDS=AR("DR",1,2)
"RTN","VWREGIT3",56,0)
 F I=1:1:$L(FLDS,";")-1 S FN=$P(FLDS,";",I) D
"RTN","VWREGIT3",57,0)
 . S FDATA=$S(+FN:$P(^DD(2,FN,0),"^",1,2),1:FN)
"RTN","VWREGIT3",58,0)
 . S RESULT($$NEXT(.RESULT))=$S(+FN:$P(FDATA,"^")_"("_FN_")",1:FN)_$S(+$P(FDATA,"^",2):"~(Multiple)",1:"")
"RTN","VWREGIT3",59,0)
 . I +$P(FDATA,"^",2) S SFN=AR("DR",2,+$P(FDATA,"^",2)) D
"RTN","VWREGIT3",60,0)
 .. F J=1:1:$L(SFN,";")-1 D
"RTN","VWREGIT3",61,0)
 ... S SDF=$P(SFN,";",J)
"RTN","VWREGIT3",62,0)
 ... S SDFDATA=$P(^DD(+$P(FDATA,"^",2),+SDF,0),"^",1,2)
"RTN","VWREGIT3",63,0)
 ... S RESULT($$NEXT(.RESULT))=">>>>> "_$P(SDFDATA,"^")_"("_SDF_";"_+$P(FDATA,"^",2)_")"_$S(+$P(SDFDATA,"^",2):"~(Multiple)",1:"")
"RTN","VWREGIT3",64,0)
 ... I +$P(SDFDATA,"^",2) S SF3=AR("DR",2,+$P(SDFDATA,"^",2)) D
"RTN","VWREGIT3",65,0)
 .... F K=1:1:$L(SF3,";")-1 S SF3DATA=$P(^DD(+$P(SDFDATA,"^",2),SF3,0),"^",1,2) D
"RTN","VWREGIT3",66,0)
 ..... S RESULT($$NEXT(.RESULT))=">>>>>>>>>> "_SF3_"~"_$P(SF3DATA,"^")_$S(+$P(SF3DATA,"^",2):"~(Multiple)",1:"")
"RTN","VWREGIT3",67,0)
 Q
"RTN","VWREGIT3",68,0)
 ;
"RTN","VWREGIT3",69,0)
NFT(SUBS) ;Patient file fields into scratch global
"RTN","VWREGIT3",70,0)
 Q $O(^UTILITY(SUBS," "),-1)+1  ;Next suscript
"RTN","VWREGIT3",71,0)
 ;
"RTN","VWREGIT3",72,0)
SD ;SUB-DICS
"RTN","VWREGIT3",73,0)
 N N,FLD,X
"RTN","VWREGIT3",74,0)
 K ^UTILITY("SFT")
"RTN","VWREGIT3",75,0)
 S X="^DD(2,""SB"")"
"RTN","VWREGIT3",76,0)
 F  S X=$Q(@X) Q:X'["SB"  D
"RTN","VWREGIT3",77,0)
 . S N=+$P(X,",",3)
"RTN","VWREGIT3",78,0)
 . S FLD=+$P(X,",",4)
"RTN","VWREGIT3",79,0)
 . S ^UTILITY("SFT",FLD,N)=""
"RTN","VWREGIT3",80,0)
 Q
"RTN","VWREGIT3",81,0)
 ;
"RTN","VWREGIT3",82,0)
LF(RESULT,TNAME) ;Full list of patient fields
"RTN","VWREGIT3",83,0)
 K RESULT
"RTN","VWREGIT3",84,0)
 S TNUM=+$P(TNAME,"(",2) D:TNUM GTNUM  ;Existing template
"RTN","VWREGIT3",85,0)
 ; Add patient file fields
"RTN","VWREGIT3",86,0)
 S RESULT($$NEXT(.RESULT))="[PF]"
"RTN","VWREGIT3",87,0)
 K ^UTILITY("FT") D SD
"RTN","VWREGIT3",88,0)
 S FLD="" F  S FLD=$O(^DD(2,"B",FLD)) Q:FLD=""  D
"RTN","VWREGIT3",89,0)
 . S N=0 F  S N=$O(^DD(2,"B",FLD,N)) Q:'+N  D:'$$REJECT(FLD,N)
"RTN","VWREGIT3",90,0)
 .. S ^UTILITY("FT",$$NFT("FT"))=FLD_"("_N_")"_"~"_$S($D(^UTILITY("SFT",N)):"(Multiple)",1:" ")
"RTN","VWREGIT3",91,0)
 .. S SDD=$O(^UTILITY("SFT",N,0)) Q:'SDD
"RTN","VWREGIT3",92,0)
 .. S SDFLD="" F  S SDFLD=$O(^DD(SDD,"B",SDFLD)) Q:SDFLD=""  D
"RTN","VWREGIT3",93,0)
 ... S SDN=0 F  S SDN=$O(^DD(SDD,"B",SDFLD,SDN)) Q:'+SDN  I '$$REJECT(SDFLD,SDN) S ^UTILITY("FT",$$NFT("FT"))=">>>>> "_SDFLD_"("_SDN_";"_SDD_")"
"RTN","VWREGIT3",94,0)
 K ^UTILITY("SFT")
"RTN","VWREGIT3",95,0)
 I '$O(^UTILITY("FT",0)) Q
"RTN","VWREGIT3",96,0)
 S X="^UTILITY(""FT"")"
"RTN","VWREGIT3",97,0)
 F I=1:1 S X=$Q(@X) Q:X'["FT"  S RESULT($$NEXT(.RESULT))=@X
"RTN","VWREGIT3",98,0)
 K ^UTILITY("FT")
"RTN","VWREGIT3",99,0)
 Q
"RTN","VWREGIT3",100,0)
 ;
"RTN","VWREGIT3",101,0)
SAVE(RESULT,FLDS) ;
"RTN","VWREGIT3",102,0)
 ;W "  ;Intentional "Instantiated" Screw Job
"RTN","VWREGIT3",103,0)
 Q:'$D(FLDS)
"RTN","VWREGIT3",104,0)
 K ^UTILITY("FLDS") M ^UTILITY("FLDS")=FLDS
"RTN","VWREGIT3",105,0)
 N TNUM,TNAME,DIC,DATA,FX,N,X,Y,DIE,NEWTEMP,PIECE
"RTN","VWREGIT3",106,0)
 ;Clean FLDS or subscripts with empty values
"RTN","VWREGIT3",107,0)
 I '$L(FLDS(0)) K FLDS(0)
"RTN","VWREGIT3",108,0)
 S N=0 F  S N=$O(FLDS(N)) Q:'+N  D
"RTN","VWREGIT3",109,0)
 . I '$L(FLDS(N)) K FLDS(N)
"RTN","VWREGIT3",110,0)
 . S Y=$P(FLDS(N),"~",2)
"RTN","VWREGIT3",111,0)
 . I $E(Y)=" " S $P(FLDS(N),"~",2)=$P(Y," ",2)
"RTN","VWREGIT3",112,0)
 ;End cleaning
"RTN","VWREGIT3",113,0)
 S NEWTEMP=0
"RTN","VWREGIT3",114,0)
 S TNUM=+$P(FLDS(0),"(",2)
"RTN","VWREGIT3",115,0)
 I 'TNUM S TNAME=$P(FLDS(0),"(")
"RTN","VWREGIT3",116,0)
 S TNUM=$O(^DIE("B",TNAME,0))
"RTN","VWREGIT3",117,0)
 I 'TNUM K DATA D  ;File a new entry
"RTN","VWREGIT3",118,0)
 . D NOW^%DTC
"RTN","VWREGIT3",119,0)
 . S DIC="^DIE("
"RTN","VWREGIT3",120,0)
 . S DATA(.402,"+1,",.01)=TNAME
"RTN","VWREGIT3",121,0)
 . S DATA(.402,"+1,",2)=%
"RTN","VWREGIT3",122,0)
 . S DATA(.402,"+1,",3)=$G(DUZ(0))
"RTN","VWREGIT3",123,0)
 . S DATA(.402,"+1,",4)=2
"RTN","VWREGIT3",124,0)
 . S DATA(.402,"+1,",5)=DUZ
"RTN","VWREGIT3",125,0)
 . S DATA(.402,"+1,",6)=$G(DUZ(0))
"RTN","VWREGIT3",126,0)
 . D UPDATE^DIE("","DATA","IEN","ERR")
"RTN","VWREGIT3",127,0)
 . S TNUM=IEN(1) D RECALL^DILFD(.402,TNUM_",",DUZ)
"RTN","VWREGIT3",128,0)
 . S NEWTEMP=1
"RTN","VWREGIT3",129,0)
 ;Primary fields
"RTN","VWREGIT3",130,0)
 ;K DATA,^DIE(TNUM,"DR")
"RTN","VWREGIT3",131,0)
 K DATA,^UTILITY("DIETED",$J),^UTILITY("DIETEDIAB",$J)
"RTN","VWREGIT3",132,0)
 K AR S N=0 F  S N=$O(FLDS(N)) Q:'+N  S X=$$PARSE(FLDS(N)) S:$L(X) AR(N)=X
"RTN","VWREGIT3",133,0)
 S FX="",N=0 F  S N=$O(AR(N)) Q:'+N  D
"RTN","VWREGIT3",134,0)
 . I AR(N)'["~" S FX=FX_AR(N)_";" Q
"RTN","VWREGIT3",135,0)
 . S FLDN=+$P(AR(N),"~")
"RTN","VWREGIT3",136,0)
 . S PREFLAB=$P($P(AR(N),FLDN,2),"~")
"RTN","VWREGIT3",137,0)
 . S FX=FX_FLDN_$S($L(PREFLAB):PREFLAB_"~",1:"")_";"
"RTN","VWREGIT3",138,0)
 S ^UTILITY("DIETED",$J,1,2)=FX
"RTN","VWREGIT3",139,0)
 ;Set up the preferred labels
"RTN","VWREGIT3",140,0)
 S N=0 F  S N=$O(AR(N)) Q:'+N  D
"RTN","VWREGIT3",141,0)
 . S LABS=$P(AR(N),"~",2) Q:'$L(LABS)
"RTN","VWREGIT3",142,0)
 . S ^UTILITY("DIETEDIAB",$J,N,0,2,0)=$P(LABS,"^")_";"_""""_$P(LABS,"^",2)_""""
"RTN","VWREGIT3",143,0)
 Q  ;TESTING
"RTN","VWREGIT3",144,0)
 ;Sub-fields of primaries
"RTN","VWREGIT3",145,0)
 K AR
"RTN","VWREGIT3",146,0)
 S N=0 F  S N=$O(FLDS(N)) Q:'+N  Q:$E(FLDS(N))=">"
"RTN","VWREGIT3",147,0)
 G REGIT:'+N  ;No sub-fields found for primaries
"RTN","VWREGIT3",148,0)
 S N=$G(N)-1 F  S N=$O(FLDS(N)) Q:'+N  D:$E(FLDS(N))=">"
"RTN","VWREGIT3",149,0)
 . S PIECE=$L(FLDS(N),"(")
"RTN","VWREGIT3",150,0)
 . S X=$P($P(FLDS(N),"(",PIECE),")")
"RTN","VWREGIT3",151,0)
 . S SUBDIC=+$P(X,";",2),SUBFLD=+$P(X,";")
"RTN","VWREGIT3",152,0)
 . I '$D(AR(SUBDIC)) S AR(SUBDIC)=""
"RTN","VWREGIT3",153,0)
 . S AR(SUBDIC)=AR(SUBDIC)_SUBFLD_";"
"RTN","VWREGIT3",154,0)
 M ^DIE(TNUM,"DR",2)=AR
"RTN","VWREGIT3",155,0)
REGIT I NEWTEMP D  ;Update HD/regit.txt
"RTN","VWREGIT3",156,0)
 . S HD=$$GET^XPAR("ALL","VW GUI REG TEMPLATE DIRECTORY")
"RTN","VWREGIT3",157,0)
 . S FILE="regit.txt"
"RTN","VWREGIT3",158,0)
 . S P4=1
"RTN","VWREGIT3",159,0)
 . S P5=""
"RTN","VWREGIT3",160,0)
 . S X=$$FTG^%ZISH(HD,FILE,$NA(AR(1)),P4,P5)
"RTN","VWREGIT3",161,0)
 . S N=0 F  S N=$O(AR(N)) Q:'+N  Q:AR(N)["[ID"
"RTN","VWREGIT3",162,0)
 . K AR(N) S AR(N)=TNAME_"("_IEN(1)_")"
"RTN","VWREGIT3",163,0)
 . S AR(N+1)="[ID]"
"RTN","VWREGIT3",164,0)
 . ZWR AR
"RTN","VWREGIT3",165,0)
 . S X=$$GTF^%ZISH($NA(AR(1)),1,HD,"regit.txt")
"RTN","VWREGIT3",166,0)
SOUT S RESULT(0)=$S($G(IEN(1)):TNAME_"("_IEN(1)_")",1:-1)
"RTN","VWREGIT3",167,0)
 Q
"RTN","VWREGIT3",168,0)
 ;
"RTN","VWREGIT3",169,0)
HELP(RESULT,DATA) ;Get help for Fileman Fields
"RTN","VWREGIT3",170,0)
 ; ***************************************************
"RTN","VWREGIT3",171,0)
 ; *Incoming DATA__FILE^IEN[O]^FIELD^FLAGS^MSG_ROOT) *
"RTN","VWREGIT3",172,0)
 ; ***************************************************
"RTN","VWREGIT3",173,0)
 K RESULT,@$P(DATA,"^",5)
"RTN","VWREGIT3",174,0)
 N FILE,IEN,FLD,FLAGS,X
"RTN","VWREGIT3",175,0)
 S X="FILE^IEN^FLD^FLAGS"
"RTN","VWREGIT3",176,0)
 F I=1:1:4 S @$P(X,"^",I)=$P(DATA,"^",I)
"RTN","VWREGIT3",177,0)
 D HELP^DIE(FILE,IEN,FLD,FLAGS,$P(DATA,"^",5))
"RTN","VWREGIT3",178,0)
 F I=1:1:AR("DIHELP") S RESULT(I)=AR("DIHELP",I) 
"RTN","VWREGIT3",179,0)
 K @$P(DATA,"^",5),DATA
"RTN","VWREGIT3",180,0)
 Q
"RTN","VWREGIT3",181,0)
 ;
"RTN","VWREGIT3",182,0)
FP(RESULT,FLDS) ;Disassociated kids
"RTN","VWREGIT3",183,0)
 ;W "  ;Intentional "instantiated" failure
"RTN","VWREGIT3",184,0)
 K RESULT,PAR
"RTN","VWREGIT3",185,0)
 N N,FIELD,SUBDIC,PARENT,X
"RTN","VWREGIT3",186,0)
 S N=0 F  S N=$O(FLDS(N)) Q:'+N  D:$E(FLDS(N))=">"
"RTN","VWREGIT3",187,0)
 . S FIELD=$P($P(FLDS(N),"(",2),";")
"RTN","VWREGIT3",188,0)
 . S SUBDIC=$P($P(FLDS(N),";",2),")")
"RTN","VWREGIT3",189,0)
 . S PARENT=$O(^DD(2,"SB",SUBDIC,0))
"RTN","VWREGIT3",190,0)
 . Q:'PARENT
"RTN","VWREGIT3",191,0)
 . S PAR(PARENT)=$P(^DD(2,PARENT,0),"^")_"("_PARENT_")~(Multiple)"
"RTN","VWREGIT3",192,0)
 . S PAR(PARENT,$O(PAR(PARENT," "),-1)+1)=FLDS(N)
"RTN","VWREGIT3",193,0)
 . K FLDS(N)
"RTN","VWREGIT3",194,0)
 S X="PAR" F  S X=$Q(@X) Q:X=""  S FLDS($$NEXT(.FLDS))=@X
"RTN","VWREGIT3",195,0)
 K PAR
"RTN","VWREGIT3",196,0)
 S N=0 F  S N=$O(FLDS(N)) Q:'+N  S RESULT($$NEXT(.RESULT))=FLDS(N)
"RTN","VWREGIT3",197,0)
 K FLDS
"RTN","VWREGIT3",198,0)
 Q
"RTN","VWREGIT3",199,0)
 ;
"RTN","VWREGIT4")
0^11^B43791810
"RTN","VWREGIT4",1,0)
VWREGIT4 ;VWEHR/BFPro-Jim Bell, et al-World VistA Patient Registration Utility
"RTN","VWREGIT4",2,0)
 ;;1.0;WorldVistA;BellFelder Productions;** **;Build 1;
"RTN","VWREGIT4",3,0)
 ;
"RTN","VWREGIT4",4,0)
 ;This routine utility is for all known patient data fields
"RTN","VWREGIT4",5,0)
 ;
"RTN","VWREGIT4",6,0)
 ;GNU License: See WVLIC.txt
"RTN","VWREGIT4",7,0)
 ;Modified FOIA VISTA,
"RTN","VWREGIT4",8,0)
 ;Copyright 2013 WorldVistA.  Licensed under the terms of the GNU
"RTN","VWREGIT4",9,0)
 Q
"RTN","VWREGIT4",10,0)
 ;
"RTN","VWREGIT4",11,0)
INR() Q $O(RESULT(" "),-1)+1
"RTN","VWREGIT4",12,0)
 ;
"RTN","VWREGIT4",13,0)
CLEAN ;Remove VA Specific nodes
"RTN","VWREGIT4",14,0)
 ;S X="AR" F  S X=$Q(@X) Q:X=""  I $P(X,",",$L(X,",")-1)["<LABEL HERE>" K @X
"RTN","VWREGIT4",15,0)
 ;COMPONENTS
"RTN","VWREGIT4",16,0)
 ;ENTERED BY
"RTN","VWREGIT4",17,0)
 ;NEXT AVA. APPT. INDICATOR
"RTN","VWREGIT4",18,0)
 ;DATA ENTRY CLERK
"RTN","VWREGIT4",19,0)
 ;DESIRED DATE OF APPOINTMENT
"RTN","VWREGIT4",20,0)
 ;DATE APPT. MADE
"RTN","VWREGIT4",21,0)
 Q
"RTN","VWREGIT4",22,0)
 ;      
"RTN","VWREGIT4",23,0)
DEMOG(RESULT,IDATA) ;
"RTN","VWREGIT4",24,0)
 K RESULT
"RTN","VWREGIT4",25,0)
 Q:'$L(IDATA)
"RTN","VWREGIT4",26,0)
 S XFN=$P(IDATA,"^")
"RTN","VWREGIT4",27,0)
 S PAT=+$P(IDATA,"^",2)
"RTN","VWREGIT4",28,0)
 Q:'PAT!('XFN)  ;Huh? No patient! No File!
"RTN","VWREGIT4",29,0)
 D GETS^DIQ(XFN,PAT_",","**","NIER","AR","ERR")
"RTN","VWREGIT4",30,0)
 ;
"RTN","VWREGIT4",31,0)
 N X,Y,AGE,XAGE,XDATA,XX,XPID,IDOB,DOB,LINE
"RTN","VWREGIT4",32,0)
 I '$G(DT) S X="T" D ^%DT S DT=Y
"RTN","VWREGIT4",33,0)
DID S XDATA=""
"RTN","VWREGIT4",34,0)
 ;Q  ;testing
"RTN","VWREGIT4",35,0)
 S $P(LINE,"-",78)=""
"RTN","VWREGIT4",36,0)
 F I="NAME","PRIMARY LONG ID","DATE OF BIRTH","SEX" D
"RTN","VWREGIT4",37,0)
 . I I="NAME" S XDATA=$G(AR(XFN,PAT_",",I,"E")) Q
"RTN","VWREGIT4",38,0)
 . I I="PRIMARY LONG ID" S XPID=$G(AR(XFN,PAT_",",I,"E")) D  Q
"RTN","VWREGIT4",39,0)
 .. S XX=$E(XPID,1,$L(XPID)-4)
"RTN","VWREGIT4",40,0)
 .. S XX=$TR(XX,"0123456789","#")
"RTN","VWREGIT4",41,0)
 .. S XPID=XX_$E(XPID,$L(XPID)-3,$L(XPID))
"RTN","VWREGIT4",42,0)
 .. S $P(XDATA,"     ",2)="IDN: "_XPID
"RTN","VWREGIT4",43,0)
 . I I="DATE OF BIRTH" S DOB=$G(AR(PAT,XFN,PAT_",",I,"E")) D  S $P(XDATA,"     ",3)="DOB: "_DOB_" ("_AGE_" old "_$G(AR(XFN,PAT_",","SEX","E"))_")" Q
"RTN","VWREGIT4",44,0)
 .. S IDOB=$G(AR(XFN,PAT_",",I,"I"))
"RTN","VWREGIT4",45,0)
 .. S DOBT=$G(AR(XFN,PAT_",",540000.1))
"RTN","VWREGIT4",46,0)
 .. Q:'IDOB&'DOBT
"RTN","VWREGIT4",47,0)
 .. S X1=DT,X2=IDOB D ^%DTC
"RTN","VWREGIT4",48,0)
 .. I X=0,DOBT D  S AGE=HOURS+MIN_" Hours"
"RTN","VWREGIT4",49,0)
 ... S HOURS=$E($P(DOBT,".",2),1,2)
"RTN","VWREGIT4",50,0)
 ... S MIN=$E($P(DOBT,".",2),3,99)/60
"RTN","VWREGIT4",51,0)
 .. I X=0,'DOBT S XAGE=$P($H,",",2)/60/60,AGE=$P(XAGE,".")_"."_$E($P(XAGE,".",2))_" Hours" Q
"RTN","VWREGIT4",52,0)
 .. S AGE=$S(X<60:X_" Days",1:"")
"RTN","VWREGIT4",53,0)
 .. I 'AGE,X<365 S XAGE=X/30.4,AGE=$P(XAGE,".")_"."_$E($P(XAGE,".",2))_" Months"
"RTN","VWREGIT4",54,0)
 .. I 'AGE S XAGE=X/365.25,AGE=$P(XAGE,".")_$E($P(XAGE,".",2))_" Years"
"RTN","VWREGIT4",55,0)
 S RESULT(0)=XDATA
"RTN","VWREGIT4",56,0)
ADD D  S RESULT($$INR)="Address: "_ST1
"RTN","VWREGIT4",57,0)
 . S ST1=$G(AR(XFN,PAT_",","STREET ADDRESS 1 (CIVIL)","E"))
"RTN","VWREGIT4",58,0)
 . I '$L(ST1) S ST1=$G(AR(XFN,PAT_",","STREET ADDRESS 1 (VA)","E"))
"RTN","VWREGIT4",59,0)
 . I '$L(ST1) S ST1=$G(AR(XFN,PAT_",","STREET ADDRESS [LINE 1]","E"))
"RTN","VWREGIT4",60,0)
 . Q:'$l(ST1)
"RTN","VWREGIT4",61,0)
 . S ST2=$G(AR(XFN,PAT_",","STREET ADDRESS 2 (CIVIL)","E"))
"RTN","VWREGIT4",62,0)
        . I '$L(ST2) S ST2=$G(AR(XFN,PAT_",","STREET ADDRESS 1 (VA)","E"))
"RTN","VWREGIT4",63,0)
        . I '$L(ST2) S ST2=$G(AR(XFN,PAT_",","STREET ADDRESS [LINE 1]","E"))
"RTN","VWREGIT4",64,0)
 . S ST1=ST1_" "_ST2_", "
"RTN","VWREGIT4",65,0)
 . S CIT=$G(AR(XFN,PAT_",","CITY (CIVIL)","E"))
"RTN","VWREGIT4",66,0)
 . I '$L(CIT) S CIT=$G(AR(XFN,PAT_",","CITY (VA)","E"))
"RTN","VWREGIT4",67,0)
 . I '$L(CIT) S CIT=$G(AR(XFN,PAT_",","CITY","E"))
"RTN","VWREGIT4",68,0)
 . S ST1=ST1_$S('$L(CIT):"<City not listed>",1:CIT)_", "
"RTN","VWREGIT4",69,0)
 . S STATE=$G(AR(XFN,PAT_",","STATE (CIVIL)","E"))
"RTN","VWREGIT4",70,0)
 . I '$L(STATE) S STATE=$G(AR(XFN,PAT_",","STATE (VA)","E"))
"RTN","VWREGIT4",71,0)
 . I '$L(STATE) S STATE=$G(AR(XFN,PAT_",","STATE","E"))
"RTN","VWREGIT4",72,0)
 . S ST1=ST1_$S('$L(STATE):"<State/province not listed>",1:STATE)
"RTN","VWREGIT4",73,0)
 . S PC=$G(AR(XFN,PAT_",","POSTAL CODE","E"))
"RTN","VWREGIT4",74,0)
 . I '$L(PC) S PC=$G(AR(XFN,PAT_",","ZIP (CIVIL)","E"))
"RTN","VWREGIT4",75,0)
 . I '$L(PC) S PC=$G(AR(XFN,PAT_",","ZIP (VA)","E"))
"RTN","VWREGIT4",76,0)
 . I '$L(PC) S PC=$G(AR(XFN,PAT_",","ZIP CODE","E"))
"RTN","VWREGIT4",77,0)
 . I '$L(PC) S PC=$G(AR(XFN,PAT_",","ZIP+4 (VA)","E"))
"RTN","VWREGIT4",78,0)
 . I '$L(PC) S PC=$G(AR(XFN,PAT_",","ZIP+4 (CIVIL)","E"))
"RTN","VWREGIT4",79,0)
 . I '$L(PC) S PC=$G(AR(XFN,PAT_",","ZIP+4","E"))
"RTN","VWREGIT4",80,0)
 . S ST1=ST1_"  "_PC
"RTN","VWREGIT4",81,0)
 S RESULT($$INR)=LINE
"RTN","VWREGIT4",82,0)
NOK D  S RESULT($$INR)="Next of Kin: "_$S($L(NK):NK,1:"<No listing>")
"RTN","VWREGIT4",83,0)
 . S NK="" Q:'$L($G(AR(XFN,PAT_",","K-NAME","E")))
"RTN","VWREGIT4",84,0)
 . S NK=$G(AR(XFN,PAT_",","K-NAME OF PRIMARY NOK","E"))
"RTN","VWREGIT4",85,0)
 . S NKDAT=$G(AR(XFN,PAT_",","K-RELATIONSHIP TO PATIENT","E")) S NK=NK_$S($L(NKDAT):"("_NKDAT_")",1:"")
"RTN","VWREGIT4",86,0)
 . S NKDAT=$G(AR(XFN,PAT_",","K-STREET ADDRESS [LINE 1]","E"))
"RTN","VWREGIT4",87,0)
 . I $L($G(AR(XFN,PAT_",","K-STREET ADDRESS [LINE 2]","E"))) S NKDAT=", "_$G(AR(XFN,PAT_",","K-STREET ADDRESS [LINE 2]","E"))
"RTN","VWREGIT4",88,0)
 . S NK=NK_$S($L(NKDAT):NKDAT,1:"")
"RTN","VWREGIT4",89,0)
 D  I $L($G(NK)) S RESULT($$INR)="Next of Kin: "_NK
"RTN","VWREGIT4",90,0)
 . Q:'$L($G(AR(XFN,PAT_",","K-NAME","E")))
"RTN","VWREGIT4",91,0)
 . Q:'$L($G(AR(XFN,PAT_",","K2-NAME","E")))
"RTN","VWREGIT4",92,0)
        . S NK=$G(AR(XFN,PAT_",","K2-NAME OF PRIMARY NOK","E"))
"RTN","VWREGIT4",93,0)
        . S NKDAT=$G(AR(XFN,PAT_",","K2-RELATIONSHIP TO PATIENT","E")) S NK=NK_$S($L(NKDAT):"("_NKDAT_")",1:"")
"RTN","VWREGIT4",94,0)
        . S NKDAT=$G(AR(XFN,PAT_",","K2-STREET ADDRESS [LINE 1]","E"))
"RTN","VWREGIT4",95,0)
        . I $L($G(AR(XFN,PAT_",","K2-STREET ADDRESS [LINE 2]","E"))) S NKDAT=", "_$G(AR(XFN,PAT_",","K2-STREET ADDRESS [LINE 2]","E"))
"RTN","VWREGIT4",96,0)
        . S NK=NK_$S($L(NKDAT):NKDAT,1:"")
"RTN","VWREGIT4",97,0)
ICE ;
"RTN","VWREGIT4",98,0)
 I '$L($G(AR(XFN,PAT_",","E-NAME","E"))) S RESULT($$INR)=$J("ICE: ",$L("NEXT OF KIN: "))_"<No listing>" G ICEOUT
"RTN","VWREGIT4",99,0)
 S ICE=$G(AR(XFN,PAT_",","E-NAME","E"))
"RTN","VWREGIT4",100,0)
 S EADD=$G(AR(XFN,PAT_",","E-STREET ADDRESS [LINE 1]","E"))
"RTN","VWREGIT4",101,0)
 S EAD2=$G(AR(XFN,PAT_",","E-STREET ADDRESS [LINE 2]","E"))
"RTN","VWREGIT4",102,0)
 S ECITY=$G(AR(XFN,PAT_",","E-CITY","E"))
"RTN","VWREGIT4",103,0)
 S ESTATE=$G(AR(XFN,PAT_",","E-STATE","E"))
"RTN","VWREGIT4",104,0)
 S EZIP=$G(AR(XFN,PAT_",","E-ZIP+4","E"))
"RTN","VWREGIT4",105,0)
 S IPHONE=$G(AR(XFN,PAT_",","E-PHONE NUMBER","E"))
"RTN","VWREGIT4",106,0)
 S WPHONE=$G(AR(XFN,PAT_",","E-WORK PHONE NUMBER","E"))
"RTN","VWREGIT4",107,0)
 S RESULT($$INR)=$J("ICE: ",$L("NEXT OF KIN: "))_ICE
"RTN","VWREGIT4",108,0)
 S RESULT($$INR)=$J("Address: ",$L("NEXT OF KIN: "))_$S($L(EADD):EADD_$S($L(EAD2):" "_EAD2,1:""),1:"<No listing>")
"RTN","VWREGIT4",109,0)
 S RESULT($$INR)=$J("City: ",$L("NEXT OF KIN: "))_ECITY
"RTN","VWREGIT4",110,0)
 S RESULT($$INR)=$J("State: ",$L("NEXT OF KIN: "))_ESTATE
"RTN","VWREGIT4",111,0)
 S RESULT($$INR)=$J("Zip: ",$L("NEXT OF KIN: "))_EZIP
"RTN","VWREGIT4",112,0)
 S RESULT($$INR)=$J("Phone: ",$L("NEXT OF KIN: "))_IPHONE
"RTN","VWREGIT4",113,0)
 S RESULT($$INR)=$J("Work: ",$L("NEXT OF KIN: "))_WPHONE
"RTN","VWREGIT4",114,0)
ICEOUT S RESULT($$INR)=LINE
"RTN","VWREGIT4",115,0)
INS D  S RESULT($$INR)="Insurance/Coverage: "_$S($L(IC):IC,1:"<No listing>")
"RTN","VWREGIT4",116,0)
 . K AR(2.312)  ;Get it from the horse's mouth
"RTN","VWREGIT4",117,0)
 . S IC="" S N=0 F  S N=$O(^DPT(PAT,.312,N)) Q:'+N  S IC=IC_$P(^DIC(36,+^(N,0),0),"^")_$S($O(^DPT(PAT,.312,N)):", ",1:"")
"RTN","VWREGIT4",118,0)
 S RESULT($$INR)=LINE
"RTN","VWREGIT4",119,0)
ER S HEADER="Walk-in/ER",$P(HEADER,"    ",2)="Date/Time"
"RTN","VWREGIT4",120,0)
 S $P(HEADER,"          ",3)="Type of Benefit"
"RTN","VWREGIT4",121,0)
 S RESULT($$INR)=HEADER
"RTN","VWREGIT4",122,0)
 S N=0 F  S N=$O(^DPT(PAT,"DIS",N)) Q:'+N  S XDIS=^(N,0) D
"RTN","VWREGIT4",123,0)
 . S Y=+XDIS X ^DD("DD") S $P(WER,"              ",2)=Y
"RTN","VWREGIT4",124,0)
 . S $P(WER,"            ",3)=$P($P($P(^DD(2.101,2,0),"^",3),";",$P(XDIS,"^",3)),":",2),RESULT($$INR)=WER,WER=""
"RTN","VWREGIT4",125,0)
 S RESULT($$INR)=WER
"RTN","VWREGIT4",126,0)
 S RESULT($$INR)=LINE
"RTN","VWREGIT4",127,0)
APPT S HEADER="Sched. Appts",$P(HEADER,"  ",2)="Date/Time",$P(HEADER,"          ",3)="Clinic"
"RTN","VWREGIT4",128,0)
 S RESULT($$INR)=HEADER
"RTN","VWREGIT4",129,0)
 S N=0 F  S N=$O(^DPT(PAT,"S",N)) Q:'+N  S XDIS=^(N,0) D
"RTN","VWREGIT4",130,0)
 . S Y=N X ^DD("DD") S $P(WER,"              ",2)=Y
"RTN","VWREGIT4",131,0)
 . S $P(WER,"            ",3)=$P(^SC(+XDIS,0),"^")
"RTN","VWREGIT4",132,0)
 . S RESULT($$INR)=WER
"RTN","VWREGIT4",133,0)
 S RESULT($$INR)=LINE
"RTN","VWREGIT4",134,0)
ADM S HEADER="Admit",$P(HEADER,"         ",2)="Discharge"
"RTN","VWREGIT4",135,0)
 S RESULT($$INR)=HEADER
"RTN","VWREGIT4",136,0)
 K WER
"RTN","VWREGIT4",137,0)
 S N=0 F  S N=$O(^DGPM("C",PAT,N)) Q:'+N  S XDIS=^(N,0) D
"RTN","VWREGIT4",138,0)
 . S Y=+XDIS X ^DD("DD") S WER=Y
"RTN","VWREGIT4",139,0)
 . S DMOV=$P(XDIS,"^",17)
"RTN","VWREGIT4",140,0)
 . S:DMOV Y=+^DGPM(DMOV,0) X ^DD("DD") S $P(WER,"  ",2)=Y
"RTN","VWREGIT4",141,0)
 . S RESULT($$INR)=WER,WER=""
"RTN","VWREGIT4",142,0)
 I '$L($G(WER)) S RESULT($$INR)="No admissions of file"
"RTN","VWREGIT4",143,0)
 S RESULT($$INR)=LINE
"RTN","VWREGIT4",144,0)
XIT K AR,CIT,DIC,DOBT,EAD2,EADD,ECITY,ESTATE,EZIP,HEADER,I,IC,ICE
"RTN","VWREGIT4",145,0)
 K IPHONE,N,NK,PAT,PC,XFN,ST1,ST2,STATE,WPHONE
"RTN","VWREGIT4",146,0)
 Q
"VER")
8.0^22.0
**END**
**END**