source: VWGUIRegistration/trunk/VWREGIT.m @ 1806

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