- 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 Feb 18, 2025@23:32:51 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 !