Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: LEXA

LEXA.m

Go to the documentation of this file.
  1. 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
  1. ;
  1. ; Global Variables
  1. ; ^LEX(757.01 SACC 1.3
  1. ; ^LEX(757.13 SACC 1.3
  1. ; ^LEX(757.14 SACC 1.3
  1. ; ^LEX(757.41 SACC 1.3
  1. ; ^LEXT(757.2 SACC 1.3
  1. ; ^TMP("LEXFND",$J) SACC 2.3.2.5.1
  1. ; ^TMP("LEXHIT",$J) SACC 2.3.2.5.1
  1. ; ^TMP("LEXSCH",$J) SACC 2.3.2.5.1
  1. ;
  1. ; External References
  1. ; ^DIM ICR 10016
  1. ; $$GET1^DIQ ICR 2056
  1. ; $$DT^XLFDT ICR 10103
  1. ; $$UP^XLFSTR ICR 10104
  1. ;
  1. LOOK(LEXX,LEXAP,LEXLL,LEXSUB,LEXCDT,LEXXSR,LEXXCT,LEXFMT) ; Main Lexicon Lookup
  1. ;
  1. ; Input
  1. ;
  1. ; Parameters
  1. ; LEXX User Input
  1. ; LEXAP Application
  1. ; LEXLL Selection List Length
  1. ; LEXSUB Mode/Subset (file 757.2)
  1. ; LEXVDT Date to use for retrieving/displaying codes
  1. ; LEXXSR Source (file 757.14)
  1. ; LEXXCT Category (file 757.13)
  1. ; LEXFMT Output Format
  1. ; 0 Default, Display Text
  1. ; 1 Parsed Format
  1. ;
  1. ; Optional Global search parameters
  1. ; ^TMP("LEXSCH",$J,PAR)=VALUE
  1. ;
  1. ; Output
  1. ;
  1. ; Global Arrays
  1. ; Expressions found ^TMP("LEXFND",$J,FQ,IEN)=DT
  1. ; Review List ^TMP("LEXHITS",$J,#)=IEN^DT
  1. ;
  1. ; Local Array
  1. ; Display List LEX("LIST",#)
  1. ;
  1. ; Default Format LEXFMT'>0
  1. ;
  1. ; LEX("LIST",0)=LAST^TOTAL
  1. ; LEX("LIST",#)=IEN^Expression (coding system and code)
  1. ;
  1. ; LEX("LIST",1)="301253^Bone Age Studies (CPT-4 77072)"
  1. ;
  1. ; Parsed Format LEXFMT=1
  1. ;
  1. ; LEX("LIST",0)=LAST^TOTAL
  1. ; LEX("LIST",#)=IEN^Expression
  1. ; LEX("LIST",#,Source)=Code^Coding System
  1. ;
  1. ; LEX("LIST",1)="301253^Bone Age Studies"
  1. ; LEX("LIST",1,3)="77072^CPT-4"
  1. ;
  1. ;
  1. S LEXCDT=$P($G(LEXCDT),".",1) S:LEXCDT?7N LEXVDT=LEXCDT D VDT^LEXU K DIERR,LEX
  1. K ^TMP("LEXFND",$J),^TMP("LEXHIT",$J)
  1. K ^TMP("LEXSCH",$J,"EXC"),^TMP("LEXSCH",$J,"EXM"),^TMP("LEXSCH",$J,"NUM")
  1. K:+$G(^TMP("LEXSCH",$J,"ADF",0))=0 ^TMP("LEXSCH",$J)
  1. I $D(DIC(0)) D
  1. .S:DIC(0)["L" DIC(0)=$P(DIC(0),"L",1)_$P(DIC(0),"L",2)
  1. .S:DIC(0)["I" DIC(0)=$P(DIC(0),"I",1)_$P(DIC(0),"I",2)
  1. N LEXXNAR,LEXAFMT S LEXQ=1,LEXXNAR=$G(LEXX),LEXX=$$UP^XLFSTR($G(LEXX))
  1. I LEXX=""!(LEXX["^") D EN^LEXAR("^",$G(LEXVDT)) K LEXAP D EXIT Q
  1. N LEXSC S LEXSC=$$CAT($G(LEXXCT),$G(LEXXSR))
  1. N LEXXCT,LEXXSR S:+($P(LEXSC,"^",1))>0 LEXXCT=+($P(LEXSC,"^",1)) S:+($P(LEXSC,"^",2))>0 LEXXSR=+($P(LEXSC,"^",2))
  1. S LEXAP=$$UP^XLFSTR($G(LEXAP))
  1. S LEXLL=+$G(LEXLL)
  1. S LEXSUB=$G(LEXSUB),LEXAFMT=$G(LEXFMT)
  1. S ^TMP("LEXSCH",$J,"FMT",0)=+($G(LEXAFMT)),^TMP("LEXSCH",$J,"FMT",1)="Output Format"
  1. S ^TMP("LEXSCH",$J,"APP",0)=+$$AP^LEXDFN2($G(LEXAP)) S:^TMP("LEXSCH",$J,"APP",0)=0 ^TMP("LEXSCH",$J,"APP",0)=1
  1. S:$L($G(LEXDISP)) ^TMP("LEXSCH",$J,"DIS",0)=$G(LEXDISP)
  1. S:LEXSUB="" LEXSUB=^TMP("LEXSCH",$J,"APP",0)
  1. S:$L($G(DIC("S"))) ^TMP("LEXSCH",$J,"FIL",0)=DIC("S")
  1. S:LEXLL=0 LEXLL=5
  1. S ^TMP("LEXSCH",$J,"LEN",0)=LEXLL
  1. X ; Search for X
  1. I '$L($G(LEXX)) D D EXIT Q
  1. .S LEX("ERR",0)=$G(LEX("ERR",0))+1
  1. .S LEX("ERR",LEX("ERR",0))="User input LEXX missing or invalid"
  1. APP ; Application
  1. I +$G(^TMP("LEXSCH",$J,"APP",0))=0!('$D(^LEXT(757.2,+$G(^TMP("LEXSCH",$J,"APP",0)),0))) D D EXIT Q
  1. .S LEX("ERR",0)=$G(LEX("ERR",0))+1
  1. .S LEX("ERR",LEX("ERR",0))="Calling application identification LEXAP missing or invalid"
  1. USR ; User
  1. I +$G(DUZ)=0!('$L($$GET1^DIQ(200,+($G(DUZ)),.01))) D D EXIT Q
  1. .S LEX("ERR",0)=$G(LEX("ERR",0))+1
  1. .S LEX("ERR",LEX("ERR",0))="User identification DUZ missing or invalid"
  1. N LEXFND,LEXISCD
  1. S (LEXFND,LEXISCD)=0
  1. S ^TMP("LEXSCH",$J,"USR",0)=+$G(DUZ)
  1. S ^TMP("LEXSCH",$J,"NAR",0)=LEXX
  1. S ^TMP("LEXSCH",$J,"SCH",0)=$$UP^XLFSTR(LEXX)
  1. DEF ; Defaults CONFIG^LEXSET
  1. N LEXFIL,LEXDSP,LEXFILR S:$L($G(DIC("S"))) LEXFIL=DIC("S")
  1. I '$L($G(LEXFIL)),$L($G(^TMP("LEXSCH",$J,"FIL",0))) S LEXFIL=^TMP("LEXSCH",$J,"FIL",0)
  1. N LEXNS,LEXSS S LEXNS=$$NS^LEXDFN2(LEXAP),LEXSS=$$MD^LEXDFN2(LEXSUB)
  1. I +$G(^TMP("LEXSCH",$J,"ADF",0))=0 D CONFIG^LEXSET(LEXNS,LEXSS,$G(LEXVDT))
  1. S:$L($G(LEXDISP)) ^TMP("LEXSCH",$J,"DIS",0)=$G(LEXDISP)
  1. I '$L($G(LEXFIL)),$L($G(^TMP("LEXSCH",$J,"FIL",0))) S LEXFIL=^TMP("LEXSCH",$J,"FIL",0)
  1. S:$L($G(LEXFIL)) LEXFIL=$$FIL(LEXFIL)
  1. S LEXFIL=$G(LEXFIL) N LEXDISP
  1. K ^TMP("LEXFND",$J),^TMP("LEXHIT",$J)
  1. D MAN I $D(LEX("ERR")) D EXIT Q
  1. D SETUP^LEXAM($G(^TMP("LEXSCH",$J,"VOC",0)))
  1. I $D(LEX("ERR")) D EXIT Q
  1. LK ; Look-up Start Lookup
  1. N LEXSOA
  1. HLP ; Look-up Help ADDL^LEXAL
  1. I (LEXX["?"&($P(LEXX,"?",2)'?1N.N))!(LEXX["??") D I $D(LEX("HLP")) D EXIT Q
  1. . D QMH^LEXAR3(LEXX)
  1. IEN ; Look-up by IEN ADDL^LEXAL
  1. S LEXFND=$$EN^LEXAI(^TMP("LEXSCH",$J,"NAR",0),$G(LEXVDT))
  1. I +LEXFND D EXIT Q
  1. SCT ; Look-up by Shortcuts EN^LEXASC Disabled in LEX*2.0*103
  1. I +$G(^TMP("LEXSCH",$J,"SCT",0)),$D(^LEX(757.41,^TMP("LEXSCH",$J,"SCT",0))) D
  1. . S LEXFND=$$EN^LEXASC(^TMP("LEXSCH",$J,"SCH",0),^TMP("LEXSCH",$J,"SCT",0),$G(LEXVDT))
  1. I +LEXFND D EXIT Q
  1. CODE ; Look-up by Code EN^LEXABC
  1. S LEXFND=$$EN^LEXABC(^TMP("LEXSCH",$J,"SCH",0),$G(LEXVDT))
  1. I +LEXFND D EXIT Q
  1. I $L($G(^TMP("LEXSCH",$J,"SCH",0))) D
  1. . S:$D(^LEX(757.01,"AWRD",^TMP("LEXSCH",$J,"SCH",0))) LEXISCD=0
  1. I +LEXFND'>0,+($G(LEXISCD))>0 D EXIT Q
  1. EXACT ; Look-up Exact Match EN^LEXAB
  1. S LEXFND=$$EN^LEXAB(^TMP("LEXSCH",$J,"SCH",0),$G(LEXVDT))
  1. K:+LEXFND=0 ^TMP("LEXFND",$J) K ^TMP("LEXHIT",$J)
  1. KEYWRD ; Look-up by word EN^LEXALK
  1. D EN^LEXALK
  1. EXIT ; Clean-up and quit End Lookup
  1. K LEXQ,LEXDICS,LEXFIL,LEXFILR,LEXDSP,LEXSHOW,LEXSHCT,LEXSUB
  1. K LEXOVR,LEXUN,LEXLKFL,LEXLKGL,LEXLKIX,LEXLKSH,LEXTKNS,LEXTKN
  1. K LEXI,LEXM Q:$D(LEX("HLP"))
  1. S:$L(LEXX) LEX("NAR")=LEXX S:$L(LEXXNAR) LEX("NAR")=LEXXNAR S LEX=0
  1. S:$L($G(LEX("NAR"))) ^TMP("LEXSCH",$J,"NAR",0)=$G(LEX("NAR"))
  1. S:$G(^TMP("LEXSCH",$J,"NUM",0))>0 LEX=$G(^TMP("LEXSCH",$J,"NUM",0))
  1. D:$D(LEX("ERR")) CLN
  1. I $D(LEX),+$G(LEX)=0,'$D(LEX("LIST")),$L($G(LEXX)) D
  1. . N LEXC,LEXF,LEXV,LEXM,LEXL
  1. . S LEXC=1
  1. . S LEXF=$G(^TMP("LEXSCH",$J,"FIL",0))
  1. . S LEXV=$G(^TMP("LEXSCH",$J,"VOC",0))
  1. . D:+$G(^TMP("LEXSCH",$J,"UNR",0))>0 EN^LEXAR(LEXX,$G(LEXVDT))
  1. . S:$L(LEXX) LEX("NAR")=LEXX S:$L(LEXXNAR) LEX("NAR")=LEXXNAR S LEX=0
  1. . S:$L($G(LEX("NAR"))) ^TMP("LEXSCH",$J,"NAR",0)=$G(LEX("NAR"))
  1. . S:'$D(LEX("HLP")) LEX("HLP",LEXC)=" A suitable term could not be found based on user input"
  1. . S:LEXF="I 1" LEXF=""
  1. . I $L(LEXF)!(LEXV'="WRD"),'$D(LEX("HLP")) D
  1. . . S LEX("HLP",LEXC)=$G(LEX("HLP",LEXC))_" and "
  1. . . S LEXC=LEXC+1
  1. . . S LEX("HLP",LEXC)=" current user defaults"
  1. . . S LEX("HLP",0)=LEXC
  1. . S:'$D(LEX("HLP")) LEX("HLP",LEXC)=$G(LEX("HLP",LEXC))_"."
  1. Q
  1. CLN ; Clean
  1. K LEXQ,LEXTKNS,LEXTKN,LEXI
  1. K ^TMP("LEXSCH",$J),^TMP("LEXHIT",$J),^TMP("LEXFND",$J)
  1. Q
  1. MAN ; Mandatory variables
  1. N LEXERR
  1. F LEXERR="SCH","VOC","APP","USR" D
  1. .I '$L($G(^TMP("LEXSCH",$J,LEXERR,0))) D
  1. ..S LEX("ERR",0)=$G(LEX("ERR",0))+1
  1. ..S LEX("ERR",LEX("ERR",0))="Mandatory variable ^TMP(""LEXSCH"",$J,"""_LEXERR_""",0) missing or invalid"
  1. Q
  1. CAT(X,Y) ; Source Category
  1. 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))) ""
  1. 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
  1. S LEXU=$$UP^XLFSTR(LEX),(X,LEXC)=+($O(^LEX(757.13,"C",LEXU,0))) Q:'$D(^LEX(757.13,"C",LEXU)) ""
  1. I +LEXC>0,LEXC=+($O(^LEX(757.13,"C",LEXU," "),-1)) S X=+LEXC S:+LEXS>0 X=X_"^"_+LEXS Q X
  1. S LEXO="",LEXI=0 F S LEXI=$O(^LEX(757.13,"C",LEXU,LEXI)) Q:+LEXI'>0 D Q:+LEXO>0
  1. . S:$P($G(^LEX(757.13,LEXI,4)),"^",1)=LEXS LEXO=LEXI
  1. S X="" S:+LEXO>0 X=+LEXO S:+LEXO>0&(+LEXS>0) X=X_"^"_+LEXS
  1. Q X
  1. SRC(X) ; Source
  1. 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
  1. 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
  1. Q ""
  1. FIL(X) ; Validate Filter
  1. S X=$G(X) N DIC Q:'$L(X) X D ^DIM S:'$D(X) X=""
  1. Q X
  1. ;
  1. INFO(X,LEXVDT) ; Get Information about a Term
  1. ;
  1. ; Input
  1. ;
  1. ; X Internal Entry Number in file 757.01
  1. ; LEXVDT Optional date - retrieves codes active
  1. ; on a specified date
  1. ;
  1. ; Output
  1. ;
  1. ; Local Array LEX("SEL") or null
  1. ;
  1. ; LEX("SEL","EXP") Expressions Concepts/Synonyms/Variants
  1. ; LEX("SEL","SIG") Expression definition
  1. ; LEX("SEL","SRC") Classification Codes
  1. ; LEX("SEL"."STY") Semantic Class/Semantic Types
  1. ; LEX("SEL","VAS") VA Classification Sources
  1. ;
  1. K LEX("SEL") S X=+$G(X) Q:X=0 Q:'$D(^LEX(757.01,X,0))
  1. N LEXD S LEXD=$G(LEXVDT) S:+LEXD'>0 LEXD=$$DT^XLFDT
  1. N LEXVDT S LEXVDT=LEXD D SET^LEXAR4(X,LEXVDT)
  1. Q
  1. ;
  1. INC(X) ; Increment Expression Frequency
  1. ;
  1. ; Input
  1. ;
  1. ; X Internal Entry Number in file 757.01
  1. ;
  1. ; Output
  1. ;
  1. ; None
  1. ;
  1. ; This API increments the Frequency counter for an expressions
  1. ; Major Concept. This will cause the expression to occur higher
  1. ; on the selection list, effectively placing the most frequently
  1. ; used terms at the top of the list.
  1. D INC^LEXAR8(+($G(X)))
  1. Q
  1. ;
  1. SCH ; Search Parameters
  1. N NN,NC S NN="^TMP(""LEXSCH"","_$J_")",NC="^TMP(""LEXSCH"","_$J_","
  1. W ! F S NN=$Q(@NN) Q:'$L(NN)!(NN'[NC) W !,NN,"=",@NN
  1. W !