/*----------------------------------------------------------------------------*
 * Module: metaph.p
 *
 * Hacked version of metaphone routine
 *----------------------------------------------------------------------------*/

DEF VAR meta_len AS INTEGER NO-UNDO.
DEF VAR org_name AS CHAR NO-UNDO INITIAL "to whom it may concern".

/*---------------------------------------------------------------------------*
 * dologic - private module
 *---------------------------------------------------------------------------*/
FUNCTION DoLogic RETURNS CHAR
  (INPUT this_idx AS INTEGER):

  DEF VAR this_char AS CHAR.

  this_char = SUBSTRING(org_name,this_idx,1).

  CASE this_char:
    WHEN "B" THEN DO:
      IF this_idx = meta_len THEN DO:
        IF SUBSTRING(org_name,this_idx - 1,1) <> "M" THEN
          RETURN this_char.
      END.
      ELSE
        RETURN this_char.
    END.
    WHEN "C" THEN DO:
      IF this_idx + 1 <= meta_len THEN
        IF SUBSTRING(org_name,this_idx - 1,1) = "S" AND
          TRIM(SUBSTRING(org_name,this_idx + 1,1),"EIY") = "" THEN
          RETURN "".
      IF this_idx + 2 <= meta_len THEN
        IF SUBSTRING(org_name,this_idx + 1,1) = "I" AND
          SUBSTRING(org_name,this_idx + 2,1) = "A" THEN
          RETURN "X".
      IF this_idx < meta_len THEN DO:
        IF TRIM(SUBSTRING(org_name,this_idx + 1,1),"EIY") = "" THEN
          RETURN "S".
        IF SUBSTRING(org_name,this_idx + 1,1) = "H" AND
          SUBSTRING(org_name,this_idx - 1,1) = "S" THEN
          RETURN "K".
        IF SUBSTRING(org_name,this_idx + 1,1) = "H" THEN DO:
          IF this_idx + 2 <= meta_len THEN DO:
            IF TRIM(SUBSTRING(org_name,this_idx + 2,1),"AEIOU") = "" THEN
              RETURN "K".
            ELSE
              RETURN "X".
          END.
          ELSE
            RETURN "X".
        END.
      END.

      RETURN "K".
    END.
    WHEN "D" THEN DO:
      IF this_idx + 2 <= meta_len THEN
        IF SUBSTRING(org_name,this_idx + 1,1) = "G" AND
          TRIM(SUBSTRING(org_name,this_idx + 2,1),"EIY") = "" THEN
          RETURN "J".
      RETURN "T".
    END.
    WHEN "G" THEN DO:
      IF this_idx + 2 <= meta_len THEN
        IF SUBSTRING(org_name,this_idx + 1,1) = "H" AND
          TRIM(SUBSTRING(org_name,this_idx + 2,1),"AEIOUT") = "" THEN
          RETURN "".
      IF this_idx + 1 = meta_len THEN
        IF SUBSTRING(org_name,this_idx + 1,1) = "N" THEN
          RETURN "".
      IF this_idx + 3 = meta_len THEN
        IF SUBSTRING(org_name,this_idx + 1,1) = "N" AND
          SUBSTRING(org_name,this_idx + 2,1) = "E" AND
          SUBSTRING(org_name,this_idx + 3,1) = "D" THEN
          RETURN "".
      IF this_idx + 1 <= meta_len THEN
        IF SUBSTRING(org_name,this_idx - 1,1) = "D" AND
          TRIM(SUBSTRING(org_name,this_idx + 1,1),"EIY") = "" THEN
          RETURN "".
      IF this_idx < meta_len THEN
        IF TRIM(SUBSTRING(org_name,this_idx + 1,1),"EIY") = "" THEN
          RETURN "J".
      RETURN "K".
    END.
    WHEN "H" THEN DO:
      IF this_idx = meta_len THEN
        RETURN "".
      IF TRIM(SUBSTRING(org_name,this_idx - 1,1),"CSPTG") = "" THEN
        RETURN "".
      IF this_idx + 1 <= meta_len THEN
        IF TRIM(SUBSTRING(org_name,this_idx + 1,1),"AEIOU") = "" THEN
          RETURN this_char.
    END.
    WHEN "K" THEN DO:
      IF TRIM(SUBSTRING(org_name,this_idx - 1,1),"0123456789") <> "" THEN
        RETURN this_char.
    END.
    WHEN "P" THEN DO:
      IF this_idx < meta_len THEN
        IF SUBSTRING(org_name,this_idx + 1,1) = "H" THEN
          RETURN "F".
      RETURN this_char.
    END.
    WHEN "Q" THEN DO:
      RETURN "K".
    END.
    WHEN "S" THEN DO:
      IF this_idx + 2 <= meta_len THEN
        IF SUBSTRING(org_name,this_idx + 1,1) = "I" AND
          TRIM(SUBSTRING(org_name,this_idx + 2,1),"AO") = "" THEN
          RETURN "X".
      IF this_idx < meta_len THEN
        IF SUBSTRING(org_name,this_idx + 1,1) = "H" THEN
          RETURN "X".
      RETURN this_char.
    END.
    WHEN "T" THEN DO:
      IF this_idx + 2 <= meta_len THEN DO:
        IF SUBSTRING(org_name,this_idx + 1,1) = "I" AND
          TRIM(SUBSTRING(org_name,this_idx + 2,1),"AO") = "" THEN
          RETURN "X".
        IF SUBSTRING(org_name,this_idx + 1,1) = "C" AND
          SUBSTRING(org_name,this_idx + 2,1) = "H" THEN
          RETURN "".
      END.
      IF this_idx < meta_len THEN DO:
        IF SUBSTRING(org_name,this_idx + 1,1) = "H" THEN
          IF SUBSTRING(org_name,this_idx - 1,1) = "T" THEN
            RETURN "".
          ELSE
            RETURN "O".
      END.
      RETURN this_char.
    END.
    WHEN "W" OR WHEN "Y" THEN DO:
      IF this_idx < meta_len THEN
        IF TRIM(SUBSTRING(org_name,this_idx + 1,1),"AEIOU") = "" THEN
          RETURN this_char.
    END.
    OTHERWISE DO:
      IF this_char >= "A" AND this_char <= "Z" AND
        TRIM(this_char,"AEIOU") <> "" THEN
        RETURN this_char.
    END.
  END CASE.

  RETURN "".

END FUNCTION. /* DoLogic */

/*---------------------------------------------------------------------------*
 * metaphone() - public function
 *---------------------------------------------------------------------------*/
FUNCTION metaphone RETURNS CHAR
  (INPUT pass_name AS CHAR):

  DEF VAR idx       AS INTEGER NO-UNDO.
  DEF VAR new_char  AS CHAR NO-UNDO.
  DEF VAR ret_name  AS CHAR NO-UNDO.

  /* initialization */
  ASSIGN pass_name = CAPS(pass_name)
         org_name  = "".

  /* parse out unwanted's */
  DO idx = 1 TO LENGTH(pass_name):
    new_char = SUBSTRING(pass_name,idx,1).
    IF (new_char >= "A" AND new_char <= "Z")
      OR (new_char >= "a" AND new_char <= "z")
      OR (new_char >= "0" AND new_char <= "9") THEN
      org_name = org_name + new_char.
  END.

  /* if no length, return */
  IF LENGTH(org_name) = 0 THEN RETURN "".

  /* more initialization */
  ASSIGN meta_len = LENGTH(org_name)
         ret_name = SUBSTRING(org_name,1,1).

  /* main loop to generate metaphone */
  DO idx = 2 TO meta_len:
    IF TRIM(SUBSTRING(org_name,idx,1),"0123456789") <> "" THEN
      ret_name = ret_name + DoLogic(idx).
  END.

  RETURN ret_name.

END FUNCTION. /* metaphone */


MESSAGE org_name SKIP metaphone(org_name) VIEW-AS ALERT-BOX.

/* end of program */