Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: LEXALK

LEXALK.m

Go to the documentation of this file. 
  1. 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
  1.  ;               
  1.  ; Global Variables
  1.  ;    ^LEX(               N/A
  1.  ;    ^TMP("LEXFND")      SACC 2.3.2.5.1
  1.  ;    ^TMP("LEXHIT")      SACC 2.3.2.5.1
  1.  ;    ^TMP("LEXSCH")      SACC 2.3.2.5.1
  1.  ;               
  1.  ; External References
  1.  ;    $$DT^XLFDT          ICR  10103
  1.  ;    ^LEX(               ICR   1571
  1.  ;               
  1.  ; Local Variables NEWed or KILLed Elsewhere
  1.  ;    LEXFIL      NEWed in LEXA
  1.  ;    LEXFILR     NEWed in LEXA
  1.  ;    LEXTKN      KILLed in LEXA
  1.  ;    LEXTKNS     KILLed in LEXA
  1.  ;    LEXVDT      NEWed in LEXA
  1.  ;               
  1.  ; Special Lookup variables
  1.  ;                    
  1.  ;    LEXSUB      Vocabulary
  1.  ;    LEXSHCT     Shortcuts
  1.  ;    LEXDICS     Screen - DIC("S") Format
  1.  ;    LEXSHOW     Displayable codes
  1.  ;    LEXLKFL     File Number
  1.  ;    LEXLKGL     Global Root
  1.  ;    LEXLKMD     Use Modifiers
  1.  ;    LEXLKIX     Index to use during lookup
  1.  ;    LEXLKSH     User Input (Search String)
  1.  ;    LEXTKN(     Tokens in order of frequency of use
  1.  ;    LEXTKNS(    Tokens in order of entry
  1.  ;                    
  1. EN ; Look-up user input
  1.  N LEXSUB,LEXSHCT,LEXDICS,LEXSHOW,LEXLKFL,LEXLKGL,LEXLKMD,LEXLKIX,LEXLKSH
  1.  D VDT^LEXU S LEXLKSH=$G(^TMP("LEXSCH",$J,"SCH",0)) I $L(LEXLKSH)<2 D  Q
  1.  . S LEX("ERR",0)=+($G(LEX("ERR",0)))+1,LEX("ERR",LEX("ERR",0))="User input missing or invalid"
  1.  S LEXSUB=$G(^TMP("LEXSCH",$J,"VOC",0)) S:LEXSUB="" LEXSUB="WRD"
  1.  S LEXLKMD=+($G(^TMP("LEXSCH",$J,"MOD",0)))
  1.  S LEXLKIX=$G(^TMP("LEXSCH",$J,"IDX",0)) S:LEXLKIX="" LEXLKIX="AWRD"
  1.  S LEXLKFL=$G(^TMP("LEXSCH",$J,"FLN",0)) I LEXLKFL'["757." D  Q
  1.  . S LEX("ERR",0)=+($G(LEX("ERR",0)))+1,LEX("ERR",LEX("ERR",0))="File number missing or invalid"
  1.  S LEXLKGL=$G(^TMP("LEXSCH",$J,"GBL",0)) I LEXLKGL'["LEX(757." D  Q
  1.  . S LEX("ERR",0)=+($G(LEX("ERR",0)))+1,LEX("ERR",LEX("ERR",0))="Global location missing or invalid"
  1.  S LEXSHOW=$G(^TMP("LEXSCH",$J,"DIS",0))
  1.  D TOKEN^LEXAM(LEXLKSH)
  1.  N LEXOK,LEXDES,LEXDSP,LEXT,LEXO,LEXI,LEXE,LEXM,LEXME
  1.  N LEXSS Q:$G(LEXLKFL)'["757."
  1.  S LEXSS="" I $D(LEXTKNS(0)) D
  1.  . N LEXI F LEXI=1:1:LEXTKNS(0) S LEXSS=LEXSS_" "_LEXTKNS(LEXI)
  1.  . S LEXSS=$E(LEXSS,2,$L(LEXSS))
  1.  S ^TMP("LEXSCH",$J,"SCH",0)=$G(LEXSS)
  1.  S LEXT=$G(LEXTKN(1)),LEXO=$$SCH(LEXT)
  1.  I $G(LEXSHCT)="",$G(LEXTKN(0))=1,$D(^LEX(LEXLKFL,LEXLKIX,LEXT)) D EXACT
  1.  I $G(LEXSHCT)="",$G(LEXTKN(0))=1,$D(^LEX(LEXLKFL,LEXLKIX,LEXT)) D  G END
  1.  . D EXACT
  1.  . I +($O(^LEX(757.01,"ASL",LEXT,0)))>6000 Q
  1.  . D TOKEN
  1.  D TOKEN
  1. END ; End look-up by word
  1.  I $D(^TMP("LEXFND",$J)) D BEG^LEXAL
  1.  I '$D(^TMP("LEXFND",$J)) D
  1.  . K LEX,^TMP("LEXFND",$J),^TMP("LEXHIT",$J) S LEX=0
  1.  S:+($G(^TMP("LEXSCH",$J,"UNR",0)))>0&($L($G(^TMP("LEXSCH",$J,"NAR",0)))) LEX("NAR")=$G(^TMP("LEXSCH",$J,"NAR",0))
  1.  Q
  1. EXACT ; Main loop throuth TOKENS that equal LEXT
  1.  S LEXO=$$SCH(LEXT) F  S LEXO=$O(^LEX(LEXLKFL,LEXLKIX,LEXO)) Q:LEXO'=LEXT  D IEN
  1.  Q
  1. TOKEN ; Main loop though TOKENS containing LEXT
  1.  S LEXO=$$SCH(LEXT) F  S LEXO=$O(^LEX(LEXLKFL,LEXLKIX,LEXO)) Q:LEXO'[LEXT!(LEXO="")  D IEN
  1.  Q
  1. IEN ; Loop throuth Internal Entry Numbers
  1.  S LEXI=0 F  S LEXI=$O(^LEX(LEXLKFL,LEXLKIX,LEXO,LEXI)) Q:+LEXI=0  D
  1.  . I +($G(LEXNOKEY))>0 N LEXK S LEXK=$$KWO($G(LEXO),$G(LEXI)) Q:LEXK>0
  1.  . D CHK
  1.  Q
  1. CHK ; Check each token
  1.  N LEXOK,LEXO,LEXLKT S LEXLKT="ALK",LEXE=LEXI,LEXOK=1
  1.  S:LEXLKGL'["757.01" LEXE=+$G(^LEX(LEXLKFL,LEXI,0)) Q:LEXE=0
  1.  ; Filter
  1.  S LEXFILR=$$EN^LEXAFIL($G(LEXFIL),LEXE) Q:LEXFILR=0
  1.  ; Deactivated
  1.  Q:'$D(LEXIGN)&(+($P($G(^LEX(757.01,LEXE,1)),"^",5))=1)
  1.  ; Expression has Modifiers
  1.  N LEXEMOD S LEXEMOD=+($P($G(^LEX(757.01,LEXE,1)),"^",6))
  1.  S LEXM=+($G(^LEX(757.01,LEXE,1)))
  1.  S LEXME=+($G(^LEX(757,LEXM,0)))
  1.  ; Check not exact match
  1.  I $L($G(^TMP("LEXSCH",$J,"EXM",0))),+(^TMP("LEXSCH",$J,"EXM",0))=LEXE Q
  1.  I $L($G(^TMP("LEXSCH",$J,"EXC",0))),+(^TMP("LEXSCH",$J,"EXC",0))=LEXE Q
  1.  ; Check tokens
  1.  S LEXOK=1 D CHKTKNS(LEXE)
  1.  ; If the expression failed the search, and the expression has 
  1.  ; modifiers then check the modifiers
  1.  D:+LEXOK=0&(+($G(LEXEMOD))>0)&(+($G(LEXTKN(0)))>1) CHKMOD^LEXAMD2
  1.  Q:'LEXOK
  1.  ; Description (*)
  1.  S LEXDES=$$DES^LEXASC(LEXE)
  1.  ; Display of codes
  1.  S LEXDSP=$$SO^LEXASO(LEXE,$G(LEXSHOW),1,$G(LEXVDT))
  1.  D ADDL^LEXAL(LEXE,LEXDES,LEXDSP)
  1.  Q
  1. CHKTKNS(LEXE) ; Check tokens
  1.  N LEXM,LEXNOKEY S LEXM=+($G(^LEX(757.01,LEXE,1))) Q:LEXM=0
  1.  N LEXI,LEXOE,LEXC S LEXOE=LEXE,LEXI=1
  1.  F  S LEXI=$O(LEXTKN(LEXI)) Q:+LEXI=0!('LEXOK)  D  Q:'LEXOK
  1.  . N LEXT,LEXE,LEXORD S LEXT=LEXTKN(LEXI),LEXE=0,LEXOK=0
  1.  . S LEXC=$$UP(^LEX(757.01,LEXOE,0))
  1.  . I LEXC[(" "_LEXT) S LEXOK=1 Q
  1.  . I LEXC[("-"_LEXT) S LEXOK=1 Q
  1.  . I LEXC[("("_LEXT) S LEXOK=1 Q
  1.  . I LEXC[("/"_LEXT) S LEXOK=1 Q
  1.  . I $E(LEXC,1,$L(LEXT))=LEXT S LEXOK=1 Q
  1.  . S LEXORD=$$SCH(LEXT)
  1.  . I $L(LEXT),$D(^LEX(757.01,LEXOE,5,"B",LEXT)) S LEXOK=1 Q
  1.  . 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
  1.  . I $L(LEXT),$L(LEXORD) D  I $E(LEXORD,1,$L(LEXT))=LEXT S LEXOK=1 Q
  1.  . . S LEXORD=$O(^LEX(757.01,LEXOE,5,"B",LEXORD))
  1.  . F  S LEXE=$O(^LEX(757.01,"AMC",LEXM,LEXE)) Q:+LEXE=0!(LEXOK)  D  Q:LEXOK
  1.  . . Q:+($P($G(^LEX(757.01,LEXE,1)),"^",2))>3
  1.  . . S LEXC=$$UP(^LEX(757.01,LEXE,0))
  1.  . . I LEXC[(" "_LEXT) S LEXOK=1 Q
  1.  . . I LEXC[("-"_LEXT) S LEXOK=1 Q
  1.  . . I LEXC[("("_LEXT) S LEXOK=1 Q
  1.  . . I LEXC[("/"_LEXT) S LEXOK=1 Q
  1.  . . I $E(LEXC,1,$L(LEXT))=LEXT S LEXOK=1 Q
  1.  Q
  1. DES(LEXX) ; Get description flag
  1.  N LEXDES,LEXE,LEXM S LEXDES="",LEXE=+LEXX
  1.  S LEXM=$P($G(^LEX(757.01,+($G(LEXX)),1)),"^",1)
  1.  S LEXM=+($G(^LEX(757,+($G(LEXM)),0)))
  1.  S:$D(^LEX(757.01,LEXM,3)) LEXDES="*"
  1.  S LEXX=$G(LEXDES) Q LEXX
  1. SCH(LEXX) ; Search for LEXX a $Orderable variable
  1.  S:$G(LEXX)'?1N.N LEXX=$E(LEXX,1,($L(LEXX)-1))_$C($A($E(LEXX,$L(LEXX)))-1)_"~"
  1.  S:$G(LEXX)?1N.N LEXX=LEXX-.0000000000000009 N LEXIGN
  1.  Q LEXX
  1.  Q
  1. KWO(X,Y) ; Keyword only (SW)
  1.  N LEXS,LEXI,LEXE,LEXK,LEXEC,LEXKC S LEXS=$G(X) Q:$L(LEXS)<6 -1
  1.  Q:'$D(^LEX(757.01,"AWRD",LEXS)) -2
  1.  S LEXI=+($G(Y)) Q:+LEXI'>0 -3
  1.  Q:'$D(^LEX(757.01,"AWRD",LEXS,LEXI)) -4
  1.  Q:"^757.01^"'[("^"_$G(LEXLKFL)_"^") -5
  1.  S (LEXEC,LEXKC,LEXE)=0 F  S LEXE=$O(^LEX(757.01,"AWRD",LEXS,LEXI,LEXE)) Q:+LEXE=0  D
  1.  . N LEXD S LEXD=$D(^LEX(757.01,"AWRD",LEXS,LEXI,LEXE))
  1.  . S:LEXD#10>0 LEXEC=+($G(LEXEC))+1 Q:LEXD=1
  1.  . S LEXK="" F  S LEXK=$O(^LEX(757.01,"AWRD",LEXS,LEXI,LEXE,LEXK)) Q:'$L(LEXK)  D
  1.  . . S LEXEC=+($G(LEXEC))+1 S:LEXK?1N.N LEXKC=+($G(LEXKC))+1
  1.  Q:+($G(LEXKC))>0&($G(LEXKC)=$G(LEXEC)) 1
  1.  Q 0
  1. UP(X) ; Uppercase
  1.  Q $TR(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")