LEXA ;ISL/KER - Look-up (Silent) ;05/23/2017
;;2.0;LEXICON UTILITY;**3,4,6,19,25,36,38,43,55,73,80,86,103**;Sep 23, 1996;Build 2
;
; Global Variables
; ^LEX(757.01 SACC 1.3
; ^LEX(757.13 SACC 1.3
; ^LEX(757.14 SACC 1.3
; ^LEX(757.41 SACC 1.3
; ^LEXT(757.2 SACC 1.3
; ^TMP("LEXFND",$J) SACC 2.3.2.5.1
; ^TMP("LEXHIT",$J) SACC 2.3.2.5.1
; ^TMP("LEXSCH",$J) 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,LEXFMT) ; 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)
; LEXFMT Output Format
; 0 Default, Display Text
; 1 Parsed Format
;
; 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",#)
;
; Default Format LEXFMT'>0
;
; LEX("LIST",0)=LAST^TOTAL
; LEX("LIST",#)=IEN^Expression (coding system and code)
;
; LEX("LIST",1)="301253^Bone Age Studies (CPT-4 77072)"
;
; Parsed Format LEXFMT=1
;
; LEX("LIST",0)=LAST^TOTAL
; LEX("LIST",#)=IEN^Expression
; LEX("LIST",#,Source)=Code^Coding System
;
; LEX("LIST",1)="301253^Bone Age Studies"
; LEX("LIST",1,3)="77072^CPT-4"
;
;
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"),^TMP("LEXSCH",$J,"NUM")
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)
N LEXXNAR,LEXAFMT S LEXQ=1,LEXXNAR=$G(LEXX),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),LEXAFMT=$G(LEXFMT)
S ^TMP("LEXSCH",$J,"FMT",0)=+($G(LEXAFMT)),^TMP("LEXSCH",$J,"FMT",1)="Output Format"
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) N LEXDISP
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 Start Lookup
N LEXSOA
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
S LEXFND=$$EN^LEXAI(^TMP("LEXSCH",$J,"NAR",0),$G(LEXVDT))
I +LEXFND D EXIT Q
SCT ; Look-up by Shortcuts EN^LEXASC Disabled in LEX*2.0*103
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 End Lookup
K LEXQ,LEXDICS,LEXFIL,LEXFILR,LEXDSP,LEXSHOW,LEXSHCT,LEXSUB
K LEXOVR,LEXUN,LEXLKFL,LEXLKGL,LEXLKIX,LEXLKSH,LEXTKNS,LEXTKN
K LEXI,LEXM Q:$D(LEX("HLP"))
S:$L(LEXX) LEX("NAR")=LEXX S:$L(LEXXNAR) LEX("NAR")=LEXXNAR S LEX=0
S:$L($G(LEX("NAR"))) ^TMP("LEXSCH",$J,"NAR",0)=$G(LEX("NAR"))
S:$G(^TMP("LEXSCH",$J,"NUM",0))>0 LEX=$G(^TMP("LEXSCH",$J,"NUM",0))
D:$D(LEX("ERR")) CLN
I $D(LEX),+$G(LEX)=0,'$D(LEX("LIST")),$L($G(LEXX)) D
. N LEXC,LEXF,LEXV,LEXM,LEXL
. 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:$L(LEXX) LEX("NAR")=LEXX S:$L(LEXXNAR) LEX("NAR")=LEXXNAR S LEX=0
. S:$L($G(LEX("NAR"))) ^TMP("LEXSCH",$J,"NAR",0)=$G(LEX("NAR"))
. 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
;
INC(X) ; Increment Expression Frequency
;
; Input
;
; X Internal Entry Number in file 757.01
;
; Output
;
; None
;
; This API increments the Frequency counter for an expressions
; Major Concept. This will cause the expression to occur higher
; on the selection list, effectively placing the most frequently
; used terms at the top of the list.
D INC^LEXAR8(+($G(X)))
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 !
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLEXA 9736 printed Dec 13, 2024@02:06:47 Page 2
LEXA ;ISL/KER - Look-up (Silent) ;05/23/2017
+1 ;;2.0;LEXICON UTILITY;**3,4,6,19,25,36,38,43,55,73,80,86,103**;Sep 23, 1996;Build 2
+2 ;
+3 ; Global Variables
+4 ; ^LEX(757.01 SACC 1.3
+5 ; ^LEX(757.13 SACC 1.3
+6 ; ^LEX(757.14 SACC 1.3
+7 ; ^LEX(757.41 SACC 1.3
+8 ; ^LEXT(757.2 SACC 1.3
+9 ; ^TMP("LEXFND",$J) SACC 2.3.2.5.1
+10 ; ^TMP("LEXHIT",$J) SACC 2.3.2.5.1
+11 ; ^TMP("LEXSCH",$J) SACC 2.3.2.5.1
+12 ;
+13 ; External References
+14 ; ^DIM ICR 10016
+15 ; $$GET1^DIQ ICR 2056
+16 ; $$DT^XLFDT ICR 10103
+17 ; $$UP^XLFSTR ICR 10104
+18 ;
LOOK(LEXX,LEXAP,LEXLL,LEXSUB,LEXCDT,LEXXSR,LEXXCT,LEXFMT) ; 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 ; LEXFMT Output Format
+13 ; 0 Default, Display Text
+14 ; 1 Parsed Format
+15 ;
+16 ; Optional Global search parameters
+17 ; ^TMP("LEXSCH",$J,PAR)=VALUE
+18 ;
+19 ; Output
+20 ;
+21 ; Global Arrays
+22 ; Expressions found ^TMP("LEXFND",$J,FQ,IEN)=DT
+23 ; Review List ^TMP("LEXHITS",$J,#)=IEN^DT
+24 ;
+25 ; Local Array
+26 ; Display List LEX("LIST",#)
+27 ;
+28 ; Default Format LEXFMT'>0
+29 ;
+30 ; LEX("LIST",0)=LAST^TOTAL
+31 ; LEX("LIST",#)=IEN^Expression (coding system and code)
+32 ;
+33 ; LEX("LIST",1)="301253^Bone Age Studies (CPT-4 77072)"
+34 ;
+35 ; Parsed Format LEXFMT=1
+36 ;
+37 ; LEX("LIST",0)=LAST^TOTAL
+38 ; LEX("LIST",#)=IEN^Expression
+39 ; LEX("LIST",#,Source)=Code^Coding System
+40 ;
+41 ; LEX("LIST",1)="301253^Bone Age Studies"
+42 ; LEX("LIST",1,3)="77072^CPT-4"
+43 ;
+44 ;
+45 SET LEXCDT=$PIECE($GET(LEXCDT),".",1)
if LEXCDT?7N
SET LEXVDT=LEXCDT
DO VDT^LEXU
KILL DIERR,LEX
+46 KILL ^TMP("LEXFND",$JOB),^TMP("LEXHIT",$JOB)
+47 KILL ^TMP("LEXSCH",$JOB,"EXC"),^TMP("LEXSCH",$JOB,"EXM"),^TMP("LEXSCH",$JOB,"NUM")
+48 if +$GET(^TMP("LEXSCH",$JOB,"ADF",0))=0
KILL ^TMP("LEXSCH",$JOB)
+49 IF $DATA(DIC(0))
Begin DoDot:1
+50 if DIC(0)["L"
SET DIC(0)=$PIECE(DIC(0),"L",1)_$PIECE(DIC(0),"L",2)
+51 if DIC(0)["I"
SET DIC(0)=$PIECE(DIC(0),"I",1)_$PIECE(DIC(0),"I",2)
End DoDot:1
+52 NEW LEXXNAR,LEXAFMT
SET LEXQ=1
SET LEXXNAR=$GET(LEXX)
SET LEXX=$$UP^XLFSTR($GET(LEXX))
+53 IF LEXX=""!(LEXX["^")
DO EN^LEXAR("^",$GET(LEXVDT))
KILL LEXAP
DO EXIT
QUIT
+54 NEW LEXSC
SET LEXSC=$$CAT($GET(LEXXCT),$GET(LEXXSR))
+55 NEW LEXXCT,LEXXSR
if +($PIECE(LEXSC,"^",1))>0
SET LEXXCT=+($PIECE(LEXSC,"^",1))
if +($PIECE(LEXSC,"^",2))>0
SET LEXXSR=+($PIECE(LEXSC,"^",2))
+56 SET LEXAP=$$UP^XLFSTR($GET(LEXAP))
+57 SET LEXLL=+$GET(LEXLL)
+58 SET LEXSUB=$GET(LEXSUB)
SET LEXAFMT=$GET(LEXFMT)
+59 SET ^TMP("LEXSCH",$JOB,"FMT",0)=+($GET(LEXAFMT))
SET ^TMP("LEXSCH",$JOB,"FMT",1)="Output Format"
+60 SET ^TMP("LEXSCH",$JOB,"APP",0)=+$$AP^LEXDFN2($GET(LEXAP))
if ^TMP("LEXSCH",$JOB,"APP",0)=0
SET ^TMP("LEXSCH",$JOB,"APP",0)=1
+61 if $LENGTH($GET(LEXDISP))
SET ^TMP("LEXSCH",$JOB,"DIS",0)=$GET(LEXDISP)
+62 if LEXSUB=""
SET LEXSUB=^TMP("LEXSCH",$JOB,"APP",0)
+63 if $LENGTH($GET(DIC("S")))
SET ^TMP("LEXSCH",$JOB,"FIL",0)=DIC("S")
+64 if LEXLL=0
SET LEXLL=5
+65 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)
NEW LEXDISP
+9 KILL ^TMP("LEXFND",$JOB),^TMP("LEXHIT",$JOB)
+10 DO MAN
IF $DATA(LEX("ERR"))
DO EXIT
QUIT
+11 DO SETUP^LEXAM($GET(^TMP("LEXSCH",$JOB,"VOC",0)))
+12 IF $DATA(LEX("ERR"))
DO EXIT
QUIT
LK ; Look-up Start Lookup
+1 NEW LEXSOA
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
+1 SET LEXFND=$$EN^LEXAI(^TMP("LEXSCH",$JOB,"NAR",0),$GET(LEXVDT))
+2 IF +LEXFND
DO EXIT
QUIT
SCT ; Look-up by Shortcuts EN^LEXASC Disabled in LEX*2.0*103
+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)
KILL ^TMP("LEXHIT",$JOB)
KEYWRD ; Look-up by word EN^LEXALK
+1 DO EN^LEXALK
EXIT ; Clean-up and quit End Lookup
+1 KILL LEXQ,LEXDICS,LEXFIL,LEXFILR,LEXDSP,LEXSHOW,LEXSHCT,LEXSUB
+2 KILL LEXOVR,LEXUN,LEXLKFL,LEXLKGL,LEXLKIX,LEXLKSH,LEXTKNS,LEXTKN
+3 KILL LEXI,LEXM
if $DATA(LEX("HLP"))
QUIT
+4 if $LENGTH(LEXX)
SET LEX("NAR")=LEXX
if $LENGTH(LEXXNAR)
SET LEX("NAR")=LEXXNAR
SET LEX=0
+5 if $LENGTH($GET(LEX("NAR")))
SET ^TMP("LEXSCH",$JOB,"NAR",0)=$GET(LEX("NAR"))
+6 if $GET(^TMP("LEXSCH",$JOB,"NUM",0))>0
SET LEX=$GET(^TMP("LEXSCH",$JOB,"NUM",0))
+7 if $DATA(LEX("ERR"))
DO CLN
+8 IF $DATA(LEX)
IF +$GET(LEX)=0
IF '$DATA(LEX("LIST"))
IF $LENGTH($GET(LEXX))
Begin DoDot:1
+9 NEW LEXC,LEXF,LEXV,LEXM,LEXL
+10 SET LEXC=1
+11 SET LEXF=$GET(^TMP("LEXSCH",$JOB,"FIL",0))
+12 SET LEXV=$GET(^TMP("LEXSCH",$JOB,"VOC",0))
+13 if +$GET(^TMP("LEXSCH",$JOB,"UNR",0))>0
DO EN^LEXAR(LEXX,$GET(LEXVDT))
+14 if $LENGTH(LEXX)
SET LEX("NAR")=LEXX
if $LENGTH(LEXXNAR)
SET LEX("NAR")=LEXXNAR
SET LEX=0
+15 if $LENGTH($GET(LEX("NAR")))
SET ^TMP("LEXSCH",$JOB,"NAR",0)=$GET(LEX("NAR"))
+16 if '$DATA(LEX("HLP"))
SET LEX("HLP",LEXC)=" A suitable term could not be found based on user input"
+17 if LEXF="I 1"
SET LEXF=""
+18 IF $LENGTH(LEXF)!(LEXV'="WRD")
IF '$DATA(LEX("HLP"))
Begin DoDot:2
+19 SET LEX("HLP",LEXC)=$GET(LEX("HLP",LEXC))_" and "
+20 SET LEXC=LEXC+1
+21 SET LEX("HLP",LEXC)=" current user defaults"
+22 SET LEX("HLP",0)=LEXC
End DoDot:2
+23 if '$DATA(LEX("HLP"))
SET LEX("HLP",LEXC)=$GET(LEX("HLP",LEXC))_"."
End DoDot:1
+24 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
+22 ;
INC(X) ; Increment Expression Frequency
+1 ;
+2 ; Input
+3 ;
+4 ; X Internal Entry Number in file 757.01
+5 ;
+6 ; Output
+7 ;
+8 ; None
+9 ;
+10 ; This API increments the Frequency counter for an expressions
+11 ; Major Concept. This will cause the expression to occur higher
+12 ; on the selection list, effectively placing the most frequently
+13 ; used terms at the top of the list.
+14 DO INC^LEXAR8(+($GET(X)))
+15 QUIT
+16 ;
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 !
