|
midrange.com
Here's some code that I downloaded, probably from midrange computing....
SDX001RG
*===============================================================
* To compile:
*
* CRTBNDRPG PGM(XXX/SDX001RG) SRCFILE(XXX/QRPGLESRC)
*
*===============================================================
* SDX001RG: Convert a given string to a Soundex code.
* Input: Accepts a 50 character string. (In_String)
* Output: Returns a 4 character soundex code. (Soundex)
* Indicator Usage:
* 90 - General Work Indicator
* Variable Declarations:
*. 1 ...+... 2 ...+... 3 ...+... 4 ...+... 5 ...+... 6 ...+... 7 ...+... 8
DInput_Data S 1A Dim(50)
DWork_Data S 1A Dim(50)
DIn_String S 50A
DSoundex S 4A
DSave_Last S 1A INZ(*HIVAL)
DFirst_Two S 2A
DI1 S 2S 0 INZ(0)
DI2 S 2S 0 INZ(0)
DUpper C CONST('ABCDEFGHIJKLMNOPQRSTUVWXYZ')
DLower C CONST('abcdefghijklmnopqrstuvwxyz')
DCodes C CONST('01230120022455012623010202')
*********************
* Mainline Program: *
*********************
* Strip Non-Alphabet Characters from the input data
C EXSR Strip_It
* Convert input text to soundex coding
C EXSR Convert_it
* Strip out Repeat Sound Codes and Build Soundex Variable:
C EXSR Build_it
* End the program
C EVAL *inLR = *ON
* Subroutine Section:
***********************
* Strip It Subroutine *
***********************
C Strip_it BEGSR
* Strip all non-alpabetic characters from the input data:
*. 1 ...+... 2 ...+... 3 ...+... 4 ...+... 5 ...+... 6 ...+... 7 ...+... 8
*. 1 ...+... 2 ...+... 3 ...+... 4 ...+... 5 ...+... 6 ...+... 7 ...+... 8
C DOW I1 < %ELEM(Input_Data)
C EVAL I1 = I1 + 1
* Check for non-alpha characters
C Upper CHECK Input_Data(I1) 90
* Continue processing this value only if it was alphabetic
C IF *in90<>*ON
* Check for repeat letters and fill work file
C IF Save_Last <> Input_Data(I1)
C EVAL I2 = I2 + 1
C EVAL Work_Data(I2) = Input_Data(I1)
C EVAL Save_Last = Input_Data(I1)
C ENDIF
C ENDIF
C ENDDO
* Move the Work Array Information back to the Input Data Array
* and clear the work array.
C EVAL Input_Data = Work_Data
C CLEAR Work_Data
C ENDSR
*************************
* Convert it Subroutine *
*************************
C Convert_It BEGSR
* Convert input data to Soundex Coding
* First element is moved without translation:
C EVAL Work_Data(1) = Input_Data(1)
C EVAL I1 = 1
C DOW I1 < %ELEM(Input_Data)
C EVAL I1 = I1 + 1
C Upper:Codes XLATE Input_Data(I1)Work_Data(I1)
C ENDDO
* Move the Work Array Information back to the Input Data Array
* and clear the work array.
C EVAL Input_Data = Work_Data
C CLEAR Work_Data
*. 1 ...+... 2 ...+... 3 ...+... 4 ...+... 5 ...+... 6 ...+... 7 ...+... 8
*. 1 ...+... 2 ...+... 3 ...+... 4 ...+... 5 ...+... 6 ...+... 7 ...+... 8
C ENDSR
***********************
* Build It Subroutine *
***********************
C Build_it BEGSR
* Build the Soundex Variable
* First Character comes over with no further processing:
C EVAL %SUBST(Soundex:1:1) = Input_Data(1)
* Set up variables for processing loop:
C EVAL Save_Last = *HIVAL
C EVAL I1 = 1
C EVAL I2 = 1
* Do while index is less than number of input elements
* and current element is not blank
* and last Soundex element is not filled.
C DOW I1 < %ELEM(Input_Data)
C AND Input_Data(I1) > ' '
C AND I2 < 4
C EVAL I1 = I1 + 1
C IF Input_Data(I1) > ' '
* If code is not a dupe of the previous code, move it to Sound_X:
C IF Save_Last <> Input_Data(I1) AND
C Input_Data(I1) <> '0'
C EVAL Save_Last = Input_Data(I1)
C EVAL I2 = I2 +1
C EVAL %SUBST(Soundex:I2:1) = Input_Data(I1)
C ENDIF
C ENDIF
C ENDDO
* Convert any remaining blank values to zeros:
C ' ':'0' XLATE Soundex Soundex
C ENDSR
******************************
* Alter Odd Starting Letters *
******************************
*. 1 ...+... 2 ...+... 3 ...+... 4 ...+... 5 ...+... 6 ...+... 7 ...+... 8
*. 1 ...+... 2 ...+... 3 ...+... 4 ...+... 5 ...+... 6 ...+... 7 ...+... 8
C Odd_Start BEGSR
* Try to raise accuracy by substituting common weird two letter
* word starting combinations.
* Move the first two letters of our word to be converted:
C EVAL First_Two = %SUBST(In_String:1:2)
C SELECT
C WHEN First_Two = 'PH'
C EVAL %SUBST(In_String:1:2) = ' F'
C WHEN First_Two = 'NM'
C EVAL %SUBST(In_String:1:1) = ' '
C WHEN First_Two = 'PT'
C EVAL %SUBST(In_String:1:1) = ' '
C WHEN First_Two = 'KN'
C EVAL %SUBST(In_String:1:1) = ' '
C ENDSL
C ENDSR
******************************
* Initialization Subroutine: *
******************************
C *Inzsr BEGSR
* Parameters Expected by this Program:
C *Entry PLIST
C PARM In_String
C PARM Soundex
* Translate all alphabetic characters to upper case:
C Lower:Upper XLATE In_String In_String
* Alter Odd Starting Letter combinations:
C EXSR Odd_Start
* Strip Leading Blanks
C EVAL In_String = %triml(In_String)
* Place our Input Data into an array for further processing:
C MOVEA In_String Input_Data
* Make certain that the Soundex code variable is empty:
C CLEAR Soundex
C ENDSR
SDX002DF
*. 1 ...+... 2 ...+... 3 ...+... 4 ...+... 5 ...+... 6 ...+... 7 ...+... 8
A DSPSIZ(24 80 *DS3)
A CSRINPONLY
A* Main Input Screen:
A R SCREEN1
A WINDOW(5 10 9 52 *NOMSGLIN)
A CF03
A CF12
A PRINT
A WDWBORDER((*COLOR WHT) (*DSPATR HI))
A WDWTITLE((*TEXT 'Soundex Test') (*C-
A OLOR WHT))
A 2 1'Input String:'
A IN_STRING 50A I 3 2CHECK(LC)
A 5 2'Results of Last Run:'
A OUT_STRING 50A O 6 2COLOR(WHT)
A 7 2'Soundex code --------->'
A SOUNDEX 4A O 7 26COLOR(WHT)
A 8 1'F3=Exit'
A COLOR(BLU)
* Dummy Record:
A R DUMMY
A ASSUME
A 1 5' '
A*. 1 ...+... 2 ...+... 3 ...+... 4 ...+... 5 ...+... 6 ...+... 7
SDX002RG
*===============================================================
* SDX002RG: Demonstrate The Soundex Routine
*. 1 ...+... 2 ...+... 3 ...+... 4 ...+... 5 ...+... 6 ...+... 7 ...+... 8
FSDX002DF CF E WORKSTN
F INFDS(INFDS)
* Information Data Structure To Get The Function Key pressed:
D INFDS DS
D FunctionKy 369 369
* Named Hex Constants For Function Keys
D F03 C CONST(X'33')
D F12 C CONST(X'3C')
D ENTER C CONST(X'F1')
****************
* Main Program *
****************
C DOW FunctionKy <> F03
C AND FunctionKy <> F12
* Output Entry Screen:
C EXFMT Screen1
* Process Screen Based on Key used:
C SELECT
C WHEN FunctionKy = ENTER
C EXSR Process
* Verify Input
C OTHER
* Do Nothing
C ENDSL
C ENDDO
* Terminate the Program:
C EVAL *inLR = *ON
*****************************************
* Subroutine Section *
*****************************************
* Call the Soundex Routine:
C Process BEGSR
C CALL 'SDX001RG'
C PARM In_String
C PARM Soundex
C EVAL Out_String = In_String
C CLEAR In_String
C ENDSR
_________________
Art Tostaine, Jr.
CCA, Inc.
Jackson, NJ 08527
As an Amazon Associate we earn from qualifying purchases.
This mailing list archive is Copyright 1997-2024 by midrange.com and David Gibbs as a compilation work. Use of the archive is restricted to research of a business or technical nature. Any other uses are prohibited. Full details are available on our policy page. If you have questions about this, please contact [javascript protected email address].
Operating expenses for this site are earned using the Amazon Associate program and Google Adsense.
