LEXAL ;ISL/KER - Look-up List (Global) ;05/23/2017
;;2.0;LEXICON UTILITY;**6,55,80,103**;Sep 23, 1996;Build 2
;
; Global Variables
; ^LEX(757 SACC 1.3
; ^LEX(757.01 SACC 1.3
; ^LEX(757.02 SACC 1.3
; ^LEX(757.1 SACC 1.3
; ^LEX(757.13 SACC 1.3
; ^LEX(757.14 SACC 1.3
; ^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
; $$DT^XLFDT ICR 10103
; $$UP^XLFSTR ICR 10103
;
; Local Variables NEWed or KILLed Elsewhere
; LEX Output Array
; LEXAFMT Output Format
; LEXSOA Code Array
; LEXTKN Token Array
; LEXVDT Versioning Date
; LEXXCT Category
; LEXXSR Category Source
;
; Add to the list
ADDL(LEXI,LEXDS,LEXDP) ; Add
; LEXI Expression IEN
; LEXDS Expression IEN
N LEXA S LEXA=$G(LEXI) Q:LEXA=0 Q:'$D(^LEX(757.01,LEXA)) S LEXI=$$SIEN(LEXA)
S:+LEXI>0&(LEXI'=LEXA) LEXA=LEXI Q:LEXA=0 Q:'$D(^LEX(757.01,LEXA))
S LEXDS=$G(LEXDS),LEXDP=$G(LEXDP)
N LEXF,LEXT,LEXL,LEXC
S LEXT=$G(^LEX(757.01,+LEXA,0)) S:+($G(LEXAFMT))'>0 LEXT=$$DISP(LEXA,LEXDS,LEXDP)
S:$D(LEXIGN)&($P($G(^LEX(757.01,LEXA,1)),"^",5)>0) LEXT=LEXT_" (Deactivated Term)"
S LEXF=$$LSTN(LEXA,"A")
S:'$D(^TMP("LEXFND",$J,-LEXF,LEXA)) ^TMP("LEXSCH",$J,"NUM",0)=$G(^TMP("LEXSCH",$J,"NUM",0))+1
S ^TMP("LEXFND",$J,-LEXF,LEXA)=LEXT
I +($G(LEXAFMT))>0 D
. N LEXI S LEXI=0 F S LEXI=$O(LEXSOA(LEXI)) Q:+LEXI'>0 D
. . I $D(LEXSOA(+LEXI,"P")) S ^TMP("LEXFND",$J,-LEXF,LEXA,LEXI)=$G(LEXSOA(+LEXI,"P")) Q
. . N LEXN S LEXN=$O(LEXSOA(+LEXI,0)) I LEXN>0 S ^TMP("LEXFND",$J,-LEXF,LEXA,LEXI)=$G(LEXSOA(+LEXI,+LEXN)) Q
S:+LEXF'=0 ^TMP("LEXFND",$J,0)=LEXF
S LEX=$G(^TMP("LEXSCH",$J,"NUM",0))
Q
ADDN(LEXI,LEXDS,LEXDP) ; Near match
N LEXA S LEXA=$G(LEXI) Q:LEXA=0 Q:'$D(^LEX(757.01,LEXA))
S LEXI=$$SIEN(LEXA) S:+LEXI>0&(LEXI'=LEXA) LEXA=LEXI Q:LEXA=0 Q:'$D(^LEX(757.01,LEXA))
N LEXR,LEXN,LEXT S LEXR=LEXA Q:$D(^TMP("LEXFND",$J,-99999997,LEXA))
S LEXN=-99999997
F S LEXN=LEXN+1 Q:'$D(^TMP("LEXFND",$J,LEXN,0))
I $P($G(^LEX(757.01,LEXA,1)),"^",2)'=1 D Q:+LEXA=0
. S LEXA=+($G(^LEX(757.01,LEXA,1))),LEXA=+($G(^LEX(757,LEXA,0)))
S LEXDS=$G(LEXDS),LEXDP=$G(LEXDP),LEXT=$$DISP(LEXA,LEXDS,LEXDP)
S:$D(LEXIGN)&($P($G(^LEX(757.01,LEXA,1)),"^",5)>0) LEXT=LEXT_"(Deactivated Term)"
S:'$D(^TMP("LEXFND",$J,-LEXF,LEXA)) ^TMP("LEXSCH",$J,"NUM",0)=$G(^TMP("LEXSCH",$J,"NUM",0))+1
S ^TMP("LEXFND",$J,LEXN,LEXA)=LEXT
S:LEXN<$G(^TMP("LEXFND",$J,0)) ^TMP("LEXFND",$J,0)=LEXN
S LEX=$G(^TMP("LEXSCH",$J,"NUM",0))
Q
ADDE(LEXI,LEXDS,LEXDP) ; Exact match
N LEXA S LEXA=$G(LEXI) Q:LEXA=0 Q:'$D(^LEX(757.01,LEXA)) S LEXI=$$SIEN(LEXA) S:+LEXI>0&(LEXI'=LEXA) LEXA=LEXI
Q:LEXA=0 Q:'$D(^LEX(757.01,LEXA)) N LEXR,LEXT,LEXEX,LEXSR,LEXSY,LEXSI
S LEXR=LEXA,LEXDS=$G(LEXDS),LEXDP=$G(LEXDP),LEXT=$$DISP(LEXA,LEXDS,LEXDP)
S:$D(LEXIGN)&($P($G(^LEX(757.01,LEXA,1)),"^",5)>0) LEXT=LEXT_"(Deactivated Term)"
S:'$D(^TMP("LEXFND",$J,-99999999,LEXA)) ^TMP("LEXSCH",$J,"NUM",0)=$G(^TMP("LEXSCH",$J,"NUM",0))+1
S:+($G(LEXAFMT))>0 LEXT=$G(^LEX(757.01,LEXA,0))
S ^TMP("LEXFND",$J,-99999999,LEXA)=LEXT,^TMP("LEXFND",$J,0)=-99999999
I +($G(LEXAFMT))>0,$O(LEXSOA(0))>0 D
. N LEXSI S LEXSI=0 S LEXSI=$O(LEXSOA(LEXSI)) Q:+LEXSI'>0 D
. . I $D(LEXSOA(+LEXSI,"P")) S ^TMP("LEXFND",$J,-99999999,LEXA,LEXSI)=$G(LEXSOA(+LEXSI,"P")) Q
. . N LEXN S LEXN=$O(LEXSOA(+LEXSI,0))
. . I LEXN>0 S ^TMP("LEXFND",$J,-99999999,LEXA,LEXSI)=$G(LEXSOA(+LEXSI,+LEXN))
S LEX=$G(^TMP("LEXSCH",$J,"NUM",0))
Q
ADDEM(LEXI,LEXDS,LEXDP) ; Exact match Major Concept
N LEXA,LEXEX S LEXA=$G(LEXI) Q:LEXA=0 Q:'$D(^LEX(757.01,LEXA))
S LEXI=$$SIEN(LEXA) S:+LEXI>0&(LEXI'=LEXA) LEXA=LEXI Q:LEXA=0 Q:'$D(^LEX(757.01,LEXA))
S LEXEX=$G(^LEX(757.01,LEXA,0))
N LEXR,LEXT S LEXR=LEXA Q:$P($G(^LEX(757.01,LEXA,1)),"^",2)'=1
S LEXDS=$G(LEXDS),LEXDP=$G(LEXDP),LEXT=$$DISP(LEXA,LEXDS,LEXDP)
S:+($G(LEXAFMT))>0 LEXT=$G(^LEX(757.01,LEXA,0))
S:$D(LEXIGN)&($P($G(^LEX(757.01,LEXA,1)),"^",5)>0) LEXT=LEXT_"(Deactivated Term)"
S:'$D(^TMP("LEXFND",$J,-99999998,LEXA)) ^TMP("LEXSCH",$J,"NUM",0)=$G(^TMP("LEXSCH",$J,"NUM",0))+1
S ^TMP("LEXFND",$J,-99999998,LEXA)=LEXT,^TMP("LEXFND",$J,0)=-99999998
I +($G(LEXAFMT))>0,$O(LEXSOA(0))>0 D
. N LEXSI S LEXSI=0 S LEXSI=$O(LEXSOA(LEXSI)) Q:+LEXSI'>0 D
. . I $D(LEXSOA(+LEXSI,"P")) S ^TMP("LEXFND",$J,-99999998,LEXA,LEXSI)=$G(LEXSOA(+LEXSI,"P")) Q
. . N LEXN S LEXN=$O(LEXSOA(+LEXSI,0))
. . I LEXN>0 S ^TMP("LEXFND",$J,-99999998,LEXA,LEXSI)=$G(LEXSOA(+LEXSI,+LEXN))
S LEX=$G(^TMP("LEXSCH",$J,"NUM",0))
Q
ADDC(LEXI,LEXDS,LEXDP) ; Code
N LEXA S LEXA=$G(LEXI) Q:LEXA=0 Q:'$D(^LEX(757.01,LEXA)) S LEXI=$$SIEN(LEXA) S:+LEXI>0&(LEXI'=LEXA) LEXA=LEXI Q:LEXA=0 Q:'$D(^LEX(757.01,LEXA))
S LEXDS=$G(LEXDS),LEXDP=$G(LEXDP)
N LEXT,LEXF,LEXC S LEXC=+($G(^LEX(757.01,LEXA,1))) Q:LEXC=0
S LEXF=$G(^TMP("LEXFND",$J,0)) S:+LEXF=0 LEXF=-999999
S LEXF=LEXF+1 S LEXT=$$DISP(LEXA,LEXDS,LEXDP)
S:$D(LEXIGN)&($P($G(^LEX(757.01,LEXA,1)),"^",5)>0) LEXT=LEXT_"(Deactivated Term)"
S:'$D(^TMP("LEXFND",$J,-LEXF,LEXA)) ^TMP("LEXSCH",$J,"NUM",0)=$G(^TMP("LEXSCH",$J,"NUM",0))+1
S ^TMP("LEXFND",$J,LEXF,LEXA)=LEXT
S ^TMP("LEXFND",$J,0)=LEXF
S LEX=$G(^TMP("LEXSCH",$J,"NUM",0))
Q
DISP(LEXX,LEXDS,LEXDP) ; Display Text
S LEXX=$G(^LEX(757.01,LEXX,0)) I +($G(LEXAFMT))'>0 S:$L(LEXDS) LEXX=LEXX_" "_LEXDS S:$L(LEXDP) LEXX=LEXX_" "_LEXDP
Q LEXX
BEG ; Begin List
S:+($G(^TMP("LEXSCH",$J,"UNR",0)))>0&($L($G(^TMP("LEXSCH",$J,"NAR",0)))) LEX("NAR")=$G(^TMP("LEXSCH",$J,"NAR",0))
Q:'$D(^TMP("LEXFND",$J))
N LEXRL,LEXJ,LEXI,LEXA,LEXSTR,LEXDP
S LEXRL=0,LEXLL=+($G(LEXLL)) S:$G(^TMP("LEXSCH",$J,"LEN",0))>0 LEXLL=$G(^TMP("LEXSCH",$J,"LEN",0))
S:+LEXLL'>0 (LEXRL,LEXLL)=5 S LEXJ=0,LEXI=-9999999999
; Hit List ^TMP("LEXHIT",$J,#)
F S LEXI=$O(^TMP("LEXFND",$J,LEXI)) Q:+LEXI=0 D
. S LEXA=0
. F S LEXA=$O(^TMP("LEXFND",$J,LEXI,LEXA)) Q:+LEXA=0!(LEXJ=LEXLL) D Q:+LEXA=0!(LEXJ=LEXLL)
. . S LEXJ=LEXJ+1,LEXDP=^TMP("LEXFND",$J,LEXI,LEXA)
. . S ^TMP("LEXHIT",$J,0)=LEXJ
. . S ^TMP("LEXHIT",$J,LEXJ)=LEXA_"^"_LEXDP
. . I $O(^TMP("LEXFND",$J,LEXI,LEXA,0))>0 D
. . . N LEXK S LEXK=0 F S LEXK=$O(^TMP("LEXFND",$J,LEXI,LEXA,LEXK)) Q:+LEXK'>0 D
. . . . N LEXS S LEXS=$G(^TMP("LEXFND",$J,LEXI,LEXA,LEXK))
. . . . Q:'$L($P(LEXS,"^",1)) Q:'$L($P(LEXS,"^",2))
. . . . S ^TMP("LEXHIT",$J,LEXJ,LEXK)=LEXS
. . S:+($G(^TMP("LEXSCH",$J,"EXM",0)))=+LEXA ^TMP("LEXSCH",$J,"EXM",2)=LEXJ_"^"_$G(^LEX(757.01,+LEXA,0))
. . S:+($G(^TMP("LEXSCH",$J,"EXC",0)))=+LEXA ^TMP("LEXSCH",$J,"EXC",2)=LEXJ_"^"_$G(^LEX(757.01,+LEXA,0))
. . K ^TMP("LEXFND",$J,LEXI,LEXA)
; List LEX("LIST")
I $D(^TMP("LEXSCH",$J,"NUM",0)) S LEX=+($G(^TMP("LEXSCH",$J,"NUM",0)))
I LEXLL>0 D
. N LEXI,LEXJ S (LEXJ,LEXI)=0
. F S LEXJ=$O(^TMP("LEXHIT",$J,LEXJ)) Q:+LEXJ=0!(+LEXI=LEXLL) D Q:+LEXI=LEXLL
. . S LEXI=LEXI+1,LEX("LIST",LEXI)=^TMP("LEXHIT",$J,LEXJ)
. . I $O(^TMP("LEXHIT",$J,LEXJ,0))>0 D
. . . N LEXK S LEXK=0 F S LEXK=$O(^TMP("LEXHIT",$J,LEXJ,LEXK)) Q:+LEXK'>0 D
. . . . N LEXS S LEXS=$G(^TMP("LEXHIT",$J,LEXJ,LEXK))
. . . . S:$L(LEXS) LEX("LIST",LEXI,LEXK)=LEXS
. . S LEX("LIST",0)=LEXI_"^"_LEXI
. . S (LEX("MAX"),^TMP("LEXSCH",$J,"LST",0))=LEXI
S ^TMP("LEXSCH",$J,"TOL",0)=0 S:$D(LEX("LIST",1)) ^TMP("LEXSCH",$J,"TOL",0)=1
S LEX=+($G(^TMP("LEXSCH",$J,"NUM",0)))
S:^TMP("LEXSCH",$J,"TOL",0)=1&(+($G(LEX))>0) LEX("MAT")=+LEX_" match"_$S(+LEX>1:"es",1:"")_" found"
; Establish level of concept (1 = concept, >1= modifier) PCH 6
S LEX("LVL")=+($G(LEX("LVL"))) S:LEX("LVL")=0 LEX("LVL")=1
S:+($G(LEX("MAX")))>0 LEX("MIN")=1
I $L($G(^TMP("LEXSCH",$J,"EXM",2))) S LEX("EXM")=^TMP("LEXSCH",$J,"EXM",2)
I $L($G(^TMP("LEXSCH",$J,"EXC",2))) S LEX("EXC")=^TMP("LEXSCH",$J,"EXC",2)
S:+($G(^TMP("LEXSCH",$J,"UNR",0)))>0&($L($G(^TMP("LEXSCH",$J,"NAR",0)))) LEX("NAR")=$G(^TMP("LEXSCH",$J,"NAR",0))
Q:'$D(^TMP("LEXFND",$J)) K:+($G(LEXRL))>0 LEXLL
Q
LSTN(LEXA,LEXM) ; List Number
N LEXC,LEXL,LEXF,LEXK,LEXT,LEXU,LEXN,LEXI S LEXK=0
S LEXC=+($G(^LEX(757.01,LEXA,1))) Q:LEXC=0 0
S LEXT=$G(^LEX(757.01,LEXA,0)) Q:'$L(LEXT) 0
S LEXU=$$UP^XLFSTR(LEXT),LEXL=$L(LEXT) Q:LEXL=0 0
S LEXN=$$CON(LEXU,.LEXTKN),LEXI=$P(LEXN,"^",2)
S LEXN=+$P(LEXN,"^",1) S:LEXN>9 LEXN=9
S LEXL=245-LEXL S:$L(LEXL)=1 LEXL="00"_LEXL
N LEXC,LEXL,LEXF,LEXK S LEXK=0
S LEXC=+($G(^LEX(757.01,LEXA,1))) Q:LEXC=0 0
S LEXL=$L($G(^LEX(757.01,LEXA,0))) Q:LEXL=0 0
S LEXL=245-LEXL S:$L(LEXL)=1 LEXL="00"_LEXL
S:$L(LEXL)=2 LEXL="0"_LEXL S LEXL=$E(LEXL,1,3)
; Disable until after OCT 1, 2015
; S LEXF=$O(^LEX(757.001,"B",LEXC,0))
; S:+LEXF>0&($L($G(^LEX(757.001,+LEXF,0)))) LEXF=(+($P($G(^LEX(757.001,LEXF,0)),"^",3))+1)
S LEXF=+($$FREQ(LEXC,$G(LEXVDT)))+1,LEXN=+($G(LEXN))
S LEXK=$E(LEXN,1),LEXM=LEXF_"."_LEXK_LEXL
Q LEXM
CON(X,LEXX) ; Contains
;
; Input
;
; X Text String
; LEXX() An array of words passed by reference
; LEXX(1)=Word1
; LEXX(2)=Word2
; LEXX(n)=Wordn
;
; Output
;
; $$CON A 2 piece "^" delimited string
;
; 1 Number of words in LEXX() found in text X
; 2 The total number of words in array LEXX
;
N LEXI,LEXS,LEXN,LEXT S LEXN=0,LEXT=0,LEXU=$$UP^XLFSTR($G(X)) Q:'$L(LEXU) 0
S LEXI=0 F S LEXI=$O(LEXX(LEXI)) Q:+LEXI'>0 D
. N LEXS S LEXT=LEXT+1,LEXS=$$UP^XLFSTR($G(LEXX(LEXI))) Q:'$L(LEXS)
. I $E(LEXU,1,$L(LEXS))=LEXS S LEXN=LEXN+1 Q
. F LEXC=" ","/","-","(","[","<",">","{",":",";" I LEXU[(LEXC_LEXS) S LEXN=LEXN+1 Q
S X=LEXN_"^"_LEXT
Q X
Q
SIEN(X) ; Sourced IEN (PCH 55)
S X=$G(X) Q:+($G(LEXXSR))'>0&(+($G(LEXXCT))'>0) X Q:+($G(LEXXSR))>0&('$D(^LEX(757.14,+($G(LEXXSR)),0))) X Q:+($G(LEXXCT))>0&('$D(^LEX(757.13,+($G(LEXXCT)),0))) X
N LEXIEN,LEXSX,LEXEX,LEXMC S (X,LEXSX,LEXIEN)=+($G(X)) Q:+LEXIEN'>0 X Q:'$D(^LEX(757.01,+LEXIEN,1)) X S LEXMC=+($G(^LEX(757.01,+LEXIEN,1))) Q:+LEXMC'>0 X Q:'$D(^LEX(757,+LEXMC,0)) X
I +LEXXCT>0 D I LEXSX'=LEXIEN S X=LEXSX Q X
. S LEXEX=0 F S LEXEX=$O(^LEX(757.01,"AMC",+LEXMC,LEXEX)) Q:+LEXEX'>0 D Q:LEXSX'=LEXIEN
. . N LEXC S LEXC=$P($G(^LEX(757.01,+LEXEX,1)),"^",11) S:LEXC=LEXXCT LEXSX=LEXEX
I +LEXXSR>0 D I LEXSX'=LEXIEN S X=LEXSX Q X
. S LEXEX=0 F S LEXEX=$O(^LEX(757.01,"AMC",+LEXMC,LEXEX)) Q:+LEXEX'>0 D Q:LEXSX'=LEXIEN
. . N LEXC S LEXC=$P($G(^LEX(757.01,+LEXEX,1)),"^",12) S:LEXC=LEXXSR LEXSX=LEXEX
S X=LEXIEN
Q X
FREQ(X,Y) ; Get frequency based on codes and semantics
N LEXBD,LEXBEH,LEXCLA,LEXDIA,LEXEFF,LEXHIS,LEXI10
N LEXMC,LEXNF,LEXNUR,LEXPRO,LEXSAB,LEXSIEN,LEXSMC
N LEXTD,SA,SIEN S LEXMC=+($G(X)),X=0 Q:'$D(^LEX(757,LEXMC,0)) X
S LEXTD=$G(Y) S:LEXTD'?7N LEXTD=$$DT^XLFDT
N SA,LEXSAB,LEXSMC,LEXNUR,LEXI10,LEXBEH,LEXPRO,LEXDIA
S (SA,LEXNUR,LEXBEH,LEXPRO,LEXDIA,LEXI10,LEXSMC,X)=0,LEXNF=""
; ICD-10-CM 6
; ICD-10-PCS 5
; ICD-9 coded Diagnosis 4
; Behavior or non-ICD diagnosis 3
; Procedures 2
; Nursing 1
D SO I +LEXI10>0 S:+LEXDIA=1 (LEXNF,X)=6 Q X
I +LEXI10>0 S:+LEXDIA'=1 (LEXNF,X)=5 Q X
I X=0,+LEXDIA=1 S (LEXNF,X)=4 Q X
I '$L(LEXNF),+($G(LEXPRO))=1 S (LEXNF,X)=2 Q X
I '$L(LEXNF),+($G(LEXNUR))=1 S (LEXNF,X)=1 Q X
D SM I '$L(LEXNF),+($G(LEXSMC))>0 S (LEXNF,X)=3 Q X
I '$L(LEXNF) S (LEXNF,X)=0
Q X
;
SO ; Codes
N SIEN S LEXSIEN=0 F S LEXSIEN=$O(^LEX(757.02,"AMC",LEXMC,LEXSIEN)) Q:+LEXSIEN=0 D SOC
Q
SOC ; Set frequencey based on code
N LEXEFF,LEXHIS
S LEXEFF=$O(^LEX(757.02,LEXSIEN,4,"B",(LEXTD+.001)),-1) Q:LEXEFF'?7N
S LEXHIS=$O(^LEX(757.02,LEXSIEN,4,"B",LEXEFF," "),-1)
Q:$P($G(^LEX(757.02,LEXSIEN,4,+LEXHIS,0)),"^",2)'>0
S LEXSAB=$P($G(^LEX(757.02,LEXSIEN,0)),"^",3)
Q:LEXSAB=0
; ICD-10 CM/PCS
S:LEXSAB=30!(LEXSAB=31) LEXI10=1
; Diagnosis ICD-9 and ICD-10
S:LEXSAB=1!(LEXSAB=30) LEXDIA=1
; Procedures ICD-9, ICD-10, CPT and HCPCS
S:LEXSAB=2!(LEXSAB=31)!(LEXSAB=3)!(LEXSAB=4) LEXPRO=1
; Behaviors DSM-III and DSM-IV
S:LEXSAB=5!(LEXSAB=6) LEXBEH=1
; Nursing NANDA, NIC, NOC, HHC and Omaha
S:LEXSAB>10&(LEXSAB<16) LEXNUR=1
Q
;
SM ; Semantics - LEXBD Behavior and Disorders
S LEXSMC=0,LEXMC=+($G(LEXMC)) Q:'$D(^LEX(757,LEXMC,0)) N LEXCLA,LEXBD,LEXSIEN S (LEXBD,LEXSIEN)=0
F S LEXSIEN=$O(^LEX(757.1,"B",LEXMC,LEXSIEN)) Q:+LEXSIEN=0 D SMC
S LEXSMC=LEXBD
Q
SMC ; Set frequency based on semantic class
S LEXCLA=+($P($G(^LEX(757.1,LEXSIEN,0)),U,2))
; Behavior
S:LEXCLA=3&(LEXBD'>0) LEXBD=1
; Disease
S:LEXCLA=6 LEXBD=2
Q
CLR ; Clear
N LEXIGN
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLEXAL 12975 printed Apr 09, 2024@21:08:10 Page 2
LEXAL ;ISL/KER - Look-up List (Global) ;05/23/2017
+1 ;;2.0;LEXICON UTILITY;**6,55,80,103**;Sep 23, 1996;Build 2
+2 ;
+3 ; Global Variables
+4 ; ^LEX(757 SACC 1.3
+5 ; ^LEX(757.01 SACC 1.3
+6 ; ^LEX(757.02 SACC 1.3
+7 ; ^LEX(757.1 SACC 1.3
+8 ; ^LEX(757.13 SACC 1.3
+9 ; ^LEX(757.14 SACC 1.3
+10 ; ^TMP("LEXFND") SACC 2.3.2.5.1
+11 ; ^TMP("LEXHIT") SACC 2.3.2.5.1
+12 ; ^TMP("LEXSCH") SACC 2.3.2.5.1
+13 ;
+14 ; External References
+15 ; $$DT^XLFDT ICR 10103
+16 ; $$UP^XLFSTR ICR 10103
+17 ;
+18 ; Local Variables NEWed or KILLed Elsewhere
+19 ; LEX Output Array
+20 ; LEXAFMT Output Format
+21 ; LEXSOA Code Array
+22 ; LEXTKN Token Array
+23 ; LEXVDT Versioning Date
+24 ; LEXXCT Category
+25 ; LEXXSR Category Source
+26 ;
+27 ; Add to the list
ADDL(LEXI,LEXDS,LEXDP) ; Add
+1 ; LEXI Expression IEN
+2 ; LEXDS Expression IEN
+3 NEW LEXA
SET LEXA=$GET(LEXI)
if LEXA=0
QUIT
if '$DATA(^LEX(757.01,LEXA))
QUIT
SET LEXI=$$SIEN(LEXA)
+4 if +LEXI>0&(LEXI'=LEXA)
SET LEXA=LEXI
if LEXA=0
QUIT
if '$DATA(^LEX(757.01,LEXA))
QUIT
+5 SET LEXDS=$GET(LEXDS)
SET LEXDP=$GET(LEXDP)
+6 NEW LEXF,LEXT,LEXL,LEXC
+7 SET LEXT=$GET(^LEX(757.01,+LEXA,0))
if +($GET(LEXAFMT))'>0
SET LEXT=$$DISP(LEXA,LEXDS,LEXDP)
+8 if $DATA(LEXIGN)&($PIECE($GET(^LEX(757.01,LEXA,1)),"^",5)>0)
SET LEXT=LEXT_" (Deactivated Term)"
+9 SET LEXF=$$LSTN(LEXA,"A")
+10 if '$DATA(^TMP("LEXFND",$JOB,-LEXF,LEXA))
SET ^TMP("LEXSCH",$JOB,"NUM",0)=$GET(^TMP("LEXSCH",$JOB,"NUM",0))+1
+11 SET ^TMP("LEXFND",$JOB,-LEXF,LEXA)=LEXT
+12 IF +($GET(LEXAFMT))>0
Begin DoDot:1
+13 NEW LEXI
SET LEXI=0
FOR
SET LEXI=$ORDER(LEXSOA(LEXI))
if +LEXI'>0
QUIT
Begin DoDot:2
+14 IF $DATA(LEXSOA(+LEXI,"P"))
SET ^TMP("LEXFND",$JOB,-LEXF,LEXA,LEXI)=$GET(LEXSOA(+LEXI,"P"))
QUIT
+15 NEW LEXN
SET LEXN=$ORDER(LEXSOA(+LEXI,0))
IF LEXN>0
SET ^TMP("LEXFND",$JOB,-LEXF,LEXA,LEXI)=$GET(LEXSOA(+LEXI,+LEXN))
QUIT
End DoDot:2
End DoDot:1
+16 if +LEXF'=0
SET ^TMP("LEXFND",$JOB,0)=LEXF
+17 SET LEX=$GET(^TMP("LEXSCH",$JOB,"NUM",0))
+18 QUIT
ADDN(LEXI,LEXDS,LEXDP) ; Near match
+1 NEW LEXA
SET LEXA=$GET(LEXI)
if LEXA=0
QUIT
if '$DATA(^LEX(757.01,LEXA))
QUIT
+2 SET LEXI=$$SIEN(LEXA)
if +LEXI>0&(LEXI'=LEXA)
SET LEXA=LEXI
if LEXA=0
QUIT
if '$DATA(^LEX(757.01,LEXA))
QUIT
+3 NEW LEXR,LEXN,LEXT
SET LEXR=LEXA
if $DATA(^TMP("LEXFND",$JOB,-99999997,LEXA))
QUIT
+4 SET LEXN=-99999997
+5 FOR
SET LEXN=LEXN+1
if '$DATA(^TMP("LEXFND",$JOB,LEXN,0))
QUIT
+6 IF $PIECE($GET(^LEX(757.01,LEXA,1)),"^",2)'=1
Begin DoDot:1
+7 SET LEXA=+($GET(^LEX(757.01,LEXA,1)))
SET LEXA=+($GET(^LEX(757,LEXA,0)))
End DoDot:1
if +LEXA=0
QUIT
+8 SET LEXDS=$GET(LEXDS)
SET LEXDP=$GET(LEXDP)
SET LEXT=$$DISP(LEXA,LEXDS,LEXDP)
+9 if $DATA(LEXIGN)&($PIECE($GET(^LEX(757.01,LEXA,1)),"^",5)>0)
SET LEXT=LEXT_"(Deactivated Term)"
+10 if '$DATA(^TMP("LEXFND",$JOB,-LEXF,LEXA))
SET ^TMP("LEXSCH",$JOB,"NUM",0)=$GET(^TMP("LEXSCH",$JOB,"NUM",0))+1
+11 SET ^TMP("LEXFND",$JOB,LEXN,LEXA)=LEXT
+12 if LEXN<$GET(^TMP("LEXFND",$JOB,0))
SET ^TMP("LEXFND",$JOB,0)=LEXN
+13 SET LEX=$GET(^TMP("LEXSCH",$JOB,"NUM",0))
+14 QUIT
ADDE(LEXI,LEXDS,LEXDP) ; Exact match
+1 NEW LEXA
SET LEXA=$GET(LEXI)
if LEXA=0
QUIT
if '$DATA(^LEX(757.01,LEXA))
QUIT
SET LEXI=$$SIEN(LEXA)
if +LEXI>0&(LEXI'=LEXA)
SET LEXA=LEXI
+2 if LEXA=0
QUIT
if '$DATA(^LEX(757.01,LEXA))
QUIT
NEW LEXR,LEXT,LEXEX,LEXSR,LEXSY,LEXSI
+3 SET LEXR=LEXA
SET LEXDS=$GET(LEXDS)
SET LEXDP=$GET(LEXDP)
SET LEXT=$$DISP(LEXA,LEXDS,LEXDP)
+4 if $DATA(LEXIGN)&($PIECE($GET(^LEX(757.01,LEXA,1)),"^",5)>0)
SET LEXT=LEXT_"(Deactivated Term)"
+5 if '$DATA(^TMP("LEXFND",$JOB,-99999999,LEXA))
SET ^TMP("LEXSCH",$JOB,"NUM",0)=$GET(^TMP("LEXSCH",$JOB,"NUM",0))+1
+6 if +($GET(LEXAFMT))>0
SET LEXT=$GET(^LEX(757.01,LEXA,0))
+7 SET ^TMP("LEXFND",$JOB,-99999999,LEXA)=LEXT
SET ^TMP("LEXFND",$JOB,0)=-99999999
+8 IF +($GET(LEXAFMT))>0
IF $ORDER(LEXSOA(0))>0
Begin DoDot:1
+9 NEW LEXSI
SET LEXSI=0
SET LEXSI=$ORDER(LEXSOA(LEXSI))
if +LEXSI'>0
QUIT
Begin DoDot:2
+10 IF $DATA(LEXSOA(+LEXSI,"P"))
SET ^TMP("LEXFND",$JOB,-99999999,LEXA,LEXSI)=$GET(LEXSOA(+LEXSI,"P"))
QUIT
+11 NEW LEXN
SET LEXN=$ORDER(LEXSOA(+LEXSI,0))
+12 IF LEXN>0
SET ^TMP("LEXFND",$JOB,-99999999,LEXA,LEXSI)=$GET(LEXSOA(+LEXSI,+LEXN))
End DoDot:2
End DoDot:1
+13 SET LEX=$GET(^TMP("LEXSCH",$JOB,"NUM",0))
+14 QUIT
ADDEM(LEXI,LEXDS,LEXDP) ; Exact match Major Concept
+1 NEW LEXA,LEXEX
SET LEXA=$GET(LEXI)
if LEXA=0
QUIT
if '$DATA(^LEX(757.01,LEXA))
QUIT
+2 SET LEXI=$$SIEN(LEXA)
if +LEXI>0&(LEXI'=LEXA)
SET LEXA=LEXI
if LEXA=0
QUIT
if '$DATA(^LEX(757.01,LEXA))
QUIT
+3 SET LEXEX=$GET(^LEX(757.01,LEXA,0))
+4 NEW LEXR,LEXT
SET LEXR=LEXA
if $PIECE($GET(^LEX(757.01,LEXA,1)),"^",2)'=1
QUIT
+5 SET LEXDS=$GET(LEXDS)
SET LEXDP=$GET(LEXDP)
SET LEXT=$$DISP(LEXA,LEXDS,LEXDP)
+6 if +($GET(LEXAFMT))>0
SET LEXT=$GET(^LEX(757.01,LEXA,0))
+7 if $DATA(LEXIGN)&($PIECE($GET(^LEX(757.01,LEXA,1)),"^",5)>0)
SET LEXT=LEXT_"(Deactivated Term)"
+8 if '$DATA(^TMP("LEXFND",$JOB,-99999998,LEXA))
SET ^TMP("LEXSCH",$JOB,"NUM",0)=$GET(^TMP("LEXSCH",$JOB,"NUM",0))+1
+9 SET ^TMP("LEXFND",$JOB,-99999998,LEXA)=LEXT
SET ^TMP("LEXFND",$JOB,0)=-99999998
+10 IF +($GET(LEXAFMT))>0
IF $ORDER(LEXSOA(0))>0
Begin DoDot:1
+11 NEW LEXSI
SET LEXSI=0
SET LEXSI=$ORDER(LEXSOA(LEXSI))
if +LEXSI'>0
QUIT
Begin DoDot:2
+12 IF $DATA(LEXSOA(+LEXSI,"P"))
SET ^TMP("LEXFND",$JOB,-99999998,LEXA,LEXSI)=$GET(LEXSOA(+LEXSI,"P"))
QUIT
+13 NEW LEXN
SET LEXN=$ORDER(LEXSOA(+LEXSI,0))
+14 IF LEXN>0
SET ^TMP("LEXFND",$JOB,-99999998,LEXA,LEXSI)=$GET(LEXSOA(+LEXSI,+LEXN))
End DoDot:2
End DoDot:1
+15 SET LEX=$GET(^TMP("LEXSCH",$JOB,"NUM",0))
+16 QUIT
ADDC(LEXI,LEXDS,LEXDP) ; Code
+1 NEW LEXA
SET LEXA=$GET(LEXI)
if LEXA=0
QUIT
if '$DATA(^LEX(757.01,LEXA))
QUIT
SET LEXI=$$SIEN(LEXA)
if +LEXI>0&(LEXI'=LEXA)
SET LEXA=LEXI
if LEXA=0
QUIT
if '$DATA(^LEX(757.01,LEXA))
QUIT
+2 SET LEXDS=$GET(LEXDS)
SET LEXDP=$GET(LEXDP)
+3 NEW LEXT,LEXF,LEXC
SET LEXC=+($GET(^LEX(757.01,LEXA,1)))
if LEXC=0
QUIT
+4 SET LEXF=$GET(^TMP("LEXFND",$JOB,0))
if +LEXF=0
SET LEXF=-999999
+5 SET LEXF=LEXF+1
SET LEXT=$$DISP(LEXA,LEXDS,LEXDP)
+6 if $DATA(LEXIGN)&($PIECE($GET(^LEX(757.01,LEXA,1)),"^",5)>0)
SET LEXT=LEXT_"(Deactivated Term)"
+7 if '$DATA(^TMP("LEXFND",$JOB,-LEXF,LEXA))
SET ^TMP("LEXSCH",$JOB,"NUM",0)=$GET(^TMP("LEXSCH",$JOB,"NUM",0))+1
+8 SET ^TMP("LEXFND",$JOB,LEXF,LEXA)=LEXT
+9 SET ^TMP("LEXFND",$JOB,0)=LEXF
+10 SET LEX=$GET(^TMP("LEXSCH",$JOB,"NUM",0))
+11 QUIT
DISP(LEXX,LEXDS,LEXDP) ; Display Text
+1 SET LEXX=$GET(^LEX(757.01,LEXX,0))
IF +($GET(LEXAFMT))'>0
if $LENGTH(LEXDS)
SET LEXX=LEXX_" "_LEXDS
if $LENGTH(LEXDP)
SET LEXX=LEXX_" "_LEXDP
+2 QUIT LEXX
BEG ; Begin List
+1 if +($GET(^TMP("LEXSCH",$JOB,"UNR",0)))>0&($LENGTH($GET(^TMP("LEXSCH",$JOB,"NAR",0))))
SET LEX("NAR")=$GET(^TMP("LEXSCH",$JOB,"NAR",0))
+2 if '$DATA(^TMP("LEXFND",$JOB))
QUIT
+3 NEW LEXRL,LEXJ,LEXI,LEXA,LEXSTR,LEXDP
+4 SET LEXRL=0
SET LEXLL=+($GET(LEXLL))
if $GET(^TMP("LEXSCH",$JOB,"LEN",0))>0
SET LEXLL=$GET(^TMP("LEXSCH",$JOB,"LEN",0))
+5 if +LEXLL'>0
SET (LEXRL,LEXLL)=5
SET LEXJ=0
SET LEXI=-9999999999
+6 ; Hit List ^TMP("LEXHIT",$J,#)
+7 FOR
SET LEXI=$ORDER(^TMP("LEXFND",$JOB,LEXI))
if +LEXI=0
QUIT
Begin DoDot:1
+8 SET LEXA=0
+9 FOR
SET LEXA=$ORDER(^TMP("LEXFND",$JOB,LEXI,LEXA))
if +LEXA=0!(LEXJ=LEXLL)
QUIT
Begin DoDot:2
+10 SET LEXJ=LEXJ+1
SET LEXDP=^TMP("LEXFND",$JOB,LEXI,LEXA)
+11 SET ^TMP("LEXHIT",$JOB,0)=LEXJ
+12 SET ^TMP("LEXHIT",$JOB,LEXJ)=LEXA_"^"_LEXDP
+13 IF $ORDER(^TMP("LEXFND",$JOB,LEXI,LEXA,0))>0
Begin DoDot:3
+14 NEW LEXK
SET LEXK=0
FOR
SET LEXK=$ORDER(^TMP("LEXFND",$JOB,LEXI,LEXA,LEXK))
if +LEXK'>0
QUIT
Begin DoDot:4
+15 NEW LEXS
SET LEXS=$GET(^TMP("LEXFND",$JOB,LEXI,LEXA,LEXK))
+16 if '$LENGTH($PIECE(LEXS,"^",1))
QUIT
if '$LENGTH($PIECE(LEXS,"^",2))
QUIT
+17 SET ^TMP("LEXHIT",$JOB,LEXJ,LEXK)=LEXS
End DoDot:4
End DoDot:3
+18 if +($GET(^TMP("LEXSCH",$JOB,"EXM",0)))=+LEXA
SET ^TMP("LEXSCH",$JOB,"EXM",2)=LEXJ_"^"_$GET(^LEX(757.01,+LEXA,0))
+19 if +($GET(^TMP("LEXSCH",$JOB,"EXC",0)))=+LEXA
SET ^TMP("LEXSCH",$JOB,"EXC",2)=LEXJ_"^"_$GET(^LEX(757.01,+LEXA,0))
+20 KILL ^TMP("LEXFND",$JOB,LEXI,LEXA)
End DoDot:2
if +LEXA=0!(LEXJ=LEXLL)
QUIT
End DoDot:1
+21 ; List LEX("LIST")
+22 IF $DATA(^TMP("LEXSCH",$JOB,"NUM",0))
SET LEX=+($GET(^TMP("LEXSCH",$JOB,"NUM",0)))
+23 IF LEXLL>0
Begin DoDot:1
+24 NEW LEXI,LEXJ
SET (LEXJ,LEXI)=0
+25 FOR
SET LEXJ=$ORDER(^TMP("LEXHIT",$JOB,LEXJ))
if +LEXJ=0!(+LEXI=LEXLL)
QUIT
Begin DoDot:2
+26 SET LEXI=LEXI+1
SET LEX("LIST",LEXI)=^TMP("LEXHIT",$JOB,LEXJ)
+27 IF $ORDER(^TMP("LEXHIT",$JOB,LEXJ,0))>0
Begin DoDot:3
+28 NEW LEXK
SET LEXK=0
FOR
SET LEXK=$ORDER(^TMP("LEXHIT",$JOB,LEXJ,LEXK))
if +LEXK'>0
QUIT
Begin DoDot:4
+29 NEW LEXS
SET LEXS=$GET(^TMP("LEXHIT",$JOB,LEXJ,LEXK))
+30 if $LENGTH(LEXS)
SET LEX("LIST",LEXI,LEXK)=LEXS
End DoDot:4
End DoDot:3
+31 SET LEX("LIST",0)=LEXI_"^"_LEXI
+32 SET (LEX("MAX"),^TMP("LEXSCH",$JOB,"LST",0))=LEXI
End DoDot:2
if +LEXI=LEXLL
QUIT
End DoDot:1
+33 SET ^TMP("LEXSCH",$JOB,"TOL",0)=0
if $DATA(LEX("LIST",1))
SET ^TMP("LEXSCH",$JOB,"TOL",0)=1
+34 SET LEX=+($GET(^TMP("LEXSCH",$JOB,"NUM",0)))
+35 if ^TMP("LEXSCH",$JOB,"TOL",0)=1&(+($GET(LEX))>0)
SET LEX("MAT")=+LEX_" match"_$SELECT(+LEX>1:"es",1:"")_" found"
+36 ; Establish level of concept (1 = concept, >1= modifier) PCH 6
+37 SET LEX("LVL")=+($GET(LEX("LVL")))
if LEX("LVL")=0
SET LEX("LVL")=1
+38 if +($GET(LEX("MAX")))>0
SET LEX("MIN")=1
+39 IF $LENGTH($GET(^TMP("LEXSCH",$JOB,"EXM",2)))
SET LEX("EXM")=^TMP("LEXSCH",$JOB,"EXM",2)
+40 IF $LENGTH($GET(^TMP("LEXSCH",$JOB,"EXC",2)))
SET LEX("EXC")=^TMP("LEXSCH",$JOB,"EXC",2)
+41 if +($GET(^TMP("LEXSCH",$JOB,"UNR",0)))>0&($LENGTH($GET(^TMP("LEXSCH",$JOB,"NAR",0))))
SET LEX("NAR")=$GET(^TMP("LEXSCH",$JOB,"NAR",0))
+42 if '$DATA(^TMP("LEXFND",$JOB))
QUIT
if +($GET(LEXRL))>0
KILL LEXLL
+43 QUIT
LSTN(LEXA,LEXM) ; List Number
+1 NEW LEXC,LEXL,LEXF,LEXK,LEXT,LEXU,LEXN,LEXI
SET LEXK=0
+2 SET LEXC=+($GET(^LEX(757.01,LEXA,1)))
if LEXC=0
QUIT 0
+3 SET LEXT=$GET(^LEX(757.01,LEXA,0))
if '$LENGTH(LEXT)
QUIT 0
+4 SET LEXU=$$UP^XLFSTR(LEXT)
SET LEXL=$LENGTH(LEXT)
if LEXL=0
QUIT 0
+5 SET LEXN=$$CON(LEXU,.LEXTKN)
SET LEXI=$PIECE(LEXN,"^",2)
+6 SET LEXN=+$PIECE(LEXN,"^",1)
if LEXN>9
SET LEXN=9
+7 SET LEXL=245-LEXL
if $LENGTH(LEXL)=1
SET LEXL="00"_LEXL
+8 NEW LEXC,LEXL,LEXF,LEXK
SET LEXK=0
+9 SET LEXC=+($GET(^LEX(757.01,LEXA,1)))
if LEXC=0
QUIT 0
+10 SET LEXL=$LENGTH($GET(^LEX(757.01,LEXA,0)))
if LEXL=0
QUIT 0
+11 SET LEXL=245-LEXL
if $LENGTH(LEXL)=1
SET LEXL="00"_LEXL
+12 if $LENGTH(LEXL)=2
SET LEXL="0"_LEXL
SET LEXL=$EXTRACT(LEXL,1,3)
+13 ; Disable until after OCT 1, 2015
+14 ; S LEXF=$O(^LEX(757.001,"B",LEXC,0))
+15 ; S:+LEXF>0&($L($G(^LEX(757.001,+LEXF,0)))) LEXF=(+($P($G(^LEX(757.001,LEXF,0)),"^",3))+1)
+16 SET LEXF=+($$FREQ(LEXC,$GET(LEXVDT)))+1
SET LEXN=+($GET(LEXN))
+17 SET LEXK=$EXTRACT(LEXN,1)
SET LEXM=LEXF_"."_LEXK_LEXL
+18 QUIT LEXM
CON(X,LEXX) ; Contains
+1 ;
+2 ; Input
+3 ;
+4 ; X Text String
+5 ; LEXX() An array of words passed by reference
+6 ; LEXX(1)=Word1
+7 ; LEXX(2)=Word2
+8 ; LEXX(n)=Wordn
+9 ;
+10 ; Output
+11 ;
+12 ; $$CON A 2 piece "^" delimited string
+13 ;
+14 ; 1 Number of words in LEXX() found in text X
+15 ; 2 The total number of words in array LEXX
+16 ;
+17 NEW LEXI,LEXS,LEXN,LEXT
SET LEXN=0
SET LEXT=0
SET LEXU=$$UP^XLFSTR($GET(X))
if '$LENGTH(LEXU)
QUIT 0
+18 SET LEXI=0
FOR
SET LEXI=$ORDER(LEXX(LEXI))
if +LEXI'>0
QUIT
Begin DoDot:1
+19 NEW LEXS
SET LEXT=LEXT+1
SET LEXS=$$UP^XLFSTR($GET(LEXX(LEXI)))
if '$LENGTH(LEXS)
QUIT
+20 IF $EXTRACT(LEXU,1,$LENGTH(LEXS))=LEXS
SET LEXN=LEXN+1
QUIT
+21 FOR LEXC=" ","/","-","(","[","<",">","{",":",";"
IF LEXU[(LEXC_LEXS)
SET LEXN=LEXN+1
QUIT
End DoDot:1
+22 SET X=LEXN_"^"_LEXT
+23 QUIT X
+24 QUIT
SIEN(X) ; Sourced IEN (PCH 55)
+1 SET X=$GET(X)
if +($GET(LEXXSR))'>0&(+($GET(LEXXCT))'>0)
QUIT X
if +($GET(LEXXSR))>0&('$DATA(^LEX(757.14,+($GET(LEXXSR)),0)))
QUIT X
if +($GET(LEXXCT))>0&('$DATA(^LEX(757.13,+($GET(LEXXCT)),0)))
QUIT X
+2 NEW LEXIEN,LEXSX,LEXEX,LEXMC
SET (X,LEXSX,LEXIEN)=+($GET(X))
if +LEXIEN'>0
QUIT X
if '$DATA(^LEX(757.01,+LEXIEN,1))
QUIT X
SET LEXMC=+($GET(^LEX(757.01,+LEXIEN,1)))
if +LEXMC'>0
QUIT X
if '$DATA(^LEX(757,+LEXMC,0))
QUIT X
+3 IF +LEXXCT>0
Begin DoDot:1
+4 SET LEXEX=0
FOR
SET LEXEX=$ORDER(^LEX(757.01,"AMC",+LEXMC,LEXEX))
if +LEXEX'>0
QUIT
Begin DoDot:2
+5 NEW LEXC
SET LEXC=$PIECE($GET(^LEX(757.01,+LEXEX,1)),"^",11)
if LEXC=LEXXCT
SET LEXSX=LEXEX
End DoDot:2
if LEXSX'=LEXIEN
QUIT
End DoDot:1
IF LEXSX'=LEXIEN
SET X=LEXSX
QUIT X
+6 IF +LEXXSR>0
Begin DoDot:1
+7 SET LEXEX=0
FOR
SET LEXEX=$ORDER(^LEX(757.01,"AMC",+LEXMC,LEXEX))
if +LEXEX'>0
QUIT
Begin DoDot:2
+8 NEW LEXC
SET LEXC=$PIECE($GET(^LEX(757.01,+LEXEX,1)),"^",12)
if LEXC=LEXXSR
SET LEXSX=LEXEX
End DoDot:2
if LEXSX'=LEXIEN
QUIT
End DoDot:1
IF LEXSX'=LEXIEN
SET X=LEXSX
QUIT X
+9 SET X=LEXIEN
+10 QUIT X
FREQ(X,Y) ; Get frequency based on codes and semantics
+1 NEW LEXBD,LEXBEH,LEXCLA,LEXDIA,LEXEFF,LEXHIS,LEXI10
+2 NEW LEXMC,LEXNF,LEXNUR,LEXPRO,LEXSAB,LEXSIEN,LEXSMC
+3 NEW LEXTD,SA,SIEN
SET LEXMC=+($GET(X))
SET X=0
if '$DATA(^LEX(757,LEXMC,0))
QUIT X
+4 SET LEXTD=$GET(Y)
if LEXTD'?7N
SET LEXTD=$$DT^XLFDT
+5 NEW SA,LEXSAB,LEXSMC,LEXNUR,LEXI10,LEXBEH,LEXPRO,LEXDIA
+6 SET (SA,LEXNUR,LEXBEH,LEXPRO,LEXDIA,LEXI10,LEXSMC,X)=0
SET LEXNF=""
+7 ; ICD-10-CM 6
+8 ; ICD-10-PCS 5
+9 ; ICD-9 coded Diagnosis 4
+10 ; Behavior or non-ICD diagnosis 3
+11 ; Procedures 2
+12 ; Nursing 1
+13 DO SO
IF +LEXI10>0
if +LEXDIA=1
SET (LEXNF,X)=6
QUIT X
+14 IF +LEXI10>0
if +LEXDIA'=1
SET (LEXNF,X)=5
QUIT X
+15 IF X=0
IF +LEXDIA=1
SET (LEXNF,X)=4
QUIT X
+16 IF '$LENGTH(LEXNF)
IF +($GET(LEXPRO))=1
SET (LEXNF,X)=2
QUIT X
+17 IF '$LENGTH(LEXNF)
IF +($GET(LEXNUR))=1
SET (LEXNF,X)=1
QUIT X
+18 DO SM
IF '$LENGTH(LEXNF)
IF +($GET(LEXSMC))>0
SET (LEXNF,X)=3
QUIT X
+19 IF '$LENGTH(LEXNF)
SET (LEXNF,X)=0
+20 QUIT X
+21 ;
SO ; Codes
+1 NEW SIEN
SET LEXSIEN=0
FOR
SET LEXSIEN=$ORDER(^LEX(757.02,"AMC",LEXMC,LEXSIEN))
if +LEXSIEN=0
QUIT
DO SOC
+2 QUIT
SOC ; Set frequencey based on code
+1 NEW LEXEFF,LEXHIS
+2 SET LEXEFF=$ORDER(^LEX(757.02,LEXSIEN,4,"B",(LEXTD+.001)),-1)
if LEXEFF'?7N
QUIT
+3 SET LEXHIS=$ORDER(^LEX(757.02,LEXSIEN,4,"B",LEXEFF," "),-1)
+4 if $PIECE($GET(^LEX(757.02,LEXSIEN,4,+LEXHIS,0)),"^",2)'>0
QUIT
+5 SET LEXSAB=$PIECE($GET(^LEX(757.02,LEXSIEN,0)),"^",3)
+6 if LEXSAB=0
QUIT
+7 ; ICD-10 CM/PCS
+8 if LEXSAB=30!(LEXSAB=31)
SET LEXI10=1
+9 ; Diagnosis ICD-9 and ICD-10
+10 if LEXSAB=1!(LEXSAB=30)
SET LEXDIA=1
+11 ; Procedures ICD-9, ICD-10, CPT and HCPCS
+12 if LEXSAB=2!(LEXSAB=31)!(LEXSAB=3)!(LEXSAB=4)
SET LEXPRO=1
+13 ; Behaviors DSM-III and DSM-IV
+14 if LEXSAB=5!(LEXSAB=6)
SET LEXBEH=1
+15 ; Nursing NANDA, NIC, NOC, HHC and Omaha
+16 if LEXSAB>10&(LEXSAB<16)
SET LEXNUR=1
+17 QUIT
+18 ;
SM ; Semantics - LEXBD Behavior and Disorders
+1 SET LEXSMC=0
SET LEXMC=+($GET(LEXMC))
if '$DATA(^LEX(757,LEXMC,0))
QUIT
NEW LEXCLA,LEXBD,LEXSIEN
SET (LEXBD,LEXSIEN)=0
+2 FOR
SET LEXSIEN=$ORDER(^LEX(757.1,"B",LEXMC,LEXSIEN))
if +LEXSIEN=0
QUIT
DO SMC
+3 SET LEXSMC=LEXBD
+4 QUIT
SMC ; Set frequency based on semantic class
+1 SET LEXCLA=+($PIECE($GET(^LEX(757.1,LEXSIEN,0)),U,2))
+2 ; Behavior
+3 if LEXCLA=3&(LEXBD'>0)
SET LEXBD=1
+4 ; Disease
+5 if LEXCLA=6
SET LEXBD=2
+6 QUIT
CLR ; Clear
+1 NEW LEXIGN
+2 QUIT
