;"16-Feb-1999, 16:54:35
 ;"Routine Save for all M[UMPS] Library Functions
 ;
 ;" Unless otherwise noted, the code below
 ;" was approved in document X11/95-11
 ;
 ;" If corrections have been applied,
 ;" first the original line appears,
 ;" with three semicolons at the beginning of the line.
 ;
 ;" Then the source of the correction is acknowledged,
 ;" then the corrected line appears, followed by a
 ;" line containing three semicolons.
 ;
 ;"Downloaded from http://www.jacquardsystems.com/Examples/lib/mlibfunc.rs
 ;"on 5/21/07
FORMAT(V,S) ;
        ;
        ;" The code below was approved in document X11/SC13/TG2/1999-1
        ;
        New lo,mask,out,p,pos,spec,up,v1,v2,val,x
        ;
        Set lo="abcdefghijklmnopqrstuvwxyz"
        Set up="ABCDEFGHIJKLMNOPQRSTUVWXYZ"
        ;
        ;" Array spec() contains the formatting directives
        ;
        ;" First set defaults
        ;
        Set spec("CS")="$" ;" Currency symbol
        Set spec("DC")="." ;" Decimal separator
        Set spec("EC")="*" ;" Error character
        Set spec("SL")="," ;" Separator characters > 1
        Set spec("FS")=" " ;" Fill string
        ;
        ;" Other specifiers may be
        ;"  FM = Format Mask
        ;"  FO = Fill On/Off
        ;"  SR = Separator characters < 1
        ;
        ;" Then Inherit properties from System,
        ;" overwriting the defaults
        ;
        Set x="" For  Set x=$Order(^$System($System,"FORMAT",x)) Quit:x=""  Do
        . Set spec(x)=^$System($System,"FORMAT",x)
        . Quit
        ;
        ;" Then Inherit properties from current process
        ;" overwriting the system and the defaults
        ;
        Set x="" For  Set x=$Order(^$Job($Job,"FORMAT",x)) Quit:x=""  Do
        . Set spec(x)=^$Job($Job,"FORMAT",x)
        . Quit
        ;
        ;" Then look at actual parameters
        ;" overwriting anything else
        ;
        Set S=$Get(S) For  Quit:S=""  Do
        . New e,i,str,v
        . Set x=$Piece(S,"=",1)
        . Set i=$Length(x)+2,str=0,v=""
        . Set:x="" i=1
        . For i=i:1:$Length(S)+1 Do  Quit:'i
        . . Set e=$Extract(S_":",i)
        . . If 'str,e=":" Set S=$Extract(S,i+1,$Length(S)),i=0 Quit
        . . Set v=v_e Quit:e'=""""
        . . Set str=1-str
        . . Quit
        . If i>$Length(S) Set S=""
        . If x'="",v'="" Set @("spec($Translate(x,lo,up))="_v) Quit
        . Set $ECode=",M28,"
        . Quit
        ;
        ;" Make certain that DC and EC are non-empty
        ;" and not longer than 1 character
        ;
        Set spec("DC")=$Extract(spec("DC")_".",1)
        Set spec("EC")=$Extract(spec("EC")_"*",1)
        ;
        Set val=$Get(V),(mask,out)=$Get(spec("FM"))
        If mask="" Quit val
        ;
        ;" Currency string
        ;
        Set x=spec("CS")
        Set pos=0 For  Set pos=$Find(mask,"c",pos) Quit:pos<1  Do
        . Set $Extract(out,pos-1)=$Extract(x,1)
        . Set x=$Extract(x,2,$Length(x))_$Extract(x,1)
        . Quit
        ;
        ;" Sign
        ;
        Set x=$Select(val>0:"+",val<0:"-",1:" ")
        Set pos=0 For  Set pos=$Find(mask,"+",pos) Quit:pos<1  Do
        . Set $Extract(out,pos-1)=x
        . Quit
        Set pos=0 For  Set pos=$Find(mask,"-",pos) Quit:pos<1  Do
        . Set $Extract(out,pos-1)=$Select(x="-":x,1:" ")
        . Quit
        If x'="-" Set out=$Translate(out,"()","  ")
        ;
        ;" Decimal separator
        ;
        Set pos=$Find(mask,"d")
        Do:pos'<1
        . Set $Extract(out,pos-1)=spec("DC")
        . For  Set pos=$Find(mask,"d",pos) Quit:pos<1  Do
        . . Set $Extract(out,pos-1)=spec("EC")
        . . Quit
        . Quit
        ;
        ;" Right (default, format letter "n") or
        ;" left (format letter "l") adjustment?
        ;
        If mask["l",mask["n" Set $ECode=",M28,"
        ;
        ;" Left and Right Separators
        ;
        Set v1=$Piece(val,".",1),v2=$Piece(val,".",2)
        Set v1=$Translate(v1,"-")
        If mask'["l" Do
        . Set x="" For p=1:1:$Length(v1) Set x=$Extract(v1,p)_x
        . Set v1=x
        . Quit
        ;
        Set pos=$Find(mask,"d") Set:pos<1 pos=$Length(mask)+2
        ;
        ;" Integer part and Left separators
        ;
        Set x=spec("SL")
        Set p(1)=pos-2,p(2)=-1,p(3)=1
        Set:mask["l" p(1)=1,p(2)=1,p(3)=pos-2
        For p=p(1):p(2):p(3) Do
        . If "fln"[$Extract(mask,p) Do
        . . Set $Extract(out,p)=$Extract(v1,1)
        . . Set v1=$Extract(v1,2,$Length(v1))_spec("FS")
        . . If $Translate(v1,spec("FS"))="" Set x=spec("FS")
        . . Quit
        . If $Extract(mask,p)="s" Do
        . . Set $Extract(out,p)=$Extract(x,1)
        . . Set x=$Extract(x,2,$Length(x))_$Extract(x,1)
        . Quit
        ;
        ;" Fractional part and Right separators
        ;
        Set x=$Get(spec("SR"),spec("SL"))
        Set:v2="" v2=0
        For p=pos:1:$Length(mask) Do
        . If "fn"[$Extract(mask,p) Do
        . . Set $Extract(out,p)=$Extract(v2,1)
        . . Set v2=$Extract(v2,2,$Length(v2))_"0"
        . . Quit
        . If $Extract(mask,p)="s" Do
        . . Set $Extract(out,p)=$Extract(x,1)
        . . Set x=$Extract(x,2,$Length(x))_$Extract(x,1)
        . . Quit
        . Quit
        ;
        ;" Fill String
        ;
        Set x=$Get(spec("FS"))
        For p=1:1:$l(mask) Do
        . Quit:"nf"'[$Extract(mask,p)
        . Quit:$Extract(out,p)'=" "
        . Set $Extract(out,p)=$Extract(x,1)
        . Set x=$Extract(x,2,$Length(x))_$Extract(x,1)
        . Quit
        ;
        ;" Justification
        ;
        For x="+ | +","- | -","( | ("," )|) " Do
        . New find,repl
        . Set find=$Piece(x,"|",1),repl=$Piece(x,"|",2)
        . For  Quit:out'[find  Do
        . . Set out=$Piece(out,find,1)_repl_$Piece(out,find,2,$l(out)+2)
        . . Quit
        . Quit
        ;
        Quit out
 ;
 ;===
 ;
 ;
CRC16(string,seed) ;
 ;
 ;" The code below was approved in document X11/1998-32
 ;
 ;" Polynomial x**16 + x**15 + x**2 + x**0
 NEW I,J,R
 IF '$DATA(seed) SET R=0
 ELSE  IF seed'<0,seed'>65535 SET R=seed\1
 ELSE  SET $ECODE=",M28,"
 FOR I=1:1:$LENGTH(string) DO
 . SET R=$$XOR($ASCII(string,I),R,8)
 . FOR J=0:1:7 DO
 . . IF R#2 SET R=$$XOR(R\2,40961,16)
 . . ELSE  SET R=R\2
 . . QUIT
 . QUIT
 QUIT R
XOR(a,b,w) NEW I,M,R
 SET R=b,M=1
 FOR I=1:1:w DO
 . SET:a\M#2 R=R+$SELECT(R\M#2:-M,1:M)
 . SET M=M+M
 . QUIT
 QUIT R
 ;===
 ;
 ;
CRC32(string,seed) ;
 ;
 ;" The code below was approved in document X11/1998-32
 ;
 ;" Polynomial X**32 + X**26 + X**23 + X**22 +
 ;"          + X**16 + X**12 + X**11 + X**10 +
 ;"          + X**8  + X**7  + X**5  + X**4 +
 ;"          + X**2  + X     + 1
 NEW I,J,R
 IF '$DATA(seed) SET R=4294967295
 ELSE  IF seed'<0,seed'>4294967295 SET R=4294967295-seed
 ELSE  SET $ECODE=",M28,"
 FOR I=1:1:$LENGTH(string) DO
 . SET R=$$XOR($ASCII(string,I),R,8)
 . FOR J=0:1:7 DO
 . . IF R#2 SET R=$$XOR(R\2,3988292384,32)
 . . ELSE  SET R=R\2
 . . QUIT
 . QUIT
 QUIT 4294967295-R
XOR(a,b,w) NEW I,M,R
 SET R=b,M=1
 FOR I=1:1:w DO
 . SET:a\M#2 R=R+$SELECT(R\M#2:-M,1:M)
 . SET M=M+M
 . QUIT
 QUIT R
 ;" ===
 ;
 ;
CRCCCITT(string,seed) ;
 ;
 ;" The code below was approved in document X11/1998-32
 ;
 ;" Polynomial x**16 + x**12 + x**5 + x**0
 NEW I,J,R
 IF '$DATA(seed) SET R=65535
 ELSE  IF seed'<0,seed'>65535 SET R=seed\1
 ELSE  SET $ECODE=",M28,"
 FOR I=1:1:$LENGTH(string) DO
 . SET R=$$XOR($ASCII(string,I)*256,R,16)
 . FOR J=0:1:7 DO
 . . SET R=R+R
 . . QUIT:R<65536
 . . SET R=$$XOR(4129,R-65536,13)
 . . QUIT
 . QUIT
 QUIT R
XOR(a,b,w) NEW I,M,R
 SET R=b,M=1
 FOR I=1:1:w DO
 . SET:a\M#2 R=R+$SELECT(R\M#2:-M,1:M)
 . SET M=M+M
 . QUIT
 QUIT R
 ;" ===
 ;
 ;
LOWER(A,CHARMOD) NEW lo,up,x,y
 ;
 ;" The code below was approved in document X11/1998-21
 ;
 SET x=$GET(CHARMOD)
 SET lo="abcdefghijklmnopqrstuvwxyz"
 SET up="ABCDEFGHIJKLMNOPQRSTUVWXYZ"
 IF x?1"^"1E.E DO
 . SET x=$EXTRACT(x,2,$LENGTH(x))
 . IF x?1"|".E DO
 . . SET x=$REVERSE($EXTRACT(x,2,$LENGTH(x)))
 . . SET y=$REVERSE($PIECE(x,"|",2,$LENGTH(x)+2))
 . . SET x=$REVERSE($PIECE(x,"|",1))
 . . SET x=$GET(^|y|$GLOBAL(x,"CHARACTER"))
 . . QUIT
 . ELSE  SET x=$GET(^$GLOBAL(x,"CHARACTER"))
 . QUIT
 IF x="" SET x=^$JOB($JOB,"CHARACTER")
 SET x=$GET(^$CHARACTER(x,"LOWER"))
 IF x="" QUIT $TRANSLATE(A,up,lo)
 SET @("x="_x_"(A)")
 QUIT x
 ;" ===
 ;
 ;
PATCODE(A,PAT,CHARMOD) NEW x,y
 ;
 ;" The code below was approved in document X11/1998-21
 ;
 SET x=$GET(CHARMOD)
 IF x?1"^"1E.E DO
 . SET x=$EXTRACT(x,2,$LENGTH(x))
 . IF x?1"|".E DO
 . . SET x=$REVERSE($EXTRACT(x,2,$LENGTH(x)))
 . . SET y=$REVERSE($PIECE(x,"|",2,$LENGTH(x)+2))
 . . SET x=$REVERSE($PIECE(x,"|",1))
 . . SET x=$GET(^|y|$GLOBAL(x,"CHARACTER"))
 . . QUIT
 . ELSE  SET x=$GET(^$GLOBAL(x,"CHARACTER"))
 . QUIT
 IF x="" SET x=^$JOB($JOB,"CHARACTER")
 SET x=$GET(^$CHARACTER(x,"PATCODE",PAT))
 IF x="" QUIT 0
 SET @("x="_x_"(A)")
 QUIT x
 ;" ===
 ;
 ;
UPPER(A,CHARMOD) NEW lo,up,x,y
 ;
 ;" The code below was approved in document X11/1998-21
 ;
 SET x=$GET(CHARMOD)
 SET lo="abcdefghijklmnopqrstuvwxyz"
 SET up="ABCDEFGHIJKLMNOPQRSTUVWXYZ"
 IF x?1"^"1E.E DO
 . SET x=$EXTRACT(x,2,$LENGTH(x))
 . IF x?1"|".E DO
 . . SET x=$REVERSE($EXTRACT(x,2,$LENGTH(x)))
 . . SET y=$REVERSE($PIECE(x,"|",2,$LENGTH(x)+2))
 . . SET x=$REVERSE($PIECE(x,"|",1))
 . . SET x=$GET(^|y|$GLOBAL(x,"CHARACTER"))
 . . QUIT
 . ELSE  SET x=$GET(^$GLOBAL(x,"CHARACTER"))
 . QUIT
 IF x="" SET x=^$JOB($JOB,"CHARACTER")
 SET x=$GET(^$CHARACTER(x,"UPPER"))
 IF x="" QUIT $TRANSLATE(A,lo,up)
 SET @("x="_x_"(A)")
 QUIT x
 ;" ===
 ;
 ;