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