- 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
