(de soundex (Str)
   (pack
      (pad -4
         (cons
            (uppc (char (char Str)))
            (head 3
               (let Last NIL
                  (extract
                     '((C)
                        (and
                           (setq C
                              (case (uppc C)
                                 (`(chop "BFPV") "1")
                                 (`(chop "CGJKQSXZ") "2")
                                 (("D" "T") "3")
                                 ("L" "4")
                                 (("M" "N") "5")
                                 ("R" "6") ) )
                           (<> Last C)
                           (setq Last C) ) )
                     (cdr (chop Str)) ) ) ) ) ) ) )