LEXALK ;ISL/KER - Look-up by Words ;04/21/2014
;;2.0;LEXICON UTILITY;**2,3,6,25,51,80**;Sep 23, 1996;Build 10
;
; Global Variables
; ^LEX( N/A
; ^TMP("LEXFND") SACC 2.3.2.5.1
; ^TMP("LEXHIT") SACC 2.3.2.5.1
; ^TMP("LEXSCH") SACC 2.3.2.5.1
;
; External References
; $$DT^XLFDT ICR 10103
; ^LEX( ICR 1571
;
; Local Variables NEWed or KILLed Elsewhere
; LEXFIL NEWed in LEXA
; LEXFILR NEWed in LEXA
; LEXTKN KILLed in LEXA
; LEXTKNS KILLed in LEXA
; LEXVDT NEWed in LEXA
;
; Special Lookup variables
;
; LEXSUB Vocabulary
; LEXSHCT Shortcuts
; LEXDICS Screen - DIC("S") Format
; LEXSHOW Displayable codes
; LEXLKFL File Number
; LEXLKGL Global Root
; LEXLKMD Use Modifiers
; LEXLKIX Index to use during lookup
; LEXLKSH User Input (Search String)
; LEXTKN( Tokens in order of frequency of use
; LEXTKNS( Tokens in order of entry
;
EN ; Look-up user input
N LEXSUB,LEXSHCT,LEXDICS,LEXSHOW,LEXLKFL,LEXLKGL,LEXLKMD,LEXLKIX,LEXLKSH
D VDT^LEXU S LEXLKSH=$G(^TMP("LEXSCH",$J,"SCH",0)) I $L(LEXLKSH)<2 D Q
. S LEX("ERR",0)=+($G(LEX("ERR",0)))+1,LEX("ERR",LEX("ERR",0))="User input missing or invalid"
S LEXSUB=$G(^TMP("LEXSCH",$J,"VOC",0)) S:LEXSUB="" LEXSUB="WRD"
S LEXLKMD=+($G(^TMP("LEXSCH",$J,"MOD",0)))
S LEXLKIX=$G(^TMP("LEXSCH",$J,"IDX",0)) S:LEXLKIX="" LEXLKIX="AWRD"
S LEXLKFL=$G(^TMP("LEXSCH",$J,"FLN",0)) I LEXLKFL'["757." D Q
. S LEX("ERR",0)=+($G(LEX("ERR",0)))+1,LEX("ERR",LEX("ERR",0))="File number missing or invalid"
S LEXLKGL=$G(^TMP("LEXSCH",$J,"GBL",0)) I LEXLKGL'["LEX(757." D Q
. S LEX("ERR",0)=+($G(LEX("ERR",0)))+1,LEX("ERR",LEX("ERR",0))="Global location missing or invalid"
S LEXSHOW=$G(^TMP("LEXSCH",$J,"DIS",0))
D TOKEN^LEXAM(LEXLKSH)
N LEXOK,LEXDES,LEXDSP,LEXT,LEXO,LEXI,LEXE,LEXM,LEXME
N LEXSS Q:$G(LEXLKFL)'["757."
S LEXSS="" I $D(LEXTKNS(0)) D
. N LEXI F LEXI=1:1:LEXTKNS(0) S LEXSS=LEXSS_" "_LEXTKNS(LEXI)
. S LEXSS=$E(LEXSS,2,$L(LEXSS))
S ^TMP("LEXSCH",$J,"SCH",0)=$G(LEXSS)
S LEXT=$G(LEXTKN(1)),LEXO=$$SCH(LEXT)
I $G(LEXSHCT)="",$G(LEXTKN(0))=1,$D(^LEX(LEXLKFL,LEXLKIX,LEXT)) D EXACT
I $G(LEXSHCT)="",$G(LEXTKN(0))=1,$D(^LEX(LEXLKFL,LEXLKIX,LEXT)) D G END
. D EXACT
. I +($O(^LEX(757.01,"ASL",LEXT,0)))>6000 Q
. D TOKEN
D TOKEN
END ; End look-up by word
I $D(^TMP("LEXFND",$J)) D BEG^LEXAL
I '$D(^TMP("LEXFND",$J)) D
. K LEX,^TMP("LEXFND",$J),^TMP("LEXHIT",$J) S LEX=0
S:+($G(^TMP("LEXSCH",$J,"UNR",0)))>0&($L($G(^TMP("LEXSCH",$J,"NAR",0)))) LEX("NAR")=$G(^TMP("LEXSCH",$J,"NAR",0))
Q
EXACT ; Main loop throuth TOKENS that equal LEXT
S LEXO=$$SCH(LEXT) F S LEXO=$O(^LEX(LEXLKFL,LEXLKIX,LEXO)) Q:LEXO'=LEXT D IEN
Q
TOKEN ; Main loop though TOKENS containing LEXT
S LEXO=$$SCH(LEXT) F S LEXO=$O(^LEX(LEXLKFL,LEXLKIX,LEXO)) Q:LEXO'[LEXT!(LEXO="") D IEN
Q
IEN ; Loop throuth Internal Entry Numbers
S LEXI=0 F S LEXI=$O(^LEX(LEXLKFL,LEXLKIX,LEXO,LEXI)) Q:+LEXI=0 D
. I +($G(LEXNOKEY))>0 N LEXK S LEXK=$$KWO($G(LEXO),$G(LEXI)) Q:LEXK>0
. D CHK
Q
CHK ; Check each token
N LEXOK,LEXO,LEXLKT S LEXLKT="ALK",LEXE=LEXI,LEXOK=1
S:LEXLKGL'["757.01" LEXE=+$G(^LEX(LEXLKFL,LEXI,0)) Q:LEXE=0
; Filter
S LEXFILR=$$EN^LEXAFIL($G(LEXFIL),LEXE) Q:LEXFILR=0
; Deactivated
Q:'$D(LEXIGN)&(+($P($G(^LEX(757.01,LEXE,1)),"^",5))=1)
; Expression has Modifiers
N LEXEMOD S LEXEMOD=+($P($G(^LEX(757.01,LEXE,1)),"^",6))
S LEXM=+($G(^LEX(757.01,LEXE,1)))
S LEXME=+($G(^LEX(757,LEXM,0)))
; Check not exact match
I $L($G(^TMP("LEXSCH",$J,"EXM",0))),+(^TMP("LEXSCH",$J,"EXM",0))=LEXE Q
I $L($G(^TMP("LEXSCH",$J,"EXC",0))),+(^TMP("LEXSCH",$J,"EXC",0))=LEXE Q
; Check tokens
S LEXOK=1 D CHKTKNS(LEXE)
; If the expression failed the search, and the expression has
; modifiers then check the modifiers
D:+LEXOK=0&(+($G(LEXEMOD))>0)&(+($G(LEXTKN(0)))>1) CHKMOD^LEXAMD2
Q:'LEXOK
; Description (*)
S LEXDES=$$DES^LEXASC(LEXE)
; Display of codes
S LEXDSP=$$SO^LEXASO(LEXE,$G(LEXSHOW),1,$G(LEXVDT))
D ADDL^LEXAL(LEXE,LEXDES,LEXDSP)
Q
CHKTKNS(LEXE) ; Check tokens
N LEXM,LEXNOKEY S LEXM=+($G(^LEX(757.01,LEXE,1))) Q:LEXM=0
N LEXI,LEXOE,LEXC S LEXOE=LEXE,LEXI=1
F S LEXI=$O(LEXTKN(LEXI)) Q:+LEXI=0!('LEXOK) D Q:'LEXOK
. N LEXT,LEXE,LEXORD S LEXT=LEXTKN(LEXI),LEXE=0,LEXOK=0
. S LEXC=$$UP(^LEX(757.01,LEXOE,0))
. I LEXC[(" "_LEXT) S LEXOK=1 Q
. I LEXC[("-"_LEXT) S LEXOK=1 Q
. I LEXC[("("_LEXT) S LEXOK=1 Q
. I LEXC[("/"_LEXT) S LEXOK=1 Q
. I $E(LEXC,1,$L(LEXT))=LEXT S LEXOK=1 Q
. S LEXORD=$$SCH(LEXT)
. I $L(LEXT),$D(^LEX(757.01,LEXOE,5,"B",LEXT)) S LEXOK=1 Q
. I $L(LEXT),$E($O(^LEX(757.01,LEXOE,5,"B",($E(LEXT,1,($L(LEXT)-1))_$C($A($E(LEXT,$L(LEXT)))-1)_"~"))),1,$L(LEXT))=LEXT S LEXOK=1 Q
. I $L(LEXT),$L(LEXORD) D I $E(LEXORD,1,$L(LEXT))=LEXT S LEXOK=1 Q
. . S LEXORD=$O(^LEX(757.01,LEXOE,5,"B",LEXORD))
. F S LEXE=$O(^LEX(757.01,"AMC",LEXM,LEXE)) Q:+LEXE=0!(LEXOK) D Q:LEXOK
. . Q:+($P($G(^LEX(757.01,LEXE,1)),"^",2))>3
. . S LEXC=$$UP(^LEX(757.01,LEXE,0))
. . I LEXC[(" "_LEXT) S LEXOK=1 Q
. . I LEXC[("-"_LEXT) S LEXOK=1 Q
. . I LEXC[("("_LEXT) S LEXOK=1 Q
. . I LEXC[("/"_LEXT) S LEXOK=1 Q
. . I $E(LEXC,1,$L(LEXT))=LEXT S LEXOK=1 Q
Q
DES(LEXX) ; Get description flag
N LEXDES,LEXE,LEXM S LEXDES="",LEXE=+LEXX
S LEXM=$P($G(^LEX(757.01,+($G(LEXX)),1)),"^",1)
S LEXM=+($G(^LEX(757,+($G(LEXM)),0)))
S:$D(^LEX(757.01,LEXM,3)) LEXDES="*"
S LEXX=$G(LEXDES) Q LEXX
SCH(LEXX) ; Search for LEXX a $Orderable variable
S:$G(LEXX)'?1N.N LEXX=$E(LEXX,1,($L(LEXX)-1))_$C($A($E(LEXX,$L(LEXX)))-1)_"~"
S:$G(LEXX)?1N.N LEXX=LEXX-.0000000000000009 N LEXIGN
Q LEXX
Q
KWO(X,Y) ; Keyword only (SW)
N LEXS,LEXI,LEXE,LEXK,LEXEC,LEXKC S LEXS=$G(X) Q:$L(LEXS)<6 -1
Q:'$D(^LEX(757.01,"AWRD",LEXS)) -2
S LEXI=+($G(Y)) Q:+LEXI'>0 -3
Q:'$D(^LEX(757.01,"AWRD",LEXS,LEXI)) -4
Q:"^757.01^"'[("^"_$G(LEXLKFL)_"^") -5
S (LEXEC,LEXKC,LEXE)=0 F S LEXE=$O(^LEX(757.01,"AWRD",LEXS,LEXI,LEXE)) Q:+LEXE=0 D
. N LEXD S LEXD=$D(^LEX(757.01,"AWRD",LEXS,LEXI,LEXE))
. S:LEXD#10>0 LEXEC=+($G(LEXEC))+1 Q:LEXD=1
. S LEXK="" F S LEXK=$O(^LEX(757.01,"AWRD",LEXS,LEXI,LEXE,LEXK)) Q:'$L(LEXK) D
. . S LEXEC=+($G(LEXEC))+1 S:LEXK?1N.N LEXKC=+($G(LEXKC))+1
Q:+($G(LEXKC))>0&($G(LEXKC)=$G(LEXEC)) 1
Q 0
UP(X) ; Uppercase
Q $TR(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
LEXALK ;ISL/KER - Look-up by Words ;04/21/2014
+1 ;;2.0;LEXICON UTILITY;**2,3,6,25,51,80**;Sep 23, 1996;Build 10
+2 ;
+3 ; Global Variables
+4 ; ^LEX( N/A
+5 ; ^TMP("LEXFND") SACC 2.3.2.5.1
+6 ; ^TMP("LEXHIT") SACC 2.3.2.5.1
+7 ; ^TMP("LEXSCH") SACC 2.3.2.5.1
+8 ;
+9 ; External References
+10 ; $$DT^XLFDT ICR 10103
+11 ; ^LEX( ICR 1571
+12 ;
+13 ; Local Variables NEWed or KILLed Elsewhere
+14 ; LEXFIL NEWed in LEXA
+15 ; LEXFILR NEWed in LEXA
+16 ; LEXTKN KILLed in LEXA
+17 ; LEXTKNS KILLed in LEXA
+18 ; LEXVDT NEWed in LEXA
+19 ;
+20 ; Special Lookup variables
+21 ;
+22 ; LEXSUB Vocabulary
+23 ; LEXSHCT Shortcuts
+24 ; LEXDICS Screen - DIC("S") Format
+25 ; LEXSHOW Displayable codes
+26 ; LEXLKFL File Number
+27 ; LEXLKGL Global Root
+28 ; LEXLKMD Use Modifiers
+29 ; LEXLKIX Index to use during lookup
+30 ; LEXLKSH User Input (Search String)
+31 ; LEXTKN( Tokens in order of frequency of use
+32 ; LEXTKNS( Tokens in order of entry
+33 ;
EN ; Look-up user input
+1 NEW LEXSUB,LEXSHCT,LEXDICS,LEXSHOW,LEXLKFL,LEXLKGL,LEXLKMD,LEXLKIX,LEXLKSH
+2 DO VDT^LEXU
SET LEXLKSH=$GET(^TMP("LEXSCH",$JOB,"SCH",0))
IF $LENGTH(LEXLKSH)<2
Begin DoDot:1
+3 SET LEX("ERR",0)=+($GET(LEX("ERR",0)))+1
SET LEX("ERR",LEX("ERR",0))="User input missing or invalid"
End DoDot:1
QUIT
+4 SET LEXSUB=$GET(^TMP("LEXSCH",$JOB,"VOC",0))
IF LEXSUB=""
SET LEXSUB="WRD"
+5 SET LEXLKMD=+($GET(^TMP("LEXSCH",$JOB,"MOD",0)))
+6 SET LEXLKIX=$GET(^TMP("LEXSCH",$JOB,"IDX",0))
IF LEXLKIX=""
SET LEXLKIX="AWRD"
+7 SET LEXLKFL=$GET(^TMP("LEXSCH",$JOB,"FLN",0))
IF LEXLKFL'["757."
Begin DoDot:1
+8 SET LEX("ERR",0)=+($GET(LEX("ERR",0)))+1
SET LEX("ERR",LEX("ERR",0))="File number missing or invalid"
End DoDot:1
QUIT
+9 SET LEXLKGL=$GET(^TMP("LEXSCH",$JOB,"GBL",0))
IF LEXLKGL'["LEX(757."
Begin DoDot:1
+10 SET LEX("ERR",0)=+($GET(LEX("ERR",0)))+1
SET LEX("ERR",LEX("ERR",0))="Global location missing or invalid"
End DoDot:1
QUIT
+11 SET LEXSHOW=$GET(^TMP("LEXSCH",$JOB,"DIS",0))
+12 DO TOKEN^LEXAM(LEXLKSH)
+13 NEW LEXOK,LEXDES,LEXDSP,LEXT,LEXO,LEXI,LEXE,LEXM,LEXME
+14 NEW LEXSS
IF $GET(LEXLKFL)'["757."
QUIT
+15 SET LEXSS=""
IF $DATA(LEXTKNS(0))
Begin DoDot:1
+16 NEW LEXI
FOR LEXI=1:1:LEXTKNS(0)
SET LEXSS=LEXSS_" "_LEXTKNS(LEXI)
+17 SET LEXSS=$EXTRACT(LEXSS,2,$LENGTH(LEXSS))
End DoDot:1
+18 SET ^TMP("LEXSCH",$JOB,"SCH",0)=$GET(LEXSS)
+19 SET LEXT=$GET(LEXTKN(1))
SET LEXO=$$SCH(LEXT)
+20 IF $GET(LEXSHCT)=""
IF $GET(LEXTKN(0))=1
IF $DATA(^LEX(LEXLKFL,LEXLKIX,LEXT))
DO EXACT
+21 IF $GET(LEXSHCT)=""
IF $GET(LEXTKN(0))=1
IF $DATA(^LEX(LEXLKFL,LEXLKIX,LEXT))
Begin DoDot:1
+22 DO EXACT
+23 IF +($ORDER(^LEX(757.01,"ASL",LEXT,0)))>6000
QUIT
+24 DO TOKEN
End DoDot:1
GOTO END
+25 DO TOKEN
END ; End look-up by word
+1 IF $DATA(^TMP("LEXFND",$JOB))
DO BEG^LEXAL
+2 IF '$DATA(^TMP("LEXFND",$JOB))
Begin DoDot:1
+3 KILL LEX,^TMP("LEXFND",$JOB),^TMP("LEXHIT",$JOB)
SET LEX=0
End DoDot:1
+4 IF +($GET(^TMP("LEXSCH",$JOB,"UNR",0)))>0&($LENGTH($GET(^TMP("LEXSCH",$JOB,"NAR",0))))
SET LEX("NAR")=$GET(^TMP("LEXSCH",$JOB,"NAR",0))
+5 QUIT
EXACT ; Main loop throuth TOKENS that equal LEXT
+1 SET LEXO=$$SCH(LEXT)
FOR
SET LEXO=$ORDER(^LEX(LEXLKFL,LEXLKIX,LEXO))
IF LEXO'=LEXT
QUIT
DO IEN
+2 QUIT
TOKEN ; Main loop though TOKENS containing LEXT
+1 SET LEXO=$$SCH(LEXT)
FOR
SET LEXO=$ORDER(^LEX(LEXLKFL,LEXLKIX,LEXO))
IF LEXO'[LEXT!(LEXO="")
QUIT
DO IEN
+2 QUIT
IEN ; Loop throuth Internal Entry Numbers
+1 SET LEXI=0
FOR
SET LEXI=$ORDER(^LEX(LEXLKFL,LEXLKIX,LEXO,LEXI))
IF +LEXI=0
QUIT
Begin DoDot:1
+2 IF +($GET(LEXNOKEY))>0
NEW LEXK
SET LEXK=$$KWO($GET(LEXO),$GET(LEXI))
IF LEXK>0
QUIT
+3 DO CHK
End DoDot:1
+4 QUIT
CHK ; Check each token
+1 NEW LEXOK,LEXO,LEXLKT
SET LEXLKT="ALK"
SET LEXE=LEXI
SET LEXOK=1
+2 IF LEXLKGL'["757.01"
SET LEXE=+$GET(^LEX(LEXLKFL,LEXI,0))
IF LEXE=0
QUIT
+3 ; Filter
+4 SET LEXFILR=$$EN^LEXAFIL($GET(LEXFIL),LEXE)
IF LEXFILR=0
QUIT
+5 ; Deactivated
+6 IF '$DATA(LEXIGN)&(+($PIECE($GET(^LEX(757.01,LEXE,1)),"^",5))=1)
QUIT
+7 ; Expression has Modifiers
+8 NEW LEXEMOD
SET LEXEMOD=+($PIECE($GET(^LEX(757.01,LEXE,1)),"^",6))
+9 SET LEXM=+($GET(^LEX(757.01,LEXE,1)))
+10 SET LEXME=+($GET(^LEX(757,LEXM,0)))
+11 ; Check not exact match
+12 IF $LENGTH($GET(^TMP("LEXSCH",$JOB,"EXM",0)))
IF +(^TMP("LEXSCH",$JOB,"EXM",0))=LEXE
QUIT
+13 IF $LENGTH($GET(^TMP("LEXSCH",$JOB,"EXC",0)))
IF +(^TMP("LEXSCH",$JOB,"EXC",0))=LEXE
QUIT
+14 ; Check tokens
+15 SET LEXOK=1
DO CHKTKNS(LEXE)
+16 ; If the expression failed the search, and the expression has
+17 ; modifiers then check the modifiers
+18 IF +LEXOK=0&(+($GET(LEXEMOD))>0)&(+($GET(LEXTKN(0)))>1)
DO CHKMOD^LEXAMD2
+19 IF 'LEXOK
QUIT
+20 ; Description (*)
+21 SET LEXDES=$$DES^LEXASC(LEXE)
+22 ; Display of codes
+23 SET LEXDSP=$$SO^LEXASO(LEXE,$GET(LEXSHOW),1,$GET(LEXVDT))
+24 DO ADDL^LEXAL(LEXE,LEXDES,LEXDSP)
+25 QUIT
CHKTKNS(LEXE) ; Check tokens
+1 NEW LEXM,LEXNOKEY
SET LEXM=+($GET(^LEX(757.01,LEXE,1)))
IF LEXM=0
QUIT
+2 NEW LEXI,LEXOE,LEXC
SET LEXOE=LEXE
SET LEXI=1
+3 FOR
SET LEXI=$ORDER(LEXTKN(LEXI))
IF +LEXI=0!('LEXOK)
QUIT
Begin DoDot:1
+4 NEW LEXT,LEXE,LEXORD
SET LEXT=LEXTKN(LEXI)
SET LEXE=0
SET LEXOK=0
+5 SET LEXC=$$UP(^LEX(757.01,LEXOE,0))
+6 IF LEXC[(" "_LEXT)
SET LEXOK=1
QUIT
+7 IF LEXC[("-"_LEXT)
SET LEXOK=1
QUIT
+8 IF LEXC[("("_LEXT)
SET LEXOK=1
QUIT
+9 IF LEXC[("/"_LEXT)
SET LEXOK=1
QUIT
+10 IF $EXTRACT(LEXC,1,$LENGTH(LEXT))=LEXT
SET LEXOK=1
QUIT
+11 SET LEXORD=$$SCH(LEXT)
+12 IF $LENGTH(LEXT)
IF $DATA(^LEX(757.01,LEXOE,5,"B",LEXT))
SET LEXOK=1
QUIT
+13 IF $LENGTH(LEXT)
IF $EXTRACT($ORDER(^LEX(757.01,LEXOE,5,"B",($EXTRACT(LEXT,1,($LENGTH(LEXT)-1))_$CHAR($ASCII($EXTRACT(LEXT,$LENGTH(LEXT)))-1)_"~"))),1,$LENGTH(LEXT))=LEXT
SET LEXOK=1
QUIT
+14 IF $LENGTH(LEXT)
IF $LENGTH(LEXORD)
Begin DoDot:2
+15 SET LEXORD=$ORDER(^LEX(757.01,LEXOE,5,"B",LEXORD))
End DoDot:2
IF $EXTRACT(LEXORD,1,$LENGTH(LEXT))=LEXT
SET LEXOK=1
QUIT
+16 FOR
SET LEXE=$ORDER(^LEX(757.01,"AMC",LEXM,LEXE))
IF +LEXE=0!(LEXOK)
QUIT
Begin DoDot:2
+17 IF +($PIECE($GET(^LEX(757.01,LEXE,1)),"^",2))>3
QUIT
+18 SET LEXC=$$UP(^LEX(757.01,LEXE,0))
+19 IF LEXC[(" "_LEXT)
SET LEXOK=1
QUIT
+20 IF LEXC[("-"_LEXT)
SET LEXOK=1
QUIT
+21 IF LEXC[("("_LEXT)
SET LEXOK=1
QUIT
+22 IF LEXC[("/"_LEXT)
SET LEXOK=1
QUIT
+23 IF $EXTRACT(LEXC,1,$LENGTH(LEXT))=LEXT
SET LEXOK=1
QUIT
End DoDot:2
IF LEXOK
QUIT
End DoDot:1
IF 'LEXOK
QUIT
+24 QUIT
DES(LEXX) ; Get description flag
+1 NEW LEXDES,LEXE,LEXM
SET LEXDES=""
SET LEXE=+LEXX
+2 SET LEXM=$PIECE($GET(^LEX(757.01,+($GET(LEXX)),1)),"^",1)
+3 SET LEXM=+($GET(^LEX(757,+($GET(LEXM)),0)))
+4 IF $DATA(^LEX(757.01,LEXM,3))
SET LEXDES="*"
+5 SET LEXX=$GET(LEXDES)
QUIT LEXX
SCH(LEXX) ; Search for LEXX a $Orderable variable
+1 IF $GET(LEXX)'?1N.N
SET LEXX=$EXTRACT(LEXX,1,($LENGTH(LEXX)-1))_$CHAR($ASCII($EXTRACT(LEXX,$LENGTH(LEXX)))-1)_"~"
+2 IF $GET(LEXX)?1N.N
SET LEXX=LEXX-.0000000000000009
NEW LEXIGN
+3 QUIT LEXX
+4 QUIT
KWO(X,Y) ; Keyword only (SW)
+1 NEW LEXS,LEXI,LEXE,LEXK,LEXEC,LEXKC
SET LEXS=$GET(X)
IF $LENGTH(LEXS)<6
QUIT -1
+2 IF '$DATA(^LEX(757.01,"AWRD",LEXS))
QUIT -2
+3 SET LEXI=+($GET(Y))
IF +LEXI'>0
QUIT -3
+4 IF '$DATA(^LEX(757.01,"AWRD",LEXS,LEXI))
QUIT -4
+5 IF "^757.01^"'[("^"_$GET(LEXLKFL)_"^")
QUIT -5
+6 SET (LEXEC,LEXKC,LEXE)=0
FOR
SET LEXE=$ORDER(^LEX(757.01,"AWRD",LEXS,LEXI,LEXE))
IF +LEXE=0
QUIT
Begin DoDot:1
+7 NEW LEXD
SET LEXD=$DATA(^LEX(757.01,"AWRD",LEXS,LEXI,LEXE))
+8 IF LEXD#10>0
SET LEXEC=+($GET(LEXEC))+1
IF LEXD=1
QUIT
+9 SET LEXK=""
FOR
SET LEXK=$ORDER(^LEX(757.01,"AWRD",LEXS,LEXI,LEXE,LEXK))
IF '$LENGTH(LEXK)
QUIT
Begin DoDot:2
+10 SET LEXEC=+($GET(LEXEC))+1
IF LEXK?1N.N
SET LEXKC=+($GET(LEXKC))+1
End DoDot:2
End DoDot:1
+11 IF +($GET(LEXKC))>0&($GET(LEXKC)=$GET(LEXEC))
QUIT 1
+12 QUIT 0
UP(X) ; Uppercase
+1 QUIT $TRANSLATE(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
