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

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

initial load of WorldVistAEHR
File size: 6.3 KB
Line 
1DIKCP ;SFISC/MKO-PRINT INDEX(ES) ;11:33 AM 1 Nov 1999
2 ;;22.0;VA FileMan;**11**;Mar 30, 1999
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4 ;==============================
5 ; PRINT(File,Field,Flag,.Page)
6 ;==============================
7 ;In:
8 ; FIL = File #
9 ; FLD = Field # (optional) (ignored if FLAG [ M)
10 ; FLAG [ Cn : column tab stop from left margin (def=18)
11 ; [ F : print field-level indexes
12 ; [ Ln : left margin (def=0)
13 ; [ M : include subfiles (multiples) under File
14 ; [ N : don't print any mumps code
15 ; [ O : print traditional 1-node cross references
16 ; [ R : print record-level indexes
17 ; [ S : single space (no blank lines)
18 ; [ Tn : type (style) of 1st lines of each xref
19 ; PAGE("H") = header text or M code that begins with a write statement
20 ; If text : eop read issued; and @IOF, PAGE("H")
21 ; is written automatically
22 ; If M code : code must issue eop read, write @IOF, and
23 ; write the header.
24 ; undefined : no paging
25 ;
26 ; PAGE("B") = bottom margin
27 ;Out:
28 ; PAGE(U) = returns as 1, if timeout or ^ at eop
29 ;Notes:
30 ; Type 0 : Used for the listings at the beg and end of report.
31 ; First line looks like:
32 ; AC (#30) REGULAR FIELD IR SORTING ONLY
33 ;
34 ; Type 1 : Used for the listing with each field.
35 ; First line looks like:
36 ; FIELD INDEX: AC (#30) REGULAR IR SORTING ONLY
37 ;
38PRINT(FIL,FLD,FLAG,PAGE) ;Print all indexes on one file(/field)
39 Q:'$G(FIL)
40 N HSTR,LM,SB,TOP,TS,TYP,WID
41 ;
42 ;Initialize variables
43 D INIT
44 ;
45 ;M flag, print file and subfile indexes
46 I FLAG["M" D
47 . D SUBFILES^DIKCU(FIL,.SB)
48 . S TOP=1 F D Q:PAGE(U) S FIL=$O(SB(FIL)) Q:'FIL
49 .. I FLAG["R"!(FLAG["F"),$D(^DD("IX","AC",FIL)) D
50 ... D PRFILE(FIL,"",FLAG,.PAGE)
51 .. E I FLAG["O",$D(^DD(FIL,"IX")) D
52 ... D PRFILE(FIL,"",FLAG,.PAGE)
53 .. I $G(TOP) S FIL=0 K TOP
54 ;
55 E D PRFILE(FIL,$G(FLD),FLAG,.PAGE)
56 Q
57 ;
58PRFILE(FIL,FLD,FLAG,PAGE) ;Print indexes for 1 file
59 Q:'$G(FIL)
60 N FHDR,HDR,NAM,NO,XR,XRL
61 I $G(FLAG)'["i" N LM,TS,TYP,WID D INIT
62 ;
63 ;Print traditional xrefs
64 I FLAG["O" D PRFILE^DIKCP3(FIL,$G(FLD),FLAG,.PAGE,.FHDR) Q:PAGE(U)
65 I FLAG'["F",FLAG'["R" Q
66 ;
67 ;Print indexes
68 I $G(FLD)="" D
69 . ;Build list of xrefs sorted by name
70 . S XR=0 F S XR=$O(^DD("IX","AC",FIL,XR)) Q:'XR D
71 .. Q:$G(^DD("IX",XR,0))?."^" Q:FLAG'[$P(^(0),U,6) S NAM=$P(^(0),U,2)
72 .. S:NAM="" NAM=" <no name"_$G(NO)_">",NO=$G(NO)+1
73 .. S XRL(NAM,XR)=""
74 . ;
75 . ;Loop through sorted list
76 . S NAM="" F S NAM=$O(XRL(NAM)) Q:NAM="" D Q:PAGE(U)
77 .. S XR=0 F S XR=$O(XRL(NAM,XR)) Q:'XR D Q:PAGE(U)
78 ... I '$G(FHDR) D FHDR(FIL,FLAG,.PAGE,.FHDR) Q:PAGE(U)
79 ... I '$G(HDR) D HDR(FIL,FLAG,LM,.PAGE,.HDR) Q:PAGE(U)
80 ... D PRINDEX(XR,FLAG,.PAGE) Q:PAGE(U)
81 ... D WRLN("",0,.PAGE) Q:PAGE(U)
82 ... I FLAG'["S" D WRLN("",0,.PAGE)
83 ;
84 E S XR=0 F S XR=$O(^DD("IX","F",FIL,FLD,XR)) Q:'XR D Q:PAGE(U)
85 . Q:$D(^DD("IX",XR,0))?."^" Q:FLAG'[$P(^(0),U,6)
86 . I '$G(FHDR) D FHDR(FIL,FLAG,.PAGE,.FHDR) Q:PAGE(U)
87 . I '$G(HDR) D HDR(FIL,FLAG,LM,.PAGE,.HDR) Q:PAGE(U)
88 . D PRINDEX(XR,FLAG,.PAGE) Q:PAGE(U)
89 . D WRLN("",0,.PAGE) Q:PAGE(U)
90 . I FLAG'["S" D WRLN("",0,.PAGE)
91 Q
92 ;
93PRINDEX(XR,FLAG,PAGE) ;Print one index
94 G PRINDEX^DIKCP1
95 ;
96HDR(FIL,FLAG,LM,PAGE,HDR) ;Print header for indexes
97 S HDR=1
98 I FLAG'["M",FLAG'["O" Q
99 D WRLN($S(FLAG["R"&(FLAG["F"):"New-Style",FLAG["R":"Record",1:"Field")_" Indexes:",LM,.PAGE,2) Q:PAGE(U)
100 D WRLN("",0,.PAGE)
101 Q
102 ;
103FHDR(FIL,FLAG,PAGE,FHDR) ;Print header for file
104 S FHDR=1
105 Q:FLAG'["M"
106 D WRLN($P("F^Subf",U,$D(^DD(FIL,0,"UP"))#2+1)_"ile #"_FIL,0,.PAGE,2) Q:PAGE(U)
107 D WRLN("",0,.PAGE)
108 Q
109 ;
110 ;=============================
111 ; LIST(File,Field,Flag,.Page)
112 ;=============================
113 ;List Indexes that reside on a given file.
114 ;In:
115 ; Same as PRINT above (except that N and O flag don't apply)
116 ;Out:
117 ; PAGE(U) = Returns as 1, if timeout or ^ at eop
118 ;Notes:
119 ; Type 0 : Used for the listing of Indexes on a file or subfile
120 ; INDEXED BY: ANOTHER FIELD (AC), SET & FREE (C),
121 ; ANOTHER FIELD & EXTRACT (D)
122 ;
123 ; Type 1 : Used for the listing of Record Indexes with each field.
124 ; RECORD INDEXES: WF (#22) [WHOLE FILE on #9999)],
125 ; WF (#24), AC (#52)
126 ;
127LIST(FIL,FLD,FLAG,PAGE) ;
128 Q:'$G(FIL)
129 N LAB,LM,SB,SUB,TS,TYP,WID
130 ;
131 ;Initialize variables
132 D INIT
133 ;
134 ;Set label
135 I TYP=1 D
136 . I FLAG["R",FLAG["F" S LAB="INDEXES: "
137 . E I FLAG["R" S LAB="RECORD INDEXES: "
138 . E S LAB="FIELD INDEXES: "
139 E S LAB="INDEXED BY: "
140 S LAB=LAB_$J("",TS-$L(LAB))
141 ;
142 ;M flag, get and list for file and subfiles
143 I FLAG["M" D
144 . D SUBFILES^DIKCU(FIL,.SB)
145 . S SUB=""
146 . F D Q:PAGE(U) S:SUB="" SUB="SUB",FIL=0 S FIL=$O(SB(FIL)) Q:'FIL
147 .. Q:'$D(^DD("IX","B",FIL))
148 .. I SUB]""!(FLAG'["S") D WRLN("",0,.PAGE) Q:PAGE(U)
149 .. D WRLN(SUB_"FILE #"_FIL,LM,.PAGE,1) Q:PAGE(U)
150 .. D LFILE(FIL,"",FLAG,LAB,.PAGE) Q:PAGE(U)
151 ;
152 ;Otherwise, just list for one file
153 E D
154 . I FLAG'["S" D WRLN("",0,.PAGE) Q:PAGE(U)
155 . D LFILE(FIL,$G(FLD),FLAG,LAB,.PAGE)
156 Q
157 ;
158LFILE(FIL,FLD,FLAG,LAB,PAGE) ;Format list of indexes and print
159 G LFILE^DIKCP2
160 ;
161INIT ;Initialize module-wide variables
162 Q:$G(FLAG)["i"
163 S FLAG=$G(FLAG)_"i"
164 I FLAG'["F",FLAG'["R",FLAG'["O" S FLAG="OFR"_FLAG
165 S LM=+$P(FLAG,"L",2)\1
166 S TS=+$P(FLAG,"C",2) S:'TS TS=18
167 S TYP=+$P(FLAG,"T",2)\1
168 S WID=$G(IOM,80)-1-LM-TS S:WID<1 WID=1
169 S PAGE(U)=""
170 Q
171 ;
172 ;===================================
173 ; WRLN(Text,Tab,.Page,KeepWithNext)
174 ;===================================
175 ;Write a single line of text, precede with a !, do paging if necessary
176 ;In:
177 ; TXT = Text to write; $C(0) replaced with spaces.
178 ; TAB = ?Tab before writing text (def=0)
179 ; PAGE("H") = Header text or M code that begins with a write statement
180 ; If not passed in, no paging.
181 ; PAGE("B") = Bottom margin
182 ; KWN = Additional padding on bottom margin ("keep with next")
183 ;Out:
184 ; PAGE(U) = Returns as 1, if timeout or ^ at eop
185 ;
186WRLN(TXT,TAB,PAGE,KWN) ;Write a line of text
187 N X
188 S PAGE(U)=""
189 ;
190 ;Do paging, if necessary
191 I $D(PAGE("H"))#2,$G(IOSL,24)-2-$G(PAGE("B"))-$G(KWN)'>$Y D Q:PAGE(U)
192 . I PAGE("H")?1"W ".E X PAGE("H") Q
193 . I $E($G(IOST,"C"))="C" D Q:PAGE(U)
194 .. W $C(7) R X:$G(DTIME,300) I X=U!'$T S PAGE(U)=1
195 . W @$G(IOF,"#"),PAGE("H")
196 ;
197 ;Write text
198 W !?$G(TAB),$TR($G(TXT),$C(0)," ")
199 Q
Note: See TracBrowser for help on using the repository browser.