LEXAL ; ISL Look-up List (Global)                ; 10-15-97
 ;;2.0;LEXICON UTILITY;**6**;Sep 23, 1996;Build 1
 ;
 ; Add to the list
ADDL(LEXA,LEXDS,LEXDP) ; Add
 S LEXA=+($G(LEXA)) Q:LEXA=0  Q:'$D(^LEX(757.01,LEXA))
 S LEXDS=$G(LEXDS),LEXDP=$G(LEXDP)
 N LEXF,LEXT,LEXL,LEXC
 S LEXT=$$DISP(LEXA,LEXDS,LEXDP)
 S LEXF=$$LSTN(LEXA,"A")
 S:'$D(^TMP("LEXFND",$J,-LEXF,LEXA)) ^TMP("LEXSCH",$J,"NUM",0)=$G(^TMP("LEXSCH",$J,"NUM",0))+1
 S ^TMP("LEXFND",$J,-LEXF,LEXA)=LEXT
 S:+LEXF'=0 ^TMP("LEXFND",$J,0)=LEXF
 S LEX=$G(^TMP("LEXSCH",$J,"NUM",0))
 Q
ADDN(LEXA,LEXDS,LEXDP) ; Near match
 S LEXA=+($G(LEXA)) Q:LEXA=0  Q:'$D(^LEX(757.01,LEXA))
 N LEXR,LEXN S LEXR=LEXA Q:$D(^TMP("LEXFND",$J,-99999997,LEXA))
 S LEXN=-99999997
 F  S LEXN=LEXN+1 Q:'$D(^TMP("LEXFND",$J,LEXN,0))
 I $P($G(^LEX(757.01,LEXA,1)),"^",2)'=1 D  Q:+LEXA=0
 . S LEXA=+($G(^LEX(757.01,LEXA,1))),LEXA=+($G(^LEX(757,LEXA,0)))
 S LEXDS=$G(LEXDS),LEXDP=$G(LEXDP)
 N LEXT S LEXT=$$DISP(LEXA,LEXDS,LEXDP)
 S:'$D(^TMP("LEXFND",$J,-LEXF,LEXA)) ^TMP("LEXSCH",$J,"NUM",0)=$G(^TMP("LEXSCH",$J,"NUM",0))+1
 S ^TMP("LEXFND",$J,LEXN,LEXA)=LEXT
 S:LEXN<$G(^TMP("LEXFND",$J,0)) ^TMP("LEXFND",$J,0)=LEXN
 S LEX=$G(^TMP("LEXSCH",$J,"NUM",0))
 Q
ADDE(LEXA,LEXDS,LEXDP) ; Exact match
 S LEXA=+($G(LEXA)) Q:LEXA=0  Q:'$D(^LEX(757.01,LEXA))  N LEXR,LEXT S LEXR=LEXA,LEXDS=$G(LEXDS),LEXDP=$G(LEXDP),LEXT=$$DISP(LEXA,LEXDS,LEXDP)
 S:'$D(^TMP("LEXFND",$J,-99999999,LEXA)) ^TMP("LEXSCH",$J,"NUM",0)=$G(^TMP("LEXSCH",$J,"NUM",0))+1
 S ^TMP("LEXFND",$J,-99999999,LEXA)=LEXT,^TMP("LEXFND",$J,0)=-99999999
 S LEX=$G(^TMP("LEXSCH",$J,"NUM",0))
 Q
ADDEM(LEXA,LEXDS,LEXDP) ; Exact match Major Concept
 S LEXA=+($G(LEXA)) Q:LEXA=0  Q:'$D(^LEX(757.01,LEXA))  N LEXR,LEXT S LEXR=LEXA Q:$P($G(^LEX(757.01,LEXA,1)),"^",2)'=1
 S LEXDS=$G(LEXDS),LEXDP=$G(LEXDP),LEXT=$$DISP(LEXA,LEXDS,LEXDP)
 S:'$D(^TMP("LEXFND",$J,-99999998,LEXA)) ^TMP("LEXSCH",$J,"NUM",0)=$G(^TMP("LEXSCH",$J,"NUM",0))+1
 S ^TMP("LEXFND",$J,-99999998,LEXA)=LEXT,^TMP("LEXFND",$J,0)=-99999998,LEX=$G(^TMP("LEXSCH",$J,"NUM",0))
 Q
ADDC(LEXA,LEXDS,LEXDP) ; Code
 S LEXA=+($G(LEXA)) Q:LEXA=0  Q:'$D(^LEX(757.01,LEXA))
 S LEXDS=$G(LEXDS),LEXDP=$G(LEXDP)
 N LEXT,LEXF,LEXC S LEXC=+($G(^LEX(757.01,LEXA,1))) Q:LEXC=0
 S LEXF=$G(^TMP("LEXFND",$J,0)) S:+LEXF=0 LEXF=-999999
 S LEXF=LEXF+1 S LEXT=$$DISP(LEXA,LEXDS,LEXDP)
 S:'$D(^TMP("LEXFND",$J,-LEXF,LEXA)) ^TMP("LEXSCH",$J,"NUM",0)=$G(^TMP("LEXSCH",$J,"NUM",0))+1
 S ^TMP("LEXFND",$J,LEXF,LEXA)=LEXT
 S ^TMP("LEXFND",$J,0)=LEXF
 S LEX=$G(^TMP("LEXSCH",$J,"NUM",0))
 Q
DISP(LEXX,LEXDS,LEXDP) ; Display Text
 S LEXX=$G(^LEX(757.01,LEXX,0))
 S:$L(LEXDS) LEXX=LEXX_" "_LEXDS
 S:$L(LEXDP) LEXX=LEXX_" "_LEXDP
 Q LEXX
BEG ; Begin List
 S:+($G(^TMP("LEXSCH",$J,"UNR",0)))>0&($L($G(^TMP("LEXSCH",$J,"NAR",0)))) LEX("NAR")=$G(^TMP("LEXSCH",$J,"NAR",0))
 Q:'$D(^TMP("LEXFND",$J))
 N LEXRL,LEXJ,LEXI,LEXA,LEXSTR,LEXDP
 S LEXRL=0,LEXLL=+($G(^TMP("LEXSCH",$J,"LEN",0)))
 S:+LEXLL=0 (LEXRL,LEXLL)=5 S LEXJ=0,LEXI=-9999999999
 ; Hit List      ^TMP("LEXHIT",$J,#)
 F  S LEXI=$O(^TMP("LEXFND",$J,LEXI)) Q:+LEXI=0  D
 . S LEXA=0
 . F  S LEXA=$O(^TMP("LEXFND",$J,LEXI,LEXA)) Q:+LEXA=0!(LEXJ=LEXLL)  D  Q:+LEXA=0!(LEXJ=LEXLL)
 . . S LEXJ=LEXJ+1,LEXDP=^TMP("LEXFND",$J,LEXI,LEXA)
 . . S ^TMP("LEXHIT",$J,0)=LEXJ
 . . S ^TMP("LEXHIT",$J,LEXJ)=LEXA_"^"_LEXDP
 . . S:+($G(^TMP("LEXSCH",$J,"EXM",0)))=+LEXA ^TMP("LEXSCH",$J,"EXM",2)=LEXJ_"^"_$G(^LEX(757.01,+LEXA,0))
 . . S:+($G(^TMP("LEXSCH",$J,"EXC",0)))=+LEXA ^TMP("LEXSCH",$J,"EXC",2)=LEXJ_"^"_$G(^LEX(757.01,+LEXA,0))
 . . K ^TMP("LEXFND",$J,LEXI,LEXA)
 ; List          LEX("LIST")
 I $D(^TMP("LEXSCH",$J,"NUM",0)) S LEX=+($G(^TMP("LEXSCH",$J,"NUM",0)))
 I LEXLL>0 D
 . N LEXI,LEXJ S (LEXJ,LEXI)=0
 . F  S LEXJ=$O(^TMP("LEXHIT",$J,LEXJ)) Q:+LEXJ=0!(+LEXI=LEXLL)  D  Q:+LEXI=LEXLL
 . . S LEXI=LEXI+1,LEX("LIST",LEXI)=^TMP("LEXHIT",$J,LEXJ)
 . . S LEX("LIST",0)=LEXI_"^"_LEXI
 . . S (LEX("MAX"),^TMP("LEXSCH",$J,"LST",0))=LEXI
 S ^TMP("LEXSCH",$J,"TOL",0)=0 S:$D(LEX("LIST",1)) ^TMP("LEXSCH",$J,"TOL",0)=1
 S LEX=+($G(^TMP("LEXSCH",$J,"NUM",0)))
 S:^TMP("LEXSCH",$J,"TOL",0)=1&(+($G(LEX))>0) LEX("MAT")=+LEX_" match"_$S(+LEX>1:"es",1:"")_" found"
 ; Establish level of concept (1 = concept, >1= modifier)  PCH 6
 S LEX("LVL")=+($G(LEX("LVL"))) S:LEX("LVL")=0 LEX("LVL")=1
 S:+($G(LEX("MAX")))>0 LEX("MIN")=1
 I $L($G(^TMP("LEXSCH",$J,"EXM",2))) S LEX("EXM")=^TMP("LEXSCH",$J,"EXM",2)
 I $L($G(^TMP("LEXSCH",$J,"EXC",2))) S LEX("EXC")=^TMP("LEXSCH",$J,"EXC",2)
 S:+($G(^TMP("LEXSCH",$J,"UNR",0)))>0&($L($G(^TMP("LEXSCH",$J,"NAR",0)))) LEX("NAR")=$G(^TMP("LEXSCH",$J,"NAR",0))
 Q:'$D(^TMP("LEXFND",$J))  K:+($G(LEXRL))>0 LEXLL
 Q
LSTN(LEXA,LEXM) ; List Number
 N LEXC,LEXL,LEXF,LEXK S LEXK=0
 S LEXC=+($G(^LEX(757.01,LEXA,1))) Q:LEXC=0 0
 S LEXL=$L($G(^LEX(757.01,LEXA,0))) Q:LEXL=0 0
 S LEXL=245-LEXL S:$L(LEXL)=1 LEXL="00"_LEXL
 S:$L(LEXL)=2 LEXL="0"_LEXL S LEXL=$E(LEXL,1,3)
 S LEXF=$O(^LEX(757.001,"B",LEXC,0))
 S:+LEXF>0&($L($G(^LEX(757.001,+LEXF,0)))) LEXF=(+($P($G(^LEX(757.001,LEXF,0)),"^",3))+1)
 S:+LEXF=0 LEXF=1 I +($G(LEXTKN(0)))>0 D
 . N LEXI S LEXI=0 F  S LEXI=$O(LEXTKN(LEXI)) Q:+LEXI=0  D
 . . I $$UP^XLFSTR($G(^LEX(757.01,LEXA,0)))[LEXTKN(LEXI) S:LEXK<8 LEXK=LEXK+1
 S LEXK=$E(LEXK,1),LEXM=LEXF_"."_LEXK_LEXL
 Q LEXM