source: IHS-VA_UTILITIES-XB/ZIBRNSPC.m@ 641

Last change on this file since 641 was 641, checked in by Sam Habiel, 15 years ago

Initial commit of XB, move away from sf.net.
Includes kids file and documentation.
File size: 6.5 KB
Line 
1ZIBRNSPC ; IHS/ADC/GTH - NAMESPACE PREVIOUSLY WRITTEN ROUTINES ; [ 10/29/2002 7:42 AM ]
2 ;;4.0;XB;;Jul 20, 2009;Build 2
3 ; XB*3*9 IHS/SET/GTH XB*3*9 10/29/2002 Cache' mods.
4 ;
5INIT ;
6 KILL (%)
7 D ^XBKVAR
8 S DTIME=300
9 KILL %,DISYS,%H,X,^UTILITY($J),^TMP("ZIBRNSPC",$J)
10 S IOP=$I
11 D ^%ZIS
12START ;
13 W "Routine Namespace Converter",!
14 S ZIBRQUIT=0
15 D SETUP
16 G:ZIBRQUIT EXIT
17 ;S ZIBRRTN="";IHS/SET/GTH XB*3*9 10/29/2002
18 S ZIBRRTN=0 ;IHS/SET/GTH XB*3*9 10/29/2002
19 F ZIBRQ=0:0 S ZIBRRTN=$O(^UTILITY($J,ZIBRRTN)) Q:ZIBRRTN="" W !!,"-- ",ZIBRRTN," --",!! D RLOAD,RFIX,RSAVE,RNDX
20EXIT ;
21 W !!,"Done.",!
22 KILL ^UTILITY($J),^TMP("ZIBRNSPC",$J),DUOUT,DTOUT,IOP
23 KILL ZIBRANS,ZIBRCAND,ZIBRCH,ZIBRCMDT,ZIBRCPOS,ZIBRDEV,ZIBRFLI,ZIBRI,ZIBRJ,ZIBRL,ZIBRLINE,ZIBROBJ,ZIBROUTP,ZIBRPART,ZIBRPLEV,ZIBRPN,ZIBRPRFX,ZIBRQ,ZIBRQUIT,ZIBRRTN,ZIBRT,ZIBRV,ZIBRW,ZIBRXC
24 Q
25 ;
26SETUP ; INITIALIZE UTILITY
27 F ZIBRT="EXC","PEXC" F ZIBRI=0:1 S ZIBRL=$T(@ZIBRT+ZIBRI),ZIBRL=$P(ZIBRL,";;",2,255) Q:ZIBRL="" F ZIBRJ=1:1 S ZIBRW=$P(ZIBRL,"^",ZIBRJ) Q:ZIBRW="" S ^TMP("ZIBRNSPC",$J,ZIBRT,ZIBRW)=""
28PLOOP ;
29 R "Package prefix (1-5 characters): ",ZIBRPRFX:DTIME
30 S:'$T ZIBRPRFX="^"
31 I "^"'[ZIBRPRFX I $L(ZIBRPRFX)>5!(ZIBRPRFX'?1.5U) W *7," -- Invalid prefix",! G PLOOP
32 W !
33 I "^"[ZIBRPRFX S ZIBRQUIT=1 Q
34 W !,"Enter any variables to be treated as external references --",!,"not to be namespaced -- in the form NAME1,NAME2,...",!
35 F ZIBRQ=0:0 R " Externals: ",ZIBRL:DTIME,! S:'$T ZIBRL="^" Q:"^"[ZIBRL D:ZIBRL["?" SHEXT I ZIBRL]"" F ZIBRI=1:1 S ZIBRW=$P(ZIBRL,",",ZIBRI) Q:ZIBRW="" S ^TMP("ZIBRNSPC",$J,"EXC",ZIBRW)="" W " ",ZIBRW,!
36 I ZIBRL["^" S ZIBRQUIT=1 Q
37 X ^%ZOSF("RSEL")
38 I $O(^UTILITY($J,""))="" S ZIBRQUIT=1
39 Q
40 ;
41SHEXT ;
42 W !?2,"Currently defined externals:",!
43 S ZIBRW=""
44 F ZIBRQ=0:0 S W=$O(^TMP("ZIBRNSPC",$J,"EXC",ZIBRW)) Q:ZIBRW="" W ?3,ZIBRW,!
45 W !
46 S ZIBRL=""
47 Q
48 ;
49EXC ;;X^Y^DIE^DIC^DT^U^DUZ^DTIME^ZTSK^ZTDESC^ZTSAVE^ZTLOAD^ZTRTN^ZTIO^ZTDTH
50 ;;
51PEXC ;;IO^D^XB^Z
52 ;;
53 ;
54RLOAD ; LOAD ROUTINE INTO GLOBAL
55 W "Beginning routine load ... "
56 KILL ^TMP("ZIBRNSPC",$J,"T"),^("K")
57 S ZIBRXC=$E($T(RLOADX),10,255)
58 X ZIBRXC
59 W " completed.",!
60 Q
61 ;
62RLOADX ;;S ^TMP("ZIBRNSPC",$J,"T",0)=ZIBRRTN ZL @ZIBRRTN F ZIBRI=1:1 S ZIBRL=$T(+ZIBRI) Q:ZIBRL="" S ^(ZIBRI)=ZIBRL
63 ;
64RSAVE ; SAVE GLOBAL TEXT AS ROUTINE
65 W "Beginning routine save ... "
66 S ZIBRXC=$P($T(RSAVEX),"RSAVEX ",2)
67 X ZIBRXC
68 W " completed.",!
69 Q
70 ;
71 ; S ZIBRRTN=^TMP("ZIBRNSPC",$J,"T",0) X "ZR X ""F ZIBRI=1:1 Q:'$D(^(ZIBRI)) ZI ^(ZIBRI)"" ZS @ZIBRRTN" ; IHS/SET/GTH XB*3*9 10/29/2002
72RSAVEX S ZIBRRTN=^TMP("ZIBRNSPC",$J,"T",0) ZR X "F ZIBRI=1:1 Q:'$D(^(ZIBRI)) ZI ^(ZIBRI)" ZS @ZIBRRTN
73 ;
74RNDX ; PRINT INDEX OF ROUTINE CONVERSION
75 KILL %ZIS,IOP
76 S %ZIS("A")="Enter device for auxiliary listing of variable changes",%ZIS("B")=""
77 D ^%ZIS
78 S ZIBRDEV=$S($D(DTOUT)!$D(DUOUT):"^",IO=IO(0):0,1:IO)
79 Q:ZIBRDEV["^"
80 D RNDXP
81 I ZIBRDEV U ZIBRDEV D RNDXP D ^%ZISC
82 Q
83 ;
84RNDXP ;
85 S ZIBRV=" "
86 F ZIBRI=0:1 S:ZIBRI=4 ZIBRI=0 W:ZIBRI=0 ! S ZIBRV=$O(^TMP("ZIBRNSPC",$J,"V",ZIBRV)) Q:ZIBRV="" W ?(19*ZIBRI),$J(ZIBRV,8),">",^(ZIBRV)
87 W !
88 Q
89 ;
90RFIX ; FIX ROUTINE LINES STORED IN GLOBAL
91 F ZIBRFLI=1:1 Q:'$D(^TMP("ZIBRNSPC",$J,"T",ZIBRFLI)) S ZIBRLINE=^(ZIBRFLI) D LSCAN S ^TMP("ZIBRNSPC",$J,"T",ZIBRFLI)=ZIBROUTP
92 W "Line modification completed.",!
93 Q
94 ;
95LSCAN ; SCAN LINE AND REPLACE VARIABLES
96 S ZIBRCPOS=$F(ZIBRLINE," ")-1,ZIBRCH=" ",ZIBROUTP=$E(ZIBRLINE,1,ZIBRCPOS-1)
97 F ZIBRQ=0:0 Q:ZIBRCH="" D COPY1,CMD
98 Q
99 ;
100CMD ;
101 I ZIBRCH=";" S ZIBROUTP=ZIBROUTP_$E(ZIBRLINE,ZIBRCPOS,255),ZIBRCPOS=$L(ZIBRLINE)+1,ZIBRCH="" Q
102 S ZIBRCMDT=ZIBRCH
103 F ZIBRQ=0:0 Q:": "[ZIBRCH D COPY1
104 D:ZIBRCH=":" EXPR
105 Q:ZIBRCH=""
106 D COPY1
107 I ZIBRCH'=" " D ARGS
108 Q
109 ;
110COPY1 ;
111 S ZIBROUTP=ZIBROUTP_ZIBRCH
112 D ADVPOS
113 Q
114 ;
115ADDOBJ ;
116 S ZIBROBJ=ZIBROBJ_ZIBRCH
117 D ADVPOS
118 Q
119 ;
120ADVPOS ;
121 S ZIBRCPOS=ZIBRCPOS+1,ZIBRCH=$E(ZIBRLINE,ZIBRCPOS)
122 Q
123 ;
124EXPR ;
125 F ZIBRQ=0:0 Q:" "[ZIBRCH D COPYOBJ
126 Q
127 ;
128COPYOBJ ; COPY AN OBJECT, CHECKING FOR VARIABLES
129 I ZIBRCH="""" D QSTR Q
130 I ZIBRCH'?1AN,"%^$"'[ZIBRCH D COPY1 Q
131 S ZIBROBJ=""
132 F ZIBRQ=0:0 D ADDOBJ Q:ZIBRCH'?1AN
133 D:$E(ZIBROBJ)?1A TSTOBJ
134 S ZIBROUTP=ZIBROUTP_ZIBROBJ
135 Q
136 ;
137QSTR ; COPY QUOTED STRING (INCLUDED DOUBLED QUOTES)
138 F ZIBRQ=0:0 D COPY1 Q:""""[ZIBRCH
139 D COPY1
140 G:ZIBRCH="""" QSTR
141 Q
142 ;
143ARGS ; COPY ARGUMENTS -- 'DO' AND 'GO' SPECIAL CASES
144 I "GD"'[ZIBRCMDT D EXPR Q
145 F ZIBRQ=0:0 Q:" "[ZIBRCH D DGARG D:ZIBRCH=":" CPYTCOM
146 Q
147 ;
148DGARG ; PROCESS DO/GO ARGUMENTS
149 I ZIBRCH="@" D CPYTCOM Q
150 F ZIBRQ=0:0 Q:",: "[ZIBRCH D COPY1
151 D:ZIBRCH="," COPY1
152 Q
153 ;
154CPYTCOM ; COPIES OBJECTS THRU ZERO-LEVEL COMMA
155 S ZIBRPLEV=0
156 F ZIBRQ=0:0 D CPYTKN Q:" "[ZIBRCH Q:ZIBRCH=","&(ZIBRPLEV=0)
157 D:ZIBRCH="," COPY1
158 Q
159 ;
160CPYTKN ; COPIES A TOKEN, MODIFYING PARENTHESIS LEVEL
161 I ZIBRCH="(" S ZIBRPLEV=ZIBRPLEV+1 D COPY1 Q
162 I ZIBRCH=")" S ZIBRPLEV=ZIBRPLEV-1 D COPY1 Q
163 D COPYOBJ
164 Q
165 ;
166TSTOBJ ; CONDITIONALLY REPLACES A VARIABLE NAME
167 Q:$E(ZIBROBJ,1,$L(ZIBRPRFX))=ZIBRPRFX
168 Q:$D(^TMP("ZIBRNSPC",$J,"EXC",ZIBROBJ))
169 I $D(^TMP("ZIBRNSPC",$J,"V",ZIBROBJ)) S ZIBROBJ=^(ZIBROBJ) Q
170 D CHKPART
171 I ZIBRPART D VERPART Q:'ZIBRPART
172 S ZIBRCAND=ZIBRPRFX_ZIBROBJ
173 D VERCAND
174 S:ZIBRCAND="^" ZIBRCAND=ZIBROBJ
175 S ^TMP("ZIBRNSPC",$J,"V",ZIBROBJ)=ZIBRCAND
176 S ^TMP("ZIBRNSPC",$J,"NV",ZIBRCAND)=ZIBROBJ
177 S ZIBROBJ=ZIBRCAND
178 Q
179 ;
180CHKPART ; VERIFY MATCH WITH EXCLUSION PARTIAL NAME LIST
181 S ZIBRPART=0,ZIBRPN=""
182 F ZIBRQ=0:0 S ZIBRPN=$O(^TMP("ZIBRNSPC",$J,"PEXC",ZIBRPN)) Q:ZIBRPN="" I $E(ZIBROBJ,1,$L(ZIBRPN))=ZIBRPN S ZIBRPART=1 Q
183 Q
184 ;
185VERPART ; MANAGE PARTIAL MATCH
186 W "'",ZIBROBJ,"' begins with '",ZIBRPN,"'",!
187 R "Do you wish to treat it as an external reference? YES// ",ZIBRANS:DTIME,!
188 S:'$T ZIBRANS="Y"
189 S ZIBRANS=$E(ZIBRANS_"Y")
190 I ZIBRANS="?" W " Usage: ",ZIBRLINE,! G VERPART
191 S:ZIBRANS?1L ZIBRANS=$C($A(ZIBRANS)-32)
192 S:ZIBRANS="Y" ZIBRPART=0,^TMP("ZIBRNSPC",$J,"EXC",ZIBROBJ)=""
193 Q
194 ;
195VERCAND ; MANAGE AUTO CANDIDATE SELECTION
196 I $L(ZIBRCAND)>8 W "'",ZIBRCAND,"' cannot be used for '",ZIBROBJ,"' due to its length.",! D GETALT G VERCAND
197 I $D(^TMP("ZIBRNSPC",$J,"NV",ZIBRCAND)),^(ZIBRCAND)'=ZIBROBJ W "'",ZIBRCAND,"' cannot be used for '",ZIBROBJ,"'; used for '",^(ZIBRCAND),"'",! D GETALT G VERCAND
198 Q
199 ;
200GETALT ; GET ALTERNATE FOR PROPOSED CANDIDATE REPLACEMENT NAME
201 R "Please supply an alternative: ",ZIBRCAND:DTIME
202 S:'$T ZIBRCAND="^"
203 Q:ZIBRCAND="^"
204 I ZIBRCAND="?" W " Usage: ",ZIBRLINE,! G GETALT
205 I $E(ZIBRCAND,1,$L(ZIBRPRFX))=ZIBRPRFX W ! Q
206 W *7," -- does not begin with '",ZIBRPRFX,"'",!
207 R "Are you sure you want a non-namespaced variable? N// ",ZIBRANS:DTIME,!
208 S:'$T ZIBRANS="N"
209 S ZIBRANS=$E(ZIBRANS_"N")
210 I ZIBRANS?1L S ZIBRANS=$C($A(ZIBRANS)-32)
211 I ZIBRANS="Y" W ! Q
212 G GETALT
213 ;
Note: See TracBrowser for help on using the repository browser.