LEXAS2 ;ISL/KER - Look-up Check Input (ONE) ;04/21/2014
;;2.0;LEXICON UTILITY;**80**;Sep 23, 1996;Build 10
;
; Global Variables
; None
;
; External References
; $$UP^XLFSTR ICR 10103
;
ONE(LEXX) ; One letter missing/incorrect
;
; LEXRIM Trimmed string
; LEXI Character position
; LEXF First portion
; LEXT Trailing portion
; LEXTL Trailing letter
; LEXNF Strings found
; LEXO $O variable
; LEXNT Temporary string
; LEXX String returned
;
N LEXI,LEXF,LEXT,LEXTL,LEXNF,LEXO,LEXNT,LEXRIM
S LEXTL=$E(LEXX,$L(LEXX)),LEXRIM=$$TRIM^LEXAS6(LEXX)
S LEXF=$E(LEXRIM,1,($L(LEXRIM)-1)),LEXNF="",LEXKEY=$G(LEXKEY)
F LEXI=1:1:$L(LEXX) D
. S LEXF=$E(LEXX,1,LEXI)
. S LEXT=$E(LEXX,(LEXI+1),$L(LEXX))
. S LEXO=$$SCH^LEXAS6(LEXF)
. F S LEXO=$O(^LEX(757.01,"AWRD",LEXO)) Q:LEXO'[LEXF D
. . S LEXO=$E(LEXO,1,($L(LEXF)+1))
. . Q:$L(LEXO)<($L(LEXF)+1)
. . S LEXNT=LEXO_LEXT
. . I $D(^LEX(757.01,"ASL",LEXNT)) D
. . . S LEXNF=LEXNF_"/"_LEXNT
. . S LEXNT=LEXO_$E(LEXT,2,$L(LEXT))
. . I $D(^LEX(757.01,"ASL",LEXNT)) D
. . . S LEXNF=LEXNF_"/"_LEXNT
. . S LEXO=LEXO_"~"
S:$E(LEXNF,1)="/" LEXNF=$E(LEXNF,2,$L(LEXNF))
I LEXNF'="",LEXNF["/" D PICK
I LEXNF'=""&(LEXNF'["/") S LEXRIM=LEXNF Q LEXRIM
S LEXRIM=$$TRIM^LEXAS6(LEXRIM) Q LEXRIM
Q LEXRIM
;
PICK ; Pick one string
;
; LEXNF Strings found
; LEXAN Array of strings by frequency
; LEXI Position/Piece in string
; LEXIN Position/Piece in altered string
; LEXEXP Expression
; LEXES Expresseion segment/string
; LEXKEY Key for selecting string
; LEXKEYO $Orderable KEY
; LEXOK Flag - Selection is OK
; LEXC Control string
; LEXP Character position in segment
; LEXR Record number for expression
; LEXN Altered string
; LEXM Maximum string length
; LEXS Shortest string length
;
N LEXOK,LEXI,LEXC,LEXN,LEXS,LEXM S LEXI=0,LEXC=""
S LEXS=$P(LEXNF,"/",1)
F LEXI=1:1:$L(LEXNF,"/") D
. S LEXN=$P(LEXNF,"/",LEXI) I LEXC="" S LEXC=LEXN Q
. S LEXM=$S($L(LEXC)>$L(LEXN):$L(LEXC),1:$L(LEXN))
. N LEXP F LEXP=LEXM:-1:1 Q:$E(LEXC,1,LEXP)=$E(LEXN,1,LEXP)
. S:LEXP<$L(LEXS) LEXS=$E(LEXS,1,LEXP)
S LEXC=$E(LEXX,($L(LEXS)+2),$L(LEXX)),LEXN=""
; Key supplied
I $L($G(LEXKEY)) S LEXOK=0 D Q:LEXOK
. ; order through pieces
. N LEXAN,LEXI
. F LEXI=1:1:$L(LEXNF,"/") D Q:LEXOK
. . S LEXN=$P(LEXNF,"/",LEXI)
. . ; order through expressions
. . N LEXR,LEXKEYO S LEXR=0,LEXKEYO=$$SCH^LEXAS6(LEXKEY)
. . F S LEXKEYO=$O(^LEX(757.01,"AWRD",LEXKEYO)) Q:LEXKEYO=""!(LEXKEYO'[LEXKEY)!(LEXOK) D
. . . F S LEXR=$O(^LEX(757.01,"AWRD",LEXKEYO,LEXR)) Q:+LEXR=0!(LEXOK) D
. . . . N LEXEXP S LEXEXP=$$UP^XLFSTR(^LEX(757.01,LEXR,0))
. . . . N LEXIN,LEXES F LEXIN=1:1:$L(LEXEXP," ") D Q:LEXOK
. . . . . S LEXES=$P(LEXEXP," ",LEXIN)
. . . . . Q:$E(LEXES,1)'=$E(LEXN,1)
. . . . . Q:$E(LEXN,$L(LEXN))'=$E(LEXES,$L(LEXN))
. . . . . N LEXP,LEXC S LEXC=0 F LEXP=1:1:$L(LEXN) D Q:LEXOK
. . . . . . I $E(LEXES,1,$L(LEXN))[$E(LEXN,LEXP) S LEXC=LEXC+1
. . . . . S:LEXC>0 LEXAN(-(LEXC))=LEXN
. S LEXN="" S:$O(LEXAN(-999999))<0 LEXN=$O(LEXAN(-999999)),LEXN=LEXAN(LEXN)
. I LEXN'="" S LEXNF=LEXN,LEXOK=1
; No key supplied
F LEXI=1:1:$L(LEXNF,"/") D Q:LEXN[LEXC
. S LEXN=$P(LEXNF,"/",LEXI)
. I LEXN[LEXC,$E(LEXN,$L(LEXN))=LEXTL S LEXNF=LEXN
Q
LEXAS2 ;ISL/KER - Look-up Check Input (ONE) ;04/21/2014
+1 ;;2.0;LEXICON UTILITY;**80**;Sep 23, 1996;Build 10
+2 ;
+3 ; Global Variables
+4 ; None
+5 ;
+6 ; External References
+7 ; $$UP^XLFSTR ICR 10103
+8 ;
ONE(LEXX) ; One letter missing/incorrect
+1 ;
+2 ; LEXRIM Trimmed string
+3 ; LEXI Character position
+4 ; LEXF First portion
+5 ; LEXT Trailing portion
+6 ; LEXTL Trailing letter
+7 ; LEXNF Strings found
+8 ; LEXO $O variable
+9 ; LEXNT Temporary string
+10 ; LEXX String returned
+11 ;
+12 NEW LEXI,LEXF,LEXT,LEXTL,LEXNF,LEXO,LEXNT,LEXRIM
+13 SET LEXTL=$EXTRACT(LEXX,$LENGTH(LEXX))
SET LEXRIM=$$TRIM^LEXAS6(LEXX)
+14 SET LEXF=$EXTRACT(LEXRIM,1,($LENGTH(LEXRIM)-1))
SET LEXNF=""
SET LEXKEY=$GET(LEXKEY)
+15 FOR LEXI=1:1:$LENGTH(LEXX)
Begin DoDot:1
+16 SET LEXF=$EXTRACT(LEXX,1,LEXI)
+17 SET LEXT=$EXTRACT(LEXX,(LEXI+1),$LENGTH(LEXX))
+18 SET LEXO=$$SCH^LEXAS6(LEXF)
+19 FOR
SET LEXO=$ORDER(^LEX(757.01,"AWRD",LEXO))
IF LEXO'[LEXF
QUIT
Begin DoDot:2
+20 SET LEXO=$EXTRACT(LEXO,1,($LENGTH(LEXF)+1))
+21 IF $LENGTH(LEXO)<($LENGTH(LEXF)+1)
QUIT
+22 SET LEXNT=LEXO_LEXT
+23 IF $DATA(^LEX(757.01,"ASL",LEXNT))
Begin DoDot:3
+24 SET LEXNF=LEXNF_"/"_LEXNT
End DoDot:3
+25 SET LEXNT=LEXO_$EXTRACT(LEXT,2,$LENGTH(LEXT))
+26 IF $DATA(^LEX(757.01,"ASL",LEXNT))
Begin DoDot:3
+27 SET LEXNF=LEXNF_"/"_LEXNT
End DoDot:3
+28 SET LEXO=LEXO_"~"
End DoDot:2
End DoDot:1
+29 IF $EXTRACT(LEXNF,1)="/"
SET LEXNF=$EXTRACT(LEXNF,2,$LENGTH(LEXNF))
+30 IF LEXNF'=""
IF LEXNF["/"
DO PICK
+31 IF LEXNF'=""&(LEXNF'["/")
SET LEXRIM=LEXNF
QUIT LEXRIM
+32 SET LEXRIM=$$TRIM^LEXAS6(LEXRIM)
QUIT LEXRIM
+33 QUIT LEXRIM
+34 ;
PICK ; Pick one string
+1 ;
+2 ; LEXNF Strings found
+3 ; LEXAN Array of strings by frequency
+4 ; LEXI Position/Piece in string
+5 ; LEXIN Position/Piece in altered string
+6 ; LEXEXP Expression
+7 ; LEXES Expresseion segment/string
+8 ; LEXKEY Key for selecting string
+9 ; LEXKEYO $Orderable KEY
+10 ; LEXOK Flag - Selection is OK
+11 ; LEXC Control string
+12 ; LEXP Character position in segment
+13 ; LEXR Record number for expression
+14 ; LEXN Altered string
+15 ; LEXM Maximum string length
+16 ; LEXS Shortest string length
+17 ;
+18 NEW LEXOK,LEXI,LEXC,LEXN,LEXS,LEXM
SET LEXI=0
SET LEXC=""
+19 SET LEXS=$PIECE(LEXNF,"/",1)
+20 FOR LEXI=1:1:$LENGTH(LEXNF,"/")
Begin DoDot:1
+21 SET LEXN=$PIECE(LEXNF,"/",LEXI)
IF LEXC=""
SET LEXC=LEXN
QUIT
+22 SET LEXM=$SELECT($LENGTH(LEXC)>$LENGTH(LEXN):$LENGTH(LEXC),1:$LENGTH(LEXN))
+23 NEW LEXP
FOR LEXP=LEXM:-1:1
IF $EXTRACT(LEXC,1,LEXP)=$EXTRACT(LEXN,1,LEXP)
QUIT
+24 IF LEXP<$LENGTH(LEXS)
SET LEXS=$EXTRACT(LEXS,1,LEXP)
End DoDot:1
+25 SET LEXC=$EXTRACT(LEXX,($LENGTH(LEXS)+2),$LENGTH(LEXX))
SET LEXN=""
+26 ; Key supplied
+27 IF $LENGTH($GET(LEXKEY))
SET LEXOK=0
Begin DoDot:1
+28 ; order through pieces
+29 NEW LEXAN,LEXI
+30 FOR LEXI=1:1:$LENGTH(LEXNF,"/")
Begin DoDot:2
+31 SET LEXN=$PIECE(LEXNF,"/",LEXI)
+32 ; order through expressions
+33 NEW LEXR,LEXKEYO
SET LEXR=0
SET LEXKEYO=$$SCH^LEXAS6(LEXKEY)
+34 FOR
SET LEXKEYO=$ORDER(^LEX(757.01,"AWRD",LEXKEYO))
IF LEXKEYO=""!(LEXKEYO'[LEXKEY)!(LEXOK)
QUIT
Begin DoDot:3
+35 FOR
SET LEXR=$ORDER(^LEX(757.01,"AWRD",LEXKEYO,LEXR))
IF +LEXR=0!(LEXOK)
QUIT
Begin DoDot:4
+36 NEW LEXEXP
SET LEXEXP=$$UP^XLFSTR(^LEX(757.01,LEXR,0))
+37 NEW LEXIN,LEXES
FOR LEXIN=1:1:$LENGTH(LEXEXP," ")
Begin DoDot:5
+38 SET LEXES=$PIECE(LEXEXP," ",LEXIN)
+39 IF $EXTRACT(LEXES,1)'=$EXTRACT(LEXN,1)
QUIT
+40 IF $EXTRACT(LEXN,$LENGTH(LEXN))'=$EXTRACT(LEXES,$LENGTH(LEXN))
QUIT
+41 NEW LEXP,LEXC
SET LEXC=0
FOR LEXP=1:1:$LENGTH(LEXN)
Begin DoDot:6
+42 IF $EXTRACT(LEXES,1,$LENGTH(LEXN))[$EXTRACT(LEXN,LEXP)
SET LEXC=LEXC+1
End DoDot:6
IF LEXOK
QUIT
+43 IF LEXC>0
SET LEXAN(-(LEXC))=LEXN
End DoDot:5
IF LEXOK
QUIT
End DoDot:4
End DoDot:3
End DoDot:2
IF LEXOK
QUIT
+44 SET LEXN=""
IF $ORDER(LEXAN(-999999))<0
SET LEXN=$ORDER(LEXAN(-999999))
SET LEXN=LEXAN(LEXN)
+45 IF LEXN'=""
SET LEXNF=LEXN
SET LEXOK=1
End DoDot:1
IF LEXOK
QUIT
+46 ; No key supplied
+47 FOR LEXI=1:1:$LENGTH(LEXNF,"/")
Begin DoDot:1
+48 SET LEXN=$PIECE(LEXNF,"/",LEXI)
+49 IF LEXN[LEXC
IF $EXTRACT(LEXN,$LENGTH(LEXN))=LEXTL
SET LEXNF=LEXN
End DoDot:1
IF LEXN[LEXC
QUIT
+50 QUIT
