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

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

initial load of FOIAVistA 6/30/08 version
File size: 6.8 KB
Line 
1DIKCUTL2 ;SFISC/MKO-UTILITY OPTION TO MODIFY INDEX ;12:15 PM 1 Nov 2001
2 ;;22.0;VA FileMan;**68**;Mar 30, 1999
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4 ;
5 ;========
6 ; $$TYPE
7 ;========
8 ;Prompt for type xref (to reindex or modify)
9 ;Returns:
10 ; '1' for Traditional; or
11 ; '2' for New
12 ;
13TYPE() ;
14 N DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,Y
15 S DIR(0)="SAM^1:TRADITIONAL;2:NEW"
16 S DIR("A")="What type of cross-reference (Traditional or New)? "
17 S DIR("B")="Traditional"
18 S DIR("?",1)="Enter 'T' to select a Traditional cross-reference."
19 S DIR("?",2)=" Traditional cross references are stored in the data"
20 S DIR("?",3)=" dictionary under ^DD(file#,field#,1)."
21 S DIR("?",4)=" "
22 S DIR("?",5)="Enter 'N' to select a New-Style cross-reference."
23 S DIR("?",6)=" New-Style cross references are stored in the Index file."
24 S DIR("?",7)=" Compound indexes (indexes based on more than one field)"
25 S DIR("?")=" are examples of New-Style cross-references."
26 D ^DIR
27 Q $S($D(DIRUT):"",1:Y)
28 ;
29 ;==========================
30 ; GETXR(file#,.count,flag)
31 ;==========================
32 ;Loop through the "AC" index to get the list of Index file
33 ;xrefs with root file FIL.
34 ;In:
35 ; FIL = Root file #
36 ; FLG [ "M" : also get xrefs on subfiles of FIL
37 ;Out:
38 ; CNT = # xrefs^rootFile# (or null if FLG [ "M")
39 ; CNT(xref#) = rootFile#^File#^xrefName^rootType^UI[if uniq index]
40 ;
41GETXR(FIL,CNT,FLG) ;
42 N F,SB,XR
43 K CNT
44 D:$G(FLG)["M" SUBFILES^DIKCU(FIL,.SB)
45 S SB(FIL)=""
46 ;
47 S (CNT,F)=0 F S F=$O(SB(F)) Q:'F D
48 . S XR=0 F S XR=$O(^DD("IX","AC",F,XR)) Q:'XR D
49 .. I $G(^DD("IX",XR,0))?."^" K ^DD("IX","AC",F,XR) Q
50 .. S CNT=CNT+1
51 .. S CNT(XR)=F_U_$P($G(^DD("IX",XR,0)),U,1,2)_U_$P(^(0),U,8)
52 .. S:$D(^DD("KEY","AU",XR)) $P(CNT(XR),U,5)="UI"
53 ;
54 S:$G(FLG)'["M" $P(CNT,U,2)=FIL
55 Q
56 ;
57 ;============================
58 ; LIST(.count,header,screen)
59 ;============================
60 ;List the xrefs in the CNT array
61 ;In:
62 ; CNT = Array of xrefs to print (obtained by GETXR call above)
63 ; HDR = Text to print before listing
64 ; (default is 'Current Indexes[ on [sub]file #xxx]:')
65 ; SCR = Sets $T to screen out indexes (Y = index#)
66 ;
67LIST(CNT,HDR,SCR) ;
68 I '$G(CNT) W:$P(CNT,U,2) !,"There are no INDEX file cross-references defined on "_$$FSTR($P(CNT,U,2))_"." Q
69 N FIL,I,ONEFIL,RFIL,TYP,TXT,UI,XR,Y
70 ;
71 S ONEFIL=$P(CNT,U,2)
72 S:$G(HDR)="" HDR="Current Indexes"_$S(ONEFIL:" on "_$$FSTR(ONEFIL),1:"")_":"
73 W !,HDR
74 ;
75 S XR=0 F S XR=$O(CNT(XR)) Q:'XR D
76 . I $G(SCR)]"" K Y S Y=XR,Y(0)=CNT(XR) X SCR K Y E Q
77 . S FIL=$P(CNT(XR),U,2),RFIL=$P(CNT(XR),U),TYP=$P(CNT(XR),U,4)
78 . S UI=$S($P(CNT(XR),U,5)="UI":"uniqueness ",1:"")
79 . S RFIL=$S('ONEFIL:" on "_$$FSTR(RFIL),1:"")
80 . ;
81 . S TXT=XR_" "_$J("",5-$L(XR))_"'"_$P(CNT(XR),U,3)_"' "_UI
82 . I TYP'="W" S TXT=TXT_"index"_RFIL
83 . E S TXT=TXT_"whole file index"_RFIL_" (resides on "_$$FSTR(FIL)_")"
84 . ;
85 . D WRAP^DIKCU2(.TXT,-11,-2)
86 . W !," "_TXT F I=1:1 Q:$D(TXT(I))[0 W !?10,TXT(I)
87 . K TXT
88 Q
89 ;
90 ;================================
91 ; $$CHOOSE(.count,prompt,screen)
92 ;================================
93 ;Prompt for a xref from the DIKCCNT array
94 ;In:
95 ; DIKCCNT = Array contain xref data (obtained by GETXR call above)
96 ; DIKCPR = Action to include with the prompt
97 ; DIKCSCR = Sets $T to screen out entries (Y=index#)
98 ;Returns:
99 ; Index ien (or 0, if none selected)
100 ;
101CHOOSE(DIKCCNT,DIKCPR,DIKCSCR) ;
102 Q:'$G(DIKCCNT) 0
103 N I,DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,Y
104 ;
105 S DIR(0)="SAO^"
106 S I=0 F S I=$O(DIKCCNT(I)) Q:'I S DIR("C",I)=I_":"_$P(DIKCCNT(I),U,3)
107 S DIR("A")="Which Index do you wish to "_DIKCPR_"? "
108 S:+DIKCCNT=1 DIR("B")=$O(DIKCCNT(0))
109 S DIR("?")="",DIR("??")="^D LIST^DIKCUTL2(.DIKCCNT)"
110 W ! D ^DIR I 'Y!$D(DIRUT) Q 0
111 Q Y
112 ;
113 ;====================
114 ; $$FSTR(file#,flag)
115 ;====================
116 ;Return string 'file #xxx' or 'subfile #xxx'
117 ;In:
118 ; FIL = File #
119 ; FLG [ U : Capitalize 'File' or 'Subfile'
120 ;
121FSTR(FIL,FLG) ;
122 ;Q $P($P("f;F^subf;Subf",U,$G(^DD(FIL,0,"UP"))>0+1),";",$G(FLG)["U"+1)_"ile #"_FIL
123 Q $P($$EZBLD^DIALOG(8098),U,$G(^DD(FIL,0,"UP"))>0*2+1+($G(FLG)["U"))_" #"_FIL
124 ;
125 ;================
126 ; PRTMSG(index#)
127 ;================
128 ;Print message that DIXR can't be deleted because it's the
129 ;Uniqueness Index for a key.
130 ;In:
131 ; DIXR = index #
132 ;
133PRTMSG(DIXR) ;
134 N KEYID,I,INDID,MSG
135 ;
136 S KEYID=$O(^DD("KEY","AU",DIXR,0)) Q:'KEYID
137 S KEYID=$G(^DD("KEY",KEYID,0)) Q:KEYID?."^"
138 S KEYID="Key '"_$P(KEYID,U,2)_"' on File #"_$P(KEYID,U)
139 ;
140 S INDID="Index '"_$P($G(^DD("IX",DIXR,0)),U,2)_"'"
141 S MSG(0)=INDID_" cannot be deleted. It is the uniqueness index for "_KEYID_"."
142 D WRAP^DIKCU2(.MSG)
143 ;
144 W $C(7) F I=0:1 Q:'$D(MSG(I)) W !,MSG(I)
145 Q
146 ;
147 ;================
148 ; BLDLOG(index#)
149 ;================
150 ;Build and file the logic of the cross reference.
151 ;In:
152 ; DIXR = index #
153 ;
154 ;Called from EDIT^DIKCUTL after an Index is edited.
155 ;The reason for this call is if the user deletes some Cross-Reference
156 ;Values, and then Quits the form, the Set/Kill logic may not reflect
157 ;the deleted Values.
158 ;
159BLDLOG(DIXR) ;
160 N CNT,CRV,CRV0,DIERR,FCNT,FDA,FILE,IX0,KILL,L,LDIF,MAXL,MSG
161 N NAME,ORD,ROOT,RTYPE,RFILE,SBSC,SET,VAL,WKILL
162 ;
163 ;Get index data
164 S IX0=$G(^DD("IX",DIXR,0)) Q:IX0?."^"
165 I $P(IX0,U,4)="MU" D UPDEXEC(DIXR) Q
166 S FILE=$P(IX0,U),NAME=$P(IX0,U,2),RTYPE=$P(IX0,U,8),RFILE=$P(IX0,U,9)
167 ;
168 ;Build root of index and the 'Kill Entire Index Code'
169 I FILE'=RFILE Q:RTYPE'="W" S LDIF=$$FLEVDIFF^DIKCU(FILE,RFILE)
170 E S LDIF=0
171 S ROOT=$$FROOTDA^DIKCU(FILE,LDIF_"O")_""""_NAME_""""
172 S WKILL="K "_ROOT_")"
173 ;
174 ;Loop through Cross-Reference Values multiple
175 ;Build SBSC(subscript#)=order#^maxLength array
176 S CRV=0 F S CRV=$O(^DD("IX",DIXR,11.1,CRV)) Q:'CRV D
177 . S CRV0=$G(^DD("IX",DIXR,11.1,CRV,0)) Q:CRV0?."^"
178 . S ORD=$P(CRV0,U) Q:'ORD
179 . S:$P(CRV0,U,2)="F" FCNT=$G(FCNT)+1
180 . S CNT=$G(CNT)+1
181 . S SBSC=$P(CRV0,U,6) Q:'SBSC
182 . S MAXL=$P(CRV0,U,5)
183 . S SBSC(SBSC)=ORD_U_MAXL
184 ;
185 ;Loop through SBSC array and build the root w/ X(n) array
186 S SBSC=0 F S SBSC=$O(SBSC(SBSC)) Q:'SBSC D
187 . S ORD=$P(SBSC(SBSC),U),MAXL=$P(SBSC(SBSC),U,2)
188 . I $G(CNT)=1 S VAL=$S(MAXL:"$E(X,1,"_MAXL_")",1:"X")
189 . E S VAL=$S(MAXL:"$E(X("_ORD_"),1,"_MAXL_")",1:"X("_ORD_")")
190 . S ROOT=ROOT_","_VAL
191 ;
192 ;Append DA(n) to root
193 F L=LDIF:-1:1 S ROOT=ROOT_",DA("_L_")"
194 S ROOT=ROOT_",DA)"
195 ;
196 ;Build and file the Set and Kill Logic and the Execution
197 I '$O(SBSC(0)) S (SET,KILL)="Q",WKILL=""
198 E S SET="S "_ROOT_"=""""",KILL="K "_ROOT
199 K FDA
200 S FDA(.11,DIXR_",",1.1)=SET
201 S FDA(.11,DIXR_",",2.1)=KILL
202 S FDA(.11,DIXR_",",2.5)=WKILL
203 S FDA(.11,DIXR_",",.4)=$S($G(FCNT)>1:"R",1:"F")
204 D FILE^DIE("","FDA","MSG")
205 Q
206 ;
207UPDEXEC(DIXR) ;Update Execution based on number of field-type xref values
208 N CRV,CRV0,DIERR,FCNT,FDA,MSG
209 S CRV(1)=DIXR,CRV=0
210 F S CRV=$O(^DD("IX",DIXR,11.1,CRV)) Q:'CRV D
211 . S CRV0=$G(^DD("IX",DIXR,11.1,CRV,0)) Q:'CRV0
212 . S:$P(CRV0,U,2)="F" FCNT=$G(FCNT)+1
213 S FDA(.11,DIXR_",",.4)=$S($G(FCNT)>1:"R",1:"F")
214 D FILE^DIE("","FDA","MSG")
215 Q
Note: See TracBrowser for help on using the repository browser.