LEXA ; ISA/FJF/KER-Look-up (Silent) ; 09/06/2006 ;;2.0;LEXICON UTILITY;**3,4,6,19,25,36,38,43**;Sep 23, 1996;Build 1 ; ; External References ; DBIA 10104 $$UP^XLFSTR ; DBIA 10103 $$DT^XLFDT ; DBIA 10060 ^VA(200, ; DBIA 10016 ^DIM ; ; Look-up D LOOK^LEXA(LEXX,LEXAP,LEXLL,LEXSUB,lexvdt) ; ; LEXX User Input ; LEXAP Application ; LEXLL Selection List Length ; LEXSUB Mode/Subset (file 757.2) ; LEXVDT Date to use for retrieving/displaying codes ; ; 1. Search parameters ^TMP("LEXSCH",$J,PAR)=VALUE ; 2. Expressions found ^TMP("LEXFND",$J,FQ,IEN)=DT ; 3. Review List ^TMP("LEXHITS",$J,#)=IEN^DT ; 4. Display List LEX("LIST",#) ; ; LEX("LIST",0)=LAST^TOTAL ; LEX("LIST",#)=IEN^DT ; LOOK(LEXX,LEXAP,LEXLL,LEXSUB,LEXVDT) ; Search for LEXX I $G(LEXVDT)="" S LEXVDT=$$DT^XLFDT I $L($G(^TMP("LEXSCH",$J,"VDT",0))) S LEXVDT=^TMP("LEXSCH",$J,"VDT",0) K DIERR,LEX K ^TMP("LEXFND",$J),^TMP("LEXHIT",$J) K ^TMP("LEXSCH",$J,"EXC"),^TMP("LEXSCH",$J,"EXM") K:+$G(^TMP("LEXSCH",$J,"ADF",0))=0 ^TMP("LEXSCH",$J) I $D(DIC(0)) D .S:DIC(0)["L" DIC(0)=$P(DIC(0),"L",1)_$P(DIC(0),"L",2) .S:DIC(0)["I" DIC(0)=$P(DIC(0),"I",1)_$P(DIC(0),"I",2) S LEXQ=1,LEXX=$G(LEXX) I LEXX=""!(LEXX["^") D EN^LEXAR("^",$G(LEXVDT)) K LEXAP D EXIT Q S LEXAP=$$UP^XLFSTR($G(LEXAP)) S LEXLL=+$G(LEXLL) S LEXSUB=$G(LEXSUB) S ^TMP("LEXSCH",$J,"APP",0)=+$$AP^LEXDFN2($G(LEXAP)) S:^TMP("LEXSCH",$J,"APP",0)=0 ^TMP("LEXSCH",$J,"APP",0)=1 S:LEXSUB="" LEXSUB=^TMP("LEXSCH",$J,"APP",0) S:$L($G(DIC("S"))) ^TMP("LEXSCH",$J,"FIL",0)=DIC("S") S:LEXLL=0 LEXLL=5 S ^TMP("LEXSCH",$J,"LEN",0)=LEXLL X ; Search for X I '$L($G(LEXX)) D D EXIT Q .S LEX("ERR",0)=$G(LEX("ERR",0))+1 .S LEX("ERR",LEX("ERR",0))="User input LEXX missing or invalid" APP ; Application I +$G(^TMP("LEXSCH",$J,"APP",0))=0!('$D(^LEXT(757.2,+$G(^TMP("LEXSCH",$J,"APP",0)),0))) D D EXIT Q .S LEX("ERR",0)=$G(LEX("ERR",0))+1 .S LEX("ERR",LEX("ERR",0))="Calling application identification LEXAP missing or invalid" USR ; User I +$G(DUZ)=0!('$D(^VA(200,+$G(DUZ),0))) D D EXIT Q .S LEX("ERR",0)=$G(LEX("ERR",0))+1 .S LEX("ERR",LEX("ERR",0))="User identification DUZ missing or invalid" N LEXFND,LEXISCD S (LEXFND,LEXISCD)=0 S ^TMP("LEXSCH",$J,"USR",0)=+$G(DUZ) S ^TMP("LEXSCH",$J,"NAR",0)=LEXX S ^TMP("LEXSCH",$J,"SCH",0)=$$UP^XLFSTR(LEXX) DEF ; Defaults CONFIG^LEXSET N LEXFIL,LEXDSP,LEXFILR S:$L($G(DIC("S"))) LEXFIL=DIC("S") I '$L($G(LEXFIL)),$L($G(^TMP("LEXSCH",$J,"FIL",0))) S LEXFIL=^TMP("LEXSCH",$J,"FIL",0) N LEXNS,LEXSS S LEXNS=$$NS^LEXDFN2(LEXAP) S LEXSS=$$MD^LEXDFN2(LEXSUB) I +$G(^TMP("LEXSCH",$J,"ADF",0))=0 D CONFIG^LEXSET(LEXNS,LEXSS,$G(LEXVDT)) I '$L($G(LEXFIL)),$L($G(^TMP("LEXSCH",$J,"FIL",0))) S LEXFIL=^TMP("LEXSCH",$J,"FIL",0) S:$L($G(LEXFIL)) LEXFIL=$$FIL(LEXFIL) S LEXFIL=$G(LEXFIL) K ^TMP("LEXFND",$J),^TMP("LEXHIT",$J) D MAN I $D(LEX("ERR")) D EXIT Q D SETUP^LEXAM($G(^TMP("LEXSCH",$J,"VOC",0))) I $D(LEX("ERR")) D EXIT Q LK ; Look-up IEN ; Look-up by IEN ADDL^LEXAL PCH 4 I ^TMP("LEXSCH",$J,"NAR",0)?1"`"1N.N D I $D(LEX("LIST")) D EXIT Q .N LEXE,LEXUN .S LEXE=+$E(^TMP("LEXSCH",$J,"NAR",0),2,$L(^TMP("LEXSCH",$J,"NAR",0))) Q:LEXE=0 .S LEXUN=+$G(^TMP("LEXSCH",$J,"UNR",0)) .Q:'$D(^LEX(757.01,LEXE,0)) .D ADDL^LEXAL(LEXE,$$DES^LEXASC(LEXE),$$SO^LEXASO(LEXE,$G(^TMP("LEXSCH",$J,"DIS",0)),1,$G(LEXVDT))) .I $D(^TMP("LEXFND",$J)) D BEG^LEXAL .I LEXUN>0,$L($G(^TMP("LEXSCH",$J,"NAR",0))) S LEX("NAR")=$G(^TMP("LEXSCH",$J,"NAR",0)) .I LEXUN>0,$L($G(^LEX(757.01,+$G(LEXE),0))) S LEX("NAR")=$G(^LEX(757.01,+$G(LEXE),0)) SCT ; Look-up by Shortcuts EN^LEXASC I +$G(^TMP("LEXSCH",$J,"SCT",0)),$D(^LEX(757.41,^TMP("LEXSCH",$J,"SCT",0))) D .S LEXFND=$$EN^LEXASC(^TMP("LEXSCH",$J,"SCH",0),^TMP("LEXSCH",$J,"SCT",0),$G(LEXVDT)) I +LEXFND D EXIT Q CODE ; Look-up by Code EN^LEXABC S LEXFND=$$EN^LEXABC(^TMP("LEXSCH",$J,"SCH",0),$G(LEXVDT)) I +LEXFND D EXIT Q I +LEXFND'>0,+($G(LEXISCD))>0 D EXIT Q ; if code is found but it is inactive ;I +$P(LEXFND,"^",2)'=-1 S LEX=0 D EXIT Q EXACT ; Look-up Exact Match EN^LEXAB S LEXFND=$$EN^LEXAB(^TMP("LEXSCH",$J,"SCH",0),$G(LEXVDT)) K:+LEXFND=0 ^TMP("LEXFND",$J) K ^TMP("LEXHIT",$J) KEYWRD ; Look-up by word EN^LEXALK D EN^LEXALK EXIT ; Clean-up and quit K LEXQ,LEXDICS,LEXFIL,LEXFILR,LEXDSP,LEXSHOW,LEXSHCT,LEXSUB K LEXOVR,LEXUN,LEXLKFL,LEXLKGL,LEXLKIX,LEXLKSH,LEXTKNS,LEXTKN K LEXI D:$D(LEX("ERR")) CLN I $D(LEX),+$G(LEX)=0,'$D(LEX("LIST")),$L($G(LEXX)) D .N LEXC,LEXF,LEXV .S LEXC=1 .S LEXF=$G(^TMP("LEXSCH",$J,"FIL",0)) .S LEXV=$G(^TMP("LEXSCH",$J,"VOC",0)) .D:+$G(^TMP("LEXSCH",$J,"UNR",0))>0 EN^LEXAR(LEXX,$G(LEXVDT)) .S LEX("NAR")=LEXX .S LEX=0 .S LEX("HLP",LEXC)=" A suitable term could not be found based on user input" .S:LEXF="I 1" LEXF="" .I $L(LEXF)!(LEXV'="WRD") D ..S LEX("HLP",LEXC)=$G(LEX("HLP",LEXC))_" and " ..S LEXC=LEXC+1 ..S LEX("HLP",LEXC)=" current user defaults" ..S LEX("HLP",0)=LEXC .S LEX("HLP",LEXC)=$G(LEX("HLP",LEXC))_"." Q CLN ; Clean K LEXQ,LEXTKNS,LEXTKN,LEXI K ^TMP("LEXSCH",$J),^TMP("LEXHIT",$J),^TMP("LEXFND",$J) Q CLR ; Clear all (FOR TESTING ONLY) K LEX,LEXQ,LEXTKNS,LEXTKN,LEXI K ^TMP("LEXSCH"),^TMP("LEXHIT"),^TMP("LEXFND") Q MAN ; Mandatory variables N LEXERR F LEXERR="SCH","VOC","APP","USR" D .I '$L($G(^TMP("LEXSCH",$J,LEXERR,0))) D ..S LEX("ERR",0)=$G(LEX("ERR",0))+1 ..S LEX("ERR",LEX("ERR",0))="Mandatory variable ^TMP(""LEXSCH"",$J,"""_LEXERR_""",0) missing or invalid" Q FIL(X) ; Validate Filter S X=$G(X) N DIC Q:'$L(X) X D ^DIM S:'$D(X) X="" Q X ; ; D INFO^LEXA(IEN,DATE) ; ; IEN Internal Entry Number in file 757.01 ; DATE Optional - retrieves codes active on a specified date ; ; Returns array LEX("SEL") or null ; ; LEX("SEL","EXP") Expressions Concepts/Synonyms/Variants ; LEX("SEL","SIG") Expression definition ; LEX("SEL","SRC") Classification Codes ; LEX("SEL"."STY") Semantic Class/Semantic Types ; LEX("SEL","VAS") VA Classification Sources ; INFO(X,LEXVDT) ; Get Information about a Term K LEX("SEL") S X=+$G(X) Q:X=0 Q:'$D(^LEX(757.01,X,0)) N LEXD S LEXD=$G(LEXVDT) S:+LEXD'>0 LEXD=$$DT^XLFDT N LEXVDT S LEXVDT=LEXD D SET^LEXAR4(X,LEXVDT) Q