| [796] | 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
|
|---|
| 17 | FORMAT(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 | ;
|
|---|
| 184 | CRC16(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
|
|---|
| 201 | XOR(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 | ;
|
|---|
| 211 | CRC32(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
|
|---|
| 231 | XOR(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 | ;
|
|---|
| 241 | CRCCCITT(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
|
|---|
| 259 | XOR(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 | ;
|
|---|
| 269 | LOWER(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 | ;
|
|---|
| 294 | PATCODE(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 | ;
|
|---|
| 317 | UPPER(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 |
|
|---|
