LEXA ;ISL/KER - Look-up (Silent) ;04/21/2014
;;2.0;LEXICON UTILITY;**3,4,6,19,25,36,38,43,55,73,80**;Sep 23, 1996;Build 10
;
; Global Variables
; ^LEX(757.13 N/A
; ^LEX(757.14 N/A
; ^LEX(757.41 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
; ^DIM ICR 10016
; $$GET1^DIQ ICR 2056
; $$DT^XLFDT ICR 10103
; $$UP^XLFSTR ICR 10104
;
LOOK(LEXX,LEXAP,LEXLL,LEXSUB,LEXCDT,LEXXSR,LEXXCT) ; Main Lexicon Lookup
;
; Input
;
; Parameters
; LEXX User Input
; LEXAP Application
; LEXLL Selection List Length
; LEXSUB Mode/Subset (file 757.2)
; LEXVDT Date to use for retrieving/displaying codes
; LEXXSR Source (file 757.14)
; LEXXCT Category (file 757.13)
;
; Optional Global search parameters
; ^TMP("LEXSCH",$J,PAR)=VALUE
;
; Output
;
; Global Arrays
; Expressions found ^TMP("LEXFND",$J,FQ,IEN)=DT
; Review List ^TMP("LEXHITS",$J,#)=IEN^DT
;
; Local Array
; Display List LEX("LIST",#)
;
; LEX("LIST",0)=LAST^TOTAL
; LEX("LIST",#)=IEN^DT
;
S LEXCDT=$P($G(LEXCDT),".",1) S:LEXCDT?7N LEXVDT=LEXCDT D VDT^LEXU 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=$$UP^XLFSTR($G(LEXX))
I LEXX=""!(LEXX["^") D EN^LEXAR("^",$G(LEXVDT)) K LEXAP D EXIT Q
N LEXSC S LEXSC=$$CAT($G(LEXXCT),$G(LEXXSR))
N LEXXCT,LEXXSR S:+($P(LEXSC,"^",1))>0 LEXXCT=+($P(LEXSC,"^",1)) S:+($P(LEXSC,"^",2))>0 LEXXSR=+($P(LEXSC,"^",2))
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:$L($G(LEXDISP)) ^TMP("LEXSCH",$J,"DIS",0)=$G(LEXDISP)
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!('$L($$GET1^DIQ(200,+($G(DUZ)),.01))) 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),LEXSS=$$MD^LEXDFN2(LEXSUB)
I +$G(^TMP("LEXSCH",$J,"ADF",0))=0 D CONFIG^LEXSET(LEXNS,LEXSS,$G(LEXVDT))
S:$L($G(LEXDISP)) ^TMP("LEXSCH",$J,"DIS",0)=$G(LEXDISP)
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
HLP ; Look-up Help ADDL^LEXAL
I (LEXX["?"&($P(LEXX,"?",2)'?1N.N))!(LEXX["??") D I $D(LEX("HLP")) D EXIT Q
. D QMH^LEXAR3(LEXX)
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 $L($G(^TMP("LEXSCH",$J,"SCH",0))) D
. S:$D(^LEX(757.01,"AWRD",^TMP("LEXSCH",$J,"SCH",0))) LEXISCD=0
I +LEXFND'>0,+($G(LEXISCD))>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 Q:$D(LEX("HLP"))
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:'$D(LEX("NAR")) LEX("NAR")=LEXX
.S LEX=0
.S:'$D(LEX("HLP")) 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(LEX("HLP")) 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:'$D(LEX("HLP")) 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
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
CAT(X,Y) ; Source Category
N LEX,LEXC,LEXI,LEXO,LEXS,LEXU S (X,LEX)=$G(X) Q:'$L(X) "" Q:X?1N.N&('$D(^LEX(757.13,+X,0))) ""
S (LEXS,Y)=$G(Y) S:$L(LEXS) LEXS=$$SRC(LEXS) I X?1N.N,$D(^LEX(757.13,+X,0)) S X=+X S:+LEXS>0 X=X_"^"_+LEXS Q X
S LEXU=$$UP^XLFSTR(LEX),(X,LEXC)=+($O(^LEX(757.13,"C",LEXU,0))) Q:'$D(^LEX(757.13,"C",LEXU)) ""
I +LEXC>0,LEXC=+($O(^LEX(757.13,"C",LEXU," "),-1)) S X=+LEXC S:+LEXS>0 X=X_"^"_+LEXS Q X
S LEXO="",LEXI=0 F S LEXI=$O(^LEX(757.13,"C",LEXU,LEXI)) Q:+LEXI'>0 D Q:+LEXO>0
. S:$P($G(^LEX(757.13,LEXI,4)),"^",1)=LEXS LEXO=LEXI
S X="" S:+LEXO>0 X=+LEXO S:+LEXO>0&(+LEXS>0) X=X_"^"_+LEXS
Q X
SRC(X) ; Source
N LEX,LEXU S (LEX,X)=$TR($G(X),"`","") Q:'$L(LEX) "" Q:X?1N.N&('$D(^LEX(757.14,+X,0))) "" Q:X?1N.N&($D(^LEX(757.14,+X,0))) +X
S LEXU=$$UP^XLFSTR(LEX),X=$O(^LEX(757.14,"B",LEX,0)) Q:+X>0 +X S X=$O(^LEX(757.14,"B",LEXU,0)) Q:+X>0 +X
Q ""
FIL(X) ; Validate Filter
S X=$G(X) N DIC Q:'$L(X) X D ^DIM S:'$D(X) X=""
Q X
;
INFO(X,LEXVDT) ; Get Information about a Term
;
; Input
;
; X Internal Entry Number in file 757.01
; LEXVDT Optional date - retrieves codes active
; on a specified date
;
; Output
;
; Local 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
;
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
SCH ; Search Parameters
N NN,NC S NN="^TMP(""LEXSCH"","_$J_")",NC="^TMP(""LEXSCH"","_$J_","
W ! F S NN=$Q(@NN) Q:'$L(NN)!(NN'[NC) W !,NN,"=",@NN
W !
LEXA ;ISL/KER - Look-up (Silent) ;04/21/2014
+1 ;;2.0;LEXICON UTILITY;**3,4,6,19,25,36,38,43,55,73,80**;Sep 23, 1996;Build 10
+2 ;
+3 ; Global Variables
+4 ; ^LEX(757.13 N/A
+5 ; ^LEX(757.14 N/A
+6 ; ^LEX(757.41 N/A
+7 ; ^TMP("LEXFND") SACC 2.3.2.5.1
+8 ; ^TMP("LEXHIT") SACC 2.3.2.5.1
+9 ; ^TMP("LEXSCH") SACC 2.3.2.5.1
+10 ;
+11 ; External References
+12 ; ^DIM ICR 10016
+13 ; $$GET1^DIQ ICR 2056
+14 ; $$DT^XLFDT ICR 10103
+15 ; $$UP^XLFSTR ICR 10104
+16 ;
LOOK(LEXX,LEXAP,LEXLL,LEXSUB,LEXCDT,LEXXSR,LEXXCT) ; Main Lexicon Lookup
+1 ;
+2 ; Input
+3 ;
+4 ; Parameters
+5 ; LEXX User Input
+6 ; LEXAP Application
+7 ; LEXLL Selection List Length
+8 ; LEXSUB Mode/Subset (file 757.2)
+9 ; LEXVDT Date to use for retrieving/displaying codes
+10 ; LEXXSR Source (file 757.14)
+11 ; LEXXCT Category (file 757.13)
+12 ;
+13 ; Optional Global search parameters
+14 ; ^TMP("LEXSCH",$J,PAR)=VALUE
+15 ;
+16 ; Output
+17 ;
+18 ; Global Arrays
+19 ; Expressions found ^TMP("LEXFND",$J,FQ,IEN)=DT
+20 ; Review List ^TMP("LEXHITS",$J,#)=IEN^DT
+21 ;
+22 ; Local Array
+23 ; Display List LEX("LIST",#)
+24 ;
+25 ; LEX("LIST",0)=LAST^TOTAL
+26 ; LEX("LIST",#)=IEN^DT
+27 ;
+28 SET LEXCDT=$PIECE($GET(LEXCDT),".",1)
IF LEXCDT?7N
SET LEXVDT=LEXCDT
DO VDT^LEXU
KILL DIERR,LEX
+29 KILL ^TMP("LEXFND",$JOB),^TMP("LEXHIT",$JOB)
+30 KILL ^TMP("LEXSCH",$JOB,"EXC"),^TMP("LEXSCH",$JOB,"EXM")
+31 IF +$GET(^TMP("LEXSCH",$JOB,"ADF",0))=0
KILL ^TMP("LEXSCH",$JOB)
+32 IF $DATA(DIC(0))
Begin DoDot:1
+33 IF DIC(0)["L"
SET DIC(0)=$PIECE(DIC(0),"L",1)_$PIECE(DIC(0),"L",2)
+34 IF DIC(0)["I"
SET DIC(0)=$PIECE(DIC(0),"I",1)_$PIECE(DIC(0),"I",2)
End DoDot:1
+35 SET LEXQ=1
SET LEXX=$$UP^XLFSTR($GET(LEXX))
+36 IF LEXX=""!(LEXX["^")
DO EN^LEXAR("^",$GET(LEXVDT))
KILL LEXAP
DO EXIT
QUIT
+37 NEW LEXSC
SET LEXSC=$$CAT($GET(LEXXCT),$GET(LEXXSR))
+38 NEW LEXXCT,LEXXSR
IF +($PIECE(LEXSC,"^",1))>0
SET LEXXCT=+($PIECE(LEXSC,"^",1))
IF +($PIECE(LEXSC,"^",2))>0
SET LEXXSR=+($PIECE(LEXSC,"^",2))
+39 SET LEXAP=$$UP^XLFSTR($GET(LEXAP))
+40 SET LEXLL=+$GET(LEXLL)
+41 SET LEXSUB=$GET(LEXSUB)
+42 SET ^TMP("LEXSCH",$JOB,"APP",0)=+$$AP^LEXDFN2($GET(LEXAP))
+43 IF ^TMP("LEXSCH",$JOB,"APP",0)=0
SET ^TMP("LEXSCH",$JOB,"APP",0)=1
+44 IF $LENGTH($GET(LEXDISP))
SET ^TMP("LEXSCH",$JOB,"DIS",0)=$GET(LEXDISP)
+45 IF LEXSUB=""
SET LEXSUB=^TMP("LEXSCH",$JOB,"APP",0)
+46 IF $LENGTH($GET(DIC("S")))
SET ^TMP("LEXSCH",$JOB,"FIL",0)=DIC("S")
+47 IF LEXLL=0
SET LEXLL=5
+48 SET ^TMP("LEXSCH",$JOB,"LEN",0)=LEXLL
X ; Search for X
+1 IF '$LENGTH($GET(LEXX))
Begin DoDot:1
+2 SET LEX("ERR",0)=$GET(LEX("ERR",0))+1
+3 SET LEX("ERR",LEX("ERR",0))="User input LEXX missing or invalid"
End DoDot:1
DO EXIT
QUIT
APP ; Application
+1 IF +$GET(^TMP("LEXSCH",$JOB,"APP",0))=0!('$DATA(^LEXT(757.2,+$GET(^TMP("LEXSCH",$JOB,"APP",0)),0)))
Begin DoDot:1
+2 SET LEX("ERR",0)=$GET(LEX("ERR",0))+1
+3 SET LEX("ERR",LEX("ERR",0))="Calling application identification LEXAP missing or invalid"
End DoDot:1
DO EXIT
QUIT
USR ; User
+1 IF +$GET(DUZ)=0!('$LENGTH($$GET1^DIQ(200,+($GET(DUZ)),.01)))
Begin DoDot:1
+2 SET LEX("ERR",0)=$GET(LEX("ERR",0))+1
+3 SET LEX("ERR",LEX("ERR",0))="User identification DUZ missing or invalid"
End DoDot:1
DO EXIT
QUIT
+4 NEW LEXFND,LEXISCD
+5 SET (LEXFND,LEXISCD)=0
+6 SET ^TMP("LEXSCH",$JOB,"USR",0)=+$GET(DUZ)
+7 SET ^TMP("LEXSCH",$JOB,"NAR",0)=LEXX
+8 SET ^TMP("LEXSCH",$JOB,"SCH",0)=$$UP^XLFSTR(LEXX)
DEF ; Defaults CONFIG^LEXSET
+1 NEW LEXFIL,LEXDSP,LEXFILR
IF $LENGTH($GET(DIC("S")))
SET LEXFIL=DIC("S")
+2 IF '$LENGTH($GET(LEXFIL))
IF $LENGTH($GET(^TMP("LEXSCH",$JOB,"FIL",0)))
SET LEXFIL=^TMP("LEXSCH",$JOB,"FIL",0)
+3 NEW LEXNS,LEXSS
SET LEXNS=$$NS^LEXDFN2(LEXAP)
SET LEXSS=$$MD^LEXDFN2(LEXSUB)
+4 IF +$GET(^TMP("LEXSCH",$JOB,"ADF",0))=0
DO CONFIG^LEXSET(LEXNS,LEXSS,$GET(LEXVDT))
+5 IF $LENGTH($GET(LEXDISP))
SET ^TMP("LEXSCH",$JOB,"DIS",0)=$GET(LEXDISP)
+6 IF '$LENGTH($GET(LEXFIL))
IF $LENGTH($GET(^TMP("LEXSCH",$JOB,"FIL",0)))
SET LEXFIL=^TMP("LEXSCH",$JOB,"FIL",0)
+7 IF $LENGTH($GET(LEXFIL))
SET LEXFIL=$$FIL(LEXFIL)
+8 SET LEXFIL=$GET(LEXFIL)
+9 KILL ^TMP("LEXFND",$JOB),^TMP("LEXHIT",$JOB)
+10 DO MAN
+11 IF $DATA(LEX("ERR"))
DO EXIT
QUIT
+12 DO SETUP^LEXAM($GET(^TMP("LEXSCH",$JOB,"VOC",0)))
+13 IF $DATA(LEX("ERR"))
DO EXIT
QUIT
LK ; Look-up
HLP ; Look-up Help ADDL^LEXAL
+1 IF (LEXX["?"&($PIECE(LEXX,"?",2)'?1N.N))!(LEXX["??")
Begin DoDot:1
+2 DO QMH^LEXAR3(LEXX)
End DoDot:1
IF $DATA(LEX("HLP"))
DO EXIT
QUIT
IEN ; Look-up by IEN ADDL^LEXAL PCH 4
+1 IF ^TMP("LEXSCH",$JOB,"NAR",0)?1"`"1N.N
Begin DoDot:1
+2 NEW LEXE,LEXUN
+3 SET LEXE=+$EXTRACT(^TMP("LEXSCH",$JOB,"NAR",0),2,$LENGTH(^TMP("LEXSCH",$JOB,"NAR",0)))
IF LEXE=0
QUIT
+4 SET LEXUN=+$GET(^TMP("LEXSCH",$JOB,"UNR",0))
+5 IF '$DATA(^LEX(757.01,LEXE,0))
QUIT
+6 DO ADDL^LEXAL(LEXE,$$DES^LEXASC(LEXE),$$SO^LEXASO(LEXE,$GET(^TMP("LEXSCH",$JOB,"DIS",0)),1,$GET(LEXVDT)))
+7 IF $DATA(^TMP("LEXFND",$JOB))
DO BEG^LEXAL
+8 IF LEXUN>0
IF $LENGTH($GET(^TMP("LEXSCH",$JOB,"NAR",0)))
SET LEX("NAR")=$GET(^TMP("LEXSCH",$JOB,"NAR",0))
+9 IF LEXUN>0
IF $LENGTH($GET(^LEX(757.01,+$GET(LEXE),0)))
SET LEX("NAR")=$GET(^LEX(757.01,+$GET(LEXE),0))
End DoDot:1
IF $DATA(LEX("LIST"))
DO EXIT
QUIT
SCT ; Look-up by Shortcuts EN^LEXASC
+1 IF +$GET(^TMP("LEXSCH",$JOB,"SCT",0))
IF $DATA(^LEX(757.41,^TMP("LEXSCH",$JOB,"SCT",0)))
Begin DoDot:1
+2 SET LEXFND=$$EN^LEXASC(^TMP("LEXSCH",$JOB,"SCH",0),^TMP("LEXSCH",$JOB,"SCT",0),$GET(LEXVDT))
End DoDot:1
+3 IF +LEXFND
DO EXIT
QUIT
CODE ; Look-up by Code EN^LEXABC
+1 SET LEXFND=$$EN^LEXABC(^TMP("LEXSCH",$JOB,"SCH",0),$GET(LEXVDT))
+2 IF +LEXFND
DO EXIT
QUIT
+3 IF $LENGTH($GET(^TMP("LEXSCH",$JOB,"SCH",0)))
Begin DoDot:1
+4 IF $DATA(^LEX(757.01,"AWRD",^TMP("LEXSCH",$JOB,"SCH",0)))
SET LEXISCD=0
End DoDot:1
+5 IF +LEXFND'>0
IF +($GET(LEXISCD))>0
DO EXIT
QUIT
EXACT ; Look-up Exact Match EN^LEXAB
+1 SET LEXFND=$$EN^LEXAB(^TMP("LEXSCH",$JOB,"SCH",0),$GET(LEXVDT))
+2 IF +LEXFND=0
KILL ^TMP("LEXFND",$JOB)
+3 KILL ^TMP("LEXHIT",$JOB)
KEYWRD ; Look-up by word EN^LEXALK
+1 DO EN^LEXALK
EXIT ; Clean-up and quit
+1 KILL LEXQ,LEXDICS,LEXFIL,LEXFILR,LEXDSP,LEXSHOW,LEXSHCT,LEXSUB
+2 KILL LEXOVR,LEXUN,LEXLKFL,LEXLKGL,LEXLKIX,LEXLKSH,LEXTKNS,LEXTKN
+3 KILL LEXI
IF $DATA(LEX("HLP"))
QUIT
+4 IF $DATA(LEX("ERR"))
DO CLN
+5 IF $DATA(LEX)
IF +$GET(LEX)=0
IF '$DATA(LEX("LIST"))
IF $LENGTH($GET(LEXX))
Begin DoDot:1
+6 NEW LEXC,LEXF,LEXV
+7 SET LEXC=1
+8 SET LEXF=$GET(^TMP("LEXSCH",$JOB,"FIL",0))
+9 SET LEXV=$GET(^TMP("LEXSCH",$JOB,"VOC",0))
+10 IF +$GET(^TMP("LEXSCH",$JOB,"UNR",0))>0
DO EN^LEXAR(LEXX,$GET(LEXVDT))
+11 IF '$DATA(LEX("NAR"))
SET LEX("NAR")=LEXX
+12 SET LEX=0
+13 IF '$DATA(LEX("HLP"))
SET LEX("HLP",LEXC)=" A suitable term could not be found based on user input"
+14 IF LEXF="I 1"
SET LEXF=""
+15 IF $LENGTH(LEXF)!(LEXV'="WRD")
IF '$DATA(LEX("HLP"))
Begin DoDot:2
+16 SET LEX("HLP",LEXC)=$GET(LEX("HLP",LEXC))_" and "
+17 SET LEXC=LEXC+1
+18 SET LEX("HLP",LEXC)=" current user defaults"
+19 SET LEX("HLP",0)=LEXC
End DoDot:2
+20 IF '$DATA(LEX("HLP"))
SET LEX("HLP",LEXC)=$GET(LEX("HLP",LEXC))_"."
End DoDot:1
+21 QUIT
CLN ; Clean
+1 KILL LEXQ,LEXTKNS,LEXTKN,LEXI
+2 KILL ^TMP("LEXSCH",$JOB),^TMP("LEXHIT",$JOB),^TMP("LEXFND",$JOB)
+3 QUIT
MAN ; Mandatory variables
+1 NEW LEXERR
+2 FOR LEXERR="SCH","VOC","APP","USR"
Begin DoDot:1
+3 IF '$LENGTH($GET(^TMP("LEXSCH",$JOB,LEXERR,0)))
Begin DoDot:2
+4 SET LEX("ERR",0)=$GET(LEX("ERR",0))+1
+5 SET LEX("ERR",LEX("ERR",0))="Mandatory variable ^TMP(""LEXSCH"",$J,"""_LEXERR_""",0) missing or invalid"
End DoDot:2
End DoDot:1
+6 QUIT
CAT(X,Y) ; Source Category
+1 NEW LEX,LEXC,LEXI,LEXO,LEXS,LEXU
SET (X,LEX)=$GET(X)
IF '$LENGTH(X)
QUIT ""
IF X?1N.N&('$DATA(^LEX(757.13,+X,0)))
QUIT ""
+2 SET (LEXS,Y)=$GET(Y)
IF $LENGTH(LEXS)
SET LEXS=$$SRC(LEXS)
IF X?1N.N
IF $DATA(^LEX(757.13,+X,0))
SET X=+X
IF +LEXS>0
SET X=X_"^"_+LEXS
QUIT X
+3 SET LEXU=$$UP^XLFSTR(LEX)
SET (X,LEXC)=+($ORDER(^LEX(757.13,"C",LEXU,0)))
IF '$DATA(^LEX(757.13,"C",LEXU))
QUIT ""
+4 IF +LEXC>0
IF LEXC=+($ORDER(^LEX(757.13,"C",LEXU," "),-1))
SET X=+LEXC
IF +LEXS>0
SET X=X_"^"_+LEXS
QUIT X
+5 SET LEXO=""
SET LEXI=0
FOR
SET LEXI=$ORDER(^LEX(757.13,"C",LEXU,LEXI))
IF +LEXI'>0
QUIT
Begin DoDot:1
+6 IF $PIECE($GET(^LEX(757.13,LEXI,4)),"^",1)=LEXS
SET LEXO=LEXI
End DoDot:1
IF +LEXO>0
QUIT
+7 SET X=""
IF +LEXO>0
SET X=+LEXO
IF +LEXO>0&(+LEXS>0)
SET X=X_"^"_+LEXS
+8 QUIT X
SRC(X) ; Source
+1 NEW LEX,LEXU
SET (LEX,X)=$TRANSLATE($GET(X),"`","")
IF '$LENGTH(LEX)
QUIT ""
IF X?1N.N&('$DATA(^LEX(757.14,+X,0)))
QUIT ""
IF X?1N.N&($DATA(^LEX(757.14,+X,0)))
QUIT +X
+2 SET LEXU=$$UP^XLFSTR(LEX)
SET X=$ORDER(^LEX(757.14,"B",LEX,0))
IF +X>0
QUIT +X
SET X=$ORDER(^LEX(757.14,"B",LEXU,0))
IF +X>0
QUIT +X
+3 QUIT ""
FIL(X) ; Validate Filter
+1 SET X=$GET(X)
NEW DIC
IF '$LENGTH(X)
QUIT X
DO ^DIM
IF '$DATA(X)
SET X=""
+2 QUIT X
+3 ;
INFO(X,LEXVDT) ; Get Information about a Term
+1 ;
+2 ; Input
+3 ;
+4 ; X Internal Entry Number in file 757.01
+5 ; LEXVDT Optional date - retrieves codes active
+6 ; on a specified date
+7 ;
+8 ; Output
+9 ;
+10 ; Local Array LEX("SEL") or null
+11 ;
+12 ; LEX("SEL","EXP") Expressions Concepts/Synonyms/Variants
+13 ; LEX("SEL","SIG") Expression definition
+14 ; LEX("SEL","SRC") Classification Codes
+15 ; LEX("SEL"."STY") Semantic Class/Semantic Types
+16 ; LEX("SEL","VAS") VA Classification Sources
+17 ;
+18 KILL LEX("SEL")
SET X=+$GET(X)
IF X=0
QUIT
IF '$DATA(^LEX(757.01,X,0))
QUIT
+19 NEW LEXD
SET LEXD=$GET(LEXVDT)
IF +LEXD'>0
SET LEXD=$$DT^XLFDT
+20 NEW LEXVDT
SET LEXVDT=LEXD
DO SET^LEXAR4(X,LEXVDT)
+21 QUIT
SCH ; Search Parameters
+1 NEW NN,NC
SET NN="^TMP(""LEXSCH"","_$JOB_")"
SET NC="^TMP(""LEXSCH"","_$JOB_","
+2 WRITE !
FOR
SET NN=$QUERY(@NN)
IF '$LENGTH(NN)!(NN'[NC)
QUIT
WRITE !,NN,"=",@NN
+3 WRITE !
