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

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

initial load of WorldVistAEHR
File size: 6.4 KB
RevLine 
[613]1DIKKUTL1 ;SFISC/MKO-KEY CREATION ;10:08 AM 12 Jan 2001
2 ;;22.0;VA FileMan;**68**;Mar 30, 1999
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4 ;
5CREATE(DIKKTOP,DIKKFILE) ;Create a new key
6 N DIKKEY,DIKKFDA,DIKKNAME,DIKKIEN
7 ;
8 ;Prompt for name
9 S DIKKNAME=$$NAME(DIKKFILE) Q:DIKKNAME=-1
10 ;
11 ;Add new entry to Key file
12 W !," Creating new Key '"_DIKKNAME_"' ..."
13 S DIKKFDA(.31,"+1,",.01)=DIKKFILE
14 S DIKKFDA(.31,"+1,",.02)=DIKKNAME
15 S DIKKFDA(.31,"+1,",1)=$S($D(^DD("KEY","AP",DIKKFILE,"P")):"S",1:"P")
16 D UPDATE^DIE("","DIKKFDA","DIKKIEN") I $D(DIERR) D MSG^DIALOG() Q
17 ;
18 S DIKKEY=DIKKIEN(1) K DIKKIEN
19 D EDIT^DIKKUTL(DIKKEY,DIKKTOP,DIKKFILE)
20 Q
21 ;
22UIMOD(DIXR,DIKKEY,DIKKTOP,DIKKFILE) ;Modify the UI to match the Key
23 N DIKKERR,DIKKFLD,DIKKFLIS,DIKKID,DIKKMSG,DIKKNEW,DIKKOLD
24 S DIKKID=$$KEYID(DIKKEY,DIKKTOP,DIKKFILE)
25 ;
26 ;Write message
27 W !!," Modifying Uniqueness Index ..."
28 ;
29 ;Get list of fields and original kill logic
30 D GETFLIST^DIKCUTL(DIXR,.DIKKFLIS)
31 D LOADXREF^DIKC1(DIKKFILE,"","K",DIXR,"","DIKKOLD")
32 ;
33 ;Get list of fields in key
34 D GETFLD(DIKKEY,.DIKKFLD)
35 ;
36 ;Stuff values into Uniqueness Index and fields into CRV multiple
37 D STUFF(DIXR,$P(^DD("IX",DIXR,0),U),DIKKFILE,$P(^(0),U,2),.DIKKFLD,DIKKID)
38 D DELCRV(DIXR)
39 D ADDCRV(DIXR,.DIKKFLD)
40 W " DONE!"
41 ;
42 ;Get list of fields and new set logic.
43 ;Kill old and set new index, and recompile input templates and xrefs.
44 D GETFLIST^DIKCUTL(DIXR,.DIKKFLIS)
45 D LOADXREF^DIKC1(DIKKFILE,"","S",DIXR,"","DIKKNEW")
46 D KSC^DIKCUTL3(DIKKTOP,.DIKKOLD,.DIKKNEW,.DIKKFLIS)
47 Q
48 ;
49UICREATE(DIKKEY,DIKKTOP,DIKKFILE,DIKKNO) ;Create a new UI for key
50 ;Returns DIKKNO=1 if the Index could not be created.
51 N DIERR,DIKKERR,DIKKFDA,DIKKFLIS,DIKKID,DIKKMSG,DIKKNAM,DIKKNEW,DIXR,I
52 ;
53 K DIKKNO
54 S DIKKID=$$KEYID(DIKKEY,DIKKTOP,DIKKFILE)
55 ;
56 ;Write message
57 K DIKKMSG
58 S DIKKMSG(0)="I'm going to create a new Uniqueness Index to support "_DIKKID_"."
59 D WRAP^DIKCU2(.DIKKMSG)
60 W ! F I=0:1 Q:'$D(DIKKMSG(I)) W !,DIKKMSG(I)
61 K I,DIKKMSG
62 ;
63 ;Get Index Name and list of fields
64 S DIKKNAM=$$NAME^DIKCUTL1(DIKKFILE,"LS") I DIKKNAM=-1 S DIKKNO=1 Q
65 D GETFLD(DIKKEY,.DIKKFLD)
66 ;
67 ;Add uniqueness index to Index file, and fields into CRV multiple
68 D ADDUI(DIKKFILE,DIKKNAM,.DIXR) I DIXR=-1 S DIKKNO=1 Q
69 D STUFF(DIXR,DIKKFILE,DIKKFILE,DIKKNAM,.DIKKFLD,DIKKID)
70 D ADDCRV(DIXR,.DIKKFLD,.DIKKERR) I $G(DIKKERR) S DIKKNO=1 Q
71 ;
72 ;Set Uniqueness Index pointer in Key file
73 S DIKKFDA(.31,DIKKEY_",",3)=DIXR
74 D FILE^DIE("","DIKKFDA") I $D(DIERR) D MSG^DIALOG() S DIKKNO=1 Q
75 K DIKKFDA
76 ;
77 ;Get new field list and set logic.
78 ;Set new index and recompile input templates and xrefs.
79 D GETFLIST^DIKCUTL(DIXR,.DIKKFLIS)
80 D LOADXREF^DIKC1(DIKKFILE,"","S",DIXR,"","DIKKNEW")
81 D KSC^DIKCUTL3(DIKKTOP,"",.DIKKNEW,.DIKKFLIS)
82 Q
83 ;
84ADDUI(DIKKFILE,DIKKNAM,DIXR) ;Add new entry to Index file
85 N DIKKFDA,DIKKIEN
86 W !!," One moment please ..."
87 S DIKKFDA(.11,"+1,",.01)=DIKKFILE
88 S DIKKFDA(.11,"+1,",.02)=DIKKNAM
89 D UPDATE^DIE("","DIKKFDA","DIKKIEN") I $D(DIERR) D MSG^DIALOG() Q
90 S DIXR=DIKKIEN(1)
91 Q
92 ;
93STUFF(DIXR,DIKKF01,DIKKFILE,DIKKNAM,DIKKFLD,DIKKID) ;Stuff other values into
94 ;index
95 N DIERR,DIKKFDA,DIKKILL,DIKKSET,DIKKWKIL
96 ;
97 ;Build logic
98 D BLDLOG(DIKKF01,DIKKFILE,DIKKNAM,.DIKKFLD,.DIKKSET,.DIKKILL,.DIKKWKIL)
99 ;
100 ;Stuff values into other fields in Index file entry
101 S DIKKFDA(.11,DIXR_",",.11)="Uniqueness Index for "_DIKKID
102 S DIKKFDA(.11,DIXR_",",.2)="R"
103 S DIKKFDA(.11,DIXR_",",.4)=$S(DIKKFLD>1:"R",1:"F")
104 S DIKKFDA(.11,DIXR_",",.41)="IR"
105 S DIKKFDA(.11,DIXR_",",.42)="LS"
106 S DIKKFDA(.11,DIXR_",",.5)=$S(DIKKF01=DIKKFILE:"I",1:"W")
107 S DIKKFDA(.11,DIXR_",",.51)=DIKKFILE
108 S DIKKFDA(.11,DIXR_",",1.1)=DIKKSET
109 S DIKKFDA(.11,DIXR_",",2.1)=DIKKILL
110 S DIKKFDA(.11,DIXR_",",2.5)=DIKKWKIL
111 D FILE^DIE("","DIKKFDA")
112 I $D(DIERR) D MSG^DIALOG()
113 Q
114 ;
115ADDCRV(DIXR,DIKKFLD,DIKKERR) ;Add fields to Cross-Reference Values multiple
116 N DA,DD,DIC,DIERR,DIKKFDA,DIKKSS,DINUM,DO,X,Y
117 ;
118 S DIC("P")=$P(^DD(.11,11.1,0),U,2)
119 F DIKKSS=1:1 Q:$D(DIKKFLD(DIKKSS))[0 D Q:$G(DIKKERR)
120 . ;Add subentry
121 . S DIC="^DD(""IX"","_DIXR_",11.1,",DIC(0)="QL",DA(1)=DIXR
122 . S (X,DINUM)=DIKKSS
123 . K DD,DO D FILE^DICN K DA,DIC,DINUM
124 . I Y=-1 S DIKKERR=1 Q
125 . ;
126 . ;Stuff other values
127 . S DIKKFDA(.114,DIKKSS_","_DIXR_",",.5)=DIKKSS
128 . S DIKKFDA(.114,DIKKSS_","_DIXR_",",1)="F"
129 . S DIKKFDA(.114,DIKKSS_","_DIXR_",",2)=$P(DIKKFLD(DIKKSS),U,2)
130 . S DIKKFDA(.114,DIKKSS_","_DIXR_",",3)=$P(DIKKFLD(DIKKSS),U)
131 . D FILE^DIE("","DIKKFDA")
132 . I $D(DIERR) D MSG^DIALOG() S DIKKERR=1
133 Q
134 ;
135DELCRV(DIXR) ;Delete all entries in CRV multiple
136 N DA,DIK
137 S DIK="^DD(""IX"","_DIXR_",11.1,",DA(1)=DIXR
138 S DA=0 F S DA=$O(^DD("IX",DIXR,11.1,DA)) Q:'DA D ^DIK
139 Q
140 ;
141GETFLD(KEY,FLD) ;Get list fields in key
142 ;In:
143 ; KEY = key #
144 ;Out:
145 ; FLD = # subscripts
146 ; FLD(subscript#) = field^file
147 ;
148 N DA,FD,FI,SQ
149 K FLD S (FLD,SQ)=0
150 F S SQ=$O(^DD("KEY",KEY,2,"S",SQ)) Q:'SQ D
151 . S FD=$O(^DD("KEY",KEY,2,"S",SQ,0)) Q:'FD
152 . S FI=$O(^DD("KEY",KEY,2,"S",SQ,FD,0)) Q:'FI
153 . S DA=$O(^DD("KEY",KEY,2,"S",SQ,FD,FI,0)) Q:'DA
154 . Q:$D(^DD("KEY",KEY,2,DA,0))[0
155 . S FLD=FLD+1,FLD(FLD)=FD_U_FI
156 Q
157 ;
158BLDLOG(DIKKF01,DIKKFILE,DIKKNAM,DIKKFLD,DIKKSET,DIKKILL,DIKKWKIL) ;
159 ;Build the logic of the xref
160 N DIKKLDIF,DIKKROOT,DIKKSS,L
161 I 'DIKKFLD S (DIKKSET,DIKKILL)="Q",DIKKWKIL="" Q
162 ;
163 ;Build index root and entire kill logic
164 I DIKKF01'=DIKKFILE S DIKKLDIF=$$FLEVDIFF^DIKCU(DIKKF01,DIKKFILE)
165 E S DIKKLDIF=0
166 S DIKKROOT=$$FROOTDA^DIKCU(DIKKF01,DIKKLDIF_"O")_""""_DIKKNAM_""""
167 S DIKKWKIL="K "_DIKKROOT_")"
168 ;
169 ;Build root for set/kill logic
170 F DIKKSS=1:1 Q:$D(DIKKFLD(DIKKSS))[0 D
171 . S DIKKROOT=DIKKROOT_","_$S($G(DIKKFLD)=1:"X",1:"X("_DIKKSS_")")
172 ;
173 ;Append DA(n) to root
174 F L=DIKKLDIF:-1:1 S DIKKROOT=DIKKROOT_",DA("_L_")"
175 S DIKKROOT=DIKKROOT_",DA)"
176 ;
177 ;Build set/kill logic
178 S DIKKSET="S "_DIKKROOT_"=""""",DIKKILL="K "_DIKKROOT
179 Q
180 ;
181NAME(DIKKFILE) ;Get next available Key name
182 N DIKKNAME
183 N DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,Y
184 ;
185 S DIKKNAME=$O(^DD("KEY","BB",DIKKFILE,""),-1)
186 S DIKKNAME=$S(DIKKNAME="":"A",1:$C($A(DIKKNAME)+1))
187 ;
188 S DIR(0)=".31,.02"
189 S DIR("A")="Enter a Name for the new Key"
190 S DIR("B")=DIKKNAME
191 W ! F D Q:$D(X)!$D(DIRUT)
192 . D ^DIR Q:$D(DIRUT)
193 . Q:'$D(^DD("KEY","BB",DIKKFILE,X))
194 . D NAMERR("A key already exists with this name.")
195 Q $S($D(DIRUT):-1,1:X)
196 ;
197NAMERR(MSG) ;Invalid Index Name error
198 W !!,$C(7)_$G(MSG),!
199 K X
200 Q
201 ;
202KEYID(KEY,TOP,FILE) ;Return string of text that identifies the key
203 Q "Key '"_$P(^DD("KEY",KEY,0),U,2)_"' of "_$S(TOP'=FILE:"Subf",1:"F")_"ile #"_$P(^(0),U)
204 ;
Note: See TracBrowser for help on using the repository browser.