Armin van Harten posted this code to comp.lang.mumps. I
received permission to share it with M Computing
readers. Knowledge of German is useful, but not required. A
machine readable copy can be obtained by saving the source
code for this page. Code is used
entirely at the risk and responsibility of the person making the
copy.
-Kate Schell, Executive Editor
LIB
LIB ;string routinen;LIB;LIB;Diverse Stringroutinen;van Harten;micro - M; [ Rev.: 20.09.96 ]
Q ; no direct entry
;
UP1(%00) ; -- FUNCTION: first char of each word uppercase, rest lowercase --
; in :%00
;
N UPC,LOC,X,%000
S UPC="ABCDEFGHIJKLMNOPQRSTUVWXYZ???[\]",LOC="abcdefghijklmnopqrstuvwxyz???{|}"
S %00=$TR(%00,UPC,LOC)
S %000=$TR(%00,"-,.'"," ") ; valid delimiters " -,.'"
S X=1 F S $E(%00,X)=$TR($E(%00,X),LOC,UPC),X=$F(%000," ",X) Q:'X
Q %00
;
UP(%00) ; -- FUNCTION: translate all to uppercase --
; in :%00
Q $TR(%00,"abcdefghijklmnopqrstuvwxyz???{|}","ABCDEFGHIJKLMNOPQRSTUVWXYZ???[\]")
;
CTRL(%00) ; -- FUNCTION: remove control char's --
;IN: %00 ;OUT: %00
Q $TR(%00,$C(0,1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20,21,22,23,24,25,26,27,28,29,30,31),"")
;
LOW(%00) ; -- FUNCTION: translate to lowercase --
; in : %00
Q $TR(%00,"ABCDEFGHIJKLMNOPQRSTUVWXYZ???[\]","abcdefghijklmnopqrstuvwxyz???{|}")
;
NUM(%00) ; -- FUNCTION: convert to numeric from: nnn,nnn.dd or.nnn.nnn,dd format --
;IN :%00 ;OUT :%00
S %00=$TR(%00,", ",".")
S:($L(%00,".")>2) %00=$TR($P(%00,".",1,$L(%00,".")-1),".","")_"."_$P(%00,".",$L(%00,"."))
S %00=+%00 ;force numeric
Q %00
;
NFILL(%00,%L) ; -- FUNCTION: fill with leading zeros up to fixed length --
; in: %00=numeric, %L=fieldlength
;
N (%00,%L,%ERR)
S %00=$$NUM(%00) ; standardize
Q:$L(%00)=%L %00 ; ok!
;
I $L(%00)>%L Q "" ; error , par. mismatch
Q $TR($J(%00,%L)," ","0") ; convert
;
WRAP(TXT,XW,I) ; -- ROUTINE: linewrap --
; in : TXT = original textline
; : XW = linewidth
; out : I = no. outputlines
; : XW = if line doesnt fit in XW, XW contains min. poss. linewidth
;
N J,%0T
I $L(TXT)'>XW S TXT(1)=TXT,I=1 Q ; no need to wrap
;
S %0T=TXT
F I=1:1 D Q:'$L(%0T)
. I $L(%0T)<XW S TXT(I)=%0T,%0T="" Q ; rest
. F J=XW:-1:0 Q:$E(%0T,J)=" " ; find new lineend
. S TXT(I)=$S(J=0:TXT,1:$E(%0T,1,J)) ; cut
. S %0T=$S(J=0:"",1:$E(%0T,J+1,$L(%0T))) ;update buffer
. S XW=$S($L(TXT(I))>XW:$L(TXT(I)),1:XW) ;update linewidth
. Q
Q
;
CLIPB(%00) ; -- FUNCTION: clip leading and trailing blanks --
; in :%00
N I,J
Q:'$L(%00) "" ; no chars
I %00?1." " Q "" ; blankstring
F I=1:1:$L(%00) Q:$E(%00,I)'=" " ; leading blanks up to .byte I
F J=$L(%00):-1:I Q:$E(%00,J)'=" " ; trailing blanks down to byte J
Q $E(%00,I,J) ; clip
;
CLIP(%00,%0A) ; -- FUNCTION: clip leading and trailing %0A's --
; in : %00
; %0A single char (any char)
N I,J
Q:'$L(%00)
I '$L($TR(%00,%0A,"")) Q ""
F I=1:1:$L(%00) Q:$E(%00,I)'=%0A
F J=$L(%00):-1:I Q:$E(%00,J)'=%0A
Q $E(%00,I,J) ; clip
;
UML(%00) ; -- FUNCTION: ersetze umlaute durch vokale (? ->AE,..)
; this routine solves a very german problem, quite nice
; in: %00
N X,I,Y,A,B,P,PA,L
S X="AE,OE,UE,ae,oe,ue,sz,AE,OE,UE,ae,oe,ue,sz",Y="???????[\]{|}~"
F I=1:1:$L(Y) S A=$E(Y,I),B=$P(X,",",I) D:%00[A
. ; -- replace ju. --
. S (P,PA)=1,X="",L=$L(%00),LA=$L(A)
. F J=0:0 S P=$F(%00,A,P) Q:'P S X=X_$E(%00,PA,P-LA-1)_B,PA=P
. S %00=X_$E(%00,PA,L)
. Q
Q %00
;
REPL(%00,%0A,%0B) ; -- FUNCTION: replace string %0A with string %0B in string %00, VH --
; in :%00,%0A,%0B
N D,DA,F
Q:'$L(%0A) %00
Q:%00'[%0A %00
S F=$F(%00,%0A),DA=$L(%0A),D=$L(%0B)-DA
F S $E(%00,F-DA,F-1)=%0B,F=$F(%00,%0A,F+D) Q:'F
Q %00
;
Armin van Harten, has a degree in Meteorology and is a certified physician. He has 20 Years of experience in data processing as an analyst and developer and has used M since 1983. He has started the Institute of Medical Data Processing in Wetzlar and is hoping to become successful. He currently works part-time as a supervising doctor in a balneotherapeutic center for psoriasis treatment. Email: vanharten@aol.com