source: WorldVistAEHR/trunk/r/VA_FILEMAN-ARJT-DI-DD-DM-DT-%DT-%RCR/DIKCFORM.m@ 1159

Last change on this file since 1159 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR

File size: 7.7 KB
Line 
1DIKCFORM ;SFISC/MKO-ENTRY POINTS FOR THE 'DIKC EDIT' FORM ;2:57 PM 25 Apr 2002
2 ;;22.0;VA FileMan;**20,68,108**;Mar 30, 1999
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4 ;
5 ;==========================
6 ; [DIKC EDIT] entry points
7 ;==========================
8 ;
9TYPEVAL ;Validation on Type (#.2)
10 Q:DDSOLD=""
11 I X'="MU"!($G(DUZ(0))'="@") D Q
12 . S DDSERROR=1
13 . D HLP^DDSUTL($C(7)_"You can only change the Type of cross reference to MUMPS, and only if you're a programmer.")
14 ;
15 I X="MU",$P($G(^DD(+$$FNO^DILIBF($$GET^DDSVAL(.11,DA,.01)),0,"DI")),U)="Y" D Q
16 . S DDSERROR=1
17 . D HLP^DDSUTL($C(7)_"Cannot create MUMPS cross references on archived files.")
18 Q
19TYPECHG ;Post action on change for Type (#.2)
20 N NAME,USE
21 S USE=$$GET^DDSVAL(.11,DA,.42) Q:USE]""
22 S NAME=$$GET^DDSVAL(.11,DA,.02)
23 I NAME]"",$E(NAME)'="A" D PUT^DDSVAL(.11,DA,.42,"LS","","I")
24 Q
25 ;
26NAMEVAL ;Validation for Name (#.02)
27 Q:$P(^DD("IX",DA,0),U,2)=X
28 I X="" D Q
29 . S DDSERROR=1
30 . D HLP^DDSUTL($C(7)_"Index Name is a required field.")
31 ;
32 N F01,TYPE
33 ;
34 S F01=$$GET^DDSVAL(.11,DA,.01)
35 I $D(^DD("IX","BB",F01,X)) D Q
36 . S DDSERROR=1
37 . D HLP^DDSUTL($C(7)_"A"_$E("n","AEIOUaeiou"[$E(X))_" '"_X_"' Index already exists.")
38 ;
39 I $D(^DD(F01,0,"IX",X)) D Q
40 . S DDSERROR=1
41 . D HLP^DDSUTL($C(7)_"A"_$E("n","AEIOUaeiou"[$E(X))_" '"_X_"' cross-reference already exists.")
42 ;
43 I $E(X)="A",$D(^DD("KEY","AU",DA)) D Q
44 . S DDSERROR=1
45 . D HLP^DDSUTL($C(7)_"Uniqueness Index Name cannot start with 'A'.")
46 Q
47 ;
48NAMECHG ;Post action on change for Name (#.02)
49 N SORT1,SORT2,USE
50 S USE=$$GET^DDSVAL(.11,DA,.42)
51 S SORT1=$E(DDSOLD)="A",SORT2=$E(X)="A"
52 D:SORT1'=SORT2!(USE="") PUT^DDSVAL(.11,DA,.42,$S(SORT2:"S",1:"LS"),"","I")
53 D BLDLOG^DIKCFORM(DA)
54 Q
55 ;
56USEVAL ;Validation for Use (#.42)
57 N NAME,TYPE
58 S NAME=$$GET^DDSVAL(.11,DA,.02)
59 S TYPE=$$GET^DDSVAL(.11,DA,.2)
60 I NAME=""!(TYPE="") D Q
61 . S DDSERROR=1
62 . D HLP^DDSUTL($C(7)_"Please enter a NAME and TYPE for this Index.")
63 ;
64 I X="S" D:$E(NAME)'="A"
65 . S DDSERROR=1
66 . D HLP^DDSUTL($C(7)_"Indexes used for Sorting Only must start with 'A'.")
67 E I X="LS" D:$E(NAME)="A"
68 . S DDSERROR=1
69 . D HLP^DDSUTL($C(7)_"Indexes used for Lookup & Sorting cannot start with 'A'.")
70 E I TYPE="R" D
71 . S DDSERROR=1
72 . D HLP^DDSUTL($C(7)_"Only MUMPS Indexes can be Action-type Indexes.")
73 E I $E(NAME)'="A" D
74 . S DDSERROR=1
75 . D HLP^DDSUTL($C(7)_"Action-type Indexes must start with 'A'.")
76 Q
77 ;
78VALLOG ;Called from data validation of logic fields
79 I $G(DUZ(0))'="@" D Q
80 . S DDSERROR=1
81 . D HLP^DDSUTL($C(7)_"Only programmers are allowed to edit index logic.")
82 ;
83 I $$GET^DDSVAL(DIE,.DA,.2,"","I")'="MU" D Q
84 . S DDSERROR=1
85 . D HLP^DDSUTL($C(7)_"You can modify the logic of only 'MUMPS' indexes.")
86 Q
87 ;
88BLDLOG(DIXR) ;Build the logic of the cross reference
89 ;Called from post actions of fields on form [DIKC EDIT]
90 N TYPE
91 S TYPE=$$GET^DDSVAL(.11,DIXR,.2)
92 I TYPE="MU" D UPDEXEC(DIXR) Q
93 ;
94 N FILE,NAME,RTYPE,RFILE
95 S FILE=$$GET^DDSVAL(.11,DIXR,.01)
96 S NAME=$$GET^DDSVAL(.11,DIXR,.02)
97 S RTYPE=$$GET^DDSVAL(.11,DIXR,.5)
98 S RFILE=$$GET^DDSVAL(.11,DIXR,.51)
99 ;
100 N LDIF,LEV,ROOT,WKILL
101 I FILE'=RFILE Q:RTYPE'="W" S LDIF=$$FLEVDIFF^DIKCU(FILE,RFILE)
102 E S LDIF=0
103 S ROOT=$$FROOTDA^DIKCU(FILE,LDIF_"O",.LEV)_""""_NAME_""""
104 S WKILL="K "_ROOT_")"
105 ;
106 N CNT,CRV,FCNT,MAXL,ORD,SBSC,VAL
107 S CRV(1)=DIXR
108 S CRV=0 F S CRV=$O(^DD("IX",DIXR,11.1,CRV)) Q:'CRV D:$G(^(CRV,0))'?."^"
109 . S ORD=$$GET^DDSVAL(.114,.CRV,.01) Q:'ORD
110 . S:$$GET^DDSVAL(.114,.CRV,1)="F" FCNT=$G(FCNT)+1
111 . S CNT=$G(CNT)+1
112 . S SBSC=$$GET^DDSVAL(.114,.CRV,.5) Q:'SBSC
113 . S MAXL=$$GET^DDSVAL(.114,.CRV,6)
114 . S SBSC(SBSC)=ORD_U_MAXL
115 ;
116 S SBSC=0 F S SBSC=$O(SBSC(SBSC)) Q:'SBSC D
117 . S ORD=$P(SBSC(SBSC),U),MAXL=$P(SBSC(SBSC),U,2)
118 . I $G(CNT)=1 S VAL=$S(MAXL:"$E(X,1,"_MAXL_")",1:"X")
119 . E S VAL=$S(MAXL:"$E(X("_ORD_"),1,"_MAXL_")",1:"X("_ORD_")")
120 . S ROOT=ROOT_","_VAL
121 ;
122 N L
123 F L=LDIF:-1:1 S ROOT=ROOT_",DA("_L_")"
124 S ROOT=ROOT_",DA)"
125 ;
126 N SET,KILL
127 I '$O(SBSC(0)) S (SET,KILL)="Q",WKILL=""
128 E S SET="S "_ROOT_"=""""",KILL="K "_ROOT
129 D PUT^DDSVAL(.11,DIXR,1.1,SET)
130 D PUT^DDSVAL(.11,DIXR,2.1,KILL)
131 D PUT^DDSVAL(.11,DIXR,2.5,WKILL)
132 D PUT^DDSVAL(.11,DIXR,.4,$S($G(FCNT)>1:"R",1:"F"),"","I")
133 Q
134 ;
135CRVTYPE ;Post-Action on change for Cross-Reference Value -> Type of Value
136 N DIKCIENS
137 S DIKCIENS=DA_","_DA(1)_","
138 ;
139 I X="F" D
140 . D REQ^DDSUTL("FILE",1,2.1,1,DIKCIENS)
141 . D REQ^DDSUTL("FIELD",1,2.1,1,DIKCIENS)
142 . D REQ^DDSUTL("COMPUTED CODE",1,2.2,0,DIKCIENS)
143 . D PUT^DDSVAL(DIE,.DA,4,"")
144 . D PUT^DDSVAL(DIE,.DA,4.5,"")
145 E D
146 . D REQ^DDSUTL("FILE",1,2.1,0,DIKCIENS)
147 . D REQ^DDSUTL("FIELD",1,2.1,0,DIKCIENS)
148 . D REQ^DDSUTL("COMPUTED CODE",1,2.2,1,DIKCIENS)
149 . D PUT^DDSVAL(DIE,.DA,2,"")
150 . D PUT^DDSVAL(DIE,.DA,3,"")
151 ;
152 D UPDEXEC(DA(1))
153 Q
154 ;
155UPDEXEC(DIXR) ;Update Execution based on number of field-type xref values
156 N CRV,FCNT
157 S CRV(1)=DIXR,CRV=0
158 F S CRV=$O(^DD("IX",DIXR,11.1,CRV)) Q:'CRV D
159 . Q:'$$GET^DDSVAL(.114,.CRV,.01)
160 . S:$$GET^DDSVAL(.114,.CRV,1)="F" FCNT=$G(FCNT)+1
161 D PUT^DDSVAL(.11,DIXR,.4,$S($G(FCNT)>1:"R",1:"F"),"","I")
162 Q
163 ;
164BKPRE21 ;Pre-Action for block 'DIKC EDIT FIELD CRV'
165 N X
166 S X=$$GET^DDSVAL(DIE,.DA,5) D TRANS
167 Q
168 ;
169TRANS ;Post-Action on Change for Transform for Storage
170 N DIKCIENS
171 S DIKCIENS=DA_","_DA(1)_","
172 I X]"" D
173 . D UNED^DDSUTL("TRANSFORM FOR DISPLAY",1,2.1,0,DIKCIENS)
174 E D
175 . D PUT^DDSVAL(DIE,.DA,5.5,"")
176 . D UNED^DDSUTL("TRANSFORM FOR DISPLAY",1,2.1,1,DIKCIENS)
177 Q
178 ;
179VALFILE ;Data Validation for File
180 Q:X="" Q:X=DDSOLD
181 N LDIF,RFILE
182 S RFILE=$$GET^DDSVAL(.11,DA,.51)
183 ;
184 I X'=RFILE D
185 . S LDIF=$$FLEVDIFF^DIKCU(X,RFILE)
186 . I LDIF="" D Q
187 .. D HLP^DDSUTL($C(7)_"File must be a parent (ancestor) of Root File.")
188 .. S DDSERROR=1
189 . D:DDSOLD=RFILE PUT^DDSVAL(.11,DA,.5,"W","","I")
190 E D:DDSOLD'=RFILE PUT^DDSVAL(.11,DA,.5,"I","","I")
191 Q
192 ;
193FORMDV ;Form-Level Data Validation
194 ;Check that Subscript Numbers are unique and consecutive from 1.
195 N DIKCDA,DIKCI,DIKCLIST,DIKCSS,DIKCSQ
196 ;
197 ;Build list DIKCLIST(ss#,ien) while checking for duplicates.
198 ;Also check that a file# is assigned for Field-type CRVs and that
199 ;they it is equal to root file.
200 S DIKCDA(1)=DA
201 S DIKCDA=0 F S DIKCDA=$O(^DD("IX",DA,11.1,DIKCDA)) Q:'DIKCDA D
202 . I $$GET^DDSVAL(.114,.DIKCDA,1)="F" D
203 .. N DIKCFIL,DIKCMSG,DIKCRF
204 .. S DIKCFIL=$$GET^DDSVAL(.114,.DIKCDA,2)
205 .. I DIKCFIL="" D
206 ... D:'$D(DDSERROR) MSG^DDSUTL($C(7)_"UNABLE TO SAVE CHANGES")
207 ... S DDSERROR=1
208 ... S DIKCMSG(1)="FILE for Order #"_$$GET^DDSVAL(.114,.DIKCDA,.01)_" is missing."
209 ... S DIKCMSG(2)=" To correct the problem, press <RET> at the Order # on Page 2."
210 ... S DIKCMSG(3)=" In the resulting pop-up page, FILE will be filled in automatically."
211 ... S DIKCMSG(4)=" Try saving again."
212 ... D MSG^DDSUTL(.DIKCMSG)
213 .. E S DIKCRF=$$GET^DDSVAL(.11,DA,.51) I DIKCFIL'=DIKCRF D
214 ... D:'$D(DDSERROR) MSG
215 ... S DDSERROR=1
216 ... D MSG^DDSUTL("FILE for Order #"_$$GET^DDSVAL(.114,.DIKCDA,.01)_" is not equal to the Root File: "_DIKCRF_".")
217 . S DIKCSS=$$GET^DDSVAL(.114,.DIKCDA,.5) Q:'DIKCSS
218 . I $D(DIKCLIST(DIKCSS)) D
219 .. D:'$D(DDSERROR) MSG
220 .. S DDSERROR=1
221 .. D MSG^DDSUTL("The subscript number "_DIKCSS_" is used more than once.")
222 . E S DIKCLIST(DIKCSS,DIKCDA)=""
223 ;
224 ;If no duplicates, check that subscript numbers are consecutive from 1
225 I '$D(DDSERROR) D
226 . S DIKCSS=0
227 . F DIKCI=1:1 S DIKCSS=$O(DIKCLIST(DIKCSS)) Q:'DIKCSS!$G(DDSERROR) D:DIKCSS'=DIKCI
228 .. S DDSERROR=1
229 .. D MSG
230 .. D MSG^DDSUTL("Subscript numbers must be consecutive numbers starting with 1.")
231 Q
232 ;
233MSG ;Print message
234 D MSG^DDSUTL($C(7)_"UNABLE TO SAVE CHANGES")
235 Q
236 ;
237POSTSV ;Post Save
238 ;Clean-up global (get rid of null nodes)
239 ;Kill DIKCREB, the flag that indicates that a crv was deleted, but
240 ;the logic wasn't yet saved.
241 N CRV,ND
242 S CRV=0 F S CRV=$O(^DD("IX",DA,11.1,CRV)) Q:'CRV D
243 . F ND=1.5,2,3 I $D(^DD("IX",DA,11.1,CRV,ND))#2,^(ND)="" K ^(ND)
244 K DIKCREB
245 Q
Note: See TracBrowser for help on using the repository browser.