source: FOIAVistA/trunk/r/VA_FILEMAN-ARJT-DI-DD-DM-DT-%DT-%RCR/DDUCHK5.m@ 1397

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

initial load of FOIAVistA 6/30/08 version
File size: 6.6 KB
Line 
1DDUCHK5 ;SFISC/MKO-CHECK KEYS ON FILE ;8/8/03 06:26
2 ;;22.0;VA FileMan;*130*;Mar 30, 1999
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4 ;
5KEY(DDUCFI,DDUCFIX) ;Check and optionally fix structure of Key file entry
6 N DDUCKEY
7 Q:'$G(DDUCFI) S DDUCFIX=$G(DDUCFIX)
8 ;
9 ;Loop through "B" index to find KEYs that reside on this file
10 D WCHK
11 S DDUCKEY=""
12 F S DDUCKEY=$O(^DD("KEY","B",DDUCFI,DDUCKEY)) Q:DDUCKEY="" D CHKKEY
13 ;
14 ;Check "AP","BB", and "F" indexes
15 D CHKAP,CHKBB,CHKF
16 Q
17 ;
18CHKKEY ;Check Key DDUCKEY found in "B" index
19 ;In:
20 ; DDUCKEY = Key #
21 ; DDUCFI = File #
22 ; DDUCFIX = Flag to fix
23 N DDUCIEN,DDUCKEY0,DDUCKID,DDUCNM,DDUCUI
24 S DDUCKID=$$KEYID(DDUCKEY,"")
25 ;
26 ;Check that Key exists
27 I '$D(^DD("KEY",DDUCKEY)) D Q
28 . D WNOKEY
29 . D:DDUCFIX KILL($NA(^DD("KEY","B",DDUCFI,DDUCKEY)))
30 ;
31 ;Check that Key has a FILE
32 S DDUCKEY0=$G(^DD("KEY",DDUCKEY,0))
33 I $P(DDUCKEY0,U)="" D
34 . D WMS("FILE (#.01) for "_DDUCKID)
35 . D:DDUCFIX FFILE
36 ;
37 ;Get Name
38 S DDUCNM=$P(DDUCKEY0,U,2)
39 I DDUCNM]"" S DDUCKID=$$KEYID(DDUCKEY,DDUCNM)
40 E D WMS("NAME for "_DDUCKID)
41 ;
42 ;Check Priority
43 S DDUCPRI=$P(DDUCKEY0,U,3)
44 D:DDUCPRI="" WMS("PRIORITY for "_DDUCKID)
45 ;
46 ;Check Uniqueness Index
47 S DDUCUI=$P(DDUCKEY0,U,4)
48 I 'DDUCUI D
49 . D WMS("Uniqueness Index for "_DDUCKID,1)
50 E D
51 . I '$D(^DD("IX",DDUCUI,0)) D Q
52 .. D WMS("Dangling pointer. Uniqueness Index #"_DDUCUI_" pointed to by "_DDUCKID,1)
53 . D GETFLD^DIKKUTL2(DDUCKEY,DDUCUI,.DDUCKFLD,.DDUCUFLD)
54 . D:'$$GCMP^DIKCU2("DDUCKFLD","DDUCUFLD") WNE
55 ;
56 ;Check Field multiple
57 S DDUCIEN=0
58 F S DDUCIEN=$O(^DD("KEY",DDUCKEY,2,DDUCIEN)) Q:'DDUCIEN D FLD
59 ;
60 ;Reindex Key file entry
61 I DDUCFIX D
62 . N DIC,DIK,DA,X
63 . S DIK="^DD(""KEY"",",DA=DDUCKEY
64 . D IX^DIK
65 Q
66 ;
67FLD ;Check a Cross-Reference Value
68 ;In:
69 ; DDUCKEY = Key #
70 ; DDUCIEN = IEN in FIELD multiple
71 ; DDUCFIX = Flag to fix
72 ; DDUCKID = String that identifies Key
73 ; DDUCUI = Uniqueness index #
74 N DDUCFIL,DDUCFLD,DDUCFLD0,DDUCKFLD,DDUCSEQ,DDUCUFLD
75 ;
76 S DDUCFLD0=$G(^DD("KEY",DDUCKEY,2,DDUCIEN,0))
77 S DDUCFLD=$P(DDUCFLD0,U),DDUCFIL=$P(DDUCFLD0,U,2)
78 S DDUCSEQ=$P(DDUCFLD0,U,3)
79 ;
80 ;Check that field, file, and sequence are filled in
81 D:'DDUCFLD!'DDUCFIL!'DDUCSEQ WINC
82 ;
83 ;Make sure file/field exists and is in the "F" index
84 I DDUCFLD,DDUCFIL D
85 . D:$D(^DD(DDUCFIL,DDUCFLD,0))[0 WFMS
86 . I $D(^DD("KEY","F",DDUCFIL,DDUCFLD,DDUCKEY,DDUCIEN))[0 S DDUCGL=$NA(^(DDUCIEN)) D
87 .. D WMS(DDUCGL)
88 .. D:DDUCFIX SET(DDUCGL)
89 Q
90 ;
91CHKAP ;Check "AP" index (In: DDUCFI = file; DDUCFIX = flag to fix)
92 N DDUCGL,DDUCKEY,DDUCKEY0,DDUCPRI,DDUCPRIL
93 ;
94 S DDUCPRI=""
95 F S DDUCPRI=$O(^DD("KEY","AP",DDUCFI,DDUCPRI)) Q:DDUCPRI="" D
96 . S DDUCKEY=0
97 . F S DDUCKEY=$O(^DD("KEY","AP",DDUCFI,DDUCPRI,DDUCKEY)) Q:'DDUCKEY D
98 .. S DDUCKEY0=$G(^DD("KEY",DDUCKEY,0))
99 .. I $D(^DD("KEY",DDUCKEY)),$P(DDUCKEY0,U,3)="" S DDUCPRIL(DDUCKEY,DDUCPRI)=""
100 .. E I $P(DDUCKEY0,U)'=DDUCFI!($P(DDUCKEY0,U,3)'=DDUCPRI) D
101 ... S DDUCGL=$NA(^DD("KEY","AP",DDUCFI,DDUCPRI,DDUCKEY))
102 ... D WEN(DDUCGL)
103 ... D:DDUCFIX KILL(DDUCGL)
104 ;
105 ;If any of the Keys have null Priorities, check whether a single
106 ;priority for it was found in the "AP" index.
107 I $D(DDUCPRIL) S DDUCKEY=0 F S DDUCKEY=$O(DDUCPRIL(DDUCKEY)) Q:'DDUCKEY D
108 . S DDUCPRI=$O(DDUCPRIL(DDUCKEY,""))
109 . I $O(DDUCPRIL(DDUCKEY,DDUCPRI))="" D
110 .. S DDUCKID=$$KEYID(DDUCKEY)
111 .. D WPRI
112 .. D:DDUCFIX FPRI
113 . E F D S DDUCPRI=$O(DDUCPRIL(DDUCKEY,DDUCPRI)) Q:DDUCPRI=""
114 .. S DDUCGL=$NA(^DD("KEY","AP",DDUCFI,DDUCPRI,DDUCKEY))
115 .. D WEN(DDUCGL)
116 .. D:DDUCFIX KILL(DDUCGL)
117 Q
118 ;
119CHKBB ;Check "BB" index (In: DDUCFI = file; DDUCFIX = flag to fix)
120 N DDUCGL,DDUCKEY,DDUCKEY0,DDUCKID,DDUCNM,DDUCNML
121 S DDUCNM=""
122 F S DDUCNM=$O(^DD("KEY","BB",DDUCFI,DDUCNM)) Q:DDUCNM="" D
123 . S DDUCKEY=0
124 . F DDUCKEY=$O(^DD("KEY","BB",DDUCFI,DDUCNM,DDUCKEY)) Q:'DDUCKEY D
125 .. S DDUCKEY0=$G(^DD("KEY",DDUCKEY,0))
126 .. I $D(^DD("KEY",DDUCKEY)),$P(DDUCKEY0,U,2)="" S DDUCNML(DDUCKEY,DDUCNM)=""
127 .. E I $P(DDUCKEY0,U)'=DDUCFI!($P(DDUCKEY0,U,2)'=DDUCNM) D
128 ... S DDUCGL=$NA(^DD("KEY","BB",DDUCFI,DDUCNM,DDUCKEY))
129 ... D WEN(DDUCGL)
130 ... D:DDUCFIX KILL(DDUCGL)
131 ;
132 ;If any of the Keys have null Names, check whether a single name
133 ;for it was found in the "BB" index.
134 I $D(DDUCNML) S DDUCKEY=0 F S DDUCKEY=$O(DDUCNML(DDUCKEY)) Q:'DDUCKEY D
135 . S DDUCNM=$O(DDUCNML(DDUCKEY,""))
136 . I $O(DDUCNML(DDUCKEY,DDUCNM))="" D
137 .. S DDUCKID=$$KEYID(DDUCKEY,"")
138 .. D WNM
139 .. D:DDUCFIX FNM
140 . E F D S DDUCNM=$O(DDUCNML(DDUCKEY,DDUCNM)) Q:DDUCNM=""
141 .. S DDUCGL=$NA(^DD("KEY","BB",DDUCFI,DDUCNM,DDUCKEY))
142 .. D WEN(DDUCGL)
143 .. D:DDUCFIX KILL(DDUCGL)
144 Q
145 ;
146CHKF ;Check "F" index (In: DDUCFI = file; DDUCFIX = flag to fix)
147 N DDUCFLD,DDUCGL,DDUCKEY,DDUCIEN
148 S DDUCFLD=0
149 F S DDUCFLD=$O(^DD("KEY","F",DDUCFI,DDUCFLD)) Q:'DDUCFLD D
150 . S DDUCKEY=0
151 . F S DDUCKEY=$O(^DD("KEY","F",DDUCFI,DDUCFLD,DDUCKEY)) Q:'DDUCKEY D
152 .. S DDUCIEN=0
153 .. F S DDUCIEN=$O(^DD("KEY","F",DDUCFI,DDUCFLD,DDUCKEY,DDUCIEN)) Q:'DDUCIEN D
154 ... I $P($G(^DD("KEY",DDUCKEY,2,DDUCIEN,0)),U,2)'=DDUCFI!($P($G(^(0)),U)'=DDUCFLD) D
155 .... S DDUCGL=$NA(^DD("KEY","F",DDUCFI,DDUCFLD,DDUCKEY,DDUCIEN))
156 .... D WEN(DDUCGL)
157 .... D:DDUCFIX KILL(DDUCGL)
158 Q
159 ;
160 ;---------------
161FFILE ;Set the .01 of Key to DDUCFI
162 S $P(^DD("KEY",DDUCKEY,0),U)=DDUCFI
163 D WRITE("FILE (#.01) for "_DDUCKID_" set to "_DDUCFI_".",10)
164 Q
165 ;
166FNM ;Set the NAME for the Key
167 S $P(^DD("KEY",DDUCKEY,0),U,2)=DDUCNM
168 D WRITE("NAME for "_DDUCKID_" set to '"_DDUCNM_"'.",10)
169 Q
170 ;
171FPRI ;Set the PRIORITY for the Key
172 S $P(^DD("KEY",DDUCKEY,0),U,3)=DDUCPRI
173 D WRITE("PRIORITY for "_DDUCKID_" set to '"_DDUCPRI_"'.",10)
174 Q
175 ;
176KILL(GL) ;Kill a global and print a message
177 Q:'$D(@GL)
178 K @GL
179 W !?10,GL_" was killed."
180 Q
181 ;
182SET(GL,VAL) ;Set a global and print a message
183 Q:$D(@GL)
184 S VAL=$G(VAL),@GL=VAL
185 W !?10,GL_" was set"_$S(VAL]"":" to "_VAL,1:"")_"."
186 Q
187 ;
188 ;Write messages
189WCHK Q ;D WRITE("Checking Keys.",5) Q
190WNOKEY D WRITE(DDUCKID_" does not exist.",7) Q
191WMS(S,N) D WRITE(S_" is missing."_$S($G(N):" Nothing done.",1:""),7) Q
192WINC D WRITE("Field information in "_DDUCKEY_" is incomplete. Nothing done.",7) Q
193WFMS D WRITE("*File #"_DDUCFIL_", Field #"_DDUCFLD_" referenced in "_DDUCKEY_" is missing.",7) Q ;22*130
194WNE D WRITE("*Fields in "_DDUCKID_" don't match fields in Uniqueness Index.",7) Q ;22*130
195WEN(GL) D WRITE("Erroneous node "_GL_" is set.",7) Q
196WNM D WRITE("NAME for "_DDUCKID_" looks like it should be '"_DDUCNM_"'.",7) Q
197WPRI D WRITE("PRIORITY for "_DDUCKID_" looks like it should be '"_DDUCPRI_"'.",7) Q
198 ;
199WRITE(TXT,TAB) ;Write text, wrap at word boundaries.
200 N I
201 D WRAP^DIKCU2(.TXT,-TAB-2,-TAB)
202 W !?TAB,$G(TXT,$G(TXT(0))) F I=1:1 Q:'$D(TXT(I)) W !?TAB+2,TXT(I)
203 Q
204 ;
205KEYID(KEY,NM) ;Return string that identifies a Key
206 S:'$D(NM) NM=$P($G(^DD("KEY",KEY,0)),U,2)
207 Q $S(NM]"":"Key '"_NM_"' (#"_KEY_")",1:"Key #"_KEY)
Note: See TracBrowser for help on using the repository browser.