* SUBPROGRAM..: SOUNDEX * DESCRIPTION.: Generate primative Soundex key * AUTHOR......: Paul Macgowan on 8/7/93 * AMENDMENTS * BY TASK DATE COMMENTS ******************************************************************* DEFINE DATA PARAMETER 1 #SURNAME (A30) 1 REDEFINE #SURNAME 2 #SURNAME-CH (A1/1:30) 1 #GIVEN (A18) 1 REDEFINE #GIVEN 2 #GIVEN-CH (A1/1:18) 1 #SOUNDEX (A10) 1 REDEFINE #SOUNDEX 2 #SX-CH (A1/1:10) LOCAL 1 #I (I1) 1 #J (I1) 1 #LAST-CH (A1) 1 #TRANSLATE (A56) INIT <'A BBCKDDE FFGJHHI JJKKLLMNNNO PPQQRRSSTTU VVWWXXY ZS- " '> 1 REDEFINE #TRANSLATE 2 #TRANSLATE-A (A2/1:28) 1 #WORK-SOUNDX (A30) 1 REDEFINE #WORK-SOUNDX 2 #W-CH (A1/1:30) 1 #WORK-GIVEN (A18) 1 REDEFINE #WORK-GIVEN 2 #WG-CH (A1/1:18) 1 #L (I1) END-DEFINE RESET #SOUNDEX * * Generate SURNAME soundex * #SX-CH(1) := #SURNAME-CH(1) #LAST-CH := #SURNAME-CH(1) #WORK-SOUNDX := #SURNAME EXAMINE #WORK-SOUNDX TRANSLATE USING #TRANSLATE-A(*) EXAMINE #WORK-SOUNDX FOR ' ' GIVING LENGTH IN #L #I := 1 #J := 2 REPEAT WHILE #I <= #L IF #W-CH(#I) NE ' ' AND #W-CH(#I) NE #LAST-CH THEN #LAST-CH := #W-CH(#I) #SX-CH(#J) := #W-CH(#I) ADD 1 TO #J IF #J > 8 THEN ESCAPE BOTTOM END-IF END-IF ADD 1 TO #I END-REPEAT * * Generate Given soundex * #WORK-GIVEN := #GIVEN EXAMINE #WORK-GIVEN TRANSLATE USING #TRANSLATE-A(*) EXAMINE #GIVEN FOR ' ' GIVING POSITION #L LENGTH #J IF #L = 0 THEN #L := #J END-IF * RESET #LAST-CH #I := 1 #J := 8 REPEAT WHILE #I <= #L IF #WG-CH(#I) NE ' ' AND #WG-CH(#I) NE #LAST-CH THEN #LAST-CH := #WG-CH(#I) #SX-CH(#J) := #WG-CH(#I) ADD 1 TO #J IF #J > 10 THEN ESCAPE BOTTOM END-IF END-IF ADD 1 TO #I END-REPEAT * END