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

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

initial load of WorldVistAEHR
File size: 8.4 KB
Line 
1DIKCR ;SFISC/MKO-API TO CREATE A NEW-STYLE XREF ;9:55 AM 1 Nov 2002
2 ;;22.0;VA FileMan;**95**;Mar 30, 1999
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4 ;
5CREIXN(DIKCXREF,DIFLG,DIXR,DIKCOUT,DIKCMSG) ;Create a new-style index
6 ;DIFLG:
7 ; e : Throw away Dialog errors
8 ; r : Don't recompile templates, xrefs
9 ; W : Write messages to the current device
10 ; S : Execute set logic of new xref
11 ;
12CREIXNX ;Entry point from DDMOD
13 N DIKCDEL,DIKCXR,DIKCDMSG,DIKCERR,X,Y
14 ;
15 ;Init
16 S DIFLG=$G(DIFLG)
17 I DIFLG["e" S DIKCMSG="DIKCDMSG" N DIERR
18 I '$D(DIFM) N DIFM S DIFM=1 D INIZE^DIEFU
19 S DIKCDEL=$G(DIKCXREF("NAME"))]""
20 M DIKCXR=DIKCXREF
21 ;
22 ;Check input, set defaults
23 D CHK(.DIKCXR,.DIKCERR) G:DIKCERR EXIT
24 D CHKVAL(.DIKCXR,.DIKCERR) G:DIKCERR EXIT
25 ;
26 ;Delete the old index of the same name
27 D:DIKCDEL
28 . N DIKCFLAG,DIERR,DIKCDMSG
29 . S DIKCFLAG="d"_$E("W",DIFLG["W")_$E("K",DIFLG'["k")
30 . D DELIXN^DDMOD(DIKCXR("FILE"),DIKCXR("NAME"),DIKCFLAG,"","DIKCDMSG")
31 ;
32 ;Create the index
33 D UPDATE(.DIKCXR,.DIXR,DIFLG) I DIXR="" S DIKCERR=1 G EXIT
34 ;
35 ;Execute set logic
36 D:DIFLG["S" SET(DIXR,DIFLG)
37 ;
38 ;Recompile templates and xrefs
39 D:DIFLG'["r" RECOMP(DIXR,DIFLG)
40 ;
41EXIT ;Write and move error messages if necessary
42 I $G(DIERR) D
43 . D:DIFLG["W" MSG^DIALOG("WES")
44 . D:$G(DIKCMSG)]"" CALLOUT^DIEFU(DIKCMSG)
45 I $G(DIKCERR) S DIXR=""
46 E S DIXR=DIXR_U_DIKCXR("NAME")
47 Q
48 ;
49UPDATE(DIKCXR,DIXR,DIFLG) ;Call Updater to create index, return DIXR=ien
50 N DIKCFDA,DIKCIEN,IENS,ORD,R,SEQ,X
51 W:$G(DIFLG)["W" !,"Creating index definition ..."
52 ;
53 ;Set FDA for top level Index file fields
54 S DIKCFDA(.11,"+1,",.01)=DIKCXR("FILE")
55 S DIKCFDA(.11,"+1,",.02)=DIKCXR("NAME")
56 S DIKCFDA(.11,"+1,",.11)=DIKCXR("SHORT DESCR")
57 S DIKCFDA(.11,"+1,",.2)=DIKCXR("TYPE")
58 S DIKCFDA(.11,"+1,",.4)=DIKCXR("EXECUTION")
59 S DIKCFDA(.11,"+1,",.41)=DIKCXR("ACTIVITY")
60 S DIKCFDA(.11,"+1,",.42)=DIKCXR("USE")
61 S DIKCFDA(.11,"+1,",.5)=DIKCXR("ROOT TYPE")
62 S DIKCFDA(.11,"+1,",.51)=DIKCXR("ROOT FILE")
63 S DIKCFDA(.11,"+1,",1.1)=$S($G(DIKCXR("SET"))]"":DIKCXR("SET"),1:"Q")
64 S DIKCFDA(.11,"+1,",2.1)=$S($G(DIKCXR("KILL"))]"":DIKCXR("KILL"),1:"Q")
65 S:$G(DIKCXR("SET CONDITION"))]"" DIKCFDA(.11,"+1,",1.4)=DIKCXR("SET CONDITION")
66 S:$G(DIKCXR("KILL CONDITION"))]"" DIKCFDA(.11,"+1,",2.4)=DIKCXR("KILL CONDITION")
67 S:$G(DIKCXR("WHOLE KILL"))]"" DIKCFDA(.11,"+1,",2.5)=DIKCXR("WHOLE KILL")
68 ;
69 ;Set FDA for Values multiple
70 S ORD=0 F SEQ=2:1 S ORD=$O(DIKCXR("VAL",ORD)) Q:'ORD D
71 . S IENS="+"_SEQ_",+1,"
72 . S R=$NA(DIKCXR("VAL",ORD))
73 . S DIKCFDA(.114,IENS,.01)=ORD
74 . S DIKCFDA(.114,IENS,1)=@R@("TYPE")
75 . ;
76 . I @R@("TYPE")="C" S DIKCFDA(.114,IENS,4.5)=@R
77 . E D
78 .. S DIKCFDA(.114,IENS,2)=DIKCXR("ROOT FILE")
79 .. S DIKCFDA(.114,IENS,3)=@R
80 .. S X=$G(@R@("XFORM FOR STORAGE")) S:X]"" DIKCFDA(.114,IENS,5)=X
81 .. S X=$G(@R@("XFORM FOR LOOKUP")) S:X]"" DIKCFDA(.114,IENS,5.3)=X
82 .. S X=$G(@R@("XFORM FOR DISPLAY")) S:X]"" DIKCFDA(.114,IENS,5.5)=X
83 . ;
84 . S X=$G(@R@("SUBSCRIPT")) S:X]"" DIKCFDA(.114,IENS,.5)=X
85 . S X=$G(@R@("LENGTH")) S:X]"" DIKCFDA(.114,IENS,6)=X
86 . S X=$G(@R@("COLLATION")) S:X]"" DIKCFDA(.114,IENS,7)=X
87 . S X=$G(@R@("LOOKUP PROMPT")) S:X]"" DIKCFDA(.114,IENS,8)=X
88 ;
89 ;Call Updater
90 D UPDATE^DIE("E","DIKCFDA","DIKCIEN")
91 K DIXR I $G(DIERR) S DIXR="" Q
92 S DIXR=DIKCIEN(1)
93 ;
94 ;Add Description
95 D:$O(DIKCXR("DESCR",0)) WP^DIE(.11,DIXR_",",.1,"",$NA(DIKCXR("DESCR")))
96 Q
97 ;
98RECOMP(DIXR,DIFLG) ;Recompile templates and xrefs, update triggering fields
99 N DIKCFLIS,DIKCI,DIKCTLIS,DIKCTOP,DIKTEML
100 ;
101 ;Get top level file number
102 S DIKCTOP=$$FNO^DILIBF($P($G(^DD("IX",DIXR,0)),U)) Q:'DIKCTOP
103 ;
104 ;Get list of fields in xref
105 D GETFLIST^DIKCUTL(DIXR,.DIKCFLIS) Q:'$D(DIKCFLIS)
106 ;
107 ;Recompile input templates and xrefs
108 D DIEZ^DIKD2(.DIKCFLIS,DIFLG,$G(DIKCOUT))
109 D DIKZ^DIKD(DIKCTOP,DIFLG,$G(DIKCOUT)) S DIKCTOP(DIKCTOP)=""
110 ;
111 ;Also update triggering fields, and their compiled templates and xrefs
112 D TRIG^DICR(.DIKCFLIS,.DIKCTLIS)
113 I $D(DIKCTLIS) D
114 . D DIEZ^DIKD2(.DIKCTLIS,DIFLG,$G(DIKCOUT))
115 . S DIKCI=0 F S DIKCI=$O(DIKCTLIS(DIKCI)) Q:'DIKCI D
116 .. S DIKCTOP=+$$FNO^DILIBF(DIKCI) Q:$D(DIKCTOP(DIKCTOP))#2!'DIKCTOP
117 .. S DIKCTOP(DIKCTOP)=""
118 .. D DIKZ^DIKD(DIKCTOP,DIFLG,$G(DIKCOUT))
119 Q
120 ;
121CHK(DIKCXR,DIKCERR) ;Check/default input array
122 N FIL,NAM,RFIL,TYP,USE
123 S DIKCERR=0
124 ;
125 ;Check FILE
126 S FIL=$G(DIKCXR("FILE")) I 'FIL D ER202("FILE") Q
127 I '$$VFNUM^DIKCU1(FIL,"D") S DIKCERR=1 Q
128 ;
129 ;Check Type, get internal form
130 S TYP=$G(DIKCXR("TYPE")) I TYP="" D ER202("TYPE") Q
131 D CHK^DIE(.11,.2,"",TYP,.TYP) I TYP=U S DIKCERR=1 Q
132 S DIKCXR("TYPE")=TYP
133 ;
134 ;Check USE, get internal form.
135 S USE=$G(DIKCXR("USE"))
136 I USE]"" D CHK^DIE(.11,.42,"",USE,.USE) I USE=U S DIKCERR=1 Q
137 S DIKCXR("USE")=USE
138 ;
139 S NAM=$G(DIKCXR("NAME"))
140 S RFIL=$G(DIKCXR("ROOT FILE"))
141 ;
142 ;Check Root File, set Root Type
143 S:'RFIL (RFIL,DIKCXR("ROOT FILE"))=FIL
144 I FIL=RFIL S DIKCXR("ROOT TYPE")="I"
145 E D Q:DIKCERR
146 . I $$FLEVDIFF^DIKCU(FIL,RFIL)="" D ER202("ROOT FILE") Q
147 . I '$$VFNUM^DIKCU1(RFIL,"D") S DIKCERR=1 Q
148 . S DIKCXR("ROOT TYPE")="W"
149 ;
150 ;Check USE, NAME, TYPE
151 I NAM="",USE="" D ER202("NAME/USE") Q
152 I $E(NAM)="A",USE="LS" D ER202("NAME/USE") Q
153 I USE="A",TYP'="MU" D ER202("TYPE/USE") Q
154 ;
155 ;Default NAM based on USE and FILE
156 ; or USE based on NAME and TYPE
157 I NAM="" S DIKCXR("NAME")=$$GETNAM(FIL,USE)
158 E I USE="" S DIKCXR("USE")=$S($E(NAM)="A":$S(TYP="MU":"A",1:"S"),1:"LS")
159 ;
160 ;Check SHORT DESCRIPTION'=null', if null set default Activity
161 I $G(DIKCXR("SHORT DESCR"))="" D ER202("SHORT DESCR") Q
162 S:$D(DIKCXR("ACTIVITY"))[0 DIKCXR("ACTIVITY")="IR"
163 Q
164 ;
165CHKVAL(DIKCXR,DIKCERR) ;Check values, build logic for regular indexes
166 N CNT,FCNT,FIL,KILL,L,LEV,LDIF,MAXL,NAM,ORD,RFIL,ROOT,SBSC,SEQ,SET,TYP,VAL,WKIL
167 ;
168 S FIL=DIKCXR("FILE")
169 S NAM=DIKCXR("NAME")
170 S RFIL=DIKCXR("ROOT FILE")
171 S TYP=DIKCXR("TYPE")
172 S DIKCERR=0
173 ;
174 ;Begin building logic for regular indexes
175 I TYP="R" D Q:DIKCERR
176 . I FIL'=RFIL S LDIF=$$FLEVDIFF^DIKCU(FIL,RFIL)
177 . E S LDIF=0
178 . S ROOT=$$FROOTDA^DIKCU(FIL,LDIF_"O",.LEV)_""""_NAM_""""
179 . I $D(DIERR) S DIKCERR=1 Q
180 . S WKIL="K "_ROOT_")"
181 ;
182 ;Build list of subscripts, count #values and #fields
183 S ORD=0 F S ORD=$O(DIKCXR("VAL",ORD)) Q:'ORD D Q:DIKCERR
184 . I $G(DIKCXR("VAL",ORD))="" K DIKCXR("VAL",ORD) Q
185 . S CNT=$G(CNT)+1
186 . ;
187 . ;Get type of value; if field, increment field count
188 . I DIKCXR("VAL",ORD) S DIKCXR("VAL",ORD,"TYPE")="F",FCNT=$G(FCNT)+1
189 . E S DIKCXR("VAL",ORD,"TYPE")="C"
190 . ;
191 . ;Set subscript array; error if duplicate subscript #
192 . S SBSC=$G(DIKCXR("VAL",ORD,"SUBSCRIPT")) Q:'SBSC
193 . I $D(SBSC(SBSC))#2 D ER202("SUBSCRIPT") Q
194 . S SBSC(SBSC)=ORD_U_$G(DIKCXR("VAL",ORD,"LENGTH"))
195 . ;
196 . ;Set default collation
197 . S:$G(DIKCXR("VAL",ORD,"COLLATION"))="" DIKCXR("VAL",ORD,"COLLATION")="F"
198 Q:DIKCERR
199 ;
200 S SBSC=0 F SEQ=1:1 S SBSC=$O(SBSC(SBSC)) Q:'SBSC D Q:DIKCERR
201 . ;Check that subscripts are consecutive from 1
202 . I SEQ'=SBSC D ER202("SUBSCRIPTS") Q
203 . Q:TYP="MU"
204 . ;
205 . ;Continue building logic for regular indexes
206 . S ORD=$P(SBSC(SBSC),U),MAXL=$P(SBSC(SBSC),U,2)
207 . I $G(CNT)=1 S VAL=$S(MAXL:"$E(X,1,"_MAXL_")",1:"X")
208 . E S VAL=$S(MAXL:"$E(X("_ORD_"),1,"_MAXL_")",1:"X("_ORD_")")
209 . S ROOT=ROOT_","_VAL
210 ;
211 ;If null, default Execution based on #fields
212 S:$G(DIKCXR("EXECUTION"))="" DIKCXR("EXECUTION")=$S($G(FCNT)>1:"R",1:"F")
213 ;
214 ;We're done for MUMPS xrefs
215 Q:TYP="MU"
216 ;
217 ;Continue building logic for regular indexes
218 F L=LDIF:-1:1 S ROOT=ROOT_",DA("_L_")"
219 S ROOT=ROOT_",DA)"
220 ;
221 I '$O(SBSC(0)) S (SET,KILL)="Q",WKIL=""
222 E S SET="S "_ROOT_"=""""",KILL="K "_ROOT
223 S DIKCXR("SET")=SET
224 S DIKCXR("KILL")=KILL
225 S DIKCXR("WHOLE KILL")=WKIL
226 Q
227 ;
228GETNAM(F01,USE) ;Get next available index name
229 N ASC,STRT,NAME,I
230 S STRT=$S(USE="LS":"",1:"A")
231 F ASC=67:1:89 D Q:NAME]""
232 . S NAME=STRT_$C(ASC)
233 . I $D(^DD("IX","BB",F01,NAME)) S NAME="" Q
234 . I $D(^DD(F01,0,"IX",NAME)) S NAME="" Q
235 Q:NAME]"" NAME
236 ;
237 F I=1:1 D Q:NAME]""
238 . S NAME=STRT_"C"_I
239 . I $D(^DD("IX","BB",F01,NAME)) S NAME="" Q
240 . I $D(^DD(F01,0,"IX",NAME)) S NAME="" Q
241 Q NAME
242 ;
243SET(DIXR,DIFLG) ;Execute set logic
244 N DIKCRFIL,DIKCTOP,DIKCTRL,DIKCTYP
245 ;
246 S DIKCTOP=$$FNO^DILIBF($P($G(^DD("IX",DIXR,0)),U)) Q:'DIKCTOP
247 S DIKCRFIL=$P($G(^DD("IX",DIXR,0)),U,9) Q:'DIKCRFIL
248 S DIKCTYP=$P($G(^DD("IX",DIXR,0)),U,4)
249 ;
250 I $G(DIFLG)["W" D
251 . I DIKCTYP="R" W !,"Building index ..."
252 . E W !,"Executing set logic ..."
253 ;
254 ;Call INDEX^DIKC to execute the set logic
255 S DIKCTRL="S"_$S(DIKCTOP'=DIKCRFIL:"W"_DIKCRFIL,1:"")
256 D INDEX^DIKC(DIKCTOP,"","",DIXR,.DIKCTRL)
257 Q
258 ;
259ER202(DIKCP1) ;;The input variable or parameter that identifies the |1| is missing or invalid.
260 D ERR^DIKCU2(202,"","","",DIKCP1)
261 S DIKCERR=1
262 Q
Note: See TracBrowser for help on using the repository browser.