Annotation of freem/mlib/%ulstring.m, revision 1.1.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