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

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

initial load of WorldVistAEHR
File size: 4.9 KB
Line 
1DIKCUTL1 ;SFISC/MKO-UTILITY OPTION TO MODIFY INDEX ;9:10 AM 7 Aug 2001
2 ;;22.0;VA FileMan;**11,68**;Mar 30, 1999
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4 ;
5CREATE(DIKCTOP,DIKCFILE) ;Create a new index
6 N DIKCF01,DIKCFLIS,DIKCNAME,DIKCNEW,DIKCTLIS,DIKCTYPE,DIKCUSE,DIXR
7 N DA,DDSFILE,DR
8 ;
9 ;Get Type, File, Use, and Name
10 S DIKCTYPE=$$TYPE Q:DIKCTYPE=-1
11 S DIKCF01=$$FILE01(DIKCTOP,DIKCFILE) Q:DIKCF01=-1
12 S DIKCUSE=$$USE(DIKCTYPE) Q:DIKCUSE=-1
13 S DIKCNAME=$$NAME(DIKCF01,DIKCUSE) Q:DIKCNAME=-1
14 ;
15 ;Create the new index in the Index file
16 D ADD(DIKCF01,DIKCFILE,DIKCNAME,DIKCTYPE,DIKCUSE,.DIXR) Q:DIXR=-1
17 ;
18 ;Invoke form to edit index, quit if deleted,
19 ;delete if no short description
20 S DDSFILE=.11,DA=DIXR,DR="[DIKC EDIT]" D ^DDS K DDSFILE,DA,DR
21 Q:$D(^DD("IX",DIXR,0))[0
22 I $P($G(^DD("IX",DIXR,0)),U,3)="" D Q
23 . N DIK,DA
24 . S DIK="^DD(""IX"",",DA=DIXR D ^DIK
25 . W !!," Index definition deleted."
26 ;
27 ;Get new fields list and set logic.
28 ;Modify the trigger logic of fields that trigger fields in the index
29 ;Set new index, recompile input templates and xrefs.
30 D GETFLIST^DIKCUTL(DIXR,.DIKCFLIS)
31 K DIKCTLIS D TRIG^DICR(.DIKCFLIS,.DIKCTLIS)
32 D:$D(DIKCTLIS) DIEZ^DIKCUTL3(" ",.DIKCTLIS)
33 D LOADXREF^DIKC1(DIKCFILE,"","S",DIXR,"","DIKCNEW")
34 D KSC^DIKCUTL3(DIKCTOP,"",.DIKCNEW,.DIKCFLIS)
35 Q
36 ;
37TYPE() ;Prompt for index type (regular or MUMPS)
38 N DIKCTYPE,DIR,DIROUT,DIRUT,DTOUT,X,Y
39 ;
40 S DIR(0)=".11,.2",DIR("A")="Type of index",DIR("B")="REGULAR"
41 F D Q:$D(DIRUT)!$D(DIKCTYPE)
42 . W ! D ^DIR Q:$D(DIRUT)
43 . I Y="MU",$G(DUZ(0))'="@" D
44 .. W !,$C(7)_"Only programmers can create MUMPS cross references."
45 . E I Y="MU",$P($G(^DD(DIKCTOP,0,"DI")),U)="Y" D
46 .. W !,$C(7)_"Cannot create MUMPS cross references on archived files."
47 . E S DIKCTYPE=Y
48 ;
49 Q $S($D(DIRUT):-1,1:DIKCTYPE)
50 ;
51FILE01(DIKCTOP,DIKCFILE) ;Return file on which to store xref
52 ;If DIKCFILE is not a subfile, return that file #
53 I DIKCTOP=DIKCFILE Q DIKCFILE
54 ;
55 ;Otherwise, prompt for file on which to store xref
56 N FILE01,FINFO,LEV
57 N DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,Y
58 ;
59 ;Get info on subfile DICKFILE
60 D FINFO^DIKCU1(DIKCFILE,.FINFO)
61 ;
62 ;Prompt for whether whole file indexes should be created
63 W !
64 S DIR(0)="Y",DIR("B")="Yes"
65 S DIR("?")=" Enter 'Yes' if you want the index to reside at this level."
66 F LEV=0:1:$O(FINFO(""),-1)-1 D Q:$D(DIRUT)!$D(FILE01)
67 . S DIR("A")="Want to index whole "_$S(LEV:"sub",1:"")_"file "_$P(FINFO(LEV),U,3)_" (#"_$P(FINFO(LEV),U)_")"
68 . D ^DIR Q:$D(DIRUT)!'Y
69 . S FILE01=$P(FINFO(LEV),U)
70 ;
71 Q $S($D(DIRUT):-1,'$D(FILE01):DIKCFILE,1:FILE01)
72 ;
73USE(DIKCTYPE) ;Prompt for Use (Lookup or Lookup & Sorting)
74 ;DIKCTYPE = type of index
75 ;
76 N DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,Y
77 S DIR(0)=".11,.42"
78 I $G(DIKCTYPE)="MU" D
79 . S DIR("A")="How is this MUMPS cross reference to be used"
80 . S DIR("B")="ACTION"
81 E D
82 . S DIR("A",1)="Want index to be used for Lookup & Sorting"
83 . S DIR("A")=" or Sorting Only"
84 . S DIR("B")="LOOKUP & SORTING"
85 . S DIR(0)=DIR(0)_"^^I X=""A"" W !!,$C(7)_""** Only MUMPS cross references can be ACTION-type cross references. **"" K X"
86 W ! D ^DIR K DIR
87 Q $S($D(DTOUT)!$D(DUOUT):-1,1:Y)
88 ;
89NAME(DIKCF01,DIKCUSE) ;Get next available index name
90 N DIKCASC,DIKCNAME,DIKCSTRT
91 N DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,Y
92 ;
93 ;Get next available index name
94 S DIKCSTRT=$S(DIKCUSE="LS":"",1:"A")
95 F DIKCASC=67:1 D Q:DIKCNAME]""
96 . S DIKCNAME=DIKCSTRT_$C(DIKCASC)
97 . I $D(^DD("IX","BB",DIKCF01,DIKCNAME)) S DIKCNAME="" Q
98 . I $D(^DD(DIKCF01,0,"IX",DIKCNAME)) S DIKCNAME="" Q
99 ;
100 ;If not a programmer, return next available index name
101 Q:DUZ(0)'="@" DIKCNAME
102 ;
103 ;Otherwise, prompt for index name
104 W !
105 S DIR(0)=".11,.02"
106 S DIR("A")="Index Name",DIR("B")=DIKCNAME
107 F D Q:$D(X)!$D(DIRUT)
108 . D ^DIR Q:$D(DIRUT)
109 . ;
110 . ;Check response; print message and kill X if invalid
111 . I DIKCUSE="LS",$E(X)="A" D Q
112 .. D NAMERR("Indexes used for Lookup & Sorting cannot start with 'A'")
113 . I DIKCUSE="S",$E(X)'="A" D Q
114 .. D NAMERR("Indexes used for Sorting Only must start with 'A'")
115 . I DIKCUSE="A",$E(X)'="A" D Q
116 .. D NAMERR("Action-type indexes must start with 'A'")
117 . I $D(^DD("IX","BB",DIKCF01,X)) D Q
118 .. D NAMERR("There is already an index defined with this name.")
119 . I $D(^DD(DIKCF01,0,"IX",X)) D Q
120 .. D NAMERR("There is already a cross-reference defined with this name.") Q
121 ;
122 Q $S($D(DIRUT):-1,1:X)
123 ;
124NAMERR(MSG) ;Invalid index name error
125 W !!,$C(7)_$G(MSG),!
126 K X
127 Q
128 ;
129ADD(DIKCF01,DIKCFILE,DIKCNAME,DIKCTYPE,DIKCUSE,DIXR) ;
130 ;Add new entry to Index file
131 ;Returns DIXR=-1 if error
132 N DIKCFDA,DIKCIEN
133 S DIKCFDA(.11,"+1,",.01)=DIKCF01
134 S DIKCFDA(.11,"+1,",.02)=DIKCNAME
135 S DIKCFDA(.11,"+1,",.2)=DIKCTYPE
136 S DIKCFDA(.11,"+1,",.4)="F"
137 S DIKCFDA(.11,"+1,",.41)="IR"
138 S:$G(DIKCUSE)]"" DIKCFDA(.11,"+1,",.42)=DIKCUSE
139 S DIKCFDA(.11,"+1,",.5)=$S(DIKCF01=DIKCFILE:"I",1:"W")
140 S DIKCFDA(.11,"+1,",.51)=DIKCFILE
141 S DIKCFDA(.11,"+1,",1.1)="Q"
142 S DIKCFDA(.11,"+1,",2.1)="Q"
143 D UPDATE^DIE("","DIKCFDA","DIKCIEN")
144 I '$D(DIERR) S DIXR=DIKCIEN(1)
145 E D MSG^DIALOG() S DIXR=-1
146 Q
Note: See TracBrowser for help on using the repository browser.