/* SOUNDEX(0.0) Form Term SOUNDEX Numeric Key 29.06.95+21.07.95 ------------------------------------------------------------------ 0Type ------------------------------------------------------------- 0 Function 0Declaration ------------------------------------------------------ 0 DCL SOUNDEX ENTRY(CHAR(25) VAR) RETURNS(BIN FIXED); 0Reference -------------------------------------------------------- 0 SOUNDEX() 0Parameter -------------------------------------------------------- 0 Term - Term for SOUNDEX key generation 0Value ------------------------------------------------------------ 0 - Four-digit numeric SOUNDEX key of input parameter term - Returned value range is 0-6666 - Returned value of '0' indicates absence of consonants in input parameter term and should be treated in a special way, as far as SOUNDEX method is based on consonants coding and it is not working in this case 0Notes ------------------------------------------------------------ 0 - Term consonants (except H) are converted to upper case and coded using the following table: 1 - B F P V 3 - D T 5 - M N 2 - C G J K Q S X Z 4 - L 6 - R - Consonant code digit is never repeated, unless there is an uncoded symbol in between - Non-Consonants and H are ignored - SOUNDEX key is 4 digits long padded with trailing zeros when necessary) 0Examples --------------------------------------------------------- 0 SOUNDEX('')=0000 SOUNDEX('----')=0000 0 SOUNDEX('BfPv')=1000 SOUNDEX('CgJkQsXz')=2000 SOUNDEX('dT')=3000 SOUNDEX('L')=4000 SOUNDEX('nM')=5000 SOUNDEX('r')=6000 0 SOUNDEX('B-f-P-v')=1111 SOUNDEX('C-g-J-k----')=2222 SOUNDEX('-g-J-k-Q---')=2222 SOUNDEX('--J-k-Q-s--')=2222 SOUNDEX('---k-Q-s-X-')=2222 SOUNDEX('----Q-s-X-z')=2222 0 SOUNDEX('d-T')=3300 SOUNDEX('-L-')=4000 SOUNDEX('n-M')=5500 SOUNDEX('-r-')=6000 0 SOUNDEX('-Bb-Cc-Dd-Ll-')=1234 SOUNDEX('-Cc-Dd-Ll-Mm-')=2345 SOUNDEX('-Dd-Ll-Mm-Rr-')=3456 0 SOUNDEX('---B-b-C-c-D-d---')=1122 SOUNDEX('---C-c-D-d-L-l---')=2233 SOUNDEX('---D-d-L-l-M-m---')=3344 SOUNDEX('---L-l-M-m-R-r---')=4455 SOUNDEX('---M-m-R-r-B-b---')=5566 0 SOUNDEX('-RrRrRrRrRrRrRrRrRrR-')=6000 SOUNDEX('-R-r-R-r-R-r-R-r-R-r-')=6666 0Start Function --------------------------------------------------- *//* 0 debug: proc options(main); */ 0 SOUNDEX: PROC(Term) RETURNS(BIN FIXED) REORDER; /* 0Parameter -------------------------------------------------------- */ 0 DCL Term CHAR(25) VAR; /* 0Constants -------------------------------------------------------- */ 0 DCL ((Code(18) INIT(1,1,1,1,2,2,2,2,2,2,2,2,3,3,4,5,5,6), Shift(4) INIT(1000,100,10,1)) BIN FIXED, (LC_Cons INIT('bfpvcgjkqsxzdtlmnr'), UC_Cons INIT('BFPVCGJKQSXZDTLMNR')) CHAR(18)) STATIC; /* 111122222222334556 - SOUNDEX coding table 0Variables -------------------------------------------------------- */ 0 DCL UC_Term CHAR(25) VAR, 1 Trm BASED(ADDR(UC_Term)), 2 Lngth BIN FIXED, 2 Symb(25) CHAR, (Curr_Code, (Prev_Code, Sound_Key) INIT(0)) BIN FIXED; /* 0Convert Parameter Term to Upper Case (Consonants Only) ----------- */ 0 UC_Term=TRANSLATE(Term,UC_Cons,LC_Cons); /* 0Form SOUNDEX Numeric Key ----------------------------------------- */ 0 K=0; /* SOUNDEX key length counter */ DO I=1 TO Lngth; J=INDEX(UC_Cons,Symb(I)); IF (J>0) THEN DO; Curr_Code=Code(J); /* 0 put edit('Curr-Symb=''',symb(i),'''', 'Curr_Code=',curr_code, 'Prev_Code=',prev_code) (skip,col(13+length(term)), (3)a,(2)(x(2),a,p'9')); */ 0 IF (Curr_Code^=Prev_Code) THEN DO; K=K+1; IF (K>4) THEN LEAVE; Prev_Code=Curr_Code; Sound_Key=Sound_Key+ Curr_Code*Shift(K); /* 0 put edit('Sound_Key=',sound_key) (x(2),a,p'9999'); */ 0 END; END; ELSE Prev_Code=0; END; /* 0Return Function Value to the Point of Invocation and Finish It --- *//* 0 put edit('=')(skip,col(12+length(term)),a); */ 0 RETURN(Sound_Key); END SOUNDEX; /* 0Debug Function --------------------------------------------------- *//* 0 dcl term(28) char(25) var init('', '----', 'BfPv', 'CgJkQsXz', 'dT', 'L', 'nM', 'r', 'B-f-P-v', 'C-g-J-k----', '-g-J-k-Q---', '--J-k-Q-s--', '---k-Q-s-X-', '----Q-s-X-z', 'd-T', '-L-', 'n-M', '-r-', '-Bb-Cc-Dd-Ll-', '-Cc-Dd-Ll-Mm-', '-Dd-Ll-Mm-Rr-', '---B-b-C-c-D-d---', '---C-c-D-d-L-l---', '---D-d-L-l-M-m---', '---L-l-M-m-R-r---', '---M-m-R-r-B-b---', '-RrRrRrRrRrRrRrRrRrR-', '-R-r-R-r-R-r-R-r-R-r-'); 0 dcl prntttl entry(char(*) var, char(1) var, file, bin fixed, bin fixed); 0 call prntttl('SOUNDEX(0.0) Form Term SOUNDEX Numeric Key', '',sysprint,1,0); 0 put skip; put edit(('SOUNDEX(''',term(n),''')=',soundex(term(n)), '- SOUNDEX key for term ''',term(n),'''' do n=1 to 28)) (skip,(3)a,p'9999',x(2),(3)a); 0 end debug; */