home *** CD-ROM | disk | FTP | other *** search
/ RBBS in a Box Volume 1 #3.1 / RBBSIABOX31.cdr / sspl / soundex2.prg < prev    next >
Text File  |  1987-02-22  |  7KB  |  182 lines
  1. * Purpose of this program:
  2. *    1. Store the soundex code for every entry in a database file with a 
  3. *       character field containing the last name.
  4. *    2. Enter a last name.  This program generates a soundex code for it,
  5. *       and retrieves all records matching the code.
  6. *    (The codes are case insensitive)
  7. *
  8. *    Original program from the Data Based Advisor, Aug., 1984 page 46
  9. *         By John Gillen, Lexicon Publishing, 725 J Street, 
  10. *              Sacramento, CA 95814
  11. *
  12. *    Adapted to Dbase III and modified June 14, 1985 by 
  13. *         Michael Shunfenthal, 
  14. *              2602 West 235 Street, Torrance CA 90505
  15. *
  16. *    To use this program:
  17. *    1. Modify the structure of your database to add a 4-character field 
  18. *              to hold the soundex code for each last name.  Then enter:
  19. *       set procedure to soundex
  20. *
  21. *    2. Set the code into this field for the entire database:
  22. *              (the program requires approximately 8 seconds for each record)
  23. *       do sndxrpl with '<dbfname>', '<soundex field>', '<lastname field>'
  24. *
  25. *    3. Retrieve records having the same code for the entered last name:
  26. *       do sndxdisp with '<dbfname>', '<soundex field>', '<last name>'
  27. *
  28. *    Notes on above commands: 
  29. *    1. The apostrophes (or double quotes, or brackets) are required
  30. *         per the DbaseIII manual, do delimit character values.
  31. *    2. Omit the angle brackets: <>.
  32. *    3. The last name field or entry may have an embedded apostrophe 
  33. *       ("O'Brian"), space, or hyphen.
  34. *
  35. *************************************************************************
  36. *    Program operation: (procedure sndxcalc)
  37. *         Create a Soundex code for the last name parameter 
  38. *         (either a field or variable) and save in public variable msndx1
  39. *    1. Assign a value to the first letter.  This value differs from the 
  40. *       classical soundex value, as it is a number.  The same value is
  41. *       assigned to several letters; see below and the article.
  42. *    2. Check for and remove double consonants
  43. *    3. Assign a value to the remaining letters
  44. *    4. Adjust the code length to four characters
  45. *    5. Store this value in the soundex field
  46. *
  47. *    Modifications to the original article listing:
  48. *    1. Added multiple functions:
  49. *         a. Store the soundex code for a given last name field (input)
  50. *            and a given soundex-code field (output) in a given database
  51. *         b. Retrieve names given a last name, last-name field, 
  52. *            and soundex field
  53. *    2. Made more generalized: replaced the hard coded database file name
  54. *       and field names with user-entered parameters
  55. *    3. Fix bugs: ignore an apostrophe, hyphen, and space within the last name.
  56. *
  57. procedure sndxrpl
  58. parameter dbfname, lastnmfld, sndxfld
  59. public msndx1
  60. set talk off
  61. use &dbfname
  62. do while .not. eof()
  63.   mlastnm = &lastnmfld
  64.   do sndxcalc with "&mlastnm"
  65.   ? ' The record number: ' + str(recno(),4)
  66.   ?? '  Last name: ' + &lastnmfld + '  Soundex code: ' + msndx1
  67.   replace &sndxfld with msndx1
  68.   skip
  69. enddo
  70. set talk on
  71. clear
  72. return
  73.  
  74. procedure sndxdisp
  75. parameter dbfname, sndxfld, lastnam
  76. public msndx1
  77. set talk off
  78. use &dbfname
  79. do sndxcalc with "&lastnam"
  80. ? '  The soundex code for the given last name: ' + msndx1
  81. display all off for &sndxfld='&msndx1'
  82. set talk on
  83. return
  84.  
  85. procedure sndxcalc
  86. parameter charname
  87. store upper(trim("&charname")) to mtr
  88. store substr(mtr,1,1) to m1
  89. store len(mtr) to length
  90. store substr(mtr,2,length) to m2
  91. * assign a value to the first letter
  92. do case
  93.      case m1='A' .or. m1='E' .or. m1='H' .or. m1='I' .or. m1='O' .or. ;
  94.           m1='U' .or. m1='W' .or. m1='Y'
  95.           store '0' to msndx1
  96.      case m1='B' .or. m1='F' .or. m1='P' .or. m1='V'
  97.           store '1' to msndx1
  98.      case m1='C' .or. m1='G' .or. m1='J' .or. m1='K' .or. m1='Q' .or. ;
  99.           m1='S' .or. m1='X' .or.m1='Z'
  100.           store '2' to msndx1
  101.      case m1='D' .or. m1='T' 
  102.           store '3' to msndx1
  103.      case m1='L' 
  104.           store '4' to msndx1
  105.      case m1='M' .or. m1='N' 
  106.           store '5' to msndx1
  107.      case m1='R' 
  108.           store '6' to msndx1
  109. endcase
  110. store 1 to pos
  111. * check for and ignore double consonants
  112. do while pos < length-1
  113.      store substr(m2,pos,1) to mck1
  114.      store substr(m2,pos+1,1) to mck2
  115.      if mck1=mck2
  116.           store at('&mck2',m2)  to mleft
  117.           store substr(m2,1,mleft)  to mlend
  118.           store substr(m2,mleft+2,length)  to mrtend
  119.           store mlend - mrtend to m2
  120.           store len(m2) to length
  121.      endif
  122.      store pos+1 to pos
  123. enddo
  124. store 1 to pos
  125. store ' ' to msndx2
  126. store 0 to mcklen
  127. store len(m2) to length
  128. * assign values remaining characters, dropping vowels and h, w
  129. do while pos<=length .and. length>1 .and. mcklen<4
  130.   store substr(m2,pos,1) to m3
  131.   do case
  132.   * remove vowels and an apostrophe
  133.   case m3='A' .or. m3='E' .or. m3='H' .or. m3='I' .or. m3='O' .or. ;
  134.     m3='U' .or. m3='W' .or. m3='Y' .or. m3="'" .or. m3=' ' .or. m3='-'
  135.     do case
  136.     * if found in the first character, keep the remainder
  137.        case pos=1
  138.       store length-1 to newlen
  139.       store substr(m2,2,newlen) to m2
  140.       store len(m2) to length
  141.     * if found in the middle save each side
  142.        case pos>1 .and. pos<length
  143.       store at('&m3',m2) to mleft
  144.       store substr(m2,1,mleft-1) to mlfend
  145.       store length-pos to newlen
  146.       store substr(m2,mleft+1,newlen) to mrtend
  147.       store mlfend-mrtend to m2
  148.       store len(m2) to length
  149.     * if found at right end, save to next-to-last char
  150.        case pos=length
  151.       store substr(m2,1,length-1) to m2
  152.       store len(m2) to length
  153.     endcase
  154.   * append remaining letter values to first
  155.   case m3='B' .or. m3='F' .or. m3='P' .or. m3='V'
  156.     store msndx1-'1' to msndx1
  157.     store pos+1 to pos
  158.   case m3='C' .or. m3='G' .or. m3='J' .or. m3='K' .or. m3='Q' .or. ;
  159.     m3='S' .or. m3='X' .or.m3='Z'
  160.     store msndx1-'2' to msndx1
  161.     store pos+1 to pos
  162.   case m3='D' .or. m3='T' 
  163.     store msndx1-'3' to msndx1
  164.     store pos+1 to pos
  165.   case m3='L' 
  166.     store msndx1-'4' to msndx1
  167.     store pos+1 to pos
  168.   case m3='M' .or. m3='N' 
  169.     store msndx1-'5' to msndx1
  170.     store pos+1 to pos
  171.   case m3='R' 
  172.     store msndx1-'6' to msndx1
  173.     store pos+1 to pos
  174.   endcase
  175. * check for soundex length less than 4 chars
  176. store len(msndx1) to mcklen
  177. enddo while
  178. do while mcklen<4
  179.      store msndx1-'0' to msndx1
  180.      store len(msndx1) to mcklen
  181. enddo
  182. return