source: cprs/branches/tmg-cprs/m_files/TMGXPDR.m@ 1085

Last change on this file since 1085 was 796, checked in by Kevin Toppenberg, 14 years ago

Initial upload
File size: 12.6 KB
RevLine 
[796]1TMGXPDR ;TMG/kst/Altered version of XPDR ;03/25/06
2 ;;1.0;TMG-LIB;**1**;7/25/05
3
4 ;"TMGXPDR -- a custom version of XPDR
5 ;"K. Toppenberg, MD 7-25-05
6
7XPDR ;SFISC/RSD - Routine File Edit ;09/17/96 10:05
8 ;;8.0;KERNEL;**1,2,44**;Jul 10, 1995
9 Q
10
11UPDT ;update routine file
12 new DIR,DIRUT,XPD,XPDI,XPDJ
13 new XPDN ;"array of included (1 node) and excluded (0 node) namespaces
14 new X,X1,Y,Y1,%
15 new addCount set addCount=0
16
17 write !!
18 write "** ROUTINE File Updater **",!
19 write "(Allows addition of selected routines to ROUTINE file)",!
20 write "-----------------------------------------------------------",!
21 write !
22 write "Enter namespace of routines to add (e.g. TIU), or",!
23 write "routines to exclude from addition (e.g. -TIU)",!!
24
25 set DIR(0)="FO^1:9^K:X'?.1""-""1U.7UNP X"
26 set DIR("A")="Routine Namespace ([ENTER] if done)"
27 set DIR("?")="Enter 1 to 8 characters, preceed with ""-"" to exclude namespace"
28
29 ;"XPDN(0=excluded names or 1=include names, namespace)=""
30 for do quit:$data(DIRUT)
31 . do ^DIR
32 . quit:$data(DIRUT)
33 . set X=($extract(Y,$L(Y))="*")
34 . set %=($extract(Y)="-")
35 . set XPDN('%,$extract(Y,%+1,$length(Y)-X))=""
36
37 if ('$data(XPDN))!($data(DTOUT))!($data(DUOUT)) write ! goto UPDTQ
38 ;"quit:'$data(XPDN)!$data(DTOUT)!$data(DUOUT)
39 write !!,"NAMESPACE INCLUDE",?35,"EXCLUDE",!,?11,"-------",?35,"-------"
40 set (X,Y)=""
41 set (X1,Y1)=1
42 for do write !?11,X,?35,Y quit:'X1&'Y1
43 . set:X1 X=$O(XPDN(1,X)),X1=X]""
44 . set:Y1 Y=$O(XPDN(0,Y)),Y1=Y]""
45
46 kill DIR
47 set DIR(0)="Y"
48 set DIR("A")="OK to continue"
49 set DIR("B")="YES"
50 do ^DIR
51
52 quit:'Y!$data(DIRUT)
53 write !
54 set DIR(0)="Y"
55 set DIR("A")="Want me to clean up the Routine File before updating"
56 set DIR("?")="YES means you want to go throught the Routine file and delete any routine name that no longer exists on the system."
57 do ^DIR
58
59 quit:$data(DIRUT)
60 do WAIT^DICD
61 write !
62 do DELRTN:Y
63
64 ;"----------------------------------------------------------------------------
65 ;"Replacement code for below...
66 new XPDArray
67 merge XPDArray=XPDN(1) ;"node 1=>included namespaces
68 ;"ensure that all entries end with "*" (e.g. "TMG*" not "TMG")
69 set XPDI=$order(XPDArray(""))
70 if XPDI'="" for do quit:XPDI=""
71 . new node set node=XPDI
72 . set XPDI=$order(XPDArray(node))
73 . if ($extract(node,$length(node))'="*") do
74 . . kill XPDArray(node)
75 . . set XPDArray(node_"*")=""
76
77 do NOINT^%RSEL("XPDArray") ;"creates %ZR - an array of existing routines matching input request
78 set XPDJ=""
79 for do quit:XPDJ=""
80 . set XPDJ=$order(%ZR(XPDJ))
81 . if XPDJ="" quit
82 . if $data(XPDN(0,XPDJ)) quit ;"if name XPDJ is in the exclude list, skip
83 . if $order(^DIC(9.8,"B",XPDJ,0)) quit ;"if name XPDJ is already in Routine file, skip
84 . ;"check if XPDJ is refered in the EXCLUDED namespace by checking the subscript before XPDJ
85 . set %=$order(XPDN(0,XPDJ),-1)
86 . ;"if sub exist and $piece(XPDJ,sub)="" then it is part of the namespace, quit
87 . if ($length(%)>0)&($piece(XPDJ,%)="") quit
88 . ;"Add routine to ROUTINE file
89 . new XPD
90 . set XPD(9.8,"+1,",.01)=XPDJ
91 . set XPD(9.8,"+1,",1)="R"
92 . do ADD^DICA("","XPD")
93 . write "Added: ",XPDJ,!
94 . set addCount=addCount+1
95UPDTQ
96 write " ...Done.",!
97 if addCount=0 write "ROUTINE file already up to date. No additions needed.",!
98 else write addCount," entries added to ROUTINE file.",!
99 write "Leaving ROUTINE File Updater.",!
100 quit
101
102 ;"----------------------------------------------------------------------------
103
104 ;"loop thru include list XPDN(1,*), i.e. included nodes-->requested namespaces
105 ;"Goal: to consider each requested namespace...
106
107 ;"Pseudocode:
108 ;" loop (through all requested namespaces)
109 ;" XPDI = currently considered namespace
110 ;" loop (through all available routines--starting at XPDI)
111 ;" XPDJ is current routine name being considered -- from all available routines
112 ;" if current routine name (XPDJ) is in exclude list, skip
113 ;" if current routine name (XPDJ) is already in the ROUTINE file, then skip
114 ;" ... (to be completed)
115
116 ;set XPDI=""
117 ;for do quit:XPDI=""
118 ;. set XPDI=$order(XPDN(1,XPDI))
119 ;. quit:XPDI=""
120 ;. set XPDJ=XPDI
121 ;. if '$data(^$routine(XPDJ)) quit
122 ;. for set XPDJ=$order(^$routine(XPDJ)) quit:(XPDJ="")!($piece(XPDJ,XPDI)]"") do
123 ;. . if $data(XPDN(0,XPDJ)) quit ;"if name XPDJ is in the exclude list, XPDN(0,XPDJ) quit
124 ;. . if $order(^DIC(9.8,"B",XPDJ,0)) quit ;"if name XPDJ is in Routine file, quit
125 ;. . ;"check if XPDJ is refered in the EXCLUDED namespace by checking the subscript before XPDJ
126 ;. . set %=$order(XPDN(0,XPDJ),-1)
127 ;. . ;"if sub exist and $piece(XPDJ,sub)="" then it is part of the namespace, quit
128 ;. . if ($length(%)>0)&($piece(XPDJ,%)="") quit ;"e.g $piece("TMGTEST",
129 ;. . new XPD
130 ;. . set XPD(9.8,"+1,",.01)=XPDJ
131 ;. . set XPD(9.8,"+1,",1)="R"
132 ;. . do ADD^DICA("","XPD")
133 ;write " ...Done.",!
134 ;quit
135
136VER ;verify Routine file
137 N DIR,DIRUT,X,Y
138 W !,"I will delete all entries in the ROUTINE file in which",!,"the Routine no longer exist on this system!",!
139 S DIR(0)="Y",DIR("A")="OK to continue",DIR("B")="YES" D ^DIR
140 Q:'Y!$D(DIRUT) D DELRTN
141 W " ...Done.",!
142 Q
143DELRTN ;delete routine file entries
144 N DA,DIK,Y,count,max,delNum
145 S DIK="^DIC(9.8,",DA=0,count=0,max=0,delNum=0
146 ;" F S DA=$O(^DIC(9.8,DA)) Q:'DA S Y=$G(^(DA,0)) I $P(Y,U,2)="R",$T(^@$P(Y,U))="" D ^DIK
147 do INIT^XPDID
148 for set DA=$order(^DIC(9.8,DA)) quit:'DA set max=max+1
149 if max=0 set max=1
150 set XPDIDTOT=max
151 do TITLE^XPDID("Scanning for Entries to Remove...")
152 set DA=0
153 write !,"Starting search...",!
154 for set DA=$order(^DIC(9.8,DA)) quit:'DA do
155 . set count=count+1
156 . if count#50=0 do UPDATE^XPDID(count)
157 . set Y=$G(^(DA,0))
158 . if ($piece(Y,U,2)="R")&($text(^@$piece(Y,U))="") do
159 . . write "Removing: ",$piece(Y,U),!
160 . . set delNum=delNum+1
161 . . do ^DIK
162 write !
163 if delNum>0 do
164 . new temp
165 . write "Done scanning. ",delNum," Entries removed.",!
166 . read "Please press [ENTER] to continue.",temp:$get(DTIME,3600),!
167 do EXIT^XPDID()
168 quit
169PURGE ;purge file
170 N DA,DIK,DIR,DIRUT,X,XPD,XPDF,XPDI,XPDJ,XPDL,XPDN,XPDPG,XPDS,XPDUL,Y,Z
171 S DIR("?")="Enter the file you want to purge the data from.",DIR(0)="SM^B:Build;I:Install;ALL:Build & Install",DIR("A")="Purge from what file(s)"
172 D ^DIR Q:$D(DIRUT)
173 S XPDF=$S(Y="I":9.7,1:9.6) S:Y="ALL" XPDF(1)=9.7
174 K DIR S DIR("?")="Enter the number of Versions to keep in the file, for each package",DIR(0)="N^0:100:0",DIR("A")="Versions to Retain",DIR("B")=1
175 D ^DIR Q:$D(DIRUT) S XPDN=Y
176 K DIR
177 S DIR(0)="FO^3:30",DIR("?")="^D PURGEH^XPDR",DIR("A")="Package Name",DIR("B")="ALL"
178 F D ^DIR Q:$D(DIRUT) S XPD(X)="" Q:X="ALL" K DIR("B") S DIR("A")="Another Package Name"
179 Q:'$D(XPD)
180 ;if they want all, make sure all is the only one
181 I $D(XPD("ALL")) K XPD S XPD("ALL")=""
182 ;XPDF(1) is defined if doing both files, do purge twice
183 K ^TMP($J) D PURGE1(XPDF),PURGE1($G(XPDF(1))):$D(XPDF(1))
184 I '$D(^TMP($J)) W !!,"No match found" Q
185 K XPD,DIR
186 S DIR(0)="E",$P(XPDUL,"-",IOM)=""
187 ;if ALL, reset XPDF to next file and Do, then reset back to 9.6
188 D I $D(XPDF(1)) D ^DIR I Y S XPDF=XPDF(1) D S XPDF=9.6
189 .S XPD="^TMP("_$J_","_XPDF,XPDS=XPD_",",XPD=XPD_")",XPDL=$L(XPDS),XPDPG=1,Y=1
190 .W @IOF D HDR
191 .;loop thru ^TMP($J,file,package) & show list, quit if user "^"
192 .F S XPD=$Q(@XPD) Q:XPD=""!($E(XPD,1,XPDL)'=XPDS) D Q:'Y
193 ..S Z=@XPD W $P(Z,"^"),$S($P(Z,"^",3):" (duplicates)",1:""),! Q:$Y<(IOSL-4)
194 ..D ^DIR Q:'Y
195 ..S XPDPG=XPDPG+1 W @IOF D HDR
196 S DIR(0)="Y",DIR("A")="OK to DELETE these entries",DIR("B")="NO"
197 W !! D ^DIR
198 I $D(DIRUT)!'Y W !!,"Nothing Purged" Q
199 ;loop thru and delete
200 D I $D(XPDF(1)) S XPDF=XPDF(1) D
201 .S DIK="^XPD("_XPDF_",",XPD="^TMP("_$J_","_XPDF,XPDS=XPD_",",XPD=XPD_")",XPDL=$L(XPDS)
202 .F S XPD=$Q(@XPD) Q:XPD=""!($E(XPD,1,XPDL)'=XPDS) D
203 ..S XPDI=@XPD F XPDJ=2:1 S DA=$P(XPDI,"^",XPDJ) Q:'DA D ^DIK
204 Q
205 ;
206PURGE1(XPDF) ;XPDF=file #
207 N XPDFL,XPDI,XPDJ,XPDP,XPDV,Y,Z
208 W "."
209 ;if All, loop thru B x-ref
210 I $D(XPD("ALL")) D
211 .S XPDI=""
212 .F S XPDI=$O(^XPD(XPDF,"B",XPDI)) Q:XPDI="" D
213 ..S X=$$PKG^XPDUTL(XPDI) D PURGE2(X)
214 ..W "."
215 E S XPDI="" F S XPDI=$O(XPD(XPDI)) Q:XPDI="" D
216 .D PURGE2(XPDI)
217 .W "."
218 ;loop thru each package, XPDP=package name
219 S XPDP="" F S XPDP=$O(^TMP($J,XPDF,XPDP)) Q:XPDP="" D
220 .S XPDV="",XPDL=XPDN
221 .;the last is the most recent, XPDN = number to retain, XPDV=version
222 .;XPDS=type (T/V/Z)
223 .F S XPDV=$O(^TMP($J,XPDF,XPDP,XPDV),-1),XPDS="" Q:'XPDV!'XPDL F S XPDS=$O(^TMP($J,XPDF,XPDP,XPDV,XPDS),-1) Q:XPDS=""!'XPDL D
224 ..S Y="" F S Y=$O(^TMP($J,XPDF,XPDP,XPDV,XPDS,Y),-1) Q:Y=""!'XPDL D
225 ...I $D(^TMP($J,XPDF,XPDP,XPDV,XPDS,Y))#2 K ^(Y) S XPDL=XPDL-1 Q
226 ...S Z="" F S Z=$O(^TMP($J,XPDF,XPDP,XPDV,XPDS,Y,Z),-1) Q:Z=""!'XPDL K ^(Z) S XPDL=XPDL-1
227 Q
228 ;
229PURGE2(XPDX) ;XPDX=package name
230 ;XPDFL=1 this is not a patch, quit when we find a patch during loop
231 S XPDS=XPDX,XPDL=$L(XPDX),XPDFL=XPDX'["*"
232 ;loop and find matches
233 D F S XPDS=$O(^XPD(XPDF,"B",XPDS)) Q:XPDS=""!($E(XPDS,1,XPDL)'=XPDX)!($S(XPDFL:XPDS["*",1:0)) D
234 .S Y=$O(^XPD(XPDF,"B",XPDS,0)) Q:'Y
235 .Q:'$D(^XPD(XPDF,Y,0)) S Z=^(0),Y=XPDS_"^"_Y
236 .;can't delete Installs that status isn't 'Install Completed'
237 .I XPDF=9.7 Q:$P(Z,U,9)<3
238 .S XPDV=$$VER^XPDUTL(XPDS)
239 .;TMP($J,file,package name,version,"*","T/V/Z",num,patch)=NAME^DA^duplicat DAs
240 .I XPDS["*" D Q
241 ..I XPDV?1.2N1"."1.2N S ^TMP($J,XPDF,$$PKG^XPDUTL(XPDS),+XPDV,"*Z",0,+$P(XPDS,"*",3))=Y_$$DUP(XPDS,$P(Y,"^",2)) Q
242 ..I XPDV["T" S ^TMP($J,XPDF,$$PKG^XPDUTL(XPDS),+XPDV,"*T",+$P(XPDV,"T",2),+$P(XPDS,"*",3))=Y_$$DUP(XPDS,$P(Y,"^",2)) Q
243 ..I XPDV["V" S ^TMP($J,XPDF,$$PKG^XPDUTL(XPDS),+XPDV,"*V",+$P(XPDV,"V",2),+$P(XPDS,"*",3))=Y_$$DUP(XPDS,$P(Y,"^",2)) Q
244 ..S ^TMP($J,XPDF,$$PKG^XPDUTL(XPDS),+XPDV,"*",+$P(XPDS,"*",3))=Y_$$DUP(XPDS,$P(Y,"^",2))
245 .;TMP($J,file,package name,version,"Z",0)=NAME^DA^duplicate DAs
246 .I XPDV?1.2N1"."1.2N S ^TMP($J,XPDF,$$PKG^XPDUTL(XPDS),+XPDV,"Z",0)=Y_$$DUP(XPDS,$P(Y,"^",2)) Q
247 .;TMP($J,file,package name,version,"T/V",num)=NAME^DA^dup DAs
248 .I XPDV["T" S ^TMP($J,XPDF,$$PKG^XPDUTL(XPDS),+XPDV,"T",+$P(XPDV,"T",2))=Y_$$DUP(XPDS,$P(Y,"^",2)) Q
249 .I XPDV["V" S ^TMP($J,XPDF,$$PKG^XPDUTL(XPDS),+XPDV,"V",+$P(XPDV,"V",2))=Y_$$DUP(XPDS,$P(Y,"^",2)) Q
250 Q
251PURGEH ;executable help from DIR call at PURGE+8
252 W:$E(DIR("A"),1)="P" !,"Enter 'ALL' to purge all packages, or"
253 W !,"Enter the name of the Package you want to Purge.",!," i.e. KERNEL 8.0 will purge version 8.0Tx and 8.0Vx",!," XU*8.0 will purge all patches for 8.0",!
254 N DIR,X,Y
255 S DIR(0)="Y",DIR("A")="Want to see the "_$S(XPDF=9.7:"Install File",$D(XPDF(1)):"Build & Install Files",1:"Build File")_" List",DIR("B")="Y"
256 D ^DIR Q:'Y!$D(DIRUT)
257 D PURGEH1("^XPD(9.6,"):XPDF=9.6,PURGEH1("^XPD(9.7,"):XPDF=9.7!$D(XPDF(1))
258 Q
259 ;
260DUP(Z,Z1) ;find duplicate, Z=NAME, Z1=last ien
261 ;returns Y=DA^dup DA^dup DA...
262 N Y S Y=""
263 F S Z1=$O(^XPD(XPDF,"B",Z,Z1)) Q:'Z1 S Y=Y_"^"_Z1
264 Q Y
265 ;
266PURGEH1(DIC) ;
267 W !!,$S(DIC[9.6:"BUILD ",1:"INSTALL ")_"File"
268 S DIC(0)="QE",X="??" D ^DIC
269 Q
270 ;
271HDR W !,"Package(s) in ",$S(XPDF=9.7:"INSTALL",1:"BUILD")," File, "
272 I XPDN W "Retain last ",$S(XPDN=1:"version",1:XPDN_" versions")
273 E W "Don't retain any versions"
274 W ?70,"PAGE ",XPDPG,!,XPDUL,!
275 Q
Note: See TracBrowser for help on using the repository browser.