1: %ulstring ;VCL/SNW-STRING LIBRARY; 03/09/25 06:30 PM
2: ;0.0;FreeM;****FREEM**;Serena Willis @2025
3: ;
4: ; $Id: %ulstring.m,v 1.2 2025/03/10 00:38:15 snw Exp $
5: ; String library
6: ;
7: ;
8: ; Author: Serena Willis <snw@coherent-logic.com>
9: ; Copyright (C) 1998 MUG Deutschland
10: ; Copyright (C) 2023, 2025 Coherent Logic Development LLC
11: ;
12: ;
13: ; This file is part of FreeM.
14: ;
15: ; FreeM is free software: you can redistribute it and/or modify
16: ; it under the terms of the GNU Affero Public License as published by
17: ; the Free Software Foundation, either version 3 of the License, or
18: ; (at your option) any later version.
19: ;
20: ; FreeM is distributed in the hope that it will be useful,
21: ; but WITHOUT ANY WARRANTY; without even the implied warranty of
22: ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
23: ; GNU Affero Public License for more details.
24: ;
25: ; You should have received a copy of the GNU Affero Public License
26: ; along with FreeM. If not, see <https://www.gnu.org/licenses/>.
27: ;
28: ; $Log: %ulstring.m,v $
29: ; Revision 1.2 2025/03/10 00:38:15 snw
30: ; Phase 3 of REUSE compliance and header reformatting
31: ;
32: ;
33: ; SPDX-FileCopyrightText: (C) 2025 Coherent Logic Development LLC
34: ; SPDX-License-Identifier: AGPL-3.0-or-later
35: ;
36: ; STRING library - version 0.5.0.1
37: ;
38: ; Unless otherwise noted, the code below
39: ; was approved in document X11/95-11
40: ;
41: ; If corrections have been applied,
42: ; first the original line appears,
43: ; with three semicolons at the beginning of the line.
44: ;
45: ; Then the source of the correction is acknowledged,
46: ; then the corrected line appears, followed by a
47: ; line containing three semicolons.
48: ;
49: ;
50: ;
51: PRODUCE(IN,SPEC,MAX) ;
52: NEW VALUE,AGAIN,P1,P2,I,COUNT
53: SET VALUE=IN,COUNT=0
54: FOR DO QUIT:'AGAIN
55: . SET AGAIN=0
56: . SET I=""
57: . FOR SET I=$ORDER(SPEC(I)) QUIT:I="" DO QUIT:COUNT<0
58: . . QUIT:$GET(SPEC(I,1))=""
59: . . QUIT:'($DATA(SPEC(I,2))#2)
60: . . FOR QUIT:VALUE'[SPEC(I,1) DO QUIT:COUNT<0
61: . . . SET P1=$PIECE(VALUE,SPEC(I,1),1)
62: . . . SET P2=$PIECE(VALUE,SPEC(I,1),2,$LENGTH(VALUE))
63: . . . SET VALUE=P1_SPEC(I,2)_P2,AGAIN=1
64: . . . SET COUNT=COUNT+1
65: . . . IF $DATA(MAX),COUNT>MAX SET COUNT=-1,AGAIN=0
66: . . . QUIT
67: . . QUIT
68: . QUIT
69: QUIT VALUE
70: ;===
71: ;
72: ;
73: REPLACE(IN,SPEC) ;
74: NEW L,MASK,K,I,LT,F,VALUE
75: SET L=$LENGTH(IN),MASK=$JUSTIFY("",L)
76: SET I="" FOR SET I=$ORDER(SPEC(I)) QUIT:I="" DO
77: . QUIT:'($DATA(SPEC(I,1))#2)
78: . QUIT:SPEC(I,1)=""
79: . QUIT:'($DATA(SPEC(I,2))#2)
80: . SET LT=$LENGTH(SPEC(I,1))
81: . SET F=0 FOR SET F=$FIND(IN,SPEC(I,1),F) QUIT:F<1 DO
82: . . QUIT:$E(MASK,F-LT,F-1)["X"
83: . . SET VALUE(F-LT)=SPEC(I,2)
84: . . SET $EXTRACT(MASK,F-LT,F-1)=$TRANSLATE($JUSTIFY("",LT)," ","X")
85: . . QUIT
86: . QUIT
87: SET VALUE="" FOR K=1:1:L DO
88: . IF $EXTRACT(MASK,K)=" " SET VALUE=VALUE_$EXTRACT(IN,K) QUIT
89: . SET:$DATA(VALUE(K)) VALUE=VALUE_VALUE(K)
90: . QUIT
91: QUIT VALUE
92: ;===
93: ;
94: ;
95: FORMAT(V,L) ;
96: ;
97: ; The code below was approved in document X11/SC13/1998-10
98: ;
99: NEW C,CD,CM,CS,DP,E,EX,FL,FM,FO,GL,GV1,GV2,GVL,GVM,GX,I,J,K,ST,TV,TY,V1,V2,VP
100: ;
101: ; Load up Format Directives from ^$FORMAT or ^SYSTEM("FORMAT")
102: DO:'$DATA(^$FORMAT) %INFORM
103: SET (FM,K)="",EX=0,EXS="EXS"
104: ;
105: ; Extract the working values from the command string
106: DO %PRELOAD
107: ;
108: ; Process the directives
109: DO %EVALU8
110: ;
111: ; Error Handling
112: DO:EX %ERROR
113: XECUTE:$LENGTH(EXS) "K "_EXS
114: QUIT K
115: ;
116: ; CM - Command Array
117: ; CS - Command String
118: ; DP - Decimal Pointer
119: ; EX - Exit Flag
120: ; EXS - KILL Exit String
121: ; FL - Field Length
122: ; FM - Format String
123: ; FO - Format Option Array
124: ; K - Return Output String
125: ; L - List of Directives
126: ; ST - String Extraction String
127: ; V - Input Value
128: ;
129: %PRELOAD ; Load the defaults prior to the application of directives
130: SET K=""
131: ; Load System Defaults
132: FOR SET K=$ORDER(^$SYSTEM("FORMAT",K)) QUIT:K="" DO
133: . SET FO(K)=^$SYSTEM("FORMAT",K)
134: . QUIT
135: ; Load Process Defaults
136: FOR SET K=$ORDER(^$FORMAT(K)) QUIT:K="" SET FO(K)=^$FORMAT(K)
137: SET (CS,L)=$GET(L)
138: ; Load Argument Overrides from the List of Directives
139: ; 1. Tokenize the Laterals
140: DO:L[""""
141: . SET CS=""
142: . FOR J=2:2:$LENGTH(L,"""") DO
143: . . SET ST=$GET(ST)+1,ST(ST)=$PIECE(L,"""",J)
144: . . SET:ST(ST)="" ST(ST)=""""
145: . . SET CS=CS_$PIECE(L,"""",J-1)_"%%"_ST_"%%"
146: . . QUIT
147: . SET CS=CS_$PIECE(L,"""",J+1)
148: . QUIT
149: ; 2. Evaluate the Directives
150: NEW C,L,X
151: FOR J=1:1:$LENGTH(CS,":") DO QUIT:EX
152: . SET CD=$PIECE(CS,":",J)
153: . SET X=$PIECE(CD,"="),TV=$PIECE(CD,"=",2,999)
154: . IF X="" SET EX=1 QUIT
155: . ; Uppercase Symbol Names Only
156: . SET TY=$TRANSLATE(X,"abcdefghijklm","ABCDEFGHIJKLM")
157: . SET TY=$TRANSLATE(TY,"nopqrstuvwxyz","NOPQRSTUVWXYZ")
158: . D
159: . . ; To bullet proof, Establish an error trap to %ERREX
160: . . IF ($LENGTH(TV,"%%")>1) DO %LOADTV SET FO(TY)=TV QUIT
161: . . IF TV="" SET FO(TY)="" QUIT
162: . . ; 3. Set the Directive in the FO array
163: . . SET FO(TY)=@TV
164: . . QUIT
165: . QUIT
166: ; 4) Construct a KILL Exit String for directives not in default list
167: NEW C,E
168: SET (C,E)=""
169: FOR SET C=$ORDER(FO(C)) QUIT:C="" SET @C=FO(C),E=E_C_","
170: SET EXS=E_"EXS"
171: SET:$DATA(FM) FL=$LENGTH(FM)
172: QUIT
173: ;
174: ; DC - Decimal Character
175: ; DP - Decimal Position
176: ; EX - Abnormal Condition Exit
177: ; FL - Format Length
178: ; FM - Format Mask
179: ; GV1 - Integer Portion
180: ; GV2 - Fractional Portion
181: ; K - Output Buffer
182: ; NOD - No Decimal
183: ; SV - Sign Value (1 = Positive, 0 = Negative)
184: ; V - Input Value
185: %EVALU8 ; Evaluate the input for loading into the output string
186: NEW NOD
187: SET SV=1
188: SET NOD='(FM["d")
189: SET:V<0 SV=0
190: SET V1=$PIECE(V,"."),V2=$PIECE(V,".",2),(GV1,GV2)=""
191: DO:FM'=""
192: . SET FL=$LENGTH(FM),DP=$FIND(FM,"d")-1
193: . SET:(DP<1) DP=$LENGTH(FM)
194: . QUIT
195: NEW C
196: DO %GETV1,%GETV2:'(NOD!EX)
197: QUIT:EX
198: ;
199: SET K=GV1_DC_GV2
200: SET:NOD K=GV1
201: IF $GET(FC)'="" SET:K[" " K=$TRANSLATE(K," ",FC)
202: SET:$LENGTH(K)'=FL EX=1
203: QUIT
204: ;
205: %GETV1 ; Get the integer portion of the value and lay it in GV1
206: NEW CP,SP
207: IF $GET(SL)'="" NEW SC SET SC=SL
208: ; 1) Set the Integer Portion of the Mask (GVM) and Length (GVL)
209: SET GVM=$PIECE(FM,"d"),GVL=$LENGTH(GVM),GL=0
210: ; 2) Get the absolute value of V1
211: SET:$EXTRACT(V1)="-" V1=$EXTRACT(V1,2,999)
212: ; 3) Establish Blank Mask, GV1
213: SET GV1=$J("",GVL),VP=$LENGTH(V1),(CP,SP)=1
214: ;
215: ; Rounding of Integer (NO DECIMAL PORTION)
216: SET:$PIECE(FM,"d",2)="" V1=$EXTRACT((V+.5)\1,1,$LENGTH(V1))
217: ; 4) Extract value for each position in the mask and set it
218: FOR L=GVL:-1:1 SET C=$EXTRACT(GVM,L) DO QUIT:EX
219: . SET GX=0
220: . DO %TRANSV1
221: . QUIT:GX!EX
222: . ;
223: . SET:GC'=" " $EXTRACT(GV1,L)=GC
224: . QUIT
225: SET:VP EX=1
226: QUIT
227: ;
228: %GETV2 ; Get the fractional portion of the value and lay it in GV2
229: NEW CP,SP
230: IF $GET(SR)'="" NEW SC SET SC=SR
231: SET GVM=$PIECE(FM,"d",2),GVL=$LENGTH(GVM),GL=0,SP=1
232: DO:GVL<$LENGTH(V2) ; Rounding of Decimal
233: . NEW J,N
234: . SET N=$EXTRACT($TRANSLATE($J("",GVL)," ",0)_5_$TRANSLATE($J("",$LENGTH(V2))," ",0),1,$LENGTH(V2))
235: . SET V2=$EXTRACT(V2+N,1,$LENGTH(V2))
236: . QUIT
237: SET GV2=$J("",GVL),VP=1,CP=1
238: FOR L=1:1:GVL SET C=$EXTRACT(GVM,L) DO QUIT:EX
239: . SET GX=0
240: . DO %TRANSV2
241: . QUIT:GX!EX
242: . ;
243: . SET:GC'=" " $EXTRACT(GV2,L)=GC
244: . QUIT
245: QUIT
246: ;
247: ; C - Current Mask Character from the FM
248: ; CP - Character Position
249: ; L - Position within
250: ; VP - Value Position
251: ; (integer - Right to Left, fraction - Left to Right)
252: %TRANSV1 ; Translate the value into the mask
253: SET (GC,GL)=" "
254: QUIT:"x "[C
255: ;
256: ; Value Completed, Apply Currency/Float/etc, if requested
257: IF 'VP DO
258: . IF "c"[C DO QUIT
259: . . SET:$GET(CP)="" CP=$LENGTH(CS)
260: . . SET GC=$EXTRACT(CS,CP),CP=CP-1
261: . . SET:CP<1 CP=$LENGTH(CS)
262: . . QUIT
263: . IF GVM["f" DO QUIT
264: . . NEW F,I,LI,LX,X,Q
265: . . SET X=" ",LI=L,LX=0
266: . . DO ; Identify the Value Represented
267: . . . IF GVM["+"!(GVM["-") DO QUIT
268: . . . . SET:GVM["+" X="+"
269: . . . . SET:V<0 X="-"
270: . . . . QUIT
271: . . . IF GVM["(" DO:V<0 QUIT
272: . . . . SET X=" ",LX=1
273: . . . . QUIT
274: . . . QUIT
275: . . FOR I=L:1:GVL SET Q=$EXTRACT(GV1,I) QUIT:Q?1N QUIT:("("_DC)[Q DO
276: . . . SET F=$EXTRACT(GVM,I),LI=I
277: . . . SET:"fs("[F $EXTRACT(GV1,I)=X
278: . . . QUIT
279: . . SET BYE=1
280: . . SET:LX $EXTRACT(GV1,LI)="("
281: . . QUIT
282: . QUIT
283: IF C="+" SET GC="+" SET:'SV GC="-" SET GL=GC QUIT
284: IF C="-" SET:'SV GC="-" SET GL=GC QUIT
285: IF C="(" SET:'SV GC="(" SET GL=GC QUIT
286: IF C=")" SET:'SV GC=")" SET GL=GC QUIT
287: DO:VP
288: . IF C="c" DO QUIT
289: . . SET:$GET(CP)="" CP=$LENGTH(CS)
290: . . SET GC=$EXTRACT(CS,CP),CP=CP-1
291: . . SET:CP<1 SP=$LENGTH(CS)
292: . . QUIT
293: . IF "fn+-"[C SET GC=$EXTRACT(V1,VP),VP=VP-1 QUIT
294: . IF C="s" DO QUIT
295: . . SET:$GET(SP)="" SP=$LENGTH(SC)
296: . . SET GC=$EXTRACT(SC,SP),SP=SP-1
297: . . SET:SP<1 SP=$LENGTH(SC)
298: . . QUIT
299: . QUIT
300: QUIT
301: ;
302: ; "c" - Currency
303: ; "f" - Floating
304: ; "n" - Numeric
305: ; "s" - Separator
306: ; "+-()" - Sign Representations
307: ;
308: %TRANSV2 ; Translate the value into the mask
309: SET GC=" "
310: QUIT:"x "[C
311: ;
312: DO:VP
313: . IF "f"[C DO QUIT
314: . . SET:$GET(CP)="" CP=1
315: . . SET GC=$EXTRACT(CS,CP),CP=CP+1
316: . . SET:CP>$LENGTH(CS) CP=1
317: . . QUIT
318: . IF C="n" DO QUIT
319: . . SET GC=$EXTRACT(V2,VP),VP=VP+1
320: . . SET:VP>$LENGTH(V2) VP=0
321: . . QUIT
322: . IF C="s" DO QUIT
323: . . SET GC=$EXTRACT(SC,SP),SP=SP+1
324: . . SET:SP<$LENGTH(SP) SP=1
325: . . QUIT
326: . QUIT
327: IF "c"[C DO QUIT
328: . SET:$GET(CP)="" CP=1
329: . SET GC=$EXTRACT(CS,CP)
330: . SET:CP>$LENGTH(CS) GC=" "
331: . SET CP=CP+1
332: . QUIT
333: IF C="+" SET GC="+" SET:'SV GC="-" SET GL=GC QUIT
334: IF C="-" SET:'SV GC="-" SET GL=GC QUIT
335: IF C="(" SET:'SV GC="(" SET GL=GC QUIT
336: IF C=")" SET:'SV GC=")" SET GL=GC QUIT
337: QUIT
338: ;
339: %ERREX ; Error Exit point
340: DO %ERROR
341: QUIT K
342: ;
343: ; EC - Error Coded String (1 character or longer)
344: ; EL - Error Code Length
345: ; FL - Field Length
346: ; K - Output String, The Error Message goes here.
347: %ERROR ; %ERROR HANDLING
348: NEW C,E,EL,L
349: SET:$GET(FL)<1 FL=$$%FLDLNG(0)
350: SET E=$GET(EC),K="",L=1
351: SET:E="" E="*"
352: SET EL=$LENGTH(E)
353: FOR I=1:1:FL SET C=$EXTRACT(E,L),L=L+1 SET:L>EL L=1 SET K=K_C
354: QUIT
355: ;
356: %LOADTV ; Do the translation of the temporary value with the string
357: NEW X
358: SET X=""
359: FOR M=1:2:$LENGTH(TV,"%%") DO
360: . SET X=X_$PIECE(TV,"%%",M)
361: . SET N=$PIECE(TV,"%%",M+1)
362: . SET:N X=X_ST(N)
363: . QUIT
364: SET TV=X
365: QUIT
366: ;
367: %FLDLNG(F) ; FIELD LENGTH Callable from Just About Anywhere
368: SET F=$GET(F)
369: QUIT:F F
370: ;
371: SET F=$LENGTH($GET(FO("FM")))
372: IF 'F DO
373: . SET F=$GET(FO("FL"))
374: . IF 'F DO
375: . . SET F=$LENGTH($GET(^$FORMAT("FM")))
376: . . IF 'F DO
377: . . . SET F=$GET(^$FORMAT("FL"))
378: . . . IF 'F DO
379: . . . . SET F=$LENGTH($GET(^$SYSTEM("FORMAT","FM")))
380: . . . . IF 'F SET F=$GET(^$SYSTEM("FORMAT","FL"))
381: . . . . QUIT
382: . . . QUIT
383: . . QUIT
384: . QUIT
385: SET:'F F=10
386: QUIT F
387: ;
388: ; Format Default Load
389: ;
390: %INFORM ; Load up the defaults
391: NEW K,X
392: SET K="",X="FORMAT"
393: IF '$DATA(^$FORMAT) DO QUIT:$DATA(^$SYSTEM(X))
394: . IF '$DATA(^$SYSTEM(X)) DO QUIT
395: . . SET ^$FORMAT("SC")=",",^$FORMAT("DC")="."
396: . . SET ^$FORMAT("CS")="$",^$FORMAT("EC")="*"
397: . . QUIT
398: . MERGE ^$FORMAT=^$SYSTEM("FORMAT")
399: . QUIT
400: ; IF ^SYSTEM DOES NOT EXIST, CREATE IT
401: DO:'$DATA(^$SYSTEM(X))
402: . MERGE ^$SYSTEM("FORMAT")=^$FORMAT
403: . QUIT
404: QUIT
405: ;
406: ;===
407: ;
408: ;
409: CRC16(string,seed) ;
410: ;
411: ; The code below was approved in document X11/1998-32
412: ;
413: ; Polynomial x**16 + x**15 + x**2 + x**0
414: NEW I,J,R
415: IF '$DATA(seed) SET R=0
416: ELSE IF seed'<0,seed'>65535 SET R=seed\1
417: ELSE SET $ECODE=",M28,"
418: FOR I=1:1:$LENGTH(string) DO
419: . SET R=$$%XOR($ASCII(string,I),R,8)
420: . FOR J=0:1:7 DO
421: . . IF R#2 SET R=$$%XOR(R\2,40961,16)
422: . . ELSE SET R=R\2
423: . . QUIT
424: . QUIT
425: QUIT R
426: %XOR(a,b,w) NEW I,M,R
427: SET R=b,M=1
428: FOR I=1:1:w DO
429: . SET:a\M#2 R=R+$SELECT(R\M#2:-M,1:M)
430: . SET M=M+M
431: . QUIT
432: QUIT R
433: ;===
434: ;
435: ;
436: CRC32(string,seed) ;
437: ;
438: ; The code below was approved in document X11/1998-32
439: ;
440: ; Polynomial X**32 + X**26 + X**23 + X**22 +
441: ; + X**16 + X**12 + X**11 + X**10 +
442: ; + X**8 + X**7 + X**5 + X**4 +
443: ; + X**2 + X + 1
444: NEW I,J,R
445: IF '$DATA(seed) SET R=4294967295
446: ELSE IF seed'<0,seed'>4294967295 SET R=seed\1
447: ELSE SET $ECODE=",M28,"
448: FOR I=1:1:$LENGTH(string) DO
449: . SET R=$$%XOR($ASCII(string,I),R,8)
450: . FOR J=0:1:7 DO
451: . . IF R#2 SET R=$$%XOR(R\2,3988292384,32)
452: . . ELSE SET R=R\2
453: . . QUIT
454: . QUIT
455: QUIT 4294967295-R
456: ; ===
457: ;
458: ;
459: CRCCCITT(string,seed) ;
460: ;
461: ; The code below was approved in document X11/1998-32
462: ;
463: ; Polynomial x**16 + x**12 + x**5 + x**0
464: NEW I,J,R
465: IF '$DATA(seed) SET R=65535
466: ELSE IF seed'<0,seed'>65535 SET R=seed\1
467: ELSE SET $ECODE=",M28,"
468: FOR I=1:1:$LENGTH(string) DO
469: . SET R=$$%XOR($ASCII(string,I)*256,R,16)
470: . FOR J=0:1:7 DO
471: . . SET R=R+R
472: . . QUIT:R<65536
473: . . SET R=$$%XOR(4129,R-65536,13)
474: . . QUIT
475: . QUIT
476: QUIT R
477: ; ===
478: ;
479: ;
480: LOWER(A,CHARMOD) NEW lo,up,x,y
481: ;
482: ; The code below was approved in document X11/1998-21
483: ;
484: SET x=$GET(CHARMOD)
485: SET lo="abcdefghijklmnopqrstuvwxyz"
486: SET up="ABCDEFGHIJKLMNOPQRSTUVWXYZ"
487: QUIT $TRANSLATE(A,up,lo)
488: IF x?1"^"1E.E DO
489: . SET x=$EXTRACT(x,2,$LENGTH(x))
490: . IF x?1"|".E DO
491: . . SET x=$REVERSE($EXTRACT(x,2,$LENGTH(x)))
492: . . SET y=$REVERSE($PIECE(x,"|",2,$LENGTH(x)+2))
493: . . SET x=$REVERSE($PIECE(x,"|",1))
494: . . SET x=$GET(^|y|$GLOBAL(x,"CHARACTER"))
495: . . QUIT
496: . ELSE SET x=$GET(^$GLOBAL(x,"CHARACTER"))
497: . QUIT
498: IF x="" SET x=^$JOB($JOB,"CHARACTER")
499: SET x=$GET(^$CHARACTER(x,"LOWER"))
500: IF x="" QUIT $TRANSLATE(A,up,lo)
501: SET @("x="_x_"(A)")
502: QUIT x
503: ; ===
504: ;
505: ;
506: PATCODE(A,PAT,CHARMOD) NEW x,y
507: ;
508: ; The code below was approved in document X11/1998-21
509: ;
510: SET x=$GET(CHARMOD)
511: IF x?1"^"1E.E DO
512: . SET x=$EXTRACT(x,2,$LENGTH(x))
513: . IF x?1"|".E DO
514: . . SET x=$REVERSE($EXTRACT(x,2,$LENGTH(x)))
515: . . SET y=$REVERSE($PIECE(x,"|",2,$LENGTH(x)+2))
516: . . SET x=$REVERSE($PIECE(x,"|",1))
517: . . SET x=$GET(^|y|$GLOBAL(x,"CHARACTER"))
518: . . QUIT
519: . ELSE SET x=$GET(^$GLOBAL(x,"CHARACTER"))
520: . QUIT
521: IF x="" SET x=^$JOB($JOB,"CHARACTER")
522: SET x=$GET(^$CHARACTER(x,"PATCODE",PAT))
523: IF x="" QUIT 0
524: SET @("x="_x_"(A)")
525: QUIT x
526: ; ===
527: ;
528: ;
529: UPPER(A,CHARMOD) NEW lo,up,x,y
530: ;
531: ; The code below was approved in document X11/1998-21
532: ;
533: SET x=$GET(CHARMOD)
534: SET lo="abcdefghijklmnopqrstuvwxyz"
535: SET up="ABCDEFGHIJKLMNOPQRSTUVWXYZ"
536: QUIT $TRANSLATE(A,lo,up)
537: IF x?1"^"1E.E DO
538: . SET x=$EXTRACT(x,2,$LENGTH(x))
539: . IF x?1"|".E DO
540: . . SET x=$REVERSE($EXTRACT(x,2,$LENGTH(x)))
541: . . SET y=$REVERSE($PIECE(x,"|",2,$LENGTH(x)+2))
542: . . SET x=$REVERSE($PIECE(x,"|",1))
543: . . SET x=$GET(^|y|$GLOBAL(x,"CHARACTER"))
544: . . QUIT
545: . ELSE SET x=$GET(^$GLOBAL(x,"CHARACTER"))
546: . QUIT
547: IF x="" SET x=^$JOB($JOB,"CHARACTER")
548: SET x=$GET(^$CHARACTER(x,"UPPER"))
549: IF x="" QUIT $TRANSLATE(A,lo,up)
550: SET @("x="_x_"(A)")
551: QUIT x
552: ; ===
553: ;
554: ;
555:
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>
![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to %ulstring.m CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [Coherent Logic Development] / freem / mlib