- LEXAS3 ;ISL/KER - Look-up Check Input (SHIFT) ;04/21/2014
- ;;2.0;LEXICON UTILITY;**80**;Sep 23, 1996;Build 1
- ;
- SHIFT(LEXX) ; Letters are shifted out of position
- ;
- ; LEXORG( Array of characters in the ORiGinal string
- ; LEXORD( Array of characters in the $O variable
- ; LEXE $E string
- ; LEXL Length
- ; LEXD Flag - Difference of strings
- ; LEXOK Flag - Shifted string is ok to use
- ; LEXO $O variable
- ; LEXI Incremental counter
- ; LEXX Returned value
- ;
- ;
- Q:$L(LEXX)<5 LEXX
- N LEXT,LEXE,LEXL,LEXO,LEXOK,LEXORG,LEXORD
- S LEXT=LEXX,LEXOK=0
- F LEXL=1:1:3 D SHF Q:LEXOK S LEXT=$E(LEXT,1,($L(LEXT)-1))
- K LEXORG,LEXORD
- S LEXX=LEXT
- Q LEXX
- ;
- SHF ; Shift letters in arrays
- K LEXORG D ORG(LEXT)
- S LEXE=$E(LEXT,1,2),LEXO=$$SCH^LEXAS6(LEXE)
- F S LEXO=$O(^LEX(757.01,"AWRD",LEXO)) Q:LEXO=""!(LEXO'[LEXE)!(LEXOK) D Q:LEXOK
- . Q:$L(LEXO)<$L(LEXT)!($L(LEXO)>($L(LEXT)+1))
- . N LEXD D ORD(LEXO) S LEXD=$$COMP
- . I LEXD S LEXOK=0 Q
- . I 'LEXD S LEXT=LEXO,LEXOK=1 Q
- Q
- ;
- ORG(LEXX) ; Original tolken
- K LEXORG N LEXI
- F LEXI=1:1:$L(LEXX) D
- . I $D(LEXORG($E(LEXX,LEXI))) D Q
- . . S LEXORG($E(LEXX,LEXI))=LEXORG($E(LEXX,LEXI))+1
- . S LEXORG($E(LEXX,LEXI))=1
- Q
- ORD(LEXO) ; Ordered tolken
- K LEXORD N LEXI
- F LEXI=1:1:$L(LEXO) D
- . I $D(LEXORD($E(LEXO,LEXI))) D Q
- . . S LEXORD($E(LEXO,LEXI))=LEXORD($E(LEXO,LEXI))+1
- . S LEXORD($E(LEXO,LEXI))=1
- Q
- COMP(LEXX) ; Compare Original to Ordered
- N LEXI,LEXD S LEXI="",LEXD=1
- F S LEXI=$O(LEXORG(LEXI)) Q:LEXI="" D Q:'LEXD
- . I '$D(LEXORD(LEXI)) S LEXD=0 Q
- . I LEXORG(LEXI)>LEXORD(LEXI) S LEXD=0
- I LEXD=0 K LEXORD Q 1
- S LEXI="",LEXD=1
- F S LEXI=$O(LEXORD(LEXI)) Q:LEXI="" D Q:'LEXD
- . ;I '$D(LEXORG(LEXI)) Q
- . I LEXORD(LEXI)>($G(LEXORG(LEXI))+1) S LEXD=0
- I LEXD=0 K LEXORD Q 1
- K LEXORD Q 0
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLEXAS3 1822 printed Jan 18, 2025@03:08:05 Page 2
- LEXAS3 ;ISL/KER - Look-up Check Input (SHIFT) ;04/21/2014
- +1 ;;2.0;LEXICON UTILITY;**80**;Sep 23, 1996;Build 1
- +2 ;
- SHIFT(LEXX) ; Letters are shifted out of position
- +1 ;
- +2 ; LEXORG( Array of characters in the ORiGinal string
- +3 ; LEXORD( Array of characters in the $O variable
- +4 ; LEXE $E string
- +5 ; LEXL Length
- +6 ; LEXD Flag - Difference of strings
- +7 ; LEXOK Flag - Shifted string is ok to use
- +8 ; LEXO $O variable
- +9 ; LEXI Incremental counter
- +10 ; LEXX Returned value
- +11 ;
- +12 ;
- +13 if $LENGTH(LEXX)<5
- QUIT LEXX
- +14 NEW LEXT,LEXE,LEXL,LEXO,LEXOK,LEXORG,LEXORD
- +15 SET LEXT=LEXX
- SET LEXOK=0
- +16 FOR LEXL=1:1:3
- DO SHF
- if LEXOK
- QUIT
- SET LEXT=$EXTRACT(LEXT,1,($LENGTH(LEXT)-1))
- +17 KILL LEXORG,LEXORD
- +18 SET LEXX=LEXT
- +19 QUIT LEXX
- +20 ;
- SHF ; Shift letters in arrays
- +1 KILL LEXORG
- DO ORG(LEXT)
- +2 SET LEXE=$EXTRACT(LEXT,1,2)
- SET LEXO=$$SCH^LEXAS6(LEXE)
- +3 FOR
- SET LEXO=$ORDER(^LEX(757.01,"AWRD",LEXO))
- if LEXO=""!(LEXO'[LEXE)!(LEXOK)
- QUIT
- Begin DoDot:1
- +4 if $LENGTH(LEXO)<$LENGTH(LEXT)!($LENGTH(LEXO)>($LENGTH(LEXT)+1))
- QUIT
- +5 NEW LEXD
- DO ORD(LEXO)
- SET LEXD=$$COMP
- +6 IF LEXD
- SET LEXOK=0
- QUIT
- +7 IF 'LEXD
- SET LEXT=LEXO
- SET LEXOK=1
- QUIT
- End DoDot:1
- if LEXOK
- QUIT
- +8 QUIT
- +9 ;
- ORG(LEXX) ; Original tolken
- +1 KILL LEXORG
- NEW LEXI
- +2 FOR LEXI=1:1:$LENGTH(LEXX)
- Begin DoDot:1
- +3 IF $DATA(LEXORG($EXTRACT(LEXX,LEXI)))
- Begin DoDot:2
- +4 SET LEXORG($EXTRACT(LEXX,LEXI))=LEXORG($EXTRACT(LEXX,LEXI))+1
- End DoDot:2
- QUIT
- +5 SET LEXORG($EXTRACT(LEXX,LEXI))=1
- End DoDot:1
- +6 QUIT
- ORD(LEXO) ; Ordered tolken
- +1 KILL LEXORD
- NEW LEXI
- +2 FOR LEXI=1:1:$LENGTH(LEXO)
- Begin DoDot:1
- +3 IF $DATA(LEXORD($EXTRACT(LEXO,LEXI)))
- Begin DoDot:2
- +4 SET LEXORD($EXTRACT(LEXO,LEXI))=LEXORD($EXTRACT(LEXO,LEXI))+1
- End DoDot:2
- QUIT
- +5 SET LEXORD($EXTRACT(LEXO,LEXI))=1
- End DoDot:1
- +6 QUIT
- COMP(LEXX) ; Compare Original to Ordered
- +1 NEW LEXI,LEXD
- SET LEXI=""
- SET LEXD=1
- +2 FOR
- SET LEXI=$ORDER(LEXORG(LEXI))
- if LEXI=""
- QUIT
- Begin DoDot:1
- +3 IF '$DATA(LEXORD(LEXI))
- SET LEXD=0
- QUIT
- +4 IF LEXORG(LEXI)>LEXORD(LEXI)
- SET LEXD=0
- End DoDot:1
- if 'LEXD
- QUIT
- +5 IF LEXD=0
- KILL LEXORD
- QUIT 1
- +6 SET LEXI=""
- SET LEXD=1
- +7 FOR
- SET LEXI=$ORDER(LEXORD(LEXI))
- if LEXI=""
- QUIT
- Begin DoDot:1
- +8 ;I '$D(LEXORG(LEXI)) Q
- +9 IF LEXORD(LEXI)>($GET(LEXORG(LEXI))+1)
- SET LEXD=0
- End DoDot:1
- if 'LEXD
- QUIT
- +10 IF LEXD=0
- KILL LEXORD
- QUIT 1
- +11 KILL LEXORD
- QUIT 0