- 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 !
