source: VWGUIRegistration/trunk/VWREGIT.m@ 1798

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