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 Apr 09, 2024@21:11:33 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
