source: FOIAVistA/tag/r/VA_FILEMAN-ARJT-DI-DD-DM-DT-%DT-%RCR/DIKCP1.m@ 636

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

initial load of FOIAVistA 6/30/08 version
File size: 6.3 KB
Line 
1DIKCP1 ;SFISC/MKO-PRINT INDEX(ES) ;11:21 AM 12 Jan 2000
2 ;;22.0;VA FileMan;**20**;Mar 30, 1999
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4PRINDEX ;Come here from PRINDEX^DIKCP
5 Q:'$G(XR)
6 N XR0
7 I $G(FLAG)'["i" N LM,TYP,TS,WID D INIT^DIKCP
8 S XR0=$G(^DD("IX",XR,0)) Q:XR0?."^"
9 ;
10 ;Print first line of information
11 D FL(XR0,WID,LM,TS,TYP,.PAGE) Q:PAGE(U)
12 I FLAG'["S" D WRLN("",0,.PAGE) Q:PAGE(U)
13 ;
14 ;Print Keys with this Uniqueness Index
15 D KEY(XR,WID,LM,TS,.PAGE) Q:PAGE(U)
16 ;
17 ;Print short description
18 I $P(XR0,U,3)]"" D Q:PAGE(U)
19 . D WLP("Short Descr: ",$P(XR0,U,3),WID,LM+TS,0,.PAGE)
20 ;
21 ;Print description
22 I $O(^DD("IX",XR,.1,0)) D Q:PAGE(U)
23 . D WRWP($NA(^DD("IX",XR,.1)),LM,WID,"Description: ",TS,.PAGE)
24 I FLAG'["S" D WRLN("",0,.PAGE) Q:PAGE(U)
25 ;
26 ;Print logic
27 I FLAG'["N" D Q:PAGE(U)
28 . D LOGIC(XR,WID,LM,TS,FLAG,.PAGE) Q:PAGE(U)
29 . I FLAG'["S" D WRLN("",0,.PAGE)
30 ;
31 ;Print Cross Reference Values
32 D CRV(XR,WID,LM,TS,FLAG,.PAGE)
33 Q
34 ;
35FL(XR0,WID,LM,TS,TYP,PAGE) ;Print first line
36 N ACT,EXEC,NAME,RTYP,SP,TYPE,TXT,USE
37 ;
38 S SP=$J("",4)
39 S EXEC=$$EXTERNAL^DILFD(.11,.4,"",$P(XR0,U,6))
40 S NAME=$P(XR0,U,2)_" (#"_XR_")"
41 S TYPE=$$EXTERNAL^DILFD(.11,.2,"",$P(XR0,U,4))
42 S ACT=$P(XR0,U,7)
43 S USE=$TR($$EXTERNAL^DILFD(.11,.42,"",$P(XR0,U,14))," ",$C(0))
44 S RTYP=$P(XR0,U,8) S:"I"[RTYP RTYP=""
45 S:RTYP]"" RTYP=$TR($$EXTERNAL^DILFD(.11,.5,"",RTYP)," ",$C(0))
46 S:RTYP]"" RTYP=SP_RTYP_$C(0)_"(#"_$P(XR0,U)_")"
47 ;
48 ;Print first line
49 I TYP=1 D
50 . S TXT=EXEC_" INDEX: ",TXT=TXT_$J("",TS-$L(TXT))
51 . S TXT=TXT_NAME_SP_TYPE_SP_ACT_SP_USE_RTYP
52 E S TXT=NAME_SP_EXEC_SP_TYPE_SP_ACT_SP_USE_RTYP
53 ;
54 D WRPHI(TXT,WID,LM,TS,0,.PAGE)
55 Q
56 ;
57KEY(XR,WID,LM,TS,PAGE) ;Print keys that have XR as Uniqueness Index
58 Q:'$D(^DD("KEY","AU",XR))
59 N KEY,KEY0,KEYLN,TXT
60 ;
61 S TXT=0,TXT(0)=""
62 S KEY=0 F S KEY=$O(^DD("KEY","AU",XR,KEY)) Q:'KEY D
63 . S KEY0=$G(^DD("KEY",KEY,0)) Q:KEY0?."^"
64 . S KEYLN="Key "_$P(KEY0,U,2)_" (#"_KEY_"), File #"_$P(KEY0,U)
65 . S:$G(TXT(TXT))]"" TXT(TXT)=TXT(TXT)_"; "
66 . D ADDSTR($TR(KEYLN," ",$C(0)),.TXT)
67 Q:$G(TXT(0))=""
68 D WLP("Unique for: ",.TXT,WID,LM+TS,0,.PAGE)
69 Q
70 ;
71LOGIC(XR,WID,LM,TS,FLAG,PAGE) ;Print set and kill logic
72 N CD,LN
73 S CD=$G(^DD("IX",XR,1))
74 I CD'?."^" D Q:PAGE(U)
75 . D WLP("Set Logic: ",CD,WID,LM+TS,1,.PAGE) Q:PAGE(U)
76 . S LN=0 F S LN=$O(^DD("IX",XR,1.2,LN)) Q:LN'=+LN D Q:PAGE(U)
77 .. S CD=$G(^DD("IX",XR,1.2,LN,1))
78 .. I CD'?."^" D WLP(LN_") ",CD,WID,LM+TS,1,.PAGE)
79 S CD=$G(^DD("IX",XR,1.4))
80 I CD'?."^" D WLP("Set Cond: ",CD,WID,LM+TS,1,.PAGE) Q:PAGE(U)
81 ;
82 S CD=$G(^DD("IX",XR,2))
83 I CD'?."^" D Q:PAGE(U)
84 . D WLP("Kill Logic: ",CD,WID,LM+TS,1,.PAGE) Q:PAGE(U)
85 . S LN=0 F S LN=$O(^DD("IX",XR,2.2,LN)) Q:LN'=+LN D Q:PAGE(U)
86 .. S CD=$G(^DD("IX",XR,2.2,LN,2))
87 .. I CD'?."^" D WLP(LN_") ",CD,WID,LM+TS,1,.PAGE)
88 S CD=$G(^DD("IX",XR,2.4))
89 I CD'?."^" D WLP("Kill Cond: ",CD,WID,LM+TS,1,.PAGE) Q:PAGE(U)
90 S CD=$G(^DD("IX",XR,2.5))
91 I CD'?."^" D WLP("Whole Kill: ",CD,WID,LM+TS,1,.PAGE) Q:PAGE(U)
92 Q
93 ;
94CRV(XR,WID,LM,TS,FLAG,PAGE) ;Print cross reference values
95 N CD,CV,CV0,FL,FD,LAB,ORD,TXT
96 S ORD="" F S ORD=$O(^DD("IX",XR,11.1,"B",ORD)) Q:ORD="" D Q:PAGE(U)
97 . S CV=$O(^DD("IX",XR,11.1,"B",ORD,0)) Q:'CV
98 . Q:$G(^DD("IX",XR,11.1,CV,0))?."^" S CV0=^(0)
99 . S LAB=$S(FLAG'["N":"X("_ORD_"): ",1:ORD_": ")
100 . ;
101 . ;Field-type values
102 . I $P(CV0,U,2)="F" D Q:PAGE(U)
103 .. S FL=$P(CV0,U,3),FD=$P(CV0,U,4)
104 .. I FL,FD S TXT=$P($G(^DD(FL,FD,0)),U)_" ("_FL_","_FD_")"
105 .. E S TXT="<undefined file/field>"
106 .. D CRVOTH(CV0,.TXT)
107 .. D WLP(LAB,TXT,WID,LM+TS,"",.PAGE)
108 . ;
109 . ;Computed-type values
110 . E D Q:PAGE(U)
111 .. S CD=$G(^DD("IX",XR,11.1,CV,1.5))
112 .. I CD'?."^" D
113 ... S TXT=$S(FLAG["N":"<computed>",1:"Computed Code: "_CD)
114 .. E S TXT="<undefined computed code>"
115 .. D WLP(LAB,TXT,WID,LM+TS,1,.PAGE) Q:PAGE(U)
116 .. S TXT=""
117 .. D CRVOTH(CV0,.TXT)
118 .. D WLP("",TXT,WID,LM+TS,"",.PAGE)
119 . ;
120 . ;Lookup prompt
121 . I $P(CV0,U,8)]"" D Q:PAGE(U)
122 .. D WLP("Lookup Prompt: ",$P(CV0,U,8),WID-18,LM+TS+18,"",.PAGE)
123 . ;
124 . ;Transform
125 . I FLAG'["N" D
126 .. S CD=$G(^DD("IX",XR,11.1,CV,2))
127 .. I CD'?."^" D WLP("Transform (Storage): ",CD,WID-24,LM+TS+24,1,.PAGE)
128 .. S CD=$G(^DD("IX",XR,11.1,CV,4))
129 .. I CD'?."^" D WLP(" Transform (Lookup): ",CD,WID-24,LM+TS+24,1,.PAGE)
130 .. S CD=$G(^DD("IX",XR,11.1,CV,3))
131 .. I CD'?."^" D WLP("Transform (Display): ",CD,WID-24,LM+TS+24,1,.PAGE)
132 Q
133 ;
134CRVOTH(CV0,TXT) ;Get other attributes of Cross Reference Value
135 S:$P(CV0,U,6) TXT=TXT_" (Subscr"_$C(0)_$P(CV0,U,6)_")"
136 S:$P(CV0,U,5) TXT=TXT_" (Len"_$C(0)_$P(CV0,U,5)_")"
137 I $P(CV0,U,7)]"" D
138 . S TXT=TXT_" ("_$$EXTERNAL^DILFD(.114,7,"",$P(CV0,U,7))_")"
139 Q
140 ;
141ADDSTR(X,TXT) ;Add string X to the TXT array
142 I $L(TXT(TXT))+$L(X)>200 S TXT=TXT+1,TXT(TXT)=""
143 S TXT(TXT)=TXT(TXT)_X
144 Q
145 ;
146WRPHI(TXT,WID,LM,TS,COD,PAGE) ;Write a paragraph with a hanging indent
147 N LAB,LN,TAB
148 S:$D(TXT(0))[0 TXT(0)=$G(TXT)
149 S LAB=$E(TXT(0),1,$G(TS)),TXT(0)=$E(TXT(0),$G(TS)+1,999)
150 D WRAP^DIKCU2(.TXT,WID,"",$G(COD))
151 D WRLN($G(LAB)_TXT(0),$G(LM),.PAGE) Q:PAGE(U)
152 F LN=1:1 Q:'$D(TXT(LN)) D WRLN(TXT(LN),$G(LM)+$G(TS),.PAGE) Q:PAGE(U)
153 Q
154 ;
155WLP(LAB,TXT,WID,TAB,COD,PAGE,WFLAG) ;Write a labeled paragraph
156 N LN
157 S:$D(TXT(0))[0 TXT(0)=$G(TXT)
158 D WRAP^DIKCU2(.TXT,WID,"",$G(COD))
159 D WRLN($G(LAB)_TXT(0),TAB-$L(LAB),.PAGE) Q:PAGE(U)
160 F LN=1:1 Q:'$D(TXT(LN)) D WRLN(TXT(LN),TAB,.PAGE) Q:PAGE(U)
161 S WFLAG=LN>1
162 Q
163 ;
164WRLN(TXT,TAB,PAGE,KWN) ;Write a line of text
165 ;See ^DIKCP for documentation
166 N X
167 S PAGE(U)=""
168 ;
169 ;Do paging, if necessary
170 I $D(PAGE("H"))#2,$G(IOSL,24)-2-$G(PAGE("B"))-$G(KWN)'>$Y D Q:PAGE(U)
171 . I PAGE("H")?1"W ".E X PAGE("H") Q
172 . I $E($G(IOST,"C"))="C" D Q:PAGE(U)
173 .. W $C(7) R X:$G(DTIME,300) I X=U!'$T S PAGE(U)=1
174 . W @$G(IOF,"#"),PAGE("H")
175 ;
176 ;Write text
177 W !?$G(TAB),$TR($G(TXT),$C(0)," ")
178 Q
179 ;
180WRWP(ROOT,LM,WID,LAB,TS,PAGE) ;Call DIWP/DIWW to format a wp field.
181 ;Then write the formatted lines.
182 Q:$G(ROOT)="" Q:'$D(@ROOT)
183 N DIWF,DIWL,DIWR,LN,X
184 N DIW,DIWI,DIWT,DIWTC,DIWX,DN,I,Z
185 K ^UTILITY($J,"W")
186 ;
187 S LM=$G(LM)\1,WID=$G(WID)\1,TS=$G(TS)\1,LAB=$G(LAB)
188 I 'WID S WID=$G(IOM,80)-1-LM-TS S:WID<1 WID=1
189 S DIWL=0,DIWR=WID,DIWF="|"
190 S LN=0 F S LN=$O(@ROOT@(LN)) Q:'LN S X=$G(@ROOT@(LN,0)) D ^DIWP
191 ;
192 D WRLN($G(LAB)_$G(^UTILITY($J,"W",DIWL,1,0)),LM+TS-$L(LAB),.PAGE)
193 G:$G(PAGE(U)) WRWPQ
194 ;
195 S LN=1 F S LN=$O(^UTILITY($J,"W",DIWL,LN)) Q:'LN D Q:$G(PAGE(U))
196 . D WRLN(^UTILITY($J,"W",DIWL,LN,0),LM+TS,.PAGE)
197 ;
198WRWPQ ;Cleanup and quit
199 K ^UTILITY($J,"W")
200 Q
Note: See TracBrowser for help on using the repository browser.