DEFINE DATA LOCAL 
01 #SOUNDEX-CODE (A4)     
01 #WORK-NAME    (A35)    
01 REDEFINE #WORK-NAME    
  02 #WORK-CHAR  (A1/1:35)
01 #WORK-LENGTH  (N3)
01 #I            (I4)
01 #ET           (P7)
01 #CNT          (P9)
01 #J            (I4)
01 #J1           (I4)
01 #FIRST-CHAR   (A1)
01 #HOLD-CHAR    (A1)
..
END-DEFINE
..
**********************************************************************
DEFINE SUBROUTINE SOUNDEX                                             
**********************************************************************
* Make sure all letters are in UPPER case.                            
EXAMINE #WORK-NAME TRANSLATE INTO UPPER CASE                          
* Find the length of last name.                                       
EXAMINE FULL #WORK-NAME FOR FULL ' ' GIVING LENGTH #WORK-LENGTH       
* Change any characters that are not letters of the alphabet          
* and make them a blank.                                              
F01. FOR #J = 1 THRU #WORK-LENGTH                                     
*                                                                     
  DECIDE ON FIRST #WORK-CHAR (#J)                                     
    VALUE 'A','B','C','D','E','F','G','H','I','J','K','L','M','N','O' 
      ESCAPE TOP /* (F01.)                                            
    VALUE 'P','Q','R','S','T','U','V','W','X','Y','Z'                 
      ESCAPE TOP /* (F01.)                                            
    NONE VALUE                                                        
      #WORK-CHAR (#J) := ' '                                          
  END-DECIDE                                                          
END-FOR /* (F01.) 
* Remove the blanks                                                   
EXAMINE FULL #WORK-NAME  FOR FULL ' ' AND DELETE                      
* Find the new length.                                                
EXAMINE FULL #WORK-NAME FOR FULL ' ' GIVING LENGTH #WORK-LENGTH       
* Remove repeating letters.  If adjacent letters are equal, only first
* occurance of that value is kept.                                    
#HOLD-CHAR           := #WORK-CHAR (1)                                
IF #WORK-LENGTH GT 1                                                  
 F02. FOR #J = 2 THRU #WORK-LENGTH                                    
   IF #WORK-CHAR (#J) = #HOLD-CHAR                                    
     #WORK-CHAR (#J) := ' '                                           
   ELSE                                                               
     #HOLD-CHAR      := #WORK-CHAR(#J)                                
   END-IF                                                             
 END-FOR /* (F02.)                                                    
END-IF                                                                
* Remove the blanks.                                                  
EXAMINE FULL #WORK-NAME  FOR FULL ' ' AND DELETE                      
* Find the new length.                                                
EXAMINE FULL #WORK-NAME FOR FULL ' ' GIVING LENGTH #WORK-LENGTH       
* Set first character and apply Soundex algorithum to scanned last name.
#FIRST-CHAR  := #WORK-CHAR (1)                                          
F03. FOR #J = 1 THRU #WORK-LENGTH                                       
*                                                                       
  DECIDE ON FIRST #WORK-CHAR (#J)                                       
    VALUE 'W','H'                                                       
      IF #J NE 1                                                        
        #WORK-CHAR (#J) := ' '                                          
      ELSE                                                              
        #WORK-CHAR (#J) := '0'                                          
      END-IF                                                            
    VALUE 'A','E','I','O','U','Y'                                       
      IF #J NE 1                                                        
        #WORK-CHAR (#J) := ' '                                          
      ELSE                                                              
        #WORK-CHAR (#J) := '0'                                          
      END-IF                                                            
    VALUE 'B','F','P','V'                                               
      #WORK-CHAR (#J)   := '1'                                          
    VALUE 'C','G','J','K','Q','S','X','Z'                               
      #WORK-CHAR (#J)   := '2'                           
    VALUE 'D','T'                                        
      #WORK-CHAR (#J)   := '3'                           
    VALUE 'L'                                            
      #WORK-CHAR (#J)   := '4'                           
    VALUE 'M','N'                                        
      #WORK-CHAR (#J)   := '5'                           
    VALUE 'R'                                            
      #WORK-CHAR (#J)   := '6'                           
    NONE VALUE                                           
      #WORK-CHAR (#J)   := ' '                           
  END-DECIDE                                             
END-FOR /* (F03.)                                        
*                                                        
#WORK-CHAR (1)          := #FIRST-CHAR                   
* Delete any remaining blanks.                           
EXAMINE FULL #WORK-NAME FOR FULL ' ' AND DELETE          
* Replace the blanks with zeros                          
EXAMINE FULL #WORK-NAME FOR FULL ' ' AND REPLACE WITH '0'
#SOUNDEX-CODE           := #WORK-NAME                    
END-SUBROUTINE /* SOUNDEX       
*                               
.....