- 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 Feb 18, 2025@23:33:01 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