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

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

initial load of WorldVistAEHR
File size: 8.0 KB
RevLine 
[613]1DIKC ;SFISC/MKO-FIRE INDEX FILE CROSS REFERENCES ;27DEC2005
2 ;;22.0;VA FileMan;**1,22,11,68,95,146**;Mar 30, 1999
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4 ;
5INDEX(DIFILE,DIREC,DIFLD,DIXREF,DICTRL) ;Fire Index file xrefs
6 N DA,DIF,DIKACT,DIKCT,DIKERR,DIKLOCK,DIKLOG,DIKON,DIKRFIL
7 N DIKTMP,DIKVAL,DIMF,DIROOT
8 ;
9 ;Initialization
10 S DIF=$E("D",$G(DICTRL)["D")
11 I DIF["D",'$D(DIQUIET) N DIQUIET S DIQUIET=1
12 I DIF["D",'$D(DIFM) N DIFM S DIFM=1 D INIZE^DIEFU
13 ;
14 ;Check (and convert) input parameters
15 D CHK^DIKC2 G:$G(DIKERR)]"" EXIT
16 ;
17 ;Setup variables
18 S DIKCT=$E("C",$G(DICTRL)["C")_$E("T",$G(DICTRL)["T")
19 S DIKLOG=$E("K",$G(DICTRL)["K")_$E("S",$G(DICTRL)["S")
20 S:DIKLOG="" DIKLOG=$E("K",DIKCT'["C")_$E("S",DIKCT'["T")
21 S DIKACT=$E("R",$G(DICTRL)["R")_$E("I",$G(DICTRL)["I")
22 S DIKRFIL=$S($G(DICTRL)["W":+$P(DICTRL,"W",2),1:DIFILE)
23 I $G(DICTRL)["k" D
24 . S DIKLOCK=+$P(DICTRL,"k",2)\1
25 . S:DIKLOCK<0 DIKLOCK=-DIKLOCK
26 . S:$E($P(DICTRL,"k",2))="-" DIKLOCK("STOP")=1
27 E S DIKLOCK=1
28 ;
29 ;Load xref information into @DIKTMP
30 S DIKTMP=$G(DICTRL("LOGIC"))
31 I $G(DIKTMP)="" D
32 . S DIKTMP=$$GETTMP^DIKC1("DIKC")
33 . I $G(DIXREF)?."^" D
34 .. I $G(DIFLD) D
35 ... D LOADFLD^DIKC1(DIKRFIL,DIFLD,DIKLOG_"W",DIKACT,DIKVAL,DIKTMP,DIKTMP,$E("i",$G(DICTRL)["i"))
36 .. E D LOADALL^DIKC1(DIKRFIL,DIKLOG,DIKACT,DIKVAL,DIKTMP,$E("s",$G(DICTRL)["s")_$E("i",$G(DICTRL)["i"),.DIMF)
37 . E D LOADXREF^DIKC1(DIKRFIL,$G(DIFLD),DIKLOG,.DIXREF,DIKVAL,DIKTMP)
38 ;
39 D:DIKRFIL'=DIFILE SBINFO^DIKCU(DIKRFIL,.DIMF)
40 ;
41 ;Fire the xrefs for all records or the record specified in DA
42 I 'DA D
43 . L +@DIROOT:DIKLOCK E D Q:$G(DIKLOCK("STOP"))
44 .. S DIKLOCK=""
45 .. D:DIF["D" ERR^DIKCU2(112,DIFILE)
46 . D FIREALL(DIFILE,.DA,DIROOT,DIKLOG,.DIMF,DIKTMP,DIKON,"",DIKCT)
47 . L:DIKLOCK]"" -@DIROOT
48 E D
49 . L +@DIROOT@(DA):DIKLOCK E D Q:$G(DIKLOCK("STOP"))
50 .. S DIKLOCK=""
51 .. D:DIF["D" ERR^DIKCU2(110,DIFILE,$$IENS^DIKCU(DIFILE,.DA))
52 . D:$D(@DIKTMP@(DIFILE)) FIRE(DIFILE,.DA,DIKLOG,DIKTMP,DIKON,"",DIKCT)
53 . D:$D(DIMF(DIFILE)) FIRESUB(DIFILE,.DA,DIROOT,DIKLOG,.DIMF,DIKTMP,DIKON,"",DIKCT)
54 . L:DIKLOCK]"" -@DIROOT@(DA)
55 ;
56 ;Cleanup ^TMP
57 K @DIKTMP
58 ;
59EXIT ;Move error messages if necessary
60 I DIF["D",$G(DIERR),$G(DICTRL("MSG"))]"" D CALLOUT^DIEFU(DICTRL("MSG"))
61 Q
62 ;
63FIREALL(DIFILE,DA,DIROOT,DILOG,DIMF,DIKTMP,DIKON,DIKEY,DIKCT) ;Fire xrefs, all recs
64 N DICNT,DIIENS,DILAST,DIXR
65 S DILOG=$G(DILOG),DIKON=$G(DIKON)
66 S DIIENS=$$IENS^DIKCU(DIFILE,.DA)
67 ;
68 ;Kill entire indexes
69 I DILOG["K",$D(@DIKTMP@("KW",DIFILE)) D XECKW(DIFILE,.DA,$D(DIMF(DIFILE))>0)
70 I '$D(@DIKTMP@(DIFILE)),'$D(DIMF(DIFILE)) Q
71 ;
72 ;Loop through all records in the file
73 S (DICNT,DA)=0 F S DA=$O(@DIROOT@(DA)) Q:DA'=+DA D
74 . S $P(DIIENS,",")=DA
75 . S DICNT=DICNT+1
76 . D:$D(@DIKTMP@(DIFILE)) FIRE(DIFILE,.DA,DILOG,DIKTMP,DIKON,.DIKEY,DIKCT,DIIENS)
77 . D:$D(DIMF(DIFILE)) FIRESUB(DIFILE,.DA,DIROOT,DILOG,.DIMF,DIKTMP,DIKON,.DIKEY,DIKCT)
78 ;
79 ;Update header node
80 I $D(@DIROOT@(0))#2 D
81 . S DILAST=$O(@DIROOT@(" "),-1) S:'DILAST DILAST=""
82 . S:'DICNT DICNT=""
83 . S $P(@DIROOT@(0),U,4)=DICNT ;**DI*22*146
84 Q
85 ;
86FIRE(DIFILE,DA,DILOG,DIKTMP,DIKON,DIKEY,DIKCT,DIIENS) ;Fire xrefs, one record
87 N DI01,DIKCLOG,DINULL,DION,DIXR,I,J,X,X2,XN
88 S DILOG=$G(DILOG),DIKON=$G(DIKON)
89 S:$G(DIIENS)="" DIIENS=$$IENS^DIKCU(DIFILE,.DA)
90 ;
91 I DIKON="" S DIXR=0 F S DIXR=$O(@DIKTMP@(DIFILE,DIXR)) Q:DIXR'=+DIXR D
92 . D SETXARR(DIFILE,DIXR,DIKTMP,.DINULL) Q:DINULL
93 . I $G(DIKCT)="" D XECUTE(DIFILE,DIXR,DILOG,.X,.X,DIKTMP) Q
94 . ;
95 . K XN S XN="",I=0 F S I=$O(X(I)) Q:'I S XN(I)=""
96 . I $G(DIKCT)="C" D XECUTE(DIFILE,DIXR,"S",.XN,.X,DIKTMP) Q
97 . I $G(DIKCT)="T" D XECUTE(DIFILE,DIXR,"K",.X,.XN,DIKTMP) Q
98 ;
99 E S DIXR=0 F S DIXR=$O(@DIKTMP@(DIFILE,DIXR)) Q:DIXR'=+DIXR D
100 . K DINFLD
101 . S DIKCLOG=""
102 . ;
103 . ;Set X2 array to new values
104 . S DION=$P(DIKON,U,2)
105 . D SETXARR(DIFILE,DIXR,DIKTMP,.DINULL,DION) M X2=X
106 . ;
107 . ;If SET requested, make sure no new values are null
108 . I DILOG["S" D
109 .. I 'DINULL S DIKCLOG="S"
110 .. E I $P(DIKON,U,4)="N" S I=0 F S I=$O(^DD("KEY","AU",DIXR,I)) Q:'I D
111 ... S DIKEY(DIFILE,I,DIIENS)="n"
112 ... S J=0 F S J=$O(DINULL(J)) Q:'J S DIKEY(DIFILE,I,DIIENS,$P(DINULL(J),U),$P(DINULL(J),U,2))=$P(DINULL(J),U,3)
113 . ;
114 . ;Set X array to old values
115 . S DION=$P(DIKON,U)
116 . D SETXARR(DIFILE,DIXR,DIKTMP,.DINULL,DION,.DI01)
117 . ;
118 . ;If KILL requested, make sure no old values are null
119 . I DILOG["K",'DINULL S DIKCLOG="K"_DIKCLOG
120 . ;
121 . ;If "C" flag, set old .01 value to null
122 . I $G(DIKCT)="C",$D(DI01) D
123 .. S I=0 F S I=$O(DI01(I)) Q:'I S X(I)=""
124 .. S:$O(DI01(0))=$O(X(0)) X=""
125 .. S DIKCLOG=$TR(DIKCLOG,"K")
126 . ;
127 . ;If "T" flag, set all new values to null
128 . I $G(DIKCT)="T" S X2="",I=0 F S I=$O(X2(I)) Q:'I S X2(I)=""
129 . ;
130 . ;Execute the kill and set logic
131 . D XECUTE(DIFILE,DIXR,DIKCLOG,.X,.X2,DIKTMP)
132 . ;
133 . I DIKCLOG["S",$P(DIKON,U,3)="K",$D(^DD("KEY","AU",DIXR)) D
134 .. Q:$$UNIQUE^DIKK2(DIFILE,DIXR,.X2,.DA,DIKTMP)
135 .. S I=0 F S I=$O(^DD("KEY","AU",DIXR,I)) Q:'I S DIKEY(DIFILE,I,DIIENS)=""
136 Q
137 ;
138FIRESUB(DIFILE,DA,DIROOT,DILOG,DIMF,DIKTMP,DIKON,DIKEY,DIKCT) ;Fire xrefs for
139 ;all subfiles under DIFILE, for all subrecords under DA
140 Q:'$D(DIMF(DIFILE))
141 N DIMULTF,DISBFILE,DISBROOT,X
142 S DILOG=$G(DILOG),DIKON=$G(DIKON)
143 ;
144 ;Push down the DA array
145 D PUSHDA^DIKCU(.DA)
146 ;
147 ;Loop through DIMF array and fire xrefs for subfiles
148 S DIMULTF=0 F S DIMULTF=$O(DIMF(DIFILE,DIMULTF)) Q:'DIMULTF D
149 . S DISBROOT=$NA(@DIROOT@(DA(1),DIMF(DIFILE,DIMULTF))) Q:'$D(@DISBROOT)
150 . S DISBFILE=DIMF(DIFILE,DIMULTF,0)
151 . D FIREALL(DISBFILE,.DA,DISBROOT,DILOG,.DIMF,DIKTMP,DIKON,.DIKEY,DIKCT)
152 ;
153 ;Pop the DA array
154 D POPDA^DIKCU(.DA)
155 Q
156 ;
157XECUTE(DIFILE,DIXR,DILOG,DIKCX1,DIKCX2,DIKTMP) ;Xecute the logic in ^TMP
158 Q:$G(DILOG)=""
159 N DIKCOD,DIKCON,X,X1,X2
160 ;
161 ;Execute kill logic
162 I DILOG["K" D
163 . S DIKCOD=$G(@DIKTMP@(DIFILE,DIXR,"K")) Q:DIKCOD?."^"
164 . S DIKCON=$G(@DIKTMP@(DIFILE,DIXR,"KC"))
165 . I DIKCON'?."^" M X=DIKCX1,X1=DIKCX1,X2=DIKCX2 X DIKCON Q:'$G(X) K X,X1,X2
166 . M X=DIKCX1,X1=DIKCX1,X2=DIKCX2
167 . X DIKCOD K X,X1,X2
168 ;
169 ;Execute set logic
170 I DILOG["S" D
171 . S DIKCOD=$G(@DIKTMP@(DIFILE,DIXR,"S")) Q:DIKCOD?."^"
172 . S DIKCON=$G(@DIKTMP@(DIFILE,DIXR,"SC"))
173 . I DIKCON'?."^" M X=DIKCX2,X1=DIKCX1,X2=DIKCX2 X DIKCON Q:'$G(X) K X,X1,X2
174 . M X=DIKCX2,X1=DIKCX1,X2=DIKCX2
175 . X DIKCOD
176 Q
177 ;
178XECKW(DIFILE,DA,DIKSUB) ;Execute the logic to kill the entire index
179 N DIKFIL,DIKKW,DIKKW0,DIKLDIF,DIXR
180 ;
181 S DIXR=0 F S DIXR=$O(@DIKTMP@("KW",DIFILE,DIXR)) Q:DIXR'=+DIXR D
182 . S DIKKW=$G(@DIKTMP@("KW",DIFILE,DIXR)) Q:DIKKW?."^"
183 . S DIKKW0=$G(@DIKTMP@("KW",DIFILE,DIXR,0))
184 . ;
185 . ;If not a whole file xref, kill the entire index and quit
186 . I DIKKW0="" X DIKKW D Q
187 .. I '$D(@DIKTMP@(DIFILE,DIXR,"S")) K @DIKTMP@(DIFILE,DIXR)
188 .. E K @DIKTMP@(DIFILE,DIXR,"K"),@DIKTMP@(DIFILE,DIXR,"KC")
189 . ;
190 . ;Quit if this isn't a whole file xref or we're not doing subfiles
191 . Q:$P(DIKKW0,U)'="W"!'$G(DIKSUB)
192 . ;
193 . ;Kill the whole index after pushing DA the appropriate amount
194 . S DIKFIL=$P(DIKKW0,U,2),DIKLDIF=$P(DIKKW0,U,3)
195 . D PUSHDA^DIKCU(.DA,DIKLDIF)
196 . X DIKKW
197 . I '$D(@DIKTMP@(DIKFIL,DIXR,"S")) K @DIKTMP@(DIKFIL,DIXR)
198 . E K @DIKTMP@(DIKFIL,DIXR,"K"),@DIKTMP@(DIKFIL,DIXR,"KC")
199 . D POPDA^DIKCU(.DA,DIKLDIF)
200 Q
201 ;
202SETXARR(DIFILE,DIXR,DIKTMP,DINULL,DION,DI01) ;Loop through DIKTMP and set X array.
203 ;If any values used as subscripts are null, return
204 ; DINULL=1
205 ; DINULL(order#) = ""
206 ; or file^field^levDiff (for field type subscripts)
207 ; DI01(order#) = "" if order # is .01 field
208 ;
209 N DIKCX,DIKF,DIKO,X1,X2
210 K X,DI01,DINULL
211 S DINULL=0,(DIKF,DIKO)=$O(@DIKTMP@(DIFILE,DIXR,0)) Q:'DIKF
212 ;
213 S:$G(DION)="" DION=U
214 F D S DIKO=$O(@DIKTMP@(DIFILE,DIXR,DIKO)) Q:'DIKO
215 . K DIKCX M DIKCX=X
216 . X $G(@DIKTMP@(DIFILE,DIXR,DIKO))
217 . I $G(X)]"",$D(@DIKTMP@(DIFILE,DIXR,DIKO,"T")) X @DIKTMP@(DIFILE,DIXR,DIKO,"T")
218 . S:$D(X)#2 (DIKCX,DIKCX(DIKO))=X K X M X=DIKCX
219 . S:$P($G(@DIKTMP@(DIFILE,DIXR,DIKO,"F")),U,2)=.01 DI01(DIKO)=""
220 . I $G(X(DIKO))="",$G(@DIKTMP@(DIFILE,DIXR,DIKO,"SS")) S DINULL=1 S:$G(@DIKTMP@(DIFILE,DIXR,DIKO,"F")) DINULL(DIKO)=@DIKTMP@(DIFILE,DIXR,DIKO,"F")
221 ;
222 S:$D(X(DIKF))#2 X=$G(X(DIKF))
223 Q
224 ;
225 ;#110 The record is currently locked.
226 ;#112 The file is currently locked.
Note: See TracBrowser for help on using the repository browser.