source: FOIAVistA/trunk/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/ZOSVKSOE.m@ 1166

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

initial load of FOIAVistA 6/30/08 version
File size: 9.2 KB
Line 
1%ZOSVKSE ;OAK/KAK - Automatic INTEGRIT Routine (Cache) ;5/9/07 10:46
2 ;;8.0;KERNEL;**90,94,197,268,456**;Jul 26, 2004
3 ;
4 ; Version for Cache
5 ;
6 Q
7 ;
8START(KMPSTEMP) ;-- called by routine CVMS+2^KMPSGE/CWINNT+1^KMPSGE in VAH
9 ;
10 ; KMPSTEMP... ^ piece 1: SiteNumber
11 ; piece 2: SessionNumber
12 ; piece 3: XTMP Global Location
13 ; piece 4: Current Date/Time
14 ; piece 5: Production UCI
15 ;
16 N DIRNAM,KMPSDT,KMPSERR,KMPSERR1,KMPSERR2,KMPSERR3,KMPSERR4
17 N KMPSLOC,KMPSPROD,KMPSSITE,KMPSVOL,KMPSZU,NUM,X,VERSION,ZV
18 ;
19 I $$NEWERR^%ZTER N $ETRAP,$ESTACK S $ETRAP="D ERROR^%ZOSVKSE"
20 E S X="ERROR^%ZOSVKSE",@^%ZOSF("TRAP")
21 ;
22 S U="^",KMPSSITE=$P(KMPSTEMP,U),NUM=$P(KMPSTEMP,U,2),KMPSLOC=$P(KMPSTEMP,U,3)
23 S KMPSDT=$P(KMPSTEMP,U,4),KMPSPROD=$P(KMPSTEMP,U,5),KMPSVOL=$P(KMPSTEMP,U,6)
24 K KMPSTEMP
25 S KMPSZU=$ZU(5)_","_KMPSVOL
26 S ^XTMP("KMPS","START",KMPSVOL,NUM)=$H
27 S VERSION=+($TR($E($ZV,38,43)," ",""))
28 ;
29UCI ;-- code from routine INTEGRIT/Integrity
30 ;
31 ; DIRNAM = directory name
32 S DIRNAM=KMPSVOL
33 ;
34 S ZV=$E($ZV,1,17)
35 I ZV="Cache for Windows" D UC1
36 I ZV="Cache for OpenVMS" D UC1VMS
37DONE ; normal exit
38 C 63
39 K ^XTMP("KMPS","START",KMPSVOL)
40 Q
41 ;
42UC1 ;-- entry point for Cache NT
43 ; code from routine INTEGRIT
44 ;
45 N A,BLK,CUR,DIRSTAT,ERR,G,GLOBAL,J,LEV,LINK,LNB,LNBLK,LNBYTE,LSNP,LTOTBLK,LTOTBYTE
46 N N,NB,NBLK,NBYTE,NP,RET,TL,TOTBLK,TOTBYTE
47 ;
48 ; prevent dismounted database
49 S DIRSTAT=$P($ZU(49,DIRNAM),",",1)
50 ; either dismounted or does not exist
51 I DIRSTAT<0 D ERR G ERROR
52 O 63:"^^"_DIRNAM
53 D INTEG1
54 I $G(GLOBAL(1))="" S ^XTMP("KMPS",KMPSSITE,NUM," NO GLOBALS ",KMPSVOL)="" Q
55 D EV1
56 Q
57 ;
58GLOCHK ;
59 N GLOINFO,JRNL,PROT,PROTINFO
60 ;
61 ; these extra logic ideas are from routine %GD
62 ; GLO = name ^ type ^ protection ^ growth_area ^ root_block (first pointer block) ^ journal ^ collate
63 S PROT=$P(GLO,U,3),PROT(0)="N",PROT(1)="R",PROT(2)="RW",PROT(3)="RWD"
64 ; protection - world ^ group ^ owner ^ network
65 S PROTINFO=PROT(PROT\16#4)_U_PROT(PROT\4#4)_U_PROT(PROT#4)_U_PROT(PROT\64#4)
66 S JRNL=$S($P(GLO,U,6):"Y",1:"N")
67 ; global info = jrnl^collating^blank^growth area block^blank^protection:world^group^owner^network^first pointer block
68 S GLOINFO=JRNL_U_$P(GLO,U,7)_"^^"_$P(GLO,U,4)_"^^"_PROTINFO_U_$P(GLO,U,5)
69 ; end of extra logic ideas
70 ;
71 S TOTBLK=TOTBLK+1
72 S G=$P(GLO,U,2,99),G=$P(G,U,4),LEV=1
73 ;
74 ; quit if global is implicit - do not process
75 I G\256=65535 Q
76 ;
77 S X="ERRHND^%ZOSVKSE",@^%ZOSF("TRAP")
78 S $ZE=""
79 ;
80B ; LEV(LEV) = root block
81 S LEV(LEV)=G
82 V G
83 S A=$V(2043,0)
84 ; find bottom level
85 I A=2!(A=6) S G=$V(2,-5),LEV=LEV+1 G B
86 ;
87 S X="",@^%ZOSF("TRAP")
88 ;
89 ; W LEV_" Levels in this global"
90 S (NBLK,LNBLK,NBYTE,LNBYTE)=0,CUR=1
91 ; LEV(1) = first block number
92 S ^XTMP("KMPS",KMPSSITE,NUM,KMPSDT,$P(GLO,U),KMPSZU)=LEV(1)_U_GLOINFO
93C S BLK=LEV(CUR),RET="RETURN^"_$ZN
94 ; W "Level: "_CUR_", "
95 ;
96 S X="ERRHND^%ZOSVKSE",@^%ZOSF("TRAP")
97 ;
98 D RESTART^%ZOSVKSS
99 ;
100 S X="",@^%ZOSF("TRAP")
101 ;
102 Q:+$G(^XTMP("KMPS","STOP"))
103RETURN S TOTBLK=NP+TOTBLK,LTOTBLK=LTOTBLK+LSNP
104 S TOTBYTE=TOTBYTE+NB,LTOTBYTE=LTOTBYTE+LNB
105 I $ZE="" S CUR=CUR+1 I CUR<LEV G C
106 ; W %TIM
107 Q
108ERRHND ; if there's an error from line tag B or from call
109 ; to RESTART^%ZOSVKVSS come here and skip the rest
110 ; of this global
111 S X="",@^%ZOSF("TRAP")
112 Q
113EV1 ;
114 N GC,GLO,GS
115 ;
116 S (TOTBLK,LTOTBLK,TOTBYTE,LTOTBYTE,GC)=0
117EV2 S GC=$O(GLOBAL(GC)),GS=1
118 ;
119 S ^XTMP("KMPS","START",KMPSVOL,NUM)=$H
120 ;
121 I GC=""!+$G(^XTMP("KMPS","STOP")) G EVL
122EV3 S GLO=$P(GLOBAL(GC),",",GS)
123 I GLO=""!+$G(^XTMP("KMPS","STOP")) G EVL
124 I GLO="*" G EV2
125 ; W "Global ^"_$P(GLO,U)
126 D GLOCHK
127 S GS=GS+1
128 G EV3
129EVL ; N TBLK
130 ; S TBLK=TOTBLK+LTOTBLK
131 ; W "Total global blocks in "_DIRNAM_" = "_TBLK
132 ; W "Total efficiency = "
133 ; I (TBLK) W ((TOTBYTE+LTOTBYTE)*100)\((2036*TOTBLK)+(2048*LTOTBLK))_"%"
134 Q
135ERR ;
136 I DIRSTAT=-1 S KMPSERR1=DIRNAM_" is dismounted"
137 I DIRSTAT=-2 S KMPSERR1=DIRNAM_" does not exist"
138 ; set the error variable
139 S $ZE="<UDIRECTORY>UC1+6^%ZOSVKSE"
140 Q
141 ;-- end code from routine INTEGRIT
142 ;
143INTEG1 ;-- code from routine INTEG1
144 ;
145 ; place global information into local variable GLOBAL array
146 ; GLOBAL(1:C) = gbl_info1, gbl_info2, ... * (no '*' on last)
147 ; gbl_info = name ^ type ^ protection ^ growth_area ^ root_block (first pointer block) ^ journal ^ collate
148 ;
149 N %ST,A,C,END,G,GD,INFO,NAM,P
150 ;
151 K GLOBAL
152 S C=1,GLOBAL(C)=""
153 V 1
154 D GFS^%ST
155 ; obtain global directory (GD) from system table array (%ST)
156 S GD=$V(%ST("GFOFFSET")+%ST("gfdir"),0,%ST("szdir")),G=0
157B1 V GD
158 S END=$V(2046,0,2),NAM="",P=0
159 ;
160NEXT G D1:END'>P
161 ;
162C1 ; build name
163 S A=$V(P,0),P=P+1
164 I A S NAM=NAM_$C(A) G C1
165 ;
166 ; info = type ^ protection ^ growth_area ^ root_block (first pointer block) ^ journal ^ collate
167 S INFO=$V(P,0,"2O")_U_$V(P+2,0)_U_$V(P+3,0,"3O")_U_$V(P+6,0,"3O")_U_$V(P,0)_U_$V(P+1,0)
168 ;
169 ; one entry
170 S GLOBAL=NAM_U_INFO
171 I $L(GLOBAL(C))>460 S GLOBAL(C)=GLOBAL(C)_"*",C=C+1,GLOBAL(C)=""
172 ;
173 S GLOBAL(C)=GLOBAL(C)_GLOBAL_","
174 ;
175 S G=G+1,P=P+9,NAM="" G NEXT
176D1 S GD=$V(2040,0,"3O") I GD G B1
177 Q
178 ;-- end code from routine INTEG1
179 ;
180ERROR ; ERROR - Tell all SAGG jobs to STOP collection
181 ;
182 C 63
183 S KMPSERR="Error encountered while running SAGG collection routine for volume set "_$G(KMPSVOL)
184 S KMPSERR2="Last global reference = "_$ZR
185 S KMPSERR3="Error code = "_$$EC^%ZOSV
186 I $D(KMPSERR4) S KMPSERR4="For more information, read text at line tag "_KMPSERR4_" in routine ^%ZOSVKSS"
187 ;
188 S ^XTMP("KMPS","ERROR",KMPSVOL)="",^XTMP("KMPS","STOP")=1
189 K ^XTMP("KMPS","START",KMPSVOL)
190 ;
191 D ^%ZTER,UNWIND^%ZTER
192 ;
193 Q
194 ;
195UC1VMS ;-- entry point for Cache VMS
196 ; code from routine Integrity (Cache v4.1.16)
197 ;
198 N GLOARRAY,RC
199 ;
200 ; set up GLOARRAY array indexed by global name
201 S RC=$$GETDIRGL^%ZOSVKSD(VERSION)
202 ;
203 I ('+RC) D ERRVMS G ERROR
204 ;
205 I '$D(GLOARRAY) S ^XTMP("KMPS",KMPSSITE,NUM," NO GLOBALS ",KMPSVOL)="" Q
206 ;
207 O 63:"^^"_DIRNAM
208 ;
209 D ALLGLO
210 ;
211 Q
212 ;
213ALLGLO ;- collect global info
214 ;
215 N COLLATE,DATASIZE,FBLK,GLO,GLOINFO,GLOTOTBLKS,GLOPNTBLKS,GLOTOTBYTES
216 N GLOPNTBYTES,GLOBIGBLKS,GLOBIGBYTES,GLOBIGSTRINGS,GRWBLK
217 N I,INFO,JRNL,LEV,MSGLIST,PROT,PROTECT,PROTINFO,RC,TPTRBLK,TRY
218 ;
219 S GLO="",RC=1
220 S PROT(0)="N",PROT(1)="R",PROT(2)="RW",PROT(3)="RWD"
221 ;
222 F S GLO=$O(GLOARRAY(GLO)) Q:GLO=""!+$G(^XTMP("KMPS","STOP")) D Q:+$G(^XTMP("KMPS","STOP"))!('+RC)
223 .;
224 .S (COLLATE,FBLK,GRWBLK,JRNL,PROTECT,TPTRBLK)=""
225 .S PROTINFO="^^^"
226 .;
227 .; return collation value for this global (GLO)
228 .;S RC=$$GetCollationType^%DM(DIRNAM,GLO,.COLLATE)
229 .;
230 .; return protection value for this global (GLO)
231 .;S RC=$$GetProtectState^%DM(DIRNAM,GLO,.PROTECT)
232 .;I +RC D
233 ..; protection - world ^ group ^ owner ^ network
234 ..;S PROTINFO=PROT(PROTECT\16#4)_U_PROT(PROTECT\4#4)_U_PROT(PROTECT#4)_U_PROT(PROTECT\64#4)
235 .;
236 .; return top pointer block and first data block for this global (GLO)
237 .;S RC=$$GetGlobalPointers^%DM(DIRNAM,GLO,.TPTRBLK,.FBLK)
238 .;
239 .;-- these extra logic ideas are from routine ^%GD
240 .; this code MUST use %utility($J) to properly work
241 .;K ^%utility($J)
242 .;
243 .; $$Fetch^%GD is NOT a PUBLIC API
244 .; <<< PUBLIC API $$GetJournalType^%DM did NOT work >>>
245 .;I $$Fetch^%GD(GLO,1,0) D
246 ..;S INFO=$G(^%utility($J,U_GLO))
247 ..;Q:INFO=""
248 ..;
249 ..;S GRWBLK=$P(INFO,U,2)
250 ..;S JRNL=$S($P(INFO,U,4):"Y",1:"N")
251 ..;
252 ..;K ^%utility($J)
253 ..;-- end of extra logic ideas from routine ^%GD
254 .;
255 .; global info - '^' delimited
256 .; piece 1: first block
257 .; piece 2: jrnl^collate
258 .; piece 3: bits(blank)
259 .; piece 4: growth area block
260 .; piece 5: protection:system(blank)
261 .; piece 6: protection:world
262 .; piece 7: group^owner
263 .; piece 8: network^top (first) pointer block
264 .S GLOINFO=FBLK_U_JRNL_U_COLLATE_"^^"_GRWBLK_"^^"_PROTINFO_U_TPTRBLK
265 .;
266 .S ^XTMP("KMPS",KMPSSITE,NUM,KMPSDT,GLO,KMPSZU)=GLOINFO
267 .;
268 .; check integrity of a single global
269 .; will stop if there are more than 999 errors with this global
270 .S RC=$$GLOINTEG^%ZOSVKSD(VERSION)
271 .;
272 .K MSGLIST
273 .D DCMPST^%ZOSVKSD(VERSION)
274 .;
275 .S (LEV,RC)=1
276 .F I=1:1:MSGLIST D
277 ..S INFO=MSGLIST(I),BLK=$$BLK(INFO),EFF=$$EFF(INFO)
278 ..;
279 ..; more than 999 errors reported
280 ..I INFO["***Further checking of this global is aborted." S RC=0 D ERRVMS1 Q
281 ..;
282 ..I ($P(INFO,":")["Top Pointer Level")!($P(INFO,":")["Top/Bottom Pnt Level") D Q
283 ...S ^XTMP("KMPS",KMPSSITE,NUM,GLO,KMPSZU,KMPSDT,1)=BLK_"^"_EFF_"%^Pointer"
284 ..I $P(INFO,":")["Pointer Level" D Q
285 ...S LEV=LEV+1,^XTMP("KMPS",KMPSSITE,NUM,GLO,KMPSZU,KMPSDT,LEV)=BLK_"^"_EFF_"%^Pointer"
286 ..I $P(INFO,":")["Bottom Pointer Level" D Q
287 ...S LEV=LEV+1,^XTMP("KMPS",KMPSSITE,NUM,GLO,KMPSZU,KMPSDT,LEV)=BLK_"^"_EFF_"%^Bottom pointer"
288 ..I $P(INFO,":")["Data Level" D Q
289 ...S ^XTMP("KMPS",KMPSSITE,NUM,GLO,KMPSZU,KMPSDT,"D")=BLK_"^"_EFF_"%^Data"
290 ..I $P(INFO,":")["Big Strings" D Q
291 ...S ^XTMP("KMPS",KMPSSITE,NUM,GLO,KMPSZU,KMPSDT,"L")=BLK_"^"_EFF_"%^LongString"
292 ;
293 I ('+RC) G ERROR
294 ;
295 Q
296 ;
297BLK(STRNG) ;-- function to obtain number of blocks from input string
298 ;
299 N BLK
300 Q:$G(STRNG)="" ""
301 S BLK=$$NOCOMMA($P($P(STRNG,"=",2)," "))
302 Q BLK
303 ;
304EFF(STRNG) ;-- function to obtain efficiency from input string
305 ;
306 N EFF
307 Q:$G(STRNG)="" ""
308 S EFF=$P($P(STRNG,"%"),"(",2)
309 Q EFF
310 ;
311NOCOMMA(IN) ;-- strip comma from input string
312 ;
313 Q $TR(IN,",","")
314 ;
315ERRVMS ;
316 S $ZE="<ERROR>UC1VMS+6^%ZOSVKSE"
317 I '+RC S KMPSERR1="ERROR: Cannot find global names for "_DIRNAM
318 Q
319 ;
320ERRVMS1 ;
321 S $ZE="<ERROR>ALLGLO+50^%ZOSVKSE"
322 S KMPSERR1="ERROR: Over 999 integrity errors with ^"_GLO_" in "_DIRNAM
323 Q
Note: See TracBrowser for help on using the repository browser.