LEXAS4 ;ISL/KER - Look-up Check Input (DBL,REM) ;04/21/2014
;;2.0;LEXICON UTILITY;**80**;Sep 23, 1996;Build 1
;
DBL(LEXX) ; Excessive Double Characters
;
; LEXI Incremental counter
; LEXOK Flag - found word yes/no
; LEXT Temporary word
; LEXD Temporary word (Double doubles)
; LEXX Return string
;
N LEXI,LEXOK,LEXT,LEXD S LEXOK=0,LEXD=""
F LEXI=1:1:$L(LEXX) D Q:LEXOK
. S LEXT=LEXX I $E(LEXX,LEXI)=$E(LEXX,(LEXI+1)) D
. . S LEXT=$E(LEXX,1,LEXI)_$E(LEXX,(LEXI+2),$L(LEXX))
. . I $D(^LEX(757.01,"ASL",LEXT)) S LEXX=LEXT,LEXOK=1 Q
. . Q:LEXI=1
. . S LEXT=$E(LEXX,1,(LEXI-1))_$E(LEXX,(LEXI+2),$L(LEXX))
. . I $D(^LEX(757.01,"ASL",LEXT)) S LEXX=LEXT,LEXOK=1 Q
I LEXOK Q LEXX
F LEXI=1:1:$L(LEXX) D
. I $E(LEXX,LEXI)'=$E(LEXX,(LEXI+1)) D
. . S LEXD=LEXD_$E(LEXX,LEXI)
I $D(^LEX(757.01,"ASL",LEXD)) S LEXX=LEXD
Q LEXX
;
REM(LEXX) ; Remove character
;
; LEXI Incremental counter
; LEXOK Flag - found word yes/no
; LEXF First segment
; LEXT Trailing segment
; LEXN Altered tolken
; LEXTN Temporary altered tolken
; LEXX Return string
;
N LEXI,LEXO,LEXCS,LEXCA,LEXTN,LEXOK,LEXF,LEXT,LEXN,LEXL
S LEXOK=0,LEXO=LEXX
F LEXI=2:1:$L(LEXO) D Q:LEXOK
. S LEXF=$E(LEXO,1,(LEXI-1)),LEXT=$E(LEXO,(LEXI+1),$L(LEXO))
. I $D(^LEX(757.01,"AWRD",(LEXF_LEXT))),$O(^LEX(757.01,"ASL",(LEXF_LEXT),0))>1 D Q
. . S LEXX=LEXF_LEXT,LEXOK=1
. S LEXN=$$REM2(LEXO,LEXI) I $D(^LEX(757.01,"AWRD",LEXN)) S LEXX=LEXN,LEXOK=1 Q
. Q:$D(^LEX(757.01,"ASL",$E(LEXO,1,LEXI)))
. S LEXF=$E(LEXO,1,(LEXI-1)),LEXT=$E(LEXO,(LEXI+1),$L(LEXO))
. I '$D(^LEX(757.01,"ASL",LEXF)),$O(^LEX(757.01,"ASL",LEXF,0))>1 D Q
. . S LEXX=$E(LEXF,1,($L(LEXF)-1)),LEXOK=1
. S LEXCA=LEXF_LEXT
. S LEXCS=LEXF_$E(LEXT,1)
. I $D(^LEX(757.01,"ASL",LEXCS)),$O(^LEX(757.01,"ASL",LEXCS,0))>1 D
. . S LEXO=LEXCA,LEXI=LEXI+1 S:LEXI=$L(LEXO) LEXOK=1
. S LEXTN=$$SHIFT^LEXAS3(LEXO)
. I $D(^LEX(757.01,"AWRD",LEXTN)),$O(^LEX(757.01,"ASL",LEXTN,0))>1 S LEXX=LEXTN,LEXOK=1 Q
. I $D(^LEX(757.01,"ASL",LEXO)),$O(^LEX(757.01,"ASL",LEXO,0))>1 S LEXX=LEXO,LEXOK=1
Q LEXX
REM2(LEXO,LEXI) ; Remove character at position LEXI
N LEXOK S LEXOK=0
S LEXF=$E(LEXO,1,LEXI)_$E(LEXO,(LEXI+2),(LEXI+3))
I $L(LEXF)>3 D
. N LEXT,LEXN,LEXP1,LEXP2 S LEXT=$E(LEXX,($L(LEXX)-4),$L(LEXX))
. S LEXN=$E(LEXF,1,($L(LEXF)-1))_$C($A($E(LEXF,$L(LEXF)))-1)_"~"
. F S LEXN=$O(^LEX(757.01,"AWRD",LEXN)) Q:LEXN=""!($E(LEXN,1,$L(LEXF))'=LEXF)!(LEXOK) D
. . S LEXP1=$E(LEXN,($L(LEXN)-($L(LEXT)-1)),$L(LEXN))
. . I $E(LEXN,($L(LEXN)-($L(LEXT)-1)),$L(LEXN))=LEXT S LEXO=LEXN,LEXOK=1
Q LEXO
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLEXAS4 2632 printed Dec 13, 2024@02:07:11 Page 2
LEXAS4 ;ISL/KER - Look-up Check Input (DBL,REM) ;04/21/2014
+1 ;;2.0;LEXICON UTILITY;**80**;Sep 23, 1996;Build 1
+2 ;
DBL(LEXX) ; Excessive Double Characters
+1 ;
+2 ; LEXI Incremental counter
+3 ; LEXOK Flag - found word yes/no
+4 ; LEXT Temporary word
+5 ; LEXD Temporary word (Double doubles)
+6 ; LEXX Return string
+7 ;
+8 NEW LEXI,LEXOK,LEXT,LEXD
SET LEXOK=0
SET LEXD=""
+9 FOR LEXI=1:1:$LENGTH(LEXX)
Begin DoDot:1
+10 SET LEXT=LEXX
IF $EXTRACT(LEXX,LEXI)=$EXTRACT(LEXX,(LEXI+1))
Begin DoDot:2
+11 SET LEXT=$EXTRACT(LEXX,1,LEXI)_$EXTRACT(LEXX,(LEXI+2),$LENGTH(LEXX))
+12 IF $DATA(^LEX(757.01,"ASL",LEXT))
SET LEXX=LEXT
SET LEXOK=1
QUIT
+13 if LEXI=1
QUIT
+14 SET LEXT=$EXTRACT(LEXX,1,(LEXI-1))_$EXTRACT(LEXX,(LEXI+2),$LENGTH(LEXX))
+15 IF $DATA(^LEX(757.01,"ASL",LEXT))
SET LEXX=LEXT
SET LEXOK=1
QUIT
End DoDot:2
End DoDot:1
if LEXOK
QUIT
+16 IF LEXOK
QUIT LEXX
+17 FOR LEXI=1:1:$LENGTH(LEXX)
Begin DoDot:1
+18 IF $EXTRACT(LEXX,LEXI)'=$EXTRACT(LEXX,(LEXI+1))
Begin DoDot:2
+19 SET LEXD=LEXD_$EXTRACT(LEXX,LEXI)
End DoDot:2
End DoDot:1
+20 IF $DATA(^LEX(757.01,"ASL",LEXD))
SET LEXX=LEXD
+21 QUIT LEXX
+22 ;
REM(LEXX) ; Remove character
+1 ;
+2 ; LEXI Incremental counter
+3 ; LEXOK Flag - found word yes/no
+4 ; LEXF First segment
+5 ; LEXT Trailing segment
+6 ; LEXN Altered tolken
+7 ; LEXTN Temporary altered tolken
+8 ; LEXX Return string
+9 ;
+10 NEW LEXI,LEXO,LEXCS,LEXCA,LEXTN,LEXOK,LEXF,LEXT,LEXN,LEXL
+11 SET LEXOK=0
SET LEXO=LEXX
+12 FOR LEXI=2:1:$LENGTH(LEXO)
Begin DoDot:1
+13 SET LEXF=$EXTRACT(LEXO,1,(LEXI-1))
SET LEXT=$EXTRACT(LEXO,(LEXI+1),$LENGTH(LEXO))
+14 IF $DATA(^LEX(757.01,"AWRD",(LEXF_LEXT)))
IF $ORDER(^LEX(757.01,"ASL",(LEXF_LEXT),0))>1
Begin DoDot:2
+15 SET LEXX=LEXF_LEXT
SET LEXOK=1
End DoDot:2
QUIT
+16 SET LEXN=$$REM2(LEXO,LEXI)
IF $DATA(^LEX(757.01,"AWRD",LEXN))
SET LEXX=LEXN
SET LEXOK=1
QUIT
+17 if $DATA(^LEX(757.01,"ASL",$EXTRACT(LEXO,1,LEXI)))
QUIT
+18 SET LEXF=$EXTRACT(LEXO,1,(LEXI-1))
SET LEXT=$EXTRACT(LEXO,(LEXI+1),$LENGTH(LEXO))
+19 IF '$DATA(^LEX(757.01,"ASL",LEXF))
IF $ORDER(^LEX(757.01,"ASL",LEXF,0))>1
Begin DoDot:2
+20 SET LEXX=$EXTRACT(LEXF,1,($LENGTH(LEXF)-1))
SET LEXOK=1
End DoDot:2
QUIT
+21 SET LEXCA=LEXF_LEXT
+22 SET LEXCS=LEXF_$EXTRACT(LEXT,1)
+23 IF $DATA(^LEX(757.01,"ASL",LEXCS))
IF $ORDER(^LEX(757.01,"ASL",LEXCS,0))>1
Begin DoDot:2
+24 SET LEXO=LEXCA
SET LEXI=LEXI+1
if LEXI=$LENGTH(LEXO)
SET LEXOK=1
End DoDot:2
+25 SET LEXTN=$$SHIFT^LEXAS3(LEXO)
+26 IF $DATA(^LEX(757.01,"AWRD",LEXTN))
IF $ORDER(^LEX(757.01,"ASL",LEXTN,0))>1
SET LEXX=LEXTN
SET LEXOK=1
QUIT
+27 IF $DATA(^LEX(757.01,"ASL",LEXO))
IF $ORDER(^LEX(757.01,"ASL",LEXO,0))>1
SET LEXX=LEXO
SET LEXOK=1
End DoDot:1
if LEXOK
QUIT
+28 QUIT LEXX
REM2(LEXO,LEXI) ; Remove character at position LEXI
+1 NEW LEXOK
SET LEXOK=0
+2 SET LEXF=$EXTRACT(LEXO,1,LEXI)_$EXTRACT(LEXO,(LEXI+2),(LEXI+3))
+3 IF $LENGTH(LEXF)>3
Begin DoDot:1
+4 NEW LEXT,LEXN,LEXP1,LEXP2
SET LEXT=$EXTRACT(LEXX,($LENGTH(LEXX)-4),$LENGTH(LEXX))
+5 SET LEXN=$EXTRACT(LEXF,1,($LENGTH(LEXF)-1))_$CHAR($ASCII($EXTRACT(LEXF,$LENGTH(LEXF)))-1)_"~"
+6 FOR
SET LEXN=$ORDER(^LEX(757.01,"AWRD",LEXN))
if LEXN=""!($EXTRACT(LEXN,1,$LENGTH(LEXF))'=LEXF)!(LEXOK)
QUIT
Begin DoDot:2
+7 SET LEXP1=$EXTRACT(LEXN,($LENGTH(LEXN)-($LENGTH(LEXT)-1)),$LENGTH(LEXN))
+8 IF $EXTRACT(LEXN,($LENGTH(LEXN)-($LENGTH(LEXT)-1)),$LENGTH(LEXN))=LEXT
SET LEXO=LEXN
SET LEXOK=1
End DoDot:2
End DoDot:1
+9 QUIT LEXO
