source: cprs/branches/tmg-cprs/m_files/TMGSTRING.m

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

Initial upload
File size: 9.3 KB
Line 
1 ;"16-Feb-1999, 16:54:35
2 ;"Routine Save for all M[UMPS] Library Functions
3 ;
4 ;" Unless otherwise noted, the code below
5 ;" was approved in document X11/95-11
6 ;
7 ;" If corrections have been applied,
8 ;" first the original line appears,
9 ;" with three semicolons at the beginning of the line.
10 ;
11 ;" Then the source of the correction is acknowledged,
12 ;" then the corrected line appears, followed by a
13 ;" line containing three semicolons.
14 ;
15 ;"Downloaded from http://www.jacquardsystems.com/Examples/lib/mlibfunc.rs
16 ;"on 5/21/07
17FORMAT(V,S) ;
18 ;
19 ;" The code below was approved in document X11/SC13/TG2/1999-1
20 ;
21 New lo,mask,out,p,pos,spec,up,v1,v2,val,x
22 ;
23 Set lo="abcdefghijklmnopqrstuvwxyz"
24 Set up="ABCDEFGHIJKLMNOPQRSTUVWXYZ"
25 ;
26 ;" Array spec() contains the formatting directives
27 ;
28 ;" First set defaults
29 ;
30 Set spec("CS")="$" ;" Currency symbol
31 Set spec("DC")="." ;" Decimal separator
32 Set spec("EC")="*" ;" Error character
33 Set spec("SL")="," ;" Separator characters > 1
34 Set spec("FS")=" " ;" Fill string
35 ;
36 ;" Other specifiers may be
37 ;" FM = Format Mask
38 ;" FO = Fill On/Off
39 ;" SR = Separator characters < 1
40 ;
41 ;" Then Inherit properties from System,
42 ;" overwriting the defaults
43 ;
44 Set x="" For Set x=$Order(^$System($System,"FORMAT",x)) Quit:x="" Do
45 . Set spec(x)=^$System($System,"FORMAT",x)
46 . Quit
47 ;
48 ;" Then Inherit properties from current process
49 ;" overwriting the system and the defaults
50 ;
51 Set x="" For Set x=$Order(^$Job($Job,"FORMAT",x)) Quit:x="" Do
52 . Set spec(x)=^$Job($Job,"FORMAT",x)
53 . Quit
54 ;
55 ;" Then look at actual parameters
56 ;" overwriting anything else
57 ;
58 Set S=$Get(S) For Quit:S="" Do
59 . New e,i,str,v
60 . Set x=$Piece(S,"=",1)
61 . Set i=$Length(x)+2,str=0,v=""
62 . Set:x="" i=1
63 . For i=i:1:$Length(S)+1 Do Quit:'i
64 . . Set e=$Extract(S_":",i)
65 . . If 'str,e=":" Set S=$Extract(S,i+1,$Length(S)),i=0 Quit
66 . . Set v=v_e Quit:e'=""""
67 . . Set str=1-str
68 . . Quit
69 . If i>$Length(S) Set S=""
70 . If x'="",v'="" Set @("spec($Translate(x,lo,up))="_v) Quit
71 . Set $ECode=",M28,"
72 . Quit
73 ;
74 ;" Make certain that DC and EC are non-empty
75 ;" and not longer than 1 character
76 ;
77 Set spec("DC")=$Extract(spec("DC")_".",1)
78 Set spec("EC")=$Extract(spec("EC")_"*",1)
79 ;
80 Set val=$Get(V),(mask,out)=$Get(spec("FM"))
81 If mask="" Quit val
82 ;
83 ;" Currency string
84 ;
85 Set x=spec("CS")
86 Set pos=0 For Set pos=$Find(mask,"c",pos) Quit:pos<1 Do
87 . Set $Extract(out,pos-1)=$Extract(x,1)
88 . Set x=$Extract(x,2,$Length(x))_$Extract(x,1)
89 . Quit
90 ;
91 ;" Sign
92 ;
93 Set x=$Select(val>0:"+",val<0:"-",1:" ")
94 Set pos=0 For Set pos=$Find(mask,"+",pos) Quit:pos<1 Do
95 . Set $Extract(out,pos-1)=x
96 . Quit
97 Set pos=0 For Set pos=$Find(mask,"-",pos) Quit:pos<1 Do
98 . Set $Extract(out,pos-1)=$Select(x="-":x,1:" ")
99 . Quit
100 If x'="-" Set out=$Translate(out,"()"," ")
101 ;
102 ;" Decimal separator
103 ;
104 Set pos=$Find(mask,"d")
105 Do:pos'<1
106 . Set $Extract(out,pos-1)=spec("DC")
107 . For Set pos=$Find(mask,"d",pos) Quit:pos<1 Do
108 . . Set $Extract(out,pos-1)=spec("EC")
109 . . Quit
110 . Quit
111 ;
112 ;" Right (default, format letter "n") or
113 ;" left (format letter "l") adjustment?
114 ;
115 If mask["l",mask["n" Set $ECode=",M28,"
116 ;
117 ;" Left and Right Separators
118 ;
119 Set v1=$Piece(val,".",1),v2=$Piece(val,".",2)
120 Set v1=$Translate(v1,"-")
121 If mask'["l" Do
122 . Set x="" For p=1:1:$Length(v1) Set x=$Extract(v1,p)_x
123 . Set v1=x
124 . Quit
125 ;
126 Set pos=$Find(mask,"d") Set:pos<1 pos=$Length(mask)+2
127 ;
128 ;" Integer part and Left separators
129 ;
130 Set x=spec("SL")
131 Set p(1)=pos-2,p(2)=-1,p(3)=1
132 Set:mask["l" p(1)=1,p(2)=1,p(3)=pos-2
133 For p=p(1):p(2):p(3) Do
134 . If "fln"[$Extract(mask,p) Do
135 . . Set $Extract(out,p)=$Extract(v1,1)
136 . . Set v1=$Extract(v1,2,$Length(v1))_spec("FS")
137 . . If $Translate(v1,spec("FS"))="" Set x=spec("FS")
138 . . Quit
139 . If $Extract(mask,p)="s" Do
140 . . Set $Extract(out,p)=$Extract(x,1)
141 . . Set x=$Extract(x,2,$Length(x))_$Extract(x,1)
142 . Quit
143 ;
144 ;" Fractional part and Right separators
145 ;
146 Set x=$Get(spec("SR"),spec("SL"))
147 Set:v2="" v2=0
148 For p=pos:1:$Length(mask) Do
149 . If "fn"[$Extract(mask,p) Do
150 . . Set $Extract(out,p)=$Extract(v2,1)
151 . . Set v2=$Extract(v2,2,$Length(v2))_"0"
152 . . Quit
153 . If $Extract(mask,p)="s" Do
154 . . Set $Extract(out,p)=$Extract(x,1)
155 . . Set x=$Extract(x,2,$Length(x))_$Extract(x,1)
156 . . Quit
157 . Quit
158 ;
159 ;" Fill String
160 ;
161 Set x=$Get(spec("FS"))
162 For p=1:1:$l(mask) Do
163 . Quit:"nf"'[$Extract(mask,p)
164 . Quit:$Extract(out,p)'=" "
165 . Set $Extract(out,p)=$Extract(x,1)
166 . Set x=$Extract(x,2,$Length(x))_$Extract(x,1)
167 . Quit
168 ;
169 ;" Justification
170 ;
171 For x="+ | +","- | -","( | ("," )|) " Do
172 . New find,repl
173 . Set find=$Piece(x,"|",1),repl=$Piece(x,"|",2)
174 . For Quit:out'[find Do
175 . . Set out=$Piece(out,find,1)_repl_$Piece(out,find,2,$l(out)+2)
176 . . Quit
177 . Quit
178 ;
179 Quit out
180 ;
181 ;===
182 ;
183 ;
184CRC16(string,seed) ;
185 ;
186 ;" The code below was approved in document X11/1998-32
187 ;
188 ;" Polynomial x**16 + x**15 + x**2 + x**0
189 NEW I,J,R
190 IF '$DATA(seed) SET R=0
191 ELSE IF seed'<0,seed'>65535 SET R=seed\1
192 ELSE SET $ECODE=",M28,"
193 FOR I=1:1:$LENGTH(string) DO
194 . SET R=$$XOR($ASCII(string,I),R,8)
195 . FOR J=0:1:7 DO
196 . . IF R#2 SET R=$$XOR(R\2,40961,16)
197 . . ELSE SET R=R\2
198 . . QUIT
199 . QUIT
200 QUIT R
201XOR(a,b,w) NEW I,M,R
202 SET R=b,M=1
203 FOR I=1:1:w DO
204 . SET:a\M#2 R=R+$SELECT(R\M#2:-M,1:M)
205 . SET M=M+M
206 . QUIT
207 QUIT R
208 ;===
209 ;
210 ;
211CRC32(string,seed) ;
212 ;
213 ;" The code below was approved in document X11/1998-32
214 ;
215 ;" Polynomial X**32 + X**26 + X**23 + X**22 +
216 ;" + X**16 + X**12 + X**11 + X**10 +
217 ;" + X**8 + X**7 + X**5 + X**4 +
218 ;" + X**2 + X + 1
219 NEW I,J,R
220 IF '$DATA(seed) SET R=4294967295
221 ELSE IF seed'<0,seed'>4294967295 SET R=4294967295-seed
222 ELSE SET $ECODE=",M28,"
223 FOR I=1:1:$LENGTH(string) DO
224 . SET R=$$XOR($ASCII(string,I),R,8)
225 . FOR J=0:1:7 DO
226 . . IF R#2 SET R=$$XOR(R\2,3988292384,32)
227 . . ELSE SET R=R\2
228 . . QUIT
229 . QUIT
230 QUIT 4294967295-R
231XOR(a,b,w) NEW I,M,R
232 SET R=b,M=1
233 FOR I=1:1:w DO
234 . SET:a\M#2 R=R+$SELECT(R\M#2:-M,1:M)
235 . SET M=M+M
236 . QUIT
237 QUIT R
238 ;" ===
239 ;
240 ;
241CRCCCITT(string,seed) ;
242 ;
243 ;" The code below was approved in document X11/1998-32
244 ;
245 ;" Polynomial x**16 + x**12 + x**5 + x**0
246 NEW I,J,R
247 IF '$DATA(seed) SET R=65535
248 ELSE IF seed'<0,seed'>65535 SET R=seed\1
249 ELSE SET $ECODE=",M28,"
250 FOR I=1:1:$LENGTH(string) DO
251 . SET R=$$XOR($ASCII(string,I)*256,R,16)
252 . FOR J=0:1:7 DO
253 . . SET R=R+R
254 . . QUIT:R<65536
255 . . SET R=$$XOR(4129,R-65536,13)
256 . . QUIT
257 . QUIT
258 QUIT R
259XOR(a,b,w) NEW I,M,R
260 SET R=b,M=1
261 FOR I=1:1:w DO
262 . SET:a\M#2 R=R+$SELECT(R\M#2:-M,1:M)
263 . SET M=M+M
264 . QUIT
265 QUIT R
266 ;" ===
267 ;
268 ;
269LOWER(A,CHARMOD) NEW lo,up,x,y
270 ;
271 ;" The code below was approved in document X11/1998-21
272 ;
273 SET x=$GET(CHARMOD)
274 SET lo="abcdefghijklmnopqrstuvwxyz"
275 SET up="ABCDEFGHIJKLMNOPQRSTUVWXYZ"
276 IF x?1"^"1E.E DO
277 . SET x=$EXTRACT(x,2,$LENGTH(x))
278 . IF x?1"|".E DO
279 . . SET x=$REVERSE($EXTRACT(x,2,$LENGTH(x)))
280 . . SET y=$REVERSE($PIECE(x,"|",2,$LENGTH(x)+2))
281 . . SET x=$REVERSE($PIECE(x,"|",1))
282 . . SET x=$GET(^|y|$GLOBAL(x,"CHARACTER"))
283 . . QUIT
284 . ELSE SET x=$GET(^$GLOBAL(x,"CHARACTER"))
285 . QUIT
286 IF x="" SET x=^$JOB($JOB,"CHARACTER")
287 SET x=$GET(^$CHARACTER(x,"LOWER"))
288 IF x="" QUIT $TRANSLATE(A,up,lo)
289 SET @("x="_x_"(A)")
290 QUIT x
291 ;" ===
292 ;
293 ;
294PATCODE(A,PAT,CHARMOD) NEW x,y
295 ;
296 ;" The code below was approved in document X11/1998-21
297 ;
298 SET x=$GET(CHARMOD)
299 IF x?1"^"1E.E DO
300 . SET x=$EXTRACT(x,2,$LENGTH(x))
301 . IF x?1"|".E DO
302 . . SET x=$REVERSE($EXTRACT(x,2,$LENGTH(x)))
303 . . SET y=$REVERSE($PIECE(x,"|",2,$LENGTH(x)+2))
304 . . SET x=$REVERSE($PIECE(x,"|",1))
305 . . SET x=$GET(^|y|$GLOBAL(x,"CHARACTER"))
306 . . QUIT
307 . ELSE SET x=$GET(^$GLOBAL(x,"CHARACTER"))
308 . QUIT
309 IF x="" SET x=^$JOB($JOB,"CHARACTER")
310 SET x=$GET(^$CHARACTER(x,"PATCODE",PAT))
311 IF x="" QUIT 0
312 SET @("x="_x_"(A)")
313 QUIT x
314 ;" ===
315 ;
316 ;
317UPPER(A,CHARMOD) NEW lo,up,x,y
318 ;
319 ;" The code below was approved in document X11/1998-21
320 ;
321 SET x=$GET(CHARMOD)
322 SET lo="abcdefghijklmnopqrstuvwxyz"
323 SET up="ABCDEFGHIJKLMNOPQRSTUVWXYZ"
324 IF x?1"^"1E.E DO
325 . SET x=$EXTRACT(x,2,$LENGTH(x))
326 . IF x?1"|".E DO
327 . . SET x=$REVERSE($EXTRACT(x,2,$LENGTH(x)))
328 . . SET y=$REVERSE($PIECE(x,"|",2,$LENGTH(x)+2))
329 . . SET x=$REVERSE($PIECE(x,"|",1))
330 . . SET x=$GET(^|y|$GLOBAL(x,"CHARACTER"))
331 . . QUIT
332 . ELSE SET x=$GET(^$GLOBAL(x,"CHARACTER"))
333 . QUIT
334 IF x="" SET x=^$JOB($JOB,"CHARACTER")
335 SET x=$GET(^$CHARACTER(x,"UPPER"))
336 IF x="" QUIT $TRANSLATE(A,lo,up)
337 SET @("x="_x_"(A)")
338 QUIT x
339 ;" ===
340 ;
341 ;
342
343
344
345
346
347
Note: See TracBrowser for help on using the repository browser.