LEXAL ;ISL/KER - Look-up List (Global) ;04/21/2014
;;2.0;LEXICON UTILITY;**6,55,80**;Sep 23, 1996;Build 10
;
; Global Variables
; ^LEX(757.13 N/A
; ^LEX(757.14 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
; $$DT^XLFDT ICR 10103
; $$UP^XLFSTR ICR 10103
;
; Add to the list
ADDL(LEXI,LEXDS,LEXDP) ; Add
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=$$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
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 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)
N LEXT 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,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 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 ^TMP("LEXFND",$J,-99999999,LEXA)=LEXT,^TMP("LEXFND",$J,0)=-99999999
S LEX=$G(^TMP("LEXSCH",$J,"NUM",0))
Q
ADDEM(LEXI,LEXDS,LEXDP) ; Exact match Major Concept
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 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:$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,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))
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(^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
. . 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)
. . 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, 2014
; 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
LEXAL ;ISL/KER - Look-up List (Global) ;04/21/2014
+1 ;;2.0;LEXICON UTILITY;**6,55,80**;Sep 23, 1996;Build 10
+2 ;
+3 ; Global Variables
+4 ; ^LEX(757.13 N/A
+5 ; ^LEX(757.14 N/A
+6 ; ^TMP("LEXFND" SACC 2.3.2.5.1
+7 ; ^TMP("LEXHIT" SACC 2.3.2.5.1
+8 ; ^TMP("LEXSCH" SACC 2.3.2.5.1
+9 ;
+10 ; External References
+11 ; $$DT^XLFDT ICR 10103
+12 ; $$UP^XLFSTR ICR 10103
+13 ;
+14 ; Add to the list
ADDL(LEXI,LEXDS,LEXDP) ; Add
+1 NEW LEXA
SET LEXA=$GET(LEXI)
IF LEXA=0
QUIT
IF '$DATA(^LEX(757.01,LEXA))
QUIT
SET LEXI=$$SIEN(LEXA)
+2 IF +LEXI>0&(LEXI'=LEXA)
SET LEXA=LEXI
IF LEXA=0
QUIT
IF '$DATA(^LEX(757.01,LEXA))
QUIT
+3 SET LEXDS=$GET(LEXDS)
SET LEXDP=$GET(LEXDP)
+4 NEW LEXF,LEXT,LEXL,LEXC
+5 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 SET LEXF=$$LSTN(LEXA,"A")
+8 IF '$DATA(^TMP("LEXFND",$JOB,-LEXF,LEXA))
SET ^TMP("LEXSCH",$JOB,"NUM",0)=$GET(^TMP("LEXSCH",$JOB,"NUM",0))+1
+9 SET ^TMP("LEXFND",$JOB,-LEXF,LEXA)=LEXT
+10 IF +LEXF'=0
SET ^TMP("LEXFND",$JOB,0)=LEXF
+11 SET LEX=$GET(^TMP("LEXSCH",$JOB,"NUM",0))
+12 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
SET LEXI=$$SIEN(LEXA)
IF +LEXI>0&(LEXI'=LEXA)
SET LEXA=LEXI
IF LEXA=0
QUIT
IF '$DATA(^LEX(757.01,LEXA))
QUIT
+2 NEW LEXR,LEXN
SET LEXR=LEXA
IF $DATA(^TMP("LEXFND",$JOB,-99999997,LEXA))
QUIT
+3 SET LEXN=-99999997
+4 FOR
SET LEXN=LEXN+1
IF '$DATA(^TMP("LEXFND",$JOB,LEXN,0))
QUIT
+5 IF $PIECE($GET(^LEX(757.01,LEXA,1)),"^",2)'=1
Begin DoDot:1
+6 SET LEXA=+($GET(^LEX(757.01,LEXA,1)))
SET LEXA=+($GET(^LEX(757,LEXA,0)))
End DoDot:1
IF +LEXA=0
QUIT
+7 SET LEXDS=$GET(LEXDS)
SET LEXDP=$GET(LEXDP)
+8 NEW LEXT
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
IF LEXA=0
QUIT
IF '$DATA(^LEX(757.01,LEXA))
QUIT
+2 NEW LEXR,LEXT
SET LEXR=LEXA
SET LEXDS=$GET(LEXDS)
SET LEXDP=$GET(LEXDP)
SET LEXT=$$DISP(LEXA,LEXDS,LEXDP)
+3 IF $DATA(LEXIGN)&($PIECE($GET(^LEX(757.01,LEXA,1)),"^",5)>0)
SET LEXT=LEXT_"(Deactivated Term)"
+4 IF '$DATA(^TMP("LEXFND",$JOB,-99999999,LEXA))
SET ^TMP("LEXSCH",$JOB,"NUM",0)=$GET(^TMP("LEXSCH",$JOB,"NUM",0))+1
+5 SET ^TMP("LEXFND",$JOB,-99999999,LEXA)=LEXT
SET ^TMP("LEXFND",$JOB,0)=-99999999
+6 SET LEX=$GET(^TMP("LEXSCH",$JOB,"NUM",0))
+7 QUIT
ADDEM(LEXI,LEXDS,LEXDP) ; Exact match Major Concept
+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 NEW LEXR,LEXT
SET LEXR=LEXA
IF $PIECE($GET(^LEX(757.01,LEXA,1)),"^",2)'=1
QUIT
+3 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,-99999998,LEXA))
SET ^TMP("LEXSCH",$JOB,"NUM",0)=$GET(^TMP("LEXSCH",$JOB,"NUM",0))+1
+6 SET ^TMP("LEXFND",$JOB,-99999998,LEXA)=LEXT
SET ^TMP("LEXFND",$JOB,0)=-99999998
SET LEX=$GET(^TMP("LEXSCH",$JOB,"NUM",0))
+7 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))
+2 IF $LENGTH(LEXDS)
SET LEXX=LEXX_" "_LEXDS
+3 IF $LENGTH(LEXDP)
SET LEXX=LEXX_" "_LEXDP
+4 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(^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 +($GET(^TMP("LEXSCH",$JOB,"EXM",0)))=+LEXA
SET ^TMP("LEXSCH",$JOB,"EXM",2)=LEXJ_"^"_$GET(^LEX(757.01,+LEXA,0))
+14 IF +($GET(^TMP("LEXSCH",$JOB,"EXC",0)))=+LEXA
SET ^TMP("LEXSCH",$JOB,"EXC",2)=LEXJ_"^"_$GET(^LEX(757.01,+LEXA,0))
+15 KILL ^TMP("LEXFND",$JOB,LEXI,LEXA)
End DoDot:2
IF +LEXA=0!(LEXJ=LEXLL)
QUIT
End DoDot:1
+16 ; List LEX("LIST")
+17 IF $DATA(^TMP("LEXSCH",$JOB,"NUM",0))
SET LEX=+($GET(^TMP("LEXSCH",$JOB,"NUM",0)))
+18 IF LEXLL>0
Begin DoDot:1
+19 NEW LEXI,LEXJ
SET (LEXJ,LEXI)=0
+20 FOR
SET LEXJ=$ORDER(^TMP("LEXHIT",$JOB,LEXJ))
IF +LEXJ=0!(+LEXI=LEXLL)
QUIT
Begin DoDot:2
+21 SET LEXI=LEXI+1
SET LEX("LIST",LEXI)=^TMP("LEXHIT",$JOB,LEXJ)
+22 SET LEX("LIST",0)=LEXI_"^"_LEXI
+23 SET (LEX("MAX"),^TMP("LEXSCH",$JOB,"LST",0))=LEXI
End DoDot:2
IF +LEXI=LEXLL
QUIT
End DoDot:1
+24 SET ^TMP("LEXSCH",$JOB,"TOL",0)=0
IF $DATA(LEX("LIST",1))
SET ^TMP("LEXSCH",$JOB,"TOL",0)=1
+25 SET LEX=+($GET(^TMP("LEXSCH",$JOB,"NUM",0)))
+26 IF ^TMP("LEXSCH",$JOB,"TOL",0)=1&(+($GET(LEX))>0)
SET LEX("MAT")=+LEX_" match"_$SELECT(+LEX>1:"es",1:"")_" found"
+27 ; Establish level of concept (1 = concept, >1= modifier) PCH 6
+28 SET LEX("LVL")=+($GET(LEX("LVL")))
IF LEX("LVL")=0
SET LEX("LVL")=1
+29 IF +($GET(LEX("MAX")))>0
SET LEX("MIN")=1
+30 IF $LENGTH($GET(^TMP("LEXSCH",$JOB,"EXM",2)))
SET LEX("EXM")=^TMP("LEXSCH",$JOB,"EXM",2)
+31 IF $LENGTH($GET(^TMP("LEXSCH",$JOB,"EXC",2)))
SET LEX("EXC")=^TMP("LEXSCH",$JOB,"EXC",2)
+32 IF +($GET(^TMP("LEXSCH",$JOB,"UNR",0)))>0&($LENGTH($GET(^TMP("LEXSCH",$JOB,"NAR",0))))
SET LEX("NAR")=$GET(^TMP("LEXSCH",$JOB,"NAR",0))
+33 IF '$DATA(^TMP("LEXFND",$JOB))
QUIT
IF +($GET(LEXRL))>0
KILL LEXLL
+34 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, 2014
+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
