source: VWGUIRegistration/tag/2.0/VWREG_03022017_P1T3_0.KID

KIDS Distribution saved on Mar 02, 2017@12:25:03
Update to VWREGIT.m
**KIDS**:VWREG_PATCH*1.0T3*0^

**INSTALL NAME**
VWREG_PATCH*1.0T3*0
"BLD",8568,0)
VWREG_PATCH*1.0T3*0^^^3170302^n
"BLD",8568,1,0)
^^1^1^3170302^
"BLD",8568,1,1,0)
Update to VWREGIT.m to clear an <UNDEF> found during testing
"BLD",8568,4,0)
^9.64PA^^
"BLD",8568,6.3)
2
"BLD",8568,"KRN",0)
^9.67PA^779.2^20
"BLD",8568,"KRN",.4,0)
.4
"BLD",8568,"KRN",.401,0)
.401
"BLD",8568,"KRN",.402,0)
.402
"BLD",8568,"KRN",.403,0)
.403
"BLD",8568,"KRN",.5,0)
.5
"BLD",8568,"KRN",.84,0)
.84
"BLD",8568,"KRN",3.6,0)
3.6
"BLD",8568,"KRN",3.8,0)
3.8
"BLD",8568,"KRN",9.2,0)
9.2
"BLD",8568,"KRN",9.8,0)
9.8
"BLD",8568,"KRN",9.8,"NM",0)
^9.68A^1^1
"BLD",8568,"KRN",9.8,"NM",1,0)
VWREGIT^^0^B34639192
"BLD",8568,"KRN",9.8,"NM","B","VWREGIT",1)

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

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

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

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

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

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

"BLD",8568,"KRN","B",3.6,3.6)

"BLD",8568,"KRN","B",3.8,3.8)

"BLD",8568,"KRN","B",9.2,9.2)

"BLD",8568,"KRN","B",9.8,9.8)

"BLD",8568,"KRN","B",19,19)

"BLD",8568,"KRN","B",19.1,19.1)

"BLD",8568,"KRN","B",101,101)

"BLD",8568,"KRN","B",409.61,409.61)

"BLD",8568,"KRN","B",771,771)

"BLD",8568,"KRN","B",779.2,779.2)

"BLD",8568,"KRN","B",870,870)

"BLD",8568,"KRN","B",8989.51,8989.51)

"BLD",8568,"KRN","B",8989.52,8989.52)

"BLD",8568,"KRN","B",8994,8994)

"BLD",8568,"QDEF")
^^^^NO^^^^NO^^NO
"BLD",8568,"QUES",0)
^9.62^^
"BLD",8568,"REQB",0)
^9.611^^
"MBREQ")
0
"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")
1
"RTN","VWREGIT")
0^1^B34639192
"RTN","VWREGIT",1,0)
VWREGIT ;Portland,OR/Jim Bell, et al Patient Registration Utility August 2015
"RTN","VWREGIT",2,0)
 ;;2.0;B/FProductions,LLC,WORLD VISTA;**LOCAL**;;Build 2
"RTN","VWREGIT",3,0)
 ;*******************************************************************
"RTN","VWREGIT",4,0)
 ;* VW Registration is designed for patient specific fields as      *
"RTN","VWREGIT",5,0)
 ;* defined in Fileman Input Templates or ad hoc field selection.   *
"RTN","VWREGIT",6,0)
 ;* Copyright Martius/MMXV ad infinitum (GNU License: See GPLv3.txt)*
"RTN","VWREGIT",7,0)
 ;*******************************************************************
"RTN","VWREGIT",8,0)
 ;;NO FALL THROUGH - JEB
"RTN","VWREGIT",9,0)
 Q
"RTN","VWREGIT",10,0)
 ;
"RTN","VWREGIT",11,0)
TFM(XF) ;TemplateField Management
"RTN","VWREGIT",12,0)
 ;***********************************************
"RTN","VWREGIT",13,0)
 ;* Check primary field entries for "parentage" *
"RTN","VWREGIT",14,0)
 ;* Add an "*" to gain all sub-fields of the    *
"RTN","VWREGIT",15,0)
 ;* parent                                      *
"RTN","VWREGIT",16,0)
 ;* REMEMBER: All fields pertain to file 2 only *
"RTN","VWREGIT",17,0)
 ;***********************************************
"RTN","VWREGIT",18,0)
 N I,N,FIELD
"RTN","VWREGIT",19,0)
 K FARRAY
"RTN","VWREGIT",20,0)
 I '$L(XF),'$G(TNUM) Q ""
"RTN","VWREGIT",21,0)
 I '$L(XF),+$G(TNUM) S XF=^DIE(TNUM,"DR",1,2)
"RTN","VWREGIT",22,0)
 F I=1:1:$L(XF,";") S:$L($P(XF,";",I)) FARRAY(I)=+$P(XF,";",I)
"RTN","VWREGIT",23,0)
 S N=0 F I=1:1 S N=$O(FARRAY(N)) Q:'+N  D
"RTN","VWREGIT",24,0)
 . S FIELD=FARRAY(N)
"RTN","VWREGIT",25,0)
 . I +$P(^DD(2,FIELD,0),"^",2) S FIELD=FIELD_"*",FMARRAY(FIELD)=$P(^(0),"^",4) K FARRAY(N)
"RTN","VWREGIT",26,0)
 S XF="",N=0 F  S N=$O(FARRAY(N)) Q:'+N  S XF=XF_FARRAY(N)_";"
"RTN","VWREGIT",27,0)
 Q XF
"RTN","VWREGIT",28,0)
 ;
"RTN","VWREGIT",29,0)
CHECK() ;
"RTN","VWREGIT",30,0)
 Q ""
"RTN","VWREGIT",31,0)
 ;
"RTN","VWREGIT",32,0)
INR() Q $O(RESULT(" "),-1)+1
"RTN","VWREGIT",33,0)
 ;
"RTN","VWREGIT",34,0)
EN(RESULT)    ;Template name and ID labels
"RTN","VWREGIT",35,0)
 ;Get the input template list
"RTN","VWREGIT",36,0)
 ;housekeeping
"RTN","VWREGIT",37,0)
 S DTIME=99999
"RTN","VWREGIT",38,0)
 ZSY "chmod 777 "_$ZD_"regparam/*.txt"
"RTN","VWREGIT",39,0)
 ;end housekeeping
"RTN","VWREGIT",40,0)
 ;
"RTN","VWREGIT",41,0)
 K AR,RESULT
"RTN","VWREGIT",42,0)
 N N,HD,FILE,LOC,P4,P5,%ZISHF,%ZISHO,DEFST,XTMP,X
"RTN","VWREGIT",43,0)
 S RESULT(0)=1
"RTN","VWREGIT",44,0)
 S DEFST="";
"RTN","VWREGIT",45,0)
 ;S DEFTMP=$O(^DIE("B","FAU_EDU",0)) ;For Florida College only
"RTN","VWREGIT",46,0)
 S RESULT(0)=$$CONTROL^VWREGITU()
"RTN","VWREGIT",47,0)
 S RESULT(1)="-1^No templates found"
"RTN","VWREGIT",48,0)
 S DEFST=$$GET^XPAR("ALL","VW REG DEFAULT STATE")
"RTN","VWREGIT",49,0)
 S DEFTMP=$$GET^XPAR("ALL","VW REG RDNPT")
"RTN","VWREGIT",50,0)
 S HD=$$GET^XPAR("ALL","VW GUI REG TEMPLATE DIRECTORY")
"RTN","VWREGIT",51,0)
 I '$L(HD) K RESULT D  Q
"RTN","VWREGIT",52,0)
 . S RESULT($$INR)="-1^NO HOME DIRECTORY - refer to IT support, if necessary."
"RTN","VWREGIT",53,0)
 . S RESULT($$INR)="No home directory has been supplied which indicates"
"RTN","VWREGIT",54,0)
 . S RESULT($$INR)="the VWREG installation is incomplete. See the Help manual"
"RTN","VWREGIT",55,0)
 . S RESULT($$INR)="for installation and Enter/Editing parameter values."
"RTN","VWREGIT",56,0)
 . S RESULT($$INR)="Thank you,"
"RTN","VWREGIT",57,0)
 . S RESULT($$INR)="      The Management."
"RTN","VWREGIT",58,0)
 S FILE="regit.txt"
"RTN","VWREGIT",59,0)
 S P4=1
"RTN","VWREGIT",60,0)
 S P5=""
"RTN","VWREGIT",61,0)
 S X=$$FTG^%ZISH(HD,FILE,$NA(AR(1)),P4,P5)
"RTN","VWREGIT",62,0)
 D:+RESULT(0)
"RTN","VWREGIT",63,0)
 . S $P(RESULT(0),"^",2)=$G(HD)
"RTN","VWREGIT",64,0)
 . S $P(RESULT(0),"^",3)=$S(DEFST:$P(^DIC(5,DEFST,0),"^")_"("_DEFST_")",1:"")
"RTN","VWREGIT",65,0)
 . S $P(RESULT(0),"^",4)=$S(+DEFTMP:$P(^DIE(DEFTMP,0),"^")_"("_DEFTMP_")",1:DEFTMP)
"RTN","VWREGIT",66,0)
 . S $P(RESULT(0),"^",5)=DUZ
"RTN","VWREGIT",67,0)
 I $O(AR(0)) S RESULT(1)="[TEMPLATES]"
"RTN","VWREGIT",68,0)
 S N=0 F  S N=$O(AR(N)) Q:'+N  D
"RTN","VWREGIT",69,0)
 . Q:$E(AR(N))="*"
"RTN","VWREGIT",70,0)
 . Q:'+$P(AR(N),"(",2)
"RTN","VWREGIT",71,0)
 . Q:$P($G(^DIE(+$P(AR(N),"(",2),0)),"^",4)'=2  ;must be pat file
"RTN","VWREGIT",72,0)
 . S RESULT($$INR)=AR(N)
"RTN","VWREGIT",73,0)
 S RESULT($$INR)="[ID]"
"RTN","VWREGIT",74,0)
 ;S N=0 F  S N=$O(^DIZ(64850003,N)) Q:'+N  S RESULT($$INR)=$P(^(N,0),"^",2)_"("_$P(^(0),"^")_")"
"RTN","VWREGIT",75,0)
 ;S N=0 F  S N=$O(RESULT(N)) Q:'+N  K:RESULT(N)="" RESULT(N)
"RTN","VWREGIT",76,0)
 I '$O(RESULT(0)) S RESULT(1)="-1^No PATIENT FILE templates found"
"RTN","VWREGIT",77,0)
 K AR
"RTN","VWREGIT",78,0)
 Q
"RTN","VWREGIT",79,0)
 ;
"RTN","VWREGIT",80,0)
NPT(RESULT,TNAME) ;
"RTN","VWREGIT",81,0)
 ; *************************************************
"RTN","VWREGIT",82,0)
 ; * Incoming: DFN^TEMPLATE NAME(IEN)              *
"RTN","VWREGIT",83,0)
 ; * Process : Get template fields plus any help   *
"RTN","VWREGIT",84,0)
 ; *           If +TNAME (a DFN), get DFN data for *
"RTN","VWREGIT",85,0)
 ; *           the template fields (Put data in    *
"RTN","VWREGIT",86,0)
 ; *           $P(RESULT(N),"^",3))                *
"RTN","VWREGIT",87,0)
 ; * Return  : RESULT(N), etc                      *
"RTN","VWREGIT",88,0)
 ; *************************************************
"RTN","VWREGIT",89,0)
 ;W "  ;Intentional bust for debugging
"RTN","VWREGIT",90,0)
 N N,TNUM,FIELDS,F,FNAME,FVALUE,FHELP,FPSC,FNUM
"RTN","VWREGIT",91,0)
 S TNUM=+$P(TNAME,"(",2),DFN=+TNAME
"RTN","VWREGIT",92,0)
 I 'TNUM S RESULT(0)="0^new patient Template not found" Q
"RTN","VWREGIT",93,0)
 S TNAME=$P($P(TNAME,"^",2),"(")
"RTN","VWREGIT",94,0)
 S TNAME=$TR(TNAME,"$&*","")  ;Clean out TMENU chars
"RTN","VWREGIT",95,0)
 I TNAME="GENERIC INS. FRM [WorldVistA]" G GIF
"RTN","VWREGIT",96,0)
 S FIELDS=$G(^DIE(TNUM,"DR",1,2))
"RTN","VWREGIT",97,0)
 I '$L(FIELDS) Q
"RTN","VWREGIT",98,0)
 K RESULT S (FNUM,FCAP)=""
"RTN","VWREGIT",99,0)
 F I=1:1:$L(FIELDS,";")-1 D
"RTN","VWREGIT",100,0)
 . S F=$P(FIELDS,";",I)
"RTN","VWREGIT",101,0)
 . Q:'$D(^DD(2,F))  ;Not existing in this patient file
"RTN","VWREGIT",102,0)
 . I F["~" S FNUM=+F,FNAME=$P($P(F,"~"),FNUM,2),F=FNUM K FNUM
"RTN","VWREGIT",103,0)
 . S FNAME=$S($L($G(FNAME)):FNAME,$L($G(^DD(2,F,.1))):$P(^(.1),"^"),1:$P(^DD(2,F,0),"^"))
"RTN","VWREGIT",104,0)
 . S FVALUE=""  ;Patient Data
"RTN","VWREGIT",105,0)
 . S FHELP=$G(^DD(2,F,3))
"RTN","VWREGIT",106,0)
 . I F'=27.02,'$L(FHELP) S N=0 F  S N=$O(^DD(2,F,21,N)) Q:'+N  S FHELP=FHELP_^(N,0)
"RTN","VWREGIT",107,0)
 . S FHELP=$TR(FHELP,"'","`")
"RTN","VWREGIT",108,0)
 . S FPSC=$P(^DD(2,F,0),"^",3)
"RTN","VWREGIT",109,0)
 . S SUBDIC=+$P(^DD(2,F,0),"^",2)
"RTN","VWREGIT",110,0)
 . S RESULT($$INR)=FNAME_"^"_F_"^"_FVALUE_"^"_FHELP_"^"_FPSC_$S(SUBDIC:"^1",1:"^0")
"RTN","VWREGIT",111,0)
 . S (FNAME,FVALUE,FHELP,FPSC)=""
"RTN","VWREGIT",112,0)
 G NPTX:'DFN
"RTN","VWREGIT",113,0)
 I DFN D GETS^DIQ(2,DFN_",","**","EN","AR")  ;,RESULT(0)=$$DFNID^VWREGITU
"RTN","VWREGIT",114,0)
 K FIELD S N=0 F  S N=$O(RESULT(N)) Q:'+N  S FIELD($P(RESULT(N),"^",2))=""
"RTN","VWREGIT",115,0)
 S X="AR" F  S X=$Q(@X) Q:X=""  D
"RTN","VWREGIT",116,0)
 . S FILE=+$P(X,"(",2)
"RTN","VWREGIT",117,0)
 . S FIELD=+$P(X,",",$L(X,",")-1)
"RTN","VWREGIT",118,0)
 . I $D(FIELD(FIELD)) S FIELD(FIELD)=@X
"RTN","VWREGIT",119,0)
 S N=0 F  S N=$O(FIELD(N)) Q:'+N  D
"RTN","VWREGIT",120,0)
 . S N2=0 F  S N2=$O(RESULT(N2)) Q:'+N2  I $P(RESULT(N2),"^",2)=N S $P(RESULT(N2),"^",3)=FIELD(N)
"RTN","VWREGIT",121,0)
 . S RESULT(0)=$$DFNID^VWREGITU()
"RTN","VWREGIT",122,0)
NPTX K FIELD,AR,FCAP,FILE,SUBDIC,N,N2,DFN
"RTN","VWREGIT",123,0)
 Q
"RTN","VWREGIT",124,0)
 ;
"RTN","VWREGIT",125,0)
PF(RESULT,XPF) ;Pointer file - get the stuff
"RTN","VWREGIT",126,0)
 K RESULT,AR
"RTN","VWREGIT",127,0)
 N X,N
"RTN","VWREGIT",128,0)
 I '$L(XPF) S RESULT(0)="???" Q
"RTN","VWREGIT",129,0)
 S XPF="^"_XPF
"RTN","VWREGIT",130,0)
 I +$P(XPF,"(",2)=.85 G NAUTPF  ;Naughty file!
"RTN","VWREGIT",131,0)
 S N=0 F  S N=$O(@(XPF_N_")")) Q:'+N  S X=$P(^(N,0),"^"),AR(X,N)=X_"("_N_")"
"RTN","VWREGIT",132,0)
 S X="AR" F  S X=$Q(@X) Q:X=""  S RESULT($$INR)=@X
"RTN","VWREGIT",133,0)
 K AR
"RTN","VWREGIT",134,0)
 Q
"RTN","VWREGIT",135,0)
 ;
"RTN","VWREGIT",136,0)
NAUTPF ;The "NAUGHTY" pointer file - has a numeric .01 - Bad file !!!
"RTN","VWREGIT",137,0)
 S N=0 F  S N=$O(@(XPF_N_")")) Q:'+N  S X=$P(^(N,0),"^") D
"RTN","VWREGIT",138,0)
 . S LANG=$P(^(0),"^",2)
"RTN","VWREGIT",139,0)
 . S AR(LANG,N)=LANG_"("_N_")"
"RTN","VWREGIT",140,0)
 S X="AR" F  S X=$Q(@X) Q:X=""  S RESULT($$INR)=@X
"RTN","VWREGIT",141,0)
 Q
"RTN","VWREGIT",142,0)
GIF ;Generic Insurance form
"RTN","VWREGIT",143,0)
 K RESULT
"RTN","VWREGIT",144,0)
 S RESULT($$INR)="Insurance Company^2.312;.01^^^DIC(36,^0"
"RTN","VWREGIT",145,0)
 S RESULT($$INR)="Group Plan^2.312;.18^^^IBA(355.3,^0"
"RTN","VWREGIT",146,0)
 S RESULT($$INR)="Policy No.^2.312;1^^^^0"
"RTN","VWREGIT",147,0)
 ;S RESULT($$INR)="Type of Plan^^^^^0"
"RTN","VWREGIT",148,0)
 S RESULT($$INR)="Coverage^355.33;40.09^^^IBE(355.1,^0"
"RTN","VWREGIT",149,0)
 S RESULT($$INR)="Effective Date^2.312;8^^^^0"
"RTN","VWREGIT",150,0)
 S RESULT($$INR)="Expiration Date^.3121;^^^^0"
"RTN","VWREGIT",151,0)
 S RESULT($$INR)="Guarantor^^^^^0"
"RTN","VWREGIT",152,0)
 S RESULT($$INR)="Signature on File^^^^0:NO;1:YES^0"
"RTN","VWREGIT",153,0)
 S RESULT($$INR)="Employer^2.312;2.015^^^^0"
"RTN","VWREGIT",154,0)
 S RESULT($$INR)="Billing Address^2.312;2.02^^^^0"
"RTN","VWREGIT",155,0)
 S RESULT($$INR)="Billing Address(cont)^2.312;2.03^^^^0"
"RTN","VWREGIT",156,0)
 S RESULT($$INR)="Postal Code^2.312;2.07^^^^0"
"RTN","VWREGIT",157,0)
 S RESULT($$INR)="City^2.312;2.05^^^^0"
"RTN","VWREGIT",158,0)
 S RESULT($$INR)="County/Region/Area^^^^^0"
"RTN","VWREGIT",159,0)
 S RESULT($$INR)="State/Province/Region^2.312;2.06^^^DIC(5,^0"
"RTN","VWREGIT",160,0)
 Q
"RTN","VWREGIT",161,0)
 ;
"RTN","VWREGIT",162,0)
 
"VER")
8.0^22.2
**END**
**END**