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