Source code in the pl/i programming language

Soundex: procedure (pword) returns (character(4));
   declare pword character (*) varying, value character (length(pword)) varying;
   declare word character (length(pword));
   declare (prevCode, currCode) character (1);
   declare alphabet CHARACTER (26) STATIC INITIAL ('AEIOUHWYBFPVCGJKQSXZDTLMNR');
   declare replace  character (26) static initial ('00000000111122222222334556');
   declare i fixed binary;

   word = pword;

   /* Buffer to build up with character codes */
   value = ''; 

   /* Make sure the word is at least two characters in length. */
   if length(word) <= 1 then return (word);

   word = uppercase(word); /* Convert to uppercase. */

   /* The current and previous character codes */
   prevCode = '0'; 

   value = substr(word, 1, 1); /* The first character is unchanged. */

   word = Translate (word, replace, alphabet);

   /* Loop through the remaining characters ... */
   do i = 2 to length(word);
      currCode = substr(word, i, 1);
      /* Check to see if the current code is the same as the last one */
      if currCode ^= prevCode & currCode ^= '0' then
         /* If the current code is a vowel, ignore it. */
         value = value || currCode;
      /* Set the new previous character code */
      prevCode = currCode; 
   end; /* of do i = ... */

   return ( left(value, 4, '0') ); /* Pad, if necessary. */
         
end Soundex;