Routine: AUTTVND1

AUTTVND1(X) ; IHS/DIRM/JDM/DFM - BETTER SOUNDEX ; [ 03/09/10   3:10 PM ]

 ;;98.1;IHS DICTIONARIES (POINTERS);*23*;MAR 04, 1998;Build 6

 ;IHS/OIT/FBD AUT*98.1*23 - ADDED ENTRY POINT ASX(X) - 3/9/2010

 ;Extrinsic function, Call with string, Returns converted string.

1 ;

 NEW D,E,F,I,I1,J,J1,L,S,T,W,X1,Z

2 ;

 S (E(1),E)=""

 ;make uppercase---keep only alpha---drop duplicate's

 F I=1:1:$L(X) S L=$E(X,I) Q:L=","  I L?1A S:$A(L)>95 L=$C($A(L)-32) I L'=E(1) S E(1)=L,E=E_L

 S E="#"_E

 D CONV

 S F=$E(E,1,3)

 F I=4:2 Q:I>$L(E)  I +$E(E,I-2,I-1)'=+$E(E,I,I+1) S F=F_$E(E,I,I+1)

 Q $E(F_"0000000000000",2,9)

CONV ;Convert word to numerics (first four sounds)

 S X=$P($T(SH),";;",2),D=0

 F I=1:1 S S=$P(X,";",I) Q:S']""!(D)  F J="S","N" S F=S_J,T=31_$S(J="S":24,1:21) D E Q:D

 F F="TIARY","TEARY","TIARE","TEARE" S T=31_$E(F,2,5) D E Q:D

 S X=$P($T(END+1),";;",2)

 F I=1:1 S J=$P(X,";",I) Q:J']""  S F=$P(J,":",1),T=$P(J,":",2) D E Q:D

 ;F I=1,2 S X(I)=$P($T(VOWEL+I),";;",2)

DOUB ;Double Vowels

 S D=0

 F J=1,2 S X=$P($T(VOWEL+J),";;",2) D

 . F I=1:1 S X1=$P(X,";",I) Q:X1']""  I E[$P(X1,":",1) S D=1,F=$P(X1,":",1),T=$P(X1,":",2),E=$P(E,F,1)_T_$P(E,F,2)

.Q

 G DOUB:D

 F I="START","CHNG","END1","CHNG1" S W=$E(I) F I1=1:1 S X=$P($T(@I+I1),";;",2) Q:X']""  F J=1:1 S J1=$P(X,";",J) Q:J1']""  S F=$P(J1,":",1),T=$P(J1,":",2) I E[F D @W

C ;Change sound to another

 S E=$P(E,F,1)_T_$P(E,F,2,99)

 G C:E[F

S ;Change 'Starts with' sound to another

 I $E(E,2,$L(F)+1)=F S E=$P(E,F,1)_T_$P(E,F,2)

E ;Change 'Ends with' sound to another

 S Z=$L(E)-($L(F))+1,Z=$S(Z>1:Z,1:2)

 I $E(E,Z,$L(E))=F S E=$E(E,1,Z-1)_T,D=1

ASX(X) ;EP - X is the string you want converted.  Returns converted string.  ;IHS/OIT/FBD AUT*98.1*23 3/1/2010

G 1

SH ;;TEOU;TIOU;TOU;TIOU;TU;TYOU;SHU;SHI;CHU;CHO;XIOU;XOU;AUT;XIU;CIOU;COU;CU;CO;SIOU;CEOU;CE;XEOU;XE;SEOU;SHOU;CHOU;CHE;CHI;SU;TIO

VOWEL ;

 ;;AE:A;AI:A;AO:O;AU:O;AW:O;AY:A;EA:E;EI:E;EO:O;EU:U;EW:U;EY:I;IA:A;IE:E;IO:I;IU:O;IW:I;IY:I;OA:O;OE:O;OI:O;OU:U;GH:;

 ;;OWE:O;OW:O;OY:O;UA:A;UE:U;UI:I;UO:O;UW:U;UY:I;WA:A;WE:E;WI:I;WO:O;WU:U;WY:I;YA:A;YE:E;YI:I;YO:O:YU:U;AA:A;EE:E;II:I;OO:O;UU:U;YY:I

END ;

 ;;VOUS:1512;RTIAL:R3118;GUE:16;

START ;

 ;;MAC:MC;WR:23:GU:16;QU:17;TH:14

CHNG ;

 ;;PE:22;GU:16;CA:24A;CE:24E;CI:24I;CY:24Y;AL:18;EL:18;IL:18;OL:18;UL:18;WL:18;YL:18;AN:21;EN:21;IN:21;AR:23;AV:15;V:15;BH:13;BT:13;ED:14;ER:23;IM:19;IT:14;IR:23;OR:23;EM:19;YT:14

 ;;OM:19;ON:21;UR:23;US:24;ES:24;UN:21;GN:21;KN:21;LK:14;LM:19;LN:21;CHM:19;TSCH:31;TSH:31;TCH:31;TSCH:31;SCH:31;SH:31;CH:31;DJ:16;MB:19;MN:21;PHN:21;PH:15;PN:21;YR:23;YN:21

 ;;WH:12;YL:18;RH:23

END1 ;

 ;;CE:24;ZE:24;TE:14;E;;ATES:24;ES:24;IS:24;OS:24;US:24;YS:24;WS:24;EZ:24;Z:24;TI:14;TY:14;CY:2411;CI:2411;TE:14;NTS:N24;21TS:2124;21T24:2124;S:24

CHNG1 ;

 ;;A:11;B:13;C:17;D:14;E:11;F:15;G:16;H:;I:11;J:16;K:17;L:18;M:19;N:21;O:12;P:22;Q:17;R:23;S:24;T:14;U:12;V:15;W:12;X:24;Y:11;Z:24

AUTTVND1(X) ; IHS/DIRM/JDM/DFM - BETTER SOUNDEX ; [ 03/09/10   3:10 PM ]

 +1       ;;98.1;IHS DICTIONARIES (POINTERS);*23*;MAR 04, 1998;Build 6

 +2       ;IHS/OIT/FBD AUT*98.1*23 - ADDED ENTRY POINT ASX(X) - 3/9/2010

 +3       ;

 +4       ;Extrinsic function, Call with string, Returns converted string.

1         ;

 +1        NEW D,E,F,I,I1,J,J1,L,S,T,W,X1,Z

2         ;

 +1        SET (E(1),E)=""

 +2       ;make uppercase---keep only alpha---drop duplicate's

 +3        FOR I=1:1:$LENGTH(X)

               SET L=$EXTRACT(X,I)

               IF L=","

                   QUIT

               IF L?1A

                   IF $ASCII(L)>95

                       SET L=$CHAR($ASCII(L)-32)

                   IF L'=E(1)

                       SET E(1)=L

                       SET E=E_L

 +4        SET E="#"_E

 +5        DO CONV

 +6        SET F=$EXTRACT(E,1,3)

 +7        FOR I=4:2

               IF I>$LENGTH(E)

                   QUIT

               IF +$EXTRACT(E,I-2,I-1)'=+$EXTRACT(E,I,I+1)

                   SET F=F_$EXTRACT(E,I,I+1)

 +8        QUIT $EXTRACT(F_"0000000000000",2,9)

 +9       ;

CONV      ;Convert word to numerics (first four sounds)

 +1        SET X=$PIECE($TEXT(SH),";;",2)

           SET D=0

 +2        FOR I=1:1

               SET S=$PIECE(X,";",I)

               IF S']""!(D)

                   QUIT

               FOR J="S","N"

                   SET F=S_J

                   SET T=31_$SELECT(J="S":24,1:21)

                   DO E

                   IF D

                       QUIT

 +3        FOR F="TIARY","TEARY","TIARE","TEARE"

               SET T=31_$EXTRACT(F,2,5)

               DO E

               IF D

                   QUIT

 +4        SET X=$PIECE($TEXT(END+1),";;",2)

 +5        FOR I=1:1

               SET J=$PIECE(X,";",I)

               IF J']""

                   QUIT

               SET F=$PIECE(J,":",1)

               SET T=$PIECE(J,":",2)

               DO E

               IF D

                   QUIT

 +6       ;F I=1,2 S X(I)=$P($T(VOWEL+I),";;",2)

DOUB      ;Double Vowels

 +1        SET D=0

 +2        FOR J=1,2

               SET X=$PIECE($TEXT(VOWEL+J),";;",2)

               Begin DoDot:1

 +3                FOR I=1:1

                       SET X1=$PIECE(X,";",I)

                       IF X1']""

                           QUIT

                       IF E[$PIECE(X1,":",1)

                           SET D=1

                           SET F=$PIECE(X1,":",1)

                           SET T=$PIECE(X1,":",2)

                           SET E=$PIECE(E,F,1)_T_$PIECE(E,F,2)

 +4                QUIT

               End DoDot:1

 +5        IF D

               GOTO DOUB

 +6        FOR I="START","CHNG","END1","CHNG1"

               SET W=$EXTRACT(I)

               FOR I1=1:1

                   SET X=$PIECE($TEXT(@I+I1),";;",2)

                   IF X']""

                       QUIT

                   FOR J=1:1

                       SET J1=$PIECE(X,";",J)

                       IF J1']""

                           QUIT

                       SET F=$PIECE(J1,":",1)

                       SET T=$PIECE(J1,":",2)

                       IF E[F

                           DO @W

 +7        QUIT

 +8       ;

C         ;Change sound to another

 +1        SET E=$PIECE(E,F,1)_T_$PIECE(E,F,2,99)

 +2        IF E[F

               GOTO C

 +3        QUIT

 +4       ;

S         ;Change 'Starts with' sound to another

 +1        IF $EXTRACT(E,2,$LENGTH(F)+1)=F

               SET E=$PIECE(E,F,1)_T_$PIECE(E,F,2)

 +2        QUIT

 +3       ;

E         ;Change 'Ends with' sound to another

 +1        SET Z=$LENGTH(E)-($LENGTH(F))+1

           SET Z=$SELECT(Z>1:Z,1:2)

 +2        IF $EXTRACT(E,Z,$LENGTH(E))=F

               SET E=$EXTRACT(E,1,Z-1)_T

               SET D=1

 +3        QUIT

 +4       ;

ASX(X)    ;EP - X is the string you want converted.  Returns converted string.  ;IHS/OIT/FBD AUT*98.1*23 3/1/2010

 +1        GOTO 1

 +2       ;

SH        ;;TEOU;TIOU;TOU;TIOU;TU;TYOU;SHU;SHI;CHU;CHO;XIOU;XOU;AUT;XIU;CIOU;COU;CU;CO;SIOU;CEOU;CE;XEOU;XE;SEOU;SHOU;CHOU;CHE;CHI;SU;TIO

 +1       ;

VOWEL     ;

 +1       ;;AE:A;AI:A;AO:O;AU:O;AW:O;AY:A;EA:E;EI:E;EO:O;EU:U;EW:U;EY:I;IA:A;IE:E;IO:I;IU:O;IW:I;IY:I;OA:O;OE:O;OI:O;OU:U;GH:;

 +2       ;;OWE:O;OW:O;OY:O;UA:A;UE:U;UI:I;UO:O;UW:U;UY:I;WA:A;WE:E;WI:I;WO:O;WU:U;WY:I;YA:A;YE:E;YI:I;YO:O:YU:U;AA:A;EE:E;II:I;OO:O;UU:U;YY:I

 +3       ;

END       ;

 +1       ;;VOUS:1512;RTIAL:R3118;GUE:16;

 +2       ;

START     ;

 +1       ;;MAC:MC;WR:23:GU:16;QU:17;TH:14

 +2       ;

CHNG      ;

 +1       ;;PE:22;GU:16;CA:24A;CE:24E;CI:24I;CY:24Y;AL:18;EL:18;IL:18;OL:18;UL:18;WL:18;YL:18;AN:21;EN:21;IN:21;AR:23;AV:15;V:15;BH:13;BT:13;ED:14;ER:23;IM:19;IT:14;IR:23;OR:23;EM:19;YT:14

 +2       ;;OM:19;ON:21;UR:23;US:24;ES:24;UN:21;GN:21;KN:21;LK:14;LM:19;LN:21;CHM:19;TSCH:31;TSH:31;TCH:31;TSCH:31;SCH:31;SH:31;CH:31;DJ:16;MB:19;MN:21;PHN:21;PH:15;PN:21;YR:23;YN:21

 +3       ;;WH:12;YL:18;RH:23

 +4       ;

END1      ;

 +1       ;;CE:24;ZE:24;TE:14;E;;ATES:24;ES:24;IS:24;OS:24;US:24;YS:24;WS:24;EZ:24;Z:24;TI:14;TY:14;CY:2411;CI:2411;TE:14;NTS:N24;21TS:2124;21T24:2124;S:24

CHNG1     ;

 +1       ;;A:11;B:13;C:17;D:14;E:11;F:15;G:16;H:;I:11;J:16;K:17;L:18;M:19;N:21;O:12;P:22;Q:17;R:23;S:24;T:14;U:12;V:15;W:12;X:24;Y:11;Z:24

AUTTVND1.m