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

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

initial load of WorldVistAEHR
File size: 5.0 KB
Line 
1DIKKP ;SFISC/MKO-PRINT KEYS ;9:52 AM 3 Mar 1998
2 ;;22.0;VA FileMan;;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 ;Print Keys defined a file
8 ;In:
9 ; FIL = File #
10 ; FLD = Field # (optional) (ignored if FLAG [ M)
11 ; FLAG [ Cn : column tab stop from left margin
12 ; [ Ln : left margin (def=0)
13 ; [ M : include subfiles (multiples) under File
14 ; [ S : suppress line feed before listing
15 ; PAGE("H") = Header text or M code that begins with a write statement
16 ; PAGE("B") = Bottom margin
17 ;Out:
18 ; PAGE(U) = Returns as 1, if timeout or ^ at eop
19 ;
20PRINT(FIL,FLD,FLAG,PAGE) ;Print keys
21 Q:'$G(FIL)
22 N FILETXT,LM,SB,SUB,TS,WID
23 ;
24 ;Initialize variables
25 D INIT
26 ;
27 ;M flag, get and print keys for file and subfiles
28 I FLAG["M" D
29 . D SUBFILES^DIKCU(FIL,.SB)
30 . S SUB=""
31 . F D Q:PAGE(U) S:SUB="" SUB="SUB",FIL=0 S FIL=$O(SB(FIL)) Q:'FIL
32 .. Q:'$D(^DD("KEY","B",FIL))
33 .. S FILETXT=SUB_"FILE #"_FIL
34 .. I SUB]""!(FLAG'["S") D WRLN("",0,.PAGE) Q:PAGE(U)
35 .. D WRLN(FILETXT,LM,.PAGE,2) Q:PAGE(U)
36 .. D WRLN($TR($J("",$L(FILETXT))," ","-"),LM,.PAGE) Q:PAGE(U)
37 .. D PRFILE(FIL,"",FLAG,.PAGE) Q:PAGE(U)
38 ;
39 ;Otherwise, print keys for one file
40 E D
41 . I FLAG'["S" D WRLN("",0,.PAGE) Q:PAGE(U)
42 . D PRFILE(FIL,$G(FLD),FLAG,.PAGE)
43 Q
44 ;
45PRFILE(FIL,FLD,FLAG,PAGE) ;Print keys for a file
46 Q:'$G(FIL)
47 N KEY,NAM,SP
48 I $G(FLAG)'["i" N LM,TS,WID D INIT
49 ;
50 I $G(FLD)="" D
51 . S NAM="" F S NAM=$O(^DD("KEY","BB",FIL,NAM)) Q:NAM="" D Q:PAGE(U)
52 .. S KEY=0 F S KEY=$O(^DD("KEY","BB",FIL,NAM,KEY)) Q:'KEY D Q:PAGE(U)
53 ... I $G(SP) D WRLN("",0,.PAGE) Q:PAGE(U)
54 ... D PRKEY(KEY,FLAG,.PAGE)
55 ... S SP=1
56 ;
57 E S KEY=0 F S KEY=$O(^DD("KEY","F",FIL,FLD,KEY)) Q:'KEY D Q:PAGE(U)
58 . I $G(SP) D WRLN("",0,.PAGE) Q:PAGE(U)
59 . D PRKEY(KEY,FLAG,.PAGE)
60 . S SP=1
61 Q
62 ;
63PRKEY(KEY,FLAG,PAGE) ;Print one key
64 Q:'$G(KEY)
65 N FIL,FLD,FLDN,LN,LUI,LUIN,NAM,PRI,SEQ,TAB1,TXT,UI,UI0
66 I $G(FLAG)'["i" N LM,TS,WID D INIT
67 ;
68 ;Print Priority, Key Name and Number
69 Q:$G(^DD("KEY",KEY,0))?."^"
70 S NAM=$P(^DD("KEY",KEY,0),U,2),PRI=$P(^(0),U,3),UI=$P(^(0),U,4)
71 S:PRI]"" PRI=$$EXTERNAL^DILFD(.31,1,"",PRI)
72 S TXT=PRI_" KEY: "
73 S TXT=TXT_$J("",TS-$L(TXT))_NAM_" (#"_KEY_")"
74 D WRLN(TXT,LM,.PAGE) Q:PAGE(U)
75 ;
76 ;Print Uniqueness Index
77 I UI D
78 . S UI0=$G(^DD("IX",UI,0))
79 . K TXT S TXT=0,TXT(0)=$P(UI0,U,2)_" (#"_UI_")"
80 . D:$P(UI0,U)'=$P(UI0,U,9) ADDSTR(" WHOLE FILE (#"_$P(UI0,U)_")",.TXT)
81 . D WRAP^DIKCU2(.TXT,WID)
82 . D WRLN("Uniqueness Index: "_TXT(0),LM+TS-18,.PAGE) Q:PAGE(U)
83 . F LN=1:1 Q:'$D(TXT(LN)) D WRLN(TXT(LN),LM+TS,.PAGE) Q:PAGE(U)
84 ;
85 ;Print Lookup Indexes
86 K TXT S TXT=0,TXT(0)=""
87 S LUIN=0 F S LUIN=$O(^DD("KEY",KEY,3.1,LUIN)) Q:'LUIN D
88 . S LUI=$P($G(^DD("KEY",KEY,3.1,LUIN,0)),U) Q:'LUI
89 . S:TXT(TXT)]"" TXT(TXT)=TXT(TXT)_", "
90 . D ADDSTR($P($G(^DD("IX",LUI,0)),U,2)_" (#"_LUI_")",.TXT)
91 I TXT(0)]"" D Q:PAGE(U)
92 . D WRAP^DIKCU2(.TXT,WID)
93 . D WRLN("Lookup Index(es): "_TXT(0),LM+TS-18,.PAGE) Q:PAGE(U)
94 . F LN=1:1 Q:'$D(TXT(LN)) D WRLN(TXT(LN),LM+TS,.PAGE) Q:PAGE(U)
95 ;
96 ;Print Fields
97 K TXT S TXT=0,TXT(0)=""
98 S SEQ=0 F S SEQ=$O(^DD("KEY",KEY,2,"S",SEQ)) Q:'SEQ D Q:PAGE(U)
99 . S FLD=0 F S FLD=$O(^DD("KEY",KEY,2,"S",SEQ,FLD)) Q:'FLD D Q:PAGE(U)
100 .. S FIL=0 F S FIL=$O(^DD("KEY",KEY,2,"S",SEQ,FLD,FIL)) Q:'FIL D Q:PAGE(U)
101 ... S FLDN=0 F S FLDN=$O(^DD("KEY",KEY,2,"S",SEQ,FLD,FIL,FLDN)) Q:'FLDN D Q:PAGE(U)
102 .... Q:$G(^DD("KEY",KEY,2,FLDN,0))?."^"
103 .... S:TXT(TXT)]"" TXT(TXT)=TXT(TXT)_" "
104 .... D ADDSTR(SEQ_")"_$C(0)_$P($G(^DD(FIL,FLD,0)),U)_" ("_FIL_","_FLD_")",.TXT)
105 I TXT(0)]"" D Q:PAGE(U)
106 . D WRAP^DIKCU2(.TXT,WID)
107 . D WRLN("File, Field: "_TXT(0),LM+TS-13,.PAGE) Q:PAGE(U)
108 . F LN=1:1 Q:'$D(TXT(LN)) D WRLN(TXT(LN),LM+TS,.PAGE) Q:PAGE(U)
109 Q
110 ;
111ADDSTR(X,TXT) ;Add string X to the TXT array
112 I $L(TXT(TXT))+$L(X)>200 S TXT=TXT+1,TXT(TXT)=""
113 S TXT(TXT)=TXT(TXT)_X
114 Q
115 ;
116INIT ;Initialize module-wide variables
117 Q:$G(FLAG)["i"
118 S FLAG=$G(FLAG)_"i"
119 S LM=$P(FLAG,"L",2)\1
120 S TS=$P(FLAG,"C",2)\1 S:'TS TS=20
121 S WID=$G(IOM,80)-1-LM-TS S:WID<1 WID=1
122 S PAGE(U)=""
123 Q
124 ;
125 ;===================================
126 ; WRLN(Text,Tab,.Page,KeepWithNext)
127 ;===================================
128 ;Write a single line of text, precede with a !, do paging if necessary
129 ;In:
130 ; TXT = Text to write; $C(0) replaced with spaces.
131 ; TAB = ?Tab before writing text (def=0)
132 ; PAGE("H") = Header text or M code that begins with a write statement
133 ; If not passed in, no paging.
134 ; PAGE("B") = Bottom margin
135 ; KWN = Additional padding on bottom margin ("keep with next")
136 ;Out:
137 ; PAGE(U) = Returns as 1, if timeout or ^ at eop
138 ;
139WRLN(TXT,TAB,PAGE,KWN) ;Write a line of text
140 N X
141 S PAGE(U)=""
142 ;
143 ;Do paging, if necessary
144 I $D(PAGE("H"))#2,$G(IOSL,24)-2-$G(PAGE("B"))-$G(KWN)'>$Y D Q:PAGE(U)
145 . I PAGE("H")?1"W ".E X PAGE("H") Q
146 . I $E($G(IOST,"C"))="C" D Q:PAGE(U)
147 .. W $C(7) R X:$G(DTIME,300) I X=U!'$T S PAGE(U)=1
148 . W @$G(IOF,"#"),PAGE("H")
149 ;
150 ;Write text
151 W !?$G(TAB),$TR($G(TXT),$C(0)," ")
152 Q
Note: See TracBrowser for help on using the repository browser.