source: IHS-VA_UTILITIES-XB/trunk/ZIBRNSPC.m@ 1602

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

Modified directory structure; moved routines.
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.