Button for 1977 Button for 1984 Button for 1990 Button for 1995 Button for MDC Button for notes Button for examples
Left Hand Pointer

Appendix I

M[UMPS] by Example

Right Hand Pointer
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.
 ;
ABS(X) Quit $Translate(+X,"-")
 ;===
 ;
 ;
ARCCOS(X) ;
 ;;; ;                                                                 Number 
 ; Winfried Gerum (8 June 1995)
 ;  Comment: This version of the function is
 ;           optimized for speed, not for precision.
 ;           The 'precision' parameter is not supported,
 ;           and the precision is at best 2 in 10**–8.
 ;;;
 ;
 New A,N,R,SIGN,XX
 If X<–1 Set $Ecode=",M28,"
 If X>1 Set $Ecode=",M28,"
 Set SIGN=1 Set:X<0 X=-X,SIGN=–1
 Set A(0)=1.5707963050,A(1)=–0.2145988016,A(2)=0.0889789874
 Set A(3)=–0.0501743046,A(4)=0.0308918810,A(5)=–0.0170881256
 Set A(6)=0.0066700901,A(7)=–0.0012624911
 Set R=A(0),XX=1 For N=1:1:7 Set XX=XX*X,R=A(N)*XX+R
 ;
 ;;; Set R=$%SQRT^MATH(1-X)*R ;                                        Number 
 ; Winfried Gerum (8 June 1995)
 Set R=$%SQRT^MATH(1-X,11)*R
 ;;;
 ;
 Quit R*SIGN
 ;===
 ;
 ;
ARCCOS(X,PREC) ;
 ;
 ;;; New L,LIM,K,SIG,SIGS ;                                            Number 
 ; Winfried Gerum (8 June 1995)
 New L,LIM,K,SIG,SIGS,VALUE
 ;;;
 ;
 If X<–1 Set $Ecode=",M28,"
 If X>1 Set $Ecode=",M28,"
 Set PREC=$Get(PREC,11)
 ;
 ;;; If $Translate(X,"-")=1 Set VALUE=0 Quit ;                         Number 
 ; Winfried Gerum (8 June 1995)
 ; Eli Reidler (28 June 1996)
 If $Translate(X,"-")=1 Quit 0
 ;;;
 ;
 Set SIG=$Select(X<0:–1,1:1),VALUE=1-(X*X)
 ;
 ;;; Set X=$%SQRT^MATH(VALUE) ;                                        Number 
 ; Winfried Gerum (8 June 1995)
 Set X=$%SQRT^MATH(VALUE,PREC)
 ;;;
 ;
 ;;; If $Translate(X,"-")=1 Do  Quit ;                                 Number 
 ; Winfried Gerum (8 June 1995)
 ; Eli Reidler (28 June 1996)
 If $Translate(X,"-")=1 Do  Quit VALUE
 . ;;;
 . ;
 . Set VALUE=$%PI^MATH()/2*X
 . Quit
 ;
 ;;; If X>0.9 Do  Quit ;                                               Number 
 ; Winfried Gerum (8 June 1995)
 ; Eli Reidler (28 June 1996)
 If X>0.9 Do  Quit VALUE
 . ;;;
 . ;
 . Set SIGS=$Select(X<0:–1,1:1)
 . Set VALUE=1/(1/X/X–1)
 . ;
 . ;;; Set X=$%SQRT^MATH(VALUE) ;                                      Number 
 . ; Winfried Gerum (8 June 1995)
 . Set X=$%SQRT^MATH(VALUE,PREC)
 . ;;;
 . ;
 . ;
 . ;;; Set VALUE=$%ARCTAN^MATH(X,10)*SIGS ;                            Number 
 . ; Winfried Gerum (8 June 1995)
 . Set VALUE=$%ARCTAN^MATH(X,PREC)*SIGS
 . ;;;
 ;
 . Quit
 Set (VALUE,L)=X
 Set LIM=$Select((PREC+3)'>11:PREC+3,1:11),@("LIM=1E-"_LIM)
 For K=3:2 Do  Quit:($Translate(L,"-")<LIM)
 . Set L=L*X*X*(K–2)/(K–1)*(K–2)/K,VALUE=VALUE+L
 . Quit
 Quit $Select(SIG<0:$%PI^MATH()-VALUE,1:VALUE)
 ;===
 ;
 ;
ARCCOSH(X,PREC) ;
 If X<1 Set $Ecode=",M28,"
 New SQ
 ;
 ;;; ;                                                                 Number 
 ; Winfried Gerum (8 June 1995)
 ; Alan Frank (October 1995)
 Set PREC=$Get(PREC,11)
 ;;;
 ;
 Set SQ=$%SQRT^MATH(X*X–1,PREC)
 Quit $%LOG^MATH(X+SQ,PREC)
 ;===
 ;
 ;
ARCCOT(X,PREC) ;
 Set PREC=$Get(PREC,11)
 Set X=1/X
 Quit $%ARCTAN^MATH(X,PREC)
 ;===
 ;
 ;
ARCCOTH(X,PREC) ;
 New L1,L2
 ;
 ;;; ;                                                                 Number 
 ; Winfried Gerum (8 June 1995)
 ; Alan Frank (October 1995)
 Set PREC=$Get(PREC,11)
 ;;;
 ;
 Set L1=$%LOG^MATH(X+1,PREC)
 Set L2=$%LOG^MATH(X–1,PREC)
 Quit L1-L2/2
 ;===
 ;
 ;
ARCCSC(X,PREC) ;
 Set PREC=$Get(PREC,11)
 Set X=1/X
 Quit $%ARCSIN^MATH(X,PREC)
 ;===
 ;
 ;
ARCSEC(X,PREC) ;
 Set PREC=$Get(PREC,11)
 Set X=1/X
 Quit $%ARCCOS^MATH(X,PREC)
 ;===
 ;
 ;
ARCSIN(X) ;
 ;;; ;                                                                 Number 
 ; Winfried Gerum (8 June 1995)
 ;  Comment: This version of the function is
 ;           optimized for speed, not for precision.
 ;           The 'precision' parameter is not supported,
 ;           and the precision is at best 2 in 10**–8.
 ;;;
 ;
 New A,N,R,SIGN,XX
 If X<–1 Set $Ecode=",M28,"
 If X>1 Set $Ecode=",M28,"
 Set SIGN=1 Set:X<0 X=-X,SIGN=–1
 Set A(0)=1.5707963050,A(1)=–0.2145988016,A(2)=0.0889789874
 Set A(3)=–0.0501743046,A(4)=0.0308918810,A(5)=–0.0170881256
 Set A(6)=0.0066700901,A(7)=–0.0012624911
 Set R=A(0),XX=1 For N=1:1:7 Set XX=XX*X,R=A(N)*XX+R
 ;
 ;;; Set R=$%SQRT^MATH(1-X)*R ;                                        Number 
 ; Winfried Gerum (8 June 1995)
 Set R=$%SQRT^MATH(1-X,11)*R
 ;;;
 ;
 Set R=$%PI^MATH()/2-R
 Quit R*SIGN
 ;===
 ;
 ;
ARCSIN(X,PREC) ;
 New L,LIM,K,SIGS,VALUE
 Set PREC=$Get(PREC,11)
 ;
 ;;; If $Translate(X,"-")=1 Do  Quit ;                                 Number 
 ; Winfried Gerum (8 June 1995)
 ; Eli Reidler (28 June 1996)
 If $Translate(X,"-")=1 Do  Quit VALUE
 . ;;;
 . ;
 . Set VALUE=$%PI^MATH()/2*X
 . Quit
 ;
 ;;; If X>0.99999 Do  Quit ;                                           Number 
 ; Winfried Gerum (8 June 1995)
 ; Eli Reidler (28 June 1996)
 If X>0.99999 Do  Quit VALUE
 . ;;;
 . ;
 . Set SIGS=$Select(X<0:–1,1:1)
 . Set VALUE=1/(1/X/X–1)
 . ;
 . ;;; Set X=$%SQRT^MATH(VALUE) ;                                      Number 
 . ; Winfried Gerum (8 June 1995)
 . Set X=$%SQRT^MATH(VALUE,PREC)
 . ;;;
 . ;
 . ;;; Set VALUE=$%ARCTAN^MATH(X,10)*SIGS ;                            Number 
 . ; Winfried Gerum (8 June 1995)
 . Set VALUE=$%ARCTAN^MATH(X,PREC)*SIGS
 . ;;;
 . ;
 . Quit
 Set (VALUE,L)=X
 Set LIM=$Select((PREC+3)'>11:PREC+3,1:11),@("LIM=1E-"_LIM)
 For K=3:2 Do  Quit:($Translate(L,"-")<LIM)
 . Set L=L*X*X*(K–2)/(K–1)*(K–2)/K,VALUE=VALUE+L
 . Quit
 Quit VALUE
 ;===
 ;
 ;
ARCSINH(X,PREC) ;
 If X<1 Set $Ecode=",M28,"
 New SQ
 ;
 ;;; ;                                                                 Number 
 ; Winfried Gerum (8 June 1995)
 ; Alan Frank (October 1995)
 Set PREC=$Get(PREC,11)
 ;;;
 ;
 Set SQ=$%SQRT^MATH(X*X+1,PREC)
 Quit $%LOG^MATH(X+SQ,PREC)
 ;===
 ;
 ;
ARCTAN(X,PREC) ;
 New FOLD,HI,L,LIM,LO,K,SIGN,SIGS,SIGT,VALUE
 Set PREC=$Get(PREC,11)
 Set LO=0.0000000001,HI=9999999999
 Set SIGT=$Select(X<0:–1,1:1),X=$Translate(X,"-")
 Set X=$Select(X<LO:LO,X>HI:HI,1:X)
 ;
 ;;; Set FOLD=$Select(X'<1:0,1:1), ;                                   Number 
 ; Eli Reidler (28 June 1996)
 Set FOLD=$Select(X'<1:0,1:1)
 ;;;
 ;
 Set X=$Select(FOLD:1/X,1:X)
 Set L=X,VALUE=$%PI^MATH()/2-(1/X),SIGN=1
 ;
 ;;; If X<1.3 Do  Quit ;                                               Number 
 ; Winfried Gerum (8 June 1995)
 ; Eli Reidler (28 June 1996)
 If X<1.3 Do  Quit VALUE
 . ;;;
 . ;
 . Set X=$Select(FOLD:1/X,1:X),VALUE=1/((1/X/X)+1)
 . ;
 . ;;; Set $%SQRT^MATH(VALUE) ;                                        Number 
 . ; Winfried Gerum (8 June 1995)
 . ; Eli Reidler (28 June 1996)
 . Set X=$%SQRT^MATH(VALUE,PREC)
 . ;;;
 . ;
 . If $Translate(X,"-")=1 Do  Quit
 . . Set VALUE=$%PI^MATH()/2*X
 . . Quit
 . If X>0.9 Do  Quit
 . . Set SIGS=$Select(X<0:–1,1:1)
 . . Set VALUE=1/(1/X/X–1)
 . . Set X=$%SQRT^MATH(VALUE)
 . . Set VALUE=$$ARCTAN(X,10)
 . . Set VALUE=VALUE*SIGS
 . . Quit
 . Set (VALUE,L)=X
 . Set LIM=$Select((PREC+3)'>11:PREC+3,1:11),@("LIM=1E-"_LIM)
 . For K=3:2 Do  Quit:($Translate(L,"-")<LIM)
 . . Set L=L*X*X*(K–2)/(K–1)*(K–2)/K,VALUE=VALUE+L
 . . Quit
 . Set VALUE=$Select(SIGT<1:-VALUE,1:VALUE)
 . Quit
 Set LIM=$Select((PREC+3)'>11:PREC+3,1:11),@("LIM=1E-"_LIM)
 For K=3:2 Do  Quit:($Translate(1/L,"-")<LIM)
 . ;
 . ;;; Set L=L*X*X,VALUE=VALUE+(1/(K*L)*SIGN), ;                       Number 
 . ; Eli Reidler (28 June 1996)
 . Set L=L*X*X,VALUE=VALUE+(1/(K*L)*SIGN)
 . ;;;
 . ;
 . Set SIGN=SIGN*–1
 . Quit
 Set VALUE=$Select(FOLD:$%PI^MATH()/2-VALUE,1:VALUE)
 Set VALUE=$Select(SIGT<1:-VALUE,1:VALUE)
 Quit VALUE
 ;===
 ;
 ;
ARCTANH(X,PREC) ;
 If X<–1 Set $Ecode=",M28,"
 If X>1 Set $Ecode=",M28,"
 ;
 ;;; ;                                                                 Number 
 ; Winfried Gerum (8 June 1995)
 ; Alan Frank (October 1995)
 Set PREC=$Get(PREC,11)
 ;;;
 ;
 Quit $%LOG^MATH(1+X/(1-X),PREC)/2
 ;===
 ;
 ;
CABS(Z) ;
 New ZRE,ZIM
 Set ZRE=+Z,ZIM=+$Piece(Z,"%",2)
 Quit $%SQRT^MATH(ZRE*ZRE+(ZIM*ZIM))
 ;===
 ;
 ;
CADD(X,Y) ;
 New XRE,XIM,YRE,YIM
 Set XRE=+X,XIM=+$Piece(X,"%",2)
 Set YRE=+Y,YIM=+$Piece(Y,"%",2)
 Quit XRE+YRE_"%"_(XIM+YIM)
 ;===
 ;
 ;
CCOS(Z,PREC) ;
 New E1,E2,IA
 ;
 ;;; ;                                                                 Number 
 ; Alan Frank (October 1995)
 Set PREC=$Get(PREC,11)
 ;;;
 ;
 Set IA=$%CMUL^MATH(Z,"0%1")
 Set E1=$%CEXP^MATH(IA,PREC)
 Set IA=-IA_"%"_(-$Piece(IA,"%",2))
 Set E2=$%CEXP^MATH(IA,PREC)
 Set IA=$%CADD^MATH(E1,E2)
 Quit $%CMUL^MATH(IA,"0.5%0")
 ;===
 ;
 ;
CDIV(X,Y) ;
 New D,IM,RE,XIM,XRE,YIM,YRE
 Set XRE=+X,XIM=+$Piece(X,"%",2)
 Set YRE=+Y,YIM=+$Piece(Y,"%",2)
 Set D=YRE*YRE+(YIM*YIM)
 Set RE=XRE*YRE+(XIM*YIM)/D
 Set IM=XIM*YRE-(XRE*YIM)/D
 Quit RE_"%"_IM
 ;===
 ;
 ;
CEXP(Z,PREC) ;
 New R,ZIM,ZRE
 ;
 ;;; ;                                                                 Number 
 ; Alan Frank (October 1995)
 Set PREC=$Get(PREC,11)
 ;;;
 ;
 Set ZRE=+Z,ZIM=+$Piece(Z,"%",2)
 Set R=$%EXP^MATH(ZRE,PREC)
 Quit R*$%COS^MATH(ZIM,PREC)_"%"_(R*$%SIN^MATH(ZIM,PREC))
 ;===
 ;
 ;
CLOG(Z,PREC) ;
 New ABS,ARG,ZIM,ZRE
 ;
 ;;; ;                                                                 Number 
 ; Alan Frank (October 1995)
 Set PREC=$Get(PREC,11)
 ;;;
 ;
 Set ABS=$%CABS^MATH(Z)
 Set ZRE=+Z,ZIM=+$Piece(Z,"%",2)
 ;
 ;;; Set ARG=$%ARCTAN^MATH(ZIM,ZRE,PREC) ;                             Number 
 ; Alan Frank (October 1995)
 Set ARG=$%ARCTAN^MATH(ZIM/ZRE,PREC)
 ;;;
 ;
 Quit $%LOG^MATH(ABS,PREC)_"%"_ARG
 ;===
 ;
 ;
CMUL(X,Y) ;
 New XIM,XRE,YIM,YRE
 Set XRE=+X,XIM=+$Piece(X,"%",2)
 Set YRE=+Y,YIM=+$Piece(Y,"%",2)
 Quit XRE*YRE-(XIM*YIM)_"%"_(XRE*YIM+(XIM*YRE))
 ;===
 ;
 ;
COMPLEX(X) Quit +X_"%0"
 ;===
 ;
 ;
CONJUG(Z) ;
 New ZIM,ZRE
 Set ZRE=+Z,ZIM=+$Piece(Z,"%",2)
 Quit ZRE_"%"_(-ZIM)
 ;===
 ;
 ;
COS(X,PREC) ;
 New L,LIM,K,SIGN,VALUE
 ;
 ;;; Set:X[":" X=$%DMSDEC^MATH(X,12) ;                                 Number 
 ; Winfried Gerum (8 June 1995)
 ;    Comment: The official description does not mention than
 ;             the function may also be called with the first
 ;             parameter in degrees, minutes and seconds.
 Set:X[":" X=$%DMSDEC^MATH(X)
 ;;;
 ;
 Set PREC=$Get(PREC,11)
 Set X=X#(2*$%PI^MATH())
 Set (VALUE,L)=1,SIGN=–1
 Set LIM=$Select((PREC+3)'>11:PREC+3,1:11),@("LIM=1E-"_LIM)
 For K=2:2 Do  Quit:($Translate(L,"-")<LIM)  Set SIGN=SIGN*–1
 . Set L=L*X*X/(K–1*K),VALUE=VALUE+(SIGN*L)
 . Quit
 Quit VALUE
 ;===
 ;
 ;
COS(X) ;
 ;;; ;                                                                 Number 
 ; Winfried Gerum (8 June 1995)
 ;  Comment: This version of the function is
 ;           optimized for speed, not for precision.
 ;           The 'precision' parameter is not supported,
 ;           and the precision is at best 1 in 10**–9.
 ;           Note that this function does not accept its
 ;           parameter in degrees, minutes and seconds.
 ;;;
 ;
 New A,N,PI,R,SIGN,XX
 ;
 ; This approximation only works for 0 <= x <= pi/2
 ; so reduce angle to correct quadrant.
 ;
 Set PI=$%PI^MATH(),X=X#(PI*2),SIGN=1
 Set:X>PI X=2*PI-X
 Set:X*2>PI X=PI-X,SIGN=–1
 ;
 Set XX=X*X,A(1)=–0.4999999963,A(2)=0.0416666418
 Set A(3)=–0.0013888397,A(4)=0.0000247609,A(5)=–0.0000002605
 Set (X,R)=1 For N=1:1:5 Set X=X*XX,R=A(N)*X+R
 Quit R*SIGN
 ;===
 ;
 ;
COSH(X,PREC) ;
 ;
 ;;; New F,I,P,R,T,XX ;                                                Number 
 ; Winfried Gerum (8 June 1995)
 New E,F,I,P,R,T,XX
 ;;;
 ;
 Set PREC=$Get(PREC,11)+1
 Set @("E=1E-"_PREC)
 Set XX=X*X,F=1,(P,R,T)=1,I=1
 For  Set T=T*XX,F=I+1*I*F,R=T/F+R,P=P-R/R,I=I+2 If -E<P,P<E Quit
 Quit R
 ;===
 ;
 ;
COT(X,PREC) ;
 New C,L,LIM,K,SIGN,VALUE
 ;
 ;;; Set:X[":" X=$%DMSDEC^MATH(X,12) ;                                 Number 
 ; Winfried Gerum (8 June 1995)
 ;    Comment: The official description does not mention than
 ;             the function may also be called with the first
 ;             parameter in degrees, minutes and seconds.
 Set:X[":" X=$%DMSDEC^MATH(X)
 ;;;
 ;
 Set PREC=$Get(PREC,11)
 Set (VALUE,L)=1,SIGN=–1
 Set LIM=$Select((PREC+3)'>11:PREC+3,1:11),@("LIM=1E-"_LIM)
 For K=2:2 Do  Quit:($Translate(L,"-")<LIM)  Set SIGN=SIGN*–1
 . Set L=L*X*X/(K–1*K),VALUE=VALUE+(SIGN*L)
 . Quit
 Set C=VALUE
 Set X=X#(2*$%PI^MATH())
 Set (VALUE,L)=X,SIGN=–1
 Set LIM=$Select((PREC+3)'>11:PREC+3,1:11),@("LIM=1E-"_LIM)
 For K=3:2 Do  Quit:($Translate(L,"-")<LIM)  Set SIGN=SIGN*–1
 . Set L=L/(K–1)*X/K*X,VALUE=VALUE+(SIGN*L)
 . Quit
 If 'VALUE Quit "INFINITE"
 Quit VALUE=C/VALUE
 ;===
 ;
 ;
COTH(X,PREC) ;
 New SINH
 If 'X Quit "INFINITE"
 ;
 ;;; ;                                                                 Number 
 ; Winfried Gerum (8 June 1995)
 ; Alan Frank (October 1995)
 Set PREC=$Get(PREC,11)
 ;;;
 ;
 Set SINH=$%SINH^MATH(X,PREC)
 If 'SINH Quit "INFINITE"
 Quit $%COSH^MATH(X,PREC)/SINH
 ;===
 ;
 ;
CPOWER(Z,N,PREC) ;
 New AR,NIM,NRE,PHI,PI,R,RHO,TH,ZIM,ZRE
 ;
 ;;; ;                                                                 Number 
 ; Alan Frank (October 1995)
 Set PREC=$Get(PREC,11)
 ;;;
 ;
 Set ZRE=+Z,ZIM=+$Piece(Z,"%",2)
 Set NRE=+N,NIM=+$Piece(N,"%",2)
 If 'ZRE,'ZIM,'NRE,'NIM Set $Ecode=",M28,"
 ;
 ;;; If 'ZRE,'ZIM Quit "0%0% ;                                         Number 
 ; Eli Reidler (28 June 1996)
 If 'ZRE,'ZIM Quit "0%0"
 ;;;
 ;
 Set PI=$%PI^MATH()
 ;
 ;;; Set R=$%SQRT^MATH(ZRE*ZRE+(ZIM*ZIM,PREC)) ;                       Number 
 ; Winfried Gerum (8 June 1995)
 ; Eli Reidler (28 June 1996)
 Set R=$%SQRT^MATH(ZRE*ZRE+(ZIM*ZIM),PREC)
 ;;;
 ;
 ;
 ;;; If ZRE Set TH=$%ARCTAN^MATH(ZIM,ZRE,PREC) ;                       Number 
 ; Alan Frank (October 1995)
 If ZRE Set TH=$%ARCTAN^MATH(ZIM/ZRE,PREC)
 ;;;
 ;
 ;;; Else  Set TH=$SELECT(ZRE>0:PI/2,1:-PI/2) ;                        Number 
 ; Winfried Gerum (8 June 1995)
 Else  Set TH=$SELECT(ZIM>0:PI/2,1:-PI/2)
 ;;;
 ;
 Set RHO=$%LOG^MATH(R,PREC)
 Set AR=$%EXP^MATH(RHO*NRE-(TH*NIM),PREC)
 Set PHI=RHO*NIM+(NRE*TH)
 Quit AR*$%COS^MATH(PHI,PREC)_"%"_(AR*$%SIN^MATH(PHI,PREC))
 ;===
 ;
 ;
CSC(X,PREC) ;
 New L,LIM,K,SIGN,VALUE
 ;
 ;;; Set:X[":" X=$%DMSDEC^MATH(X,12) ;                                 Number 
 ; Winfried Gerum (8 June 1995)
 ;    Comment: The official description does not mention than
 ;             the function may also be called with the first
 ;             parameter in degrees, minutes and seconds.
 Set:X[":" X=$%DMSDEC^MATH(X)
 ;;;
 ;
 ;;; Set PREC=$Select($Data(PREC)#2:PREC,1:10) ;                       Number 
 ; Winfried Gerum (8 June 1995)
 Set PREC=$Get(PREC,11)
 ;;;
 ;
 Set X=X#(2*$%PI^MATH())
 Set (VALUE,L)=X,SIGN=–1
 Set LIM=$Select((PREC+3)'>11:PREC+3,1:11),@("LIM=1E-"_LIM)
 For K=3:2 Do  Quit:($Translate(L,"-")<LIM)  Set SIGN=SIGN*–1
 . Set L=L/(K–1)*X/K*X,VALUE=VALUE+(SIGN*L)
 . Quit
 If 'VALUE Quit "INFINITE"
 Quit 1/VALUE
 ;===
 ;
 ;
 ;
CSCH(X,PREC) ;;;Quit 1/$%SINH^MATH(X,PREC) ;                           Number 
 ; Winfried Gerum (8 June 1995)
 ; Alan Frank (October 1995)
 Quit 1/$%SINH^MATH(X,$Get(PREC,11))
 ;;;
 ;
 ;===
 ;
 ;
CSIN(Z,PREC) ;
 New IA,E1,E2
 ;
 ;;; ;                                                                 Number 
 ; Alan Frank (October 1995)
 Set PREC=$Get(PREC,11)
 ;;;
 ;
 Set IA=$%CMUL^MATH(Z,"0%1")
 Set E1=$%CEXP^MATH(IA,PREC)
 Set IA=-IA_"%"_(-$Piece(IA,"%",2))
 Set E2=$%CEXP^MATH(IA,PREC)
 Set IA=$%CSUB^MATH(E1,E2)
 Set IA=$%CMUL^MATH(IA,"0.5%0")
 Quit $%CMUL^MATH("0%–1",IA)
 ;===
 ;
 ;
CSUB(X,Y) ;
 New XIM,XRE,YIM,YRE
 Set XRE=+X,XIM=+$Piece(X,"%",2)
 Set YRE=+Y,YIM=+$Piece(Y,"%",2)
 Quit XRE-YRE_"%"_(XIM-YIM)
 ;===
 ;
 ;
DECDMS(X,PREC) ;
 Set PREC=$Get(PREC,5)
 Set X=X#360*3600
 Set X=+$Justify(X,0,$Select((PREC-$Length(X\1))'<0:PREC-$Length(X\1),1:0))
 Quit X\3600_":"_(X\60#60)_":"_(X#60)
 ;===
 ;
 ;
DEGRAD(X) Quit X*3.14159265358979/180
 ;===
 ;
 ;
DMSDEC(X) ;
 Quit $Piece(X,":")+($Piece(X,":",2)/60)+($Piece(X,":",3)/3600)
 ;===
 ;
 ;
E() Quit 2.71828182845905
 ;===
 ;
 ;
EXP(X,PREC) ;
 New L,LIM,K,VALUE
 Set PREC=$Get(PREC,11)
 Set L=X,VALUE=X+1
 Set LIM=$Select((PREC+3)'>11:PREC+3,1:11),@("LIM=1E-"_LIM)
 For K=2:1 Set L=L*X/K,VALUE=VALUE+L Quit:($Translate(L,"-")<LIM)
 Quit VALUE
 ;===
 ;
 ;
LOG(X,PREC) ;
 New L,LIM,M,N,K,VALUE
 If X'>0 Set $Ecode=",M28,"
 Set PREC=$Get(PREC,11)
 Set M=1
 ;
 ;;; If X>0 For N=0:1 Quit:(X/M)<10  Set M=M*10 ;                      Number 
 ; Winfried Gerum (8 June 1995)
 For N=0:1 Quit:(X/M)<10  Set M=M*10
 ;;;
 ;
 If X<1 For N=0:–1 Quit:(X/M)>0.1  Set M=M*0.1
 Set X=X/M
 Set X=(X–1)/(X+1),(VALUE,L)=X
 Set LIM=$Select((PREC+3)'>11:PREC+3,1:11),@("LIM=1E-"_LIM)
 For K=3:2 Set L=L*X*X,M=L/K,VALUE=M+VALUE Set:M<0 M=-M Quit:M<LIM
 Set VALUE=VALUE*2+(N*2.30258509298749)
 Quit VALUE
 ;===
 ;
 ;
LOG10(X,PREC) ;
 New L,LIM,M,N,K,VALUE
 If X'>0 Set $Ecode=",M28,"
 Set PREC=$Get(PREC,11)
 Set M=1
 ;
 ;;; If X>0 For N=0:1 Quit:(X/M)<10  Set M=M*10 ;                      Number 
 ; Winfried Gerum (8 June 1995)
 For N=0:1 Quit:(X/M)<10  Set M=M*10
 ;;;
 ;
 If X<1 For N=0:–1 Quit:(X/M)>0.1  Set M=M*0.1
 Set X=X/M
 Set X=(X–1)/(X+1),(VALUE,L)=X
 Set LIM=$Select((PREC+3)'>11:PREC+3,1:11),@("LIM=1E-"_LIM)
 For K=3:2 Set L=L*X*X,M=L/K,VALUE=M+VALUE Set:M<0 M=-M Quit:M<LIM
 Set VALUE=VALUE*2+(N*2.30258509298749)
 Quit VALUE/2.30258509298749
 ;===
 ;
 ;
MTXADD(A,B,R,ROWS,COLS) ;
 ; Add A[ROWS,COLS] to B[ROWS,COLS],
 ; result goes to R[ROWS,COLS]
 IF $DATA(A)<10 QUIT 0
 IF $DATA(B)<10 QUIT 0
 IF $GET(ROWS)<1 QUIT 0
 IF $GET(COLS)<1 QUIT 0
 ;
 NEW ROW,COL,ANY
 FOR ROW=1:1:ROWS FOR COL=1:1:COLS DO
 . KVALUE R(ROW,COL) SET ANY=0
 . SET:$DATA(A(ROW,COL))#2 ANY=1
 . SET:$DATA(B(ROW,COL))#2 ANY=1
 . SET:ANY R(ROW,COL)=$GET(A(ROW,COL))+$GET(B(ROW,COL))
 . QUIT
 QUIT 1
 ;===
 ;
 ;
MTXCOF(A,I,K,N) ;
 ; Compute cofactor for element [i,k]
 ; in matrix A[N,N]
 NEW T,R,C,RR,CC
 SET CC=0 FOR C=1:1:N DO:C'=K
 . SET CC=CC+1,RR=0
 . FOR R=1:1:N SET:R'=I RR=RR+1,T(RR,CC)=$GET(A(R,C))
 . QUIT
 QUIT $%MTXDET^MATH(.T,N–1)
 ;===
 ;
 ;
MTXCOPY(A,R,ROWS,COLS) ;
 ; Copy A[ROWS,COLS] to R[ROWS,COLS]
 IF $DATA(A)<10 QUIT 0
 IF $GET(ROWS)<1 QUIT 0
 IF $GET(COLS)<1 QUIT 0
 ;
 NEW ROW,COL
 FOR ROW=1:1:ROWS FOR COL=1:1:COLS DO
 . KVALUE R(ROW,COL)
 . SET:$DATA(A(ROW,COL))#2 R(ROW,COL)=A(ROW,COL)
 . QUIT
 QUIT 1
 ;===
 ;
 ;
MTXDET(A,N) ;
 ; Compute determinant of matrix A[N,N]
 IF $DATA(A)<10 QUIT ""
 IF $GET(N)<1 QUIT ""
 ;
 ; First the simple cases
 ;
 IF N=1 QUIT $GET(A(1,1))
 IF N=2 QUIT $GET(A(1,1))*$GET(A(2,2))-($GET(A(1,2))*$GET(A(2,1)))
 ;
 NEW DET,I,SIGN
 ;
 ; Det A = sum (k=1:n) element (i,k) * cofactor [i,k]
 ;
 SET DET=0,SIGN=1
 FOR I=1:1:N DO
 . SET DET=$GET(A(1,I))*$%MTXCOF^MATH(.A,1,I,N)*SIGN+DET
 . SET SIGN=-SIGN
 . QUIT
 QUIT DET
 ;===
 ;
 ;
MTXEQU(A,B,R,N,M) ;
 ; Solve matrix equation A [M,M] * R [M,N] = B [M,N]
 IF $GET(M)<1 QUIT ""
 IF $GET(N)<1 QUIT ""
 ;;;IF '$%MTXDET^MATH(.A) QUIT 0
 ; Ed de Moel, 29 August 1999
 IF '$%MTXDET^MATH(.A,M) QUIT 0
 ;;;
 ;
 NEW I,I1,J,J1,J2,K,L,T,T1,T2,TEMP,X
 ;
 SET X=$%MTXCOPY^MATH(.A,.T,N,N)
 SET X=$%MTXCOPY^MATH(.B,.R,N,M)
 ;
 ; Reduction of matrix A
 ; Steps of reduction are counted by index K
 ;
 FOR K=1:1:N–1 DO
 . ;
 . ; Search for largest coefficient of T
 . ; (denoted by TEMP)
 . ; in first column of reduced system
 . ;
 . SET TEMP=0,J2=K
 . FOR J1=K:1:N DO
 . . QUIT:$TRANSLATE($GET(T(J1,K)),"-")>$TRANSLATE(TEMP,"-")
 . . SET TEMP=T(J1,K),J2=J1
 . . QUIT
 . ;
 . ; Exchange row number K with row number J2,
 . ; if necessary
 . ;
 . DO:J2'=K
 . . ;
 . . FOR J=K:1:N DO
 . . . SET T1=$GET(T(K,J)),T2=$GET(T(J2,J))
 . . . KILL T(K,J),T(J2,J)
 . . . IF T1'="" SET T(J2,J)=T1
 . . . IF T2'="" SET T(K,J)=T2
 . . . QUIT
 . . FOR J=1:1:M DO
 . . . SET T1=$GET(R(K,J)),T2=$GET(R(J2,J))
 . . . KILL R(K,J),R(J2,J)
 . . . IF T1'="" SET R(J2,J)=T1
 . . . IF T2'="" SET R(K,J)=T2
 . . . QUIT
 . . QUIT
 . ;
 . ; Actual reduction
 . ;
 . FOR I=K+1:1:N DO
 . . FOR J=K+1:1:N DO
 . . . QUIT:'$GET(T(K,K))
 . . . SET T(I,J)=-$GET(T(K,J))*$GET(T(I,K))/T(K,K)+$GET(T(I,J))
 . . . QUIT
 . . FOR J=1:1:M DO
 . . . QUIT:'$GET(T(K,K))
 . . . SET R(I,J)=-$GET(R(K,J))*$GET(T(I,K))/T(K,K)+$GET(R(I,J))
 . . . QUIT
 . . QUIT
 . QUIT
 ;
 ; Backsubstitution
 ;
 FOR J=1:1:M DO
 . IF $GET(T(N,N)) SET R(N,J)=$GET(R(N,J))/T(N,N)
 . IF N–1>0 FOR I1=1:1:N–1 DO
 . . SET I=N-I1
 . . FOR L=I+1:1:N DO
 . . . SET R(I,J)=-$GET(T(I,L))*$GET(R(L,J))+$GET(R(I,J))
 . . . QUIT
 . . IF $GET(T(I,I)) SET R(I,J)=$GET(R(I,J))/$GET(T(I,I))
 . . QUIT
 . QUIT
 ;;;QUIT $%MTXDET^MATH(.R)
 ; Ed de Moel, 29 Aug 1999
 QUIT $SELECT(M=N:$%MTXDET^MATH(.R,M),1:1)
 ;;;
 ;===
 ;
MTXINV(A,R,N) ;
 ; Invert A[N,N], result goes to R[N,N]
 IF $DATA(A)<10 QUIT 0
 IF $GET(N)<1 QUIT 0
 ;
 NEW T,X
 SET X=$%MTXUNIT^MATH(.T,N)
 QUIT $%MTXEQU^MATH(.A,.T,.R,N,N)
 ;===
 ;
 ;
MTXMUL(A,B,R,M,L,N) ;
 ; Multiply A[M,L] by B[L,N], result goes to R[M,N]
 IF $DATA(A)<10 QUIT 0
 IF $DATA(B)<10 QUIT 0
 IF $GET(L)<1 QUIT 0
 IF $GET(M)<1 QUIT 0
 IF $GET(N)<1 QUIT 0
 ;
 NEW I,J,K,SUM,ANY
 FOR I=1:1:M FOR J=1:1:N DO
 . SET (SUM,ANY)=0
 . KVALUE R(I,J)
 . FOR K=1:1:L DO
 . . SET:$DATA(A(I,K))#2 ANY=1
 . . SET:$DATA(B(K,J))#2 ANY=1
 . . SET SUM=$GET(A(I,K))*$GET(B(K,J))+SUM
 . . QUIT
 . SET:ANY R(I,J)=SUM
 . QUIT
 QUIT 1
 ;===
 ;
 ;
MTXSCA(A,R,ROWS,COLS,S) ;
 ; Multiply A[ROWS,COLS] with the scalar S,
 ; result goes to R[ROWS,COLS]
 IF $DATA(A)<10 QUIT 0
 IF $GET(ROWS)<1 QUIT 0
 IF $GET(COLS)<1 QUIT 0
 IF '($DATA(S)#2) QUIT 0
 ;
 NEW ROW,COL
 FOR ROW=1:1:ROWS FOR COL=1:1:COLS DO
 . KVALUE R(ROW,COL)
 . SET:$DATA(A(ROW,COL))#2 R(ROW,COL)=A(ROW,COL)*S
 . QUIT
 QUIT 1
 ;===
 ;
 ;
MTXSUB(A,B,R,ROWS,COLS) ;
 ; Subtract B[ROWS,COLS] from A[ROWS,COLS],
 ; result goes to R[ROWS,COLS]
 IF $DATA(A)<10 QUIT 0
 IF $DATA(B)<10 QUIT 0
 IF $GET(ROWS)<1 QUIT 0
 IF $GET(COLS)<1 QUIT 0
 ;
 NEW ROW,COL,ANY
 FOR ROW=1:1:ROWS FOR COL=1:1:COLS DO
 . KVALUE R(ROW,COL) SET ANY=0
 . SET:$DATA(A(ROW,COL))#2 ANY=1
 . SET:$DATA(B(ROW,COL))#2 ANY=1
 . ;
 . ;;; SET:ANY R(ROW,COL)=$GET(A(ROW,COL)-$GET(B(ROW,COL)) ;           Number 
 . ; Eli Reidler (28 June 1996)
 . SET:ANY R(ROW,COL)=$GET(A(ROW,COL))-$GET(B(ROW,COL))
 . ;;;
 . ;
 . QUIT
 QUIT 1
 ;===
 ;
 ;
MTXTRP(A,R,M,N) ;
 ; Transpose A[M,N], result goes to R[N,M]
 IF $DATA(A)<10 QUIT 0
 IF $GET(M)<1 QUIT 0
 IF $GET(N)<1 QUIT 0
 ;
 NEW I,J,K,D1,V1,D2,V2
 FOR I=1:1:M+N–1 FOR J=1:1:I+1\2 DO
 . SET K=I-J+1
 . IF K=J DO  QUIT
 . . SET V1=$GET(A(J,J)),D1=$DATA(A(J,J))#2
 . . IF J'>N,J'>M KVALUE R(J,J) SET:D1 R(J,J)=V1
 . . QUIT
 . ;
 . SET V1=$GET(A(K,J)),D1=$DATA(A(K,J))#2
 . SET V2=$GET(A(J,K)),D2=$DATA(A(J,K))#2
 . IF K'>M,J'>N KVALUE R(K,J) SET:D2 R(K,J)=V2
 . IF J'>M,K'>N KVALUE R(J,K) SET:D1 R(J,K)=V1
 . QUIT
 QUIT 1
 ;===
 ;
 ;
MTXUNIT(R,N,SPARSE) ;
 ; Create a unit matrix R[N,N]
 IF $GET(N)<1 QUIT 0
 ;
 NEW ROW,COL
 FOR ROW=1:1:N FOR COL=1:1:N DO
 . KVALUE R(ROW,COL)
 . IF $GET(SPARSE) QUIT:ROW'=COL
 . SET R(ROW,COL)=$SELECT(ROW=COL:1,1:0)
 . QUIT
 QUIT 1
 ;===
 ;
 ;
PI() Quit 3.14159265358979
 ;===
 ;
 ;
PRODUCE(IN,SPEC,MAX) ;
 NEW VALUE,AGAIN,P1,P2,I,COUNT
 SET VALUE=IN,COUNT=0
 FOR  DO  QUIT:'AGAIN
 . SET AGAIN=0
 . SET I=""
 . FOR  SET I=$ORDER(SPEC(I)) QUIT:I=""  DO  QUIT:COUNT<0
 . . QUIT:$GET(SPEC(I,1))=""
 . . QUIT:'($DATA(SPEC(I,2))#2)
 . . FOR  QUIT:VALUE'[SPEC(I,1)  DO  QUIT:COUNT<0
 . . . SET P1=$PIECE(VALUE,SPEC(I,1),1)
 . . . SET P2=$PIECE(VALUE,SPEC(I,1),2,$LENGTH(VALUE))
 . . . SET VALUE=P1_SPEC(I,2)_P2,AGAIN=1
 . . . SET COUNT=COUNT+1
 . . . IF $DATA(MAX),COUNT>MAX SET COUNT=–1,AGAIN=0
 . . . QUIT
 . . QUIT
 . QUIT
 QUIT VALUE
 ;===
 ;
 ;
RADDEG(X) Quit X*180/3.14159265358979
 ;===
 ;
 ;
REPLACE(IN,SPEC) ;
 NEW L,MASK,K,I,LT,F,VALUE
 SET L=$LENGTH(IN),MASK=$JUSTIFY("",L)
 SET I="" FOR  SET I=$ORDER(SPEC(I)) QUIT:I=""  DO
 . QUIT:'($DATA(SPEC(I,1))#2)
 . QUIT:SPEC(I,1)=""
 . QUIT:'($DATA(SPEC(I,2))#2)
 . SET LT=$LENGTH(SPEC(I,1))
 . SET F=0 FOR  SET F=$FIND(IN,SPEC(I,1),F) QUIT:F<1  DO
 . . QUIT:$EXTRACT(MASK,F-LT,F–1)["X"
 . . SET VALUE(F-LT)=SPEC(I,2)
 . . SET $EXTRACT(MASK,F-LT,F–1)=$TRANSLATE($JUSTIFY("",LT)," ","X")
 . . QUIT
 . QUIT
 SET VALUE="" FOR K=1:1:L DO
 . IF $EXTRACT(MASK,K)=" " SET VALUE=VALUE_$EXTRACT(IN,K) QUIT
 . SET:$DATA(VALUE(K)) VALUE=VALUE_VALUE(K)
 . QUIT
 QUIT VALUE
 ;===
 ;
 ;
SEC(X,PREC) ;
 New L,LIM,K,SIGN,VALUE
 ;
 ;;; Set:X[":" X=$%DMSDEC^MATH(X,12) ;                                 Number 
 ; Winfried Gerum (8 June 1995)
 ;    Comment: The official description does not mention than
 ;             the function may also be called with the first
 ;             parameter in degrees, minutes and seconds.
 Set:X[":" X=$%DMSDEC^MATH(X)
 ;;;
 ;
 Set PREC=$Get(PREC,11)
 Set X=X#(2*$%PI^MATH())
 Set (VALUE,L)=1,SIGN=–1
 Set LIM=$Select((PREC+3)'>11:PREC+3,1:11),@("LIM=1E-"_LIM)
 For K=2:2 Do  Quit:($Translate(L,"-")<LIM)  Set SIGN=SIGN*–1
 . Set L=L*X*X/(K–1*K),VALUE=VALUE+(SIGN*L)
 . Quit
 If 'VALUE Quit "INFINITE"
 Quit 1/VALUE
 ;===
 ;
 ;
SECH(X,PREC) ;;;Quit 1/$%COSH^MATH(X,PREC) ;                           Number 
 ; Winfried Gerum (8 June 1995)
 ; Alan Frank (October 1995)
 Quit 1/$%COSH^MATH(X,$Get(PREC,11))
 ;;;
 ;===
 ;
 ;
SIGN(X) Quit $SELECT(X<0:–1,X>0:1,1:0)
 ;===
 ;
 ;
SIN(X,PREC) ;
 New L,LIM,K,SIGN,VALUE
 ;
 ;;; Set:X[":" X=$%DMSDEC^MATH(X,12) ;                                 Number 
 ; Winfried Gerum (8 June 1995)
 ;    Comment: The official description does not mention than
 ;             the function may also be called with the first
 ;             parameter in degrees, minutes and seconds.
 Set:X[":" X=$%DMSDEC^MATH(X)
 ;;;
 ;
 Set PREC=$Get(PREC,11)
 Set X=X#(2*$%PI^MATH())
 Set (VALUE,L)=X,SIGN=–1
 Set LIM=$Select((PREC+3)'>11:PREC+3,1:11),@("LIM=1E-"_LIM)
 For K=3:2 Do  Quit:($Translate(L,"-")<LIM)  Set SIGN=SIGN*–1
 . Set L=L/(K–1)*X/K*X,VALUE=VALUE+(SIGN*L)
 . Quit
 Quit VALUE
 ;===
 ;
 ;
SIN(X) ;
 ;;; ;                                                                 Number 
 ; Winfried Gerum (8 June 1995)
 ;  Comment: This version of the function is
 ;           optimized for speed, not for precision.
 ;           The 'precision' parameter is not supported,
 ;           and the precision is at best 1 in 10**–9.
 ;           Note that this function does not accept its
 ;           parameter in degrees, minutes and seconds.
 ;;;
 ;
 New A,N,PI,R,SIGN,XX
 ;
 ; This approximation only works for 0 <= x <= pi/2
 ; so reduce angle to correct quadrant.
 ;
 Set PI=$%PI^MATH(),X=X#(PI*2),SIGN=1
 Set:X>PI X=2*PI-X,SIGN=–1
 ;
 ;;; Set:X*2<PI X=PI-X Set X=-PI/2+2 ;                                 Number 
 ; Winfried Gerum (8 June 1995)
 Set:X*2<PI X=PI-X
 ;;;
 ;
 ;
 Set XX=X*X,A(1)=–0.4999999963,A(2)=0.0416666418
 Set A(3)=–0.0013888397,A(4)=0.0000247609,A(5)=–0.0000002605
 Set (X,R)=1 For N=1:1:5 Set X=X*XX,R=A(N)*X+R
 Quit R*SIGN
 ;===
 ;
 ;
SINH(X,PREC) ;
 ;
 ;;; New F,I,P,R,T,XX ;                                                Number 
 ; Winfried Gerum (8 June 1995)
 ; Eli Reidler (28 June 1996)
 New E,F,I,P,R,T,XX
 ;;;
 ;
 Set PREC=$Get(PREC,11)+1
 Set @("E=1E-"_PREC)
 Set XX=X*X,F=1,I=2,(P,R,T)=X
 For  Set T=T*XX,F=I+1*I*F,R=T/F+R,P=P-R/R,I=I+2 If -E<P,P<E Quit
 Quit R
 ;===
 ;
 ;
SQRT(X,PREC) ;
 If X<0 Set $Ecode=",M28,"
 If X=0 Quit 0
 ;
 ;;; ;                                                                 Number 
 ; Alan Frank (October 1995)
 Set PREC=$Get(PREC,11)
 ;;;
 ;
 ;
 ;;; If X<1 Quit 1/$%SQRT^MATH(1/X) ;                                  Number 
 ; Winfried Gerum (8 June 1995)
 If X<1 Quit 1/$%SQRT^MATH(1/X,PREC)
 ;;;
 ;
 New P,R,E
 Set PREC=$Get(PREC,11)+1
 ;
 ;;; Set @(E="1E-"_PREC) ;                                             Number 
 ; Winfried Gerum (8 June 1995)
 ; Eli Reidler (28 June 1996)
 Set @("E=1E-"_PREC)
 ;;;
 ;
 Set R=X
 For  Set P=R,R=X/R+R/2,P=P-R/R If -E<P,P<E Quit
 Quit R
 ;===
 ;
 ;
TAN(X,PREC) ;
 New L,LIM,K,S,SIGN,VALUE
 ;
 ;;; Set:X[":" X=$%DMSDEC^MATH(X,12) ;                                 Number 
 ; Winfried Gerum (8 June 1995)
 ;    Comment: The official description does not mention than
 ;             the function may also be called with the first
 ;             parameter in degrees, minutes and seconds.
 Set:X[":" X=$%DMSDEC^MATH(X)
 ;;;
 ;
 Set PREC=$Get(PREC,11)
 Set X=X#(2*$%PI^MATH())
 Set (VALUE,L)=X,SIGN=–1
 Set LIM=$Select((PREC+3)'>11:PREC+3,1:11),@("LIM=1E-"_LIM)
 For K=3:2 Do  Quit:($Translate(L,"-")<LIM)  Set SIGN=SIGN*–1
 . Set L=L/(K–1)*X/K*X,VALUE=VALUE+(SIGN*L)
 . Quit
 Set S=VALUE
 Set X=X#(2*$%PI^MATH())
 Set (VALUE,L)=1,SIGN=–1
 Set LIM=$Select((PREC+3)'>11:PREC+3,1:11),@("LIM=1E-"_LIM)
 For K=2:2 Do  Quit:($Translate(L,"-")<LIM)  Set SIGN=SIGN*–1
 . Set L=L*X*X/(K–1*K),VALUE=VALUE+(SIGN*L)
 . Quit
 If 'VALUE Quit "INFINITE"
 Quit S/VALUE
 ;===
 ;
 ;
TANH(X,PREC) ;
 ;
 ;;; ;                                                                 Number 
 ; Alan Frank (October 1995)
 Set PREC=$Get(PREC,11)
 ;;;
 ;
 Quit $%SINH^MATH(X,PREC)/$%COSH^MATH(X,PREC)
 ;===
 ;
 ;
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
 ; ===
 ;
 ;
Button for 1977 Button for 1984 Button for 1990 Button for 1995 Button for MDC Button for notes Button for examples

Copyright © Standard Documents; 1977-2018 MUMPS Development Committee;
Copyright © Examples: 1995-2018 Ed de Moel;
Copyright © Annotations: 2003-2008 Jacquard Systems Research
Copyright © Annotations: 2008-2018 Ed de Moel.

The information in this page is NOT authoritative and subject to be modified at any moment.
Please consult the appropriate (draft) language standard for an authoritative definition.

Some specifications are "approved for inclusion in a future standard". Note that the MUMPS Development Committee cannot guarantee that such future standards will indeed be published.

This page most recently updated on 29-Nov-2011, 20:00:19 .

For comments, contact Ed de Moel (demoel@jacquardsystems.com)