LEXU ;ISL/KER - Miscellaneous Lexicon Utilities ;04/21/2014
;;2.0;LEXICON UTILITY;**2,6,9,15,25,36,73,51,80**;Sep 23, 1996;Build 10
;
; Global Variables
; None
;
; External References
; $$ICDDX^ICDEX ICR 5747
; $$ICDOP^ICDEX ICR 5747
; $$CPT^ICPTCOD ICR 1995
;
HELP ; API Help
D EN^LEXUH
Q
SC(LEX,LEXS,LEXVDT) ; Filter by Semantic Class
;
; Input
;
; LEX IEN of file 757.01
; LEXS Filter
; LEXVDT Date to use for screening by codes
;
; Output
;
; $$SC 1/0
;
N LEXINC,LEXEXC,LEXIC,LEXEC,LEXRREC,X D VDT
S LEXRREC=LEX Q:'$D(^LEX(757.01,LEXRREC,0)) 0
I $L(LEXS,";")=3,$P(LEXS,";",3)'="" D Q:+LEXINC>0 LEXINC
. S LEXINC=0 S LEXINC=$$SO(LEXRREC,$P(LEXS,";",3),$G(LEXVDT))
S LEXRREC=$P(^LEX(757.01,LEXRREC,1),U,1)
S LEXINC=0 F LEXIC=1:1:$L($P(LEXS,";",1),"/") D
. N LEXP,LEX1,LEX2 S LEXP=$P($P(LEXS,";",1),"/",LEXIC)
. S LEX1=$D(^LEX(757.1,"AMCC",LEXRREC,LEXP))
. S LEX2=$D(^LEX(757.1,"AMCT",LEXRREC,LEXP))
. I LEX1!(LEX2) D
. . S LEXINC=1,LEXIC=$L($P(LEXS,";",1),"/")+1
I LEXINC=0!($P(LEXS,";",2)="") K LEXIC,LEXS,LEXEC Q LEXINC
S LEXEXC=0 F LEXEC=1:1:$L($P(LEXS,";",2),"/") D
. N LEXP,LEX1,LEX2 S LEXP=$P($P(LEXS,";",2),"/",LEXEC)
. S LEX1=$D(^LEX(757.1,"AMCC",LEXRREC,LEXP))
. S LEX2=$D(^LEX(757.1,"AMCT",LEXRREC,LEXP))
. I LEX1!(LEX2) D
. . S LEXEXC=1,LEXEC=$L($P(LEXS,";",2),"/")+1
I LEXINC,'LEXEXC K LEXIC,LEXS,LEXEC Q 1
K LEXIC,LEXS,LEXEC
Q 0
ICDDP(LEX,LEXT,LEXVDT) ; Filter by ICD Diagnosis/Procedure System
;
; Input
;
; LEX IEN of file 757.01 (required)
; LEXT ICD Type (optional)
; 1 ICD Diagnosis (default)
; 2 ICD Procedures
; LEXVDT Date to use for screening by codes
; Date before Oct 1, 2013, ICD-9 assumed
; Date after Sep 30, 2013, ICD-10 assumed
; Output
;
; $$ICDDP 1/0
;
N LEXEI,LEXF,LEXMC,LEXMCE,LEXSRC,LEXSRI,ICD10 S (LEXSRC,LEXSRI)=""
S LEXEI=+LEX Q:'$D(^LEX(757.01,LEXEI,0)) 0 S ICD10=$$IMPDATE("10D")
S LEXT=$G(LEXT) S:+LEXT<0!(LEXT>2) LEXT=1 D VDT
S:LEXT=1&(LEXVDT<ICD10) LEXSRC="ICD",LEXSRI=1
S:LEXT=1&(LEXVDT'<ICD10) LEXSRC="10D",LEXSRI=30
S:LEXT=2&(LEXVDT<ICD10) LEXSRC="ICP",LEXSRI=2
S:LEXT=2&(LEXVDT'<ICD10) LEXSRC="10P",LEXSRI=31
Q:'$L(LEXSRC) 0 Q:LEXSRI'>0 0
S LEXF=0,LEXMC=+($P(^LEX(757.01,LEXEI,1),U,1)) Q:LEXMC'>0 0
S LEXMCE=+(^LEX(757,+($P(^LEX(757.01,LEXEI,1),U,1)),0)) Q:LEXMCE'>0 0
S LEXF=0 I LEXEI+LEXMCE>0 D
. N LEXSI S LEXSI=0
. F S LEXSI=$O(^LEX(757.02,"AMC",LEXMC,LEXSI)) Q:+LEXSI=0!(LEXF) D Q:LEXF
. . N LEXN0,LEXSAB,LEXSO,LEXSTA
. . S LEXN0=$G(^LEX(757.02,LEXSI,0)),LEXSAB=+($P(LEXN0,U,3))
. . Q:LEXSAB'=LEXSRI Q:"^1^2^30^31^"'[("^"_LEXSAB_"^")
. . S LEXSO=$P(LEXN0,U,2)
. . S LEXSTA=$$STATCHK^LEXSRC2(LEXSO,LEXVDT,,LEXSAB)
. . Q:+LEXSTA'>0 S LEXF=1
S LEX=$G(LEXF)
Q LEX
DX(LEX,LEXVDT) ; Filter by Diagnosis System
;
; Input
;
; LEX IEN of file 757.01
; LEXVDT Date to use for screening by codes
;
; Output
;
; $$DX 1/0
;
N LEXEI,LEXF,LEXMC,LEXMCE,LEXSRC,LEXSRI,ICD10
S LEXEI=+LEX Q:'$D(^LEX(757.01,LEXEI,0)) 0
D VDT S LEXSRC="ICD",LEXSRI=1 S ICD10=$$IMPDATE("10D")
S:+($G(LEXVDT))'<ICD10 LEXSRC="10D",LEXSRI=30
S LEXF=0,LEXMC=+($P(^LEX(757.01,LEXEI,1),U,1)) Q:LEXMC'>0 0
S LEXMCE=+(^LEX(757,+($P(^LEX(757.01,LEXEI,1),U,1)),0)) Q:LEXMCE'>0 0
S LEXF=0 I LEXEI+LEXMCE>0 D
. N LEXSI S LEXSI=0
. F S LEXSI=$O(^LEX(757.02,"AMC",LEXMC,LEXSI)) Q:+LEXSI=0!(LEXF) D
. . N LEXN0,LEXSAB,LEXSO,LEXSTA
. . S LEXN0=$G(^LEX(757.02,LEXSI,0)),LEXSAB=+($P(LEXN0,U,3))
. . Q:LEXSAB'=LEXSRI Q:"^1^30^"'[("^"_LEXSAB_"^")
. . S LEXSO=$P(LEXN0,U,2)
. . S LEXSTA=$$STATCHK^LEXSRC2(LEXSO,LEXVDT,,LEXSAB)
. . Q:+LEXSTA'>0 S LEXF=1
K LEX S LEX=$G(LEXF)
Q LEX
SO(LEX,LEXS,LEXVDT) ; Filter by Source
;
; Input
;
; LEX IEN of file 757.01
; LEXS Filter
; LEXVDT Date to use for screening by codes
;
; Output
;
; $$SO 1/0
;
N LEXABR,LEXCR,LEXF,LEXMC,LEXMCE,LEXN0,LEXSAB,LEXSO,LEXSR,LEXSTA,LEXTR
S LEXTR=+LEX,LEXF=0 Q:'$D(^LEX(757.01,LEXTR,0)) LEXF
Q:'$D(^LEX(757.01,LEXTR)) LEXF
S LEXMC=$P(^LEX(757.01,LEXTR,1),U,1)
S LEXMCE=+(^LEX(757,+($P(^LEX(757.01,LEXTR,1),U,1)),0))
D VDT I LEXTR>0,LEXMCE>0,LEXTR=LEXMCE D G SOQ
. S LEXF=0 F LEXSR=1:1:$L(LEXS,"/") D Q:LEXF>0
. . S LEXABR=$P(LEXS,"/",LEXSR),LEXCR=0
. . F S LEXCR=$O(^LEX(757.02,"AMC",LEXMC,LEXCR)) Q:+LEXCR=0 D Q:LEXF>0
. . . N LEXN0,LEXSAB,LEXQ S LEXQ=0
. . . S LEXN0=$G(^LEX(757.02,LEXCR,0))
. . . S LEXSAB=+($P(LEXN0,U,3)),LEXSO=$P(LEXN0,U,2)
. . . I $G(LEXLKT)["BC" D Q:LEXQ
. . . . N LEXNAR S LEXNAR=$G(^TMP("LEXSCH",$J,"NAR",0))
. . . . I $L($G(LEXNAR)) S:$E(LEXSO,1,$L($G(LEXNAR)))'=$G(LEXNAR) LEXQ=1
. . . S LEXSTA=$$STATCHK^LEXSRC2(LEXSO,$G(LEXVDT),,LEXSAB)
. . . Q:+LEXSTA'>0 Q:$P(LEXSTA,U,2)'=LEXCR
. . . Q:'$D(^LEX(757.03,LEXSAB,0))
. . . S LEXSAB=$E(^LEX(757.03,LEXSAB,0),1,3)
. . . I LEXSAB=LEXABR S LEXF=1
SOQ ; Quit Source Filter
K LEXCR,LEXMC,LEXMCE,LEXN0,LEXSAB,LEXABR,LEXSO,LEXSR,LEXSTA,LEXTR
Q LEXF
SRC(LEX,LEXS) ; Filter by Expression Source
; LEX Expression IEN of file 757.01
; LEXS Source IEN of 757.14
S LEX=+($G(LEX)),LEXS=+($G(LEXS)) Q:LEX=0 0 Q:LEXS=0 0
Q:'$D(^LEX(757.01,LEX,0)) 0 Q:'$D(^LEX(757.14,LEXS,0)) 0
S LEXSR=$P($G(^LEX(757.01,LEX,1)),U,12) Q:LEXSR=LEXS 1
N LEXSR,LEXMC,LEXMCE S LEXMC=+($G(^LEX(757.01,LEX,1)))
S LEXMCE=+($G(^LEX(757,+LEXMC,0)))
S LEXSR=$P($G(^LEX(757.01,LEXMCE,1)),U,12) Q:LEXSR=LEXS 1
Q 0
DEF(LEX) ; Display expression definition
; LEX IEN of file 757.01
I $D(^LEX(757.01,LEX,3,0)) D
. N LEXLN F LEXLN=1:1:$P(^LEX(757.01,LEX,3,0),U,4) D
. . I $D(^LEX(757.01,LEX,3,LEXLN,0)) W !,?2,^LEX(757.01,LEX,3,LEXLN,0)
. K LEX,LEXLN W !
Q
ID(LEX) ; ICD Diagnosis retained - ICD procedures ignored
; LEX Code
Q:'$L($G(LEX)) "" Q:$L($P(LEX,".",1))<3 ""
Q:'$D(^LEX(757.02,"AVA",(LEX_" "))) ""
N LEXO,LEXR S (LEXO,LEXR)=0
F S LEXR=$O(^LEX(757.02,"AVA",(LEX_" "),LEXR)) Q:+LEXR=0 D Q:LEXO=1
. I $D(^LEX(757.02,"AVA",(LEX_" "),LEXR,"ICD")) S LEXO=1
Q:'LEXO "" Q LEX
ICDONE(LEX,LEXVDT) ; Get One ICD-9 Diagnosis Code for a Term
;
; Input
;
; LEX IEN of file 757.01
; LEXVDT Date to use for screening by codes
;
; Output
;
; $$ICDONE ICD-9 Code
;
N LEXICD D VDT S LEXICD=$$ONE($G(LEX),$G(LEXVDT),"ICD")
Q:'$L($P(LEXICD,"^",1)) "" S LEX=LEXICD
Q LEX
D10ONE(LEX,LEXVDT) ; Get One ICD-10 Diagosis Code for a Term
;
; Input
;
; LEX IEN of file 757.01
; LEXVDT Date to use for screening by codes
;
; Output
;
; $$D10ONE ICD-10-CM Diagnosis Code or Null
;
N LEXICD D VDT S LEXICD=$$ONE($G(LEX),$G(LEXVDT),"10D")
Q:'$L($P(LEXICD,"^",1)) "" S LEX=LEXICD
Q LEX
P10ONE(LEX,LEXVDT) ; Get One ICD-10 Procedure Code for a Term
;
; Input
;
; LEX IEN of file 757.01
; LEXVDT Date to use for screening by codes
;
; Output
;
; $$P10ONE ICD-10-PCS Procedure Code or Null
;
N LEXICD D VDT S LEXICD=$$ONE($G(LEX),$G(LEXVDT),"10P")
Q:'$L($P(LEXICD,"^",1)) "" S LEX=LEXICD
Q LEX
CPTONE(LEX,LEXVDT) ; Get One CPT Code for a Term
;
; Input
;
; LEX IEN of file 757.01
; LEXVDT Date to use for screening by codes
;
; Output
;
; $$CPTONE CPT Code or Null
;
N LEXCPT D VDT S LEXCPT=$$ONE($G(LEX),$G(LEXVDT),"CPT")
Q:'$L($P(LEXCPT,"^",1)) "" S LEX=LEXCPT
Q LEX
CPCONE(LEX,LEXVDT) ; Get One HCPCS Code for a Term
;
; Input
;
; LEX IEN of file 757.01
; LEXVDT Date to use for screening by codes
;
; Output
;
; $$CPCONE HCPCS Code or Null
;
N LEXCPT D VDT S LEXCPT=$$ONE($G(LEX),$G(LEXVDT),"CPC")
Q:'$L($P(LEXCPT,"^",1)) "" S LEX=LEXCPT
Q LEX
DSMONE(LEX,LEXVDT) ; Get One DSM Code for a Term
;
; Input
;
; LEX IEN of file 757.01
; LEXVDT Date to use for screening by codes
;
; Output
;
; $$DSMONE DSM-IV Code or Null
;
N LEXDSM D VDT S LEXDSM=$$ONE^LEXSRC(LEX,"DS4")
I LEXDSM'="" D Q LEX
. S LEX=LEXDSM N LEXDAT S LEXDAT=$$ICDDX^ICDEX(LEXDSM,$G(LEXVDT),1,"E")
. S:$P(LEXDAT,"^",10)'>0 LEX=""
S LEXDSM=$$ONE^LEXSRC(LEX,"DS3") I LEXDSM'="" D Q LEX
. S LEX=LEXDSM N LEXDAT S LEXDAT=$$ICDDX^ICDEX(LEXDSM,$G(LEXVDT),1,"E")
. S:$P(LEXDAT,"^",10)'>0 LEX=""
Q ""
;
SCT(X,LEXVDT) ; Filter by SNOMED CT (SCT) (Human only)
;
; Input
;
; X IEN of file 757.01
; LEXVDT Date to use for screening by codes
;
; Output
;
; $$SCT Human SNOMED Code or Null
; Excludes Veterinary SNOMED codes
;
N LEXEX,LEXMC,LEXD,LEXC,LEXI,LEXO,LEXPL,LEXVT S LEXEX=+($G(X)),LEXD=$G(LEXVDT) Q:LEXEX'>0 0
S LEXC=$S(LEXD?7N:$$ONE^LEXU(+LEXEX,LEXD,"SCT"),1:$$ONE^LEXU(+LEXEX,,"SCT"))
Q:'$L(LEXC) 0 S LEXMC=+($G(^LEX(757.01,+LEXEX,1))) Q:LEXMC'>0 0 Q:'$D(^LEX(757.1,"B",LEXMC)) 0
S LEXVT=0,LEXI=0 F S LEXI=$O(^LEX(757.1,"B",LEXMC,LEXI)) Q:+LEXI'>0 D Q:LEXVT>0
. N LEXT,LEXN S LEXT=$P($G(^LEX(757.1,LEXI,0)),"^",3),LEXN=$$UP^XLFSTR($P($G(^LEX(757.12,+LEXT,0)),"^",2)) S:LEXN["VETERINARY" LEXVT=1
S LEXPL=0,LEXI=0 F S LEXI=$O(^LEX(757.21,"B",LEXEX,LEXI)) Q:+LEXI'>0 D Q:LEXPL>0
. N LEXT,LEXN S LEXT=$P($G(^LEX(757.21,LEXI,0)),"^",2),LEXN=$P($G(^LEXT(757.2,+LEXT,0)),"^",2) S:LEXN="PLS" LEXPL=1
S LEXO=1 S:LEXVT=1 LEXO=0 S:LEXPL'>0 LEXO=0
S X=LEXO
Q X
ONE(LEX,LEXVDT,LEXSAB) ; Get One Code for a Term by Source
;
; Input
; LEX IEN of file 757.01
; LEXVDT Date to use for screening by codes
; LEXSAB Source Abbreviation
;
; Output
;
; $$ONE Code or Null
;
N LEXDAT,LEXIEN D VDT S LEXIEN=$G(LEX) Q:+($G(LEXIEN))'>0 ""
S LEXSAB=$G(LEXSAB) Q:'$L(LEXSAB) ""
I LEXSAB?1N.N,'$D(^LEX(757.03,"ASAB",LEXSAB)),$D(^LEX(757.03,+LEXSAB,0)) D
. S LEXSAB=$P($G(^LEX(757.03,+LEXSAB,0)),"^",1)
S LEXSAB=$E($G(LEXSAB),1,3) Q:$L(LEXSAB)'=3 ""
S LEX=$$ONE^LEXSRC(LEXIEN,LEXSAB,LEXVDT),LEXDAT=""
S:LEXSAB="ICD"!(LEXSAB="DS4") LEXDAT=$$ICDDX^ICDEX(LEX,LEXVDT,1,"E")
S:LEXSAB="10D" LEXDAT=$$ICDDX^ICDEX(LEX,LEXVDT,30,"E")
S:LEXSAB="ICP" LEXDAT=$$ICDOP^ICDEX(LEX,LEXVDT,2,"E")
S:LEXSAB="10P" LEXDAT=$$ICDOP^ICDEX(LEX,LEXVDT,31,"E")
S:LEXSAB="CPT" LEXDAT=$$CPT^ICPTCOD(LEX,LEXVDT)
S:LEXSAB="CPC" LEXDAT=$$CPT^ICPTCOD(LEX,LEXVDT)
Q:"^CPT^CPC"[("^"_LEXSAB_"^")&($P(LEXDAT,"^",7)'>0) ""
Q:"^ICD^ICP^10D^10P^"[("^"_LEXSAB_"^")&($P(LEXDAT,"^",10)'>0) ""
S LEX="" I +LEXDAT'>0 D
. N LEXSIEN S LEXSIEN=0
. F S LEXSIEN=$O(^LEX(757.02,"B",LEXIEN,LEXSIEN)) Q:+LEXSIEN'>0 D Q:+LEXDAT>0
. . Q:'$D(^LEX(757.02,"ASRC",LEXSAB,LEXSIEN)) N LEXEF,LEXHI,LEXST,LEXCD
. . S LEXEF=$O(^LEX(757.02,LEXSIEN,4,"B",(LEXVDT+.001)),-1) Q:'$L(LEXEF)
. . S LEXHI=$O(^LEX(757.02,LEXSIEN,4,"B",+LEXEF," "),-1)
. . S LEXST=$P($G(^LEX(757.02,LEXSIEN,4,+LEXHI,0)),"^",2) Q:LEXST'>0
. . S LEXCD=$P($G(^LEX(757.02,+LEXSIEN,0)),"^",2)
. . S:$L(LEXCD)&(+LEXIEN>0) LEXDAT=LEXIEN_"^"_LEXCD
Q:+LEXDAT'>0 "" S LEX=$P(LEXDAT,"^",2)
I $G(LEXLKT)["BC" D
. N LEXNAR S LEXNAR=$$UP^XLFSTR($G(^TMP("LEXSCH",$J,"NAR",0)))
. I $L($G(LEXNAR)) S:$E(LEX,1,$L($G(LEXNAR)))'=$G(LEXNAR) LEX=""
Q LEX
ICD(LEX,LEXVDT) ; Get All ICD-9 Diagnosis Codes for a Term
;
; Input
;
; LEX IEN of file 757.01
; LEXVDT Date to use for screening by codes
;
; Output
;
; $$ICD <ICD-9 code><ICD-9 code><etc>
;
D VDT S LEX=$$ALL^LEXU($G(LEX),$G(LEXVDT),"ICD")
Q LEX
D10(LEX,LEXVDT) ; Get All ICD-10 Diagnosis Codes for a Term
;
; Input
;
; LEX IEN of file 757.01
; LEXVDT Date to use for screening by codes
;
; Output
;
; $$D10 <ICD-10 code><ICD-10 code><etc>
;
D VDT S LEX=$$ALL^LEXU($G(LEX),$G(LEXVDT),"10D")
Q LEX
;
ALL(LEX,LEXVDT,LEXSAB) ; Get All Codes for a Term by Source
;
; Input
;
; LEX IEN of file 757.01
; LEXVDT Date to use for screening by codes
; LEXSAB Source Abbreviation
;
; Output
;
; $$ALL A ";" delimited string of codes
; of the specified coding system
; for the term
;
N LEXDAT,LEXIEN,LEXSRC,LEXI,LEXT,LEXS D VDT
S LEXIEN=+($G(LEX)) Q:+($G(LEXIEN))'>0 ""
S LEXSAB=$E($G(LEXSAB),1,3) Q:$L(LEXSAB)'=3 ""
D ALL^LEXSRC(LEX,LEXSAB,LEXVDT)
Q:+$G(LEXSRC(0))'>0 "" S LEXI=0,LEXT=""
F S LEXI=$O(LEXSRC(LEXI)) Q:+LEXI=0 D
. S LEXS=LEXSRC(LEXI)
. S:LEXSAB="ICD" LEXDAT=$$ICDDX^ICDEX(LEXS,$G(LEXVDT),1,"E")
. S:LEXSAB="10D" LEXDAT=$$ICDDX^ICDEX(LEXS,$G(LEXVDT),30,"E")
. S:LEXSAB="10P" LEXDAT=$$ICDOP^ICDEX(LEXS,$G(LEXVDT),31,"E")
. S:LEXSAB="CPT" LEXDAT=$$CPT^ICPTCOD(LEXS,LEXVDT)
. S:LEXSAB="CPC" LEXDAT=$$CPT^ICPTCOD(LEXS,LEXVDT)
. Q:+($G(LEXDAT))'>0
. Q:"^CPT^CPT"[("^"_LEXSAB_"^")&($P($G(LEXDAT),"^",7)'>0)
. Q:"^ICD^ICP^10D^10P^"[("^"_LEXSAB_"^")&($P($G(LEXDAT),"^",10)'>0)
. Q:(LEXT_";")[(";"_LEXS_";") S LEXT=LEXT_";"_LEXS
S LEX="" S:$E(LEXT,1)=";" LEXT=$E(LEXT,2,$L(LEXT)) S LEX=LEXT
Q LEX
HIST(CODE,SYS,ARY) ; Activation History
Q $$HIST^LEXU4($G(CODE),$G(SYS),.ARY)
PERIOD(CODE,SYS,ARY) ; Return Activation Periods
Q $$PERIOD^LEXU4($G(CODE),$G(SYS),.ARY)
CSDATA(CODE,CSYS,CDT,ARY) ; Code Data
N X S X=$$CSDATA^LEXU2($G(CODE),$G(CSYS),$G(CDT),.ARY) Q X
ADR(LEX) ; Mailing Address
Q $$ADR^LEXU3($G(LEX))
VDT ; Resolve LEXVDT
D VDT^LEXU3 Q
IMPDATE(CSYS) ; Return the implementation date for a coding system
Q $$IMPDATE^LEXU3($G(CSYS))
CSYS(SYS) ; Coding System Info
Q $$CSYS^LEXU3($G(SYS))
FREQ(TXT) ; Frequency of text - ICR 5679
Q $$FREQ^LEXU3($G(TXT))
MAX(SYS) ; Coding System search Threshold - ICR 5679
Q $$MAX^LEXU3($G(SYS))
PAR(TXT,ARY) ; Parse Text into Words (for indexing)
Q $$PAR^LEXU3(TXT,.ARY)
CAT(CODE) ; Get Category of Dx Code - ICR 5679
Q $$CAT^LEX10DU($G(CODE))
ISCAT(CODE) ; Get Category of Dx Code - ICR 5679
Q $$ISCAT^LEX10DU($G(CODE))
PFI(FRAG,CDT,ARY) ; ICD-10 Procedure Code Fragment Information - ICR 5679
Q $$PFI^LEXU4($G(FRAG),$G(CDT),.ARY)
NXSAB(X,Y) ; Next Source Abbreviation
Q $$NXSAB^LEXU3($G(X),$G(Y))
INC(X) ; Increment Concept Usage for a term (by subscription only)
D INC^LEXU3($G(X))
Q
RECENT(X) ; Recently Updated (90 day window)
Q $$RECENT^LEXU3($G(X))
RUPD(X) ; Recent Update Date
Q $$RUPD^LEXU3($G(X))
LUPD(X,Y) ; Last Update
Q $$LUPD^LEXU3($G(X),$G(Y))
LEXU ;ISL/KER - Miscellaneous Lexicon Utilities ;04/21/2014
+1 ;;2.0;LEXICON UTILITY;**2,6,9,15,25,36,73,51,80**;Sep 23, 1996;Build 10
+2 ;
+3 ; Global Variables
+4 ; None
+5 ;
+6 ; External References
+7 ; $$ICDDX^ICDEX ICR 5747
+8 ; $$ICDOP^ICDEX ICR 5747
+9 ; $$CPT^ICPTCOD ICR 1995
+10 ;
HELP ; API Help
+1 DO EN^LEXUH
+2 QUIT
SC(LEX,LEXS,LEXVDT) ; Filter by Semantic Class
+1 ;
+2 ; Input
+3 ;
+4 ; LEX IEN of file 757.01
+5 ; LEXS Filter
+6 ; LEXVDT Date to use for screening by codes
+7 ;
+8 ; Output
+9 ;
+10 ; $$SC 1/0
+11 ;
+12 NEW LEXINC,LEXEXC,LEXIC,LEXEC,LEXRREC,X
DO VDT
+13 SET LEXRREC=LEX
IF '$DATA(^LEX(757.01,LEXRREC,0))
QUIT 0
+14 IF $LENGTH(LEXS,";")=3
IF $PIECE(LEXS,";",3)'=""
Begin DoDot:1
+15 SET LEXINC=0
SET LEXINC=$$SO(LEXRREC,$PIECE(LEXS,";",3),$GET(LEXVDT))
End DoDot:1
IF +LEXINC>0
QUIT LEXINC
+16 SET LEXRREC=$PIECE(^LEX(757.01,LEXRREC,1),U,1)
+17 SET LEXINC=0
FOR LEXIC=1:1:$LENGTH($PIECE(LEXS,";",1),"/")
Begin DoDot:1
+18 NEW LEXP,LEX1,LEX2
SET LEXP=$PIECE($PIECE(LEXS,";",1),"/",LEXIC)
+19 SET LEX1=$DATA(^LEX(757.1,"AMCC",LEXRREC,LEXP))
+20 SET LEX2=$DATA(^LEX(757.1,"AMCT",LEXRREC,LEXP))
+21 IF LEX1!(LEX2)
Begin DoDot:2
+22 SET LEXINC=1
SET LEXIC=$LENGTH($PIECE(LEXS,";",1),"/")+1
End DoDot:2
End DoDot:1
+23 IF LEXINC=0!($PIECE(LEXS,";",2)="")
KILL LEXIC,LEXS,LEXEC
QUIT LEXINC
+24 SET LEXEXC=0
FOR LEXEC=1:1:$LENGTH($PIECE(LEXS,";",2),"/")
Begin DoDot:1
+25 NEW LEXP,LEX1,LEX2
SET LEXP=$PIECE($PIECE(LEXS,";",2),"/",LEXEC)
+26 SET LEX1=$DATA(^LEX(757.1,"AMCC",LEXRREC,LEXP))
+27 SET LEX2=$DATA(^LEX(757.1,"AMCT",LEXRREC,LEXP))
+28 IF LEX1!(LEX2)
Begin DoDot:2
+29 SET LEXEXC=1
SET LEXEC=$LENGTH($PIECE(LEXS,";",2),"/")+1
End DoDot:2
End DoDot:1
+30 IF LEXINC
IF 'LEXEXC
KILL LEXIC,LEXS,LEXEC
QUIT 1
+31 KILL LEXIC,LEXS,LEXEC
+32 QUIT 0
ICDDP(LEX,LEXT,LEXVDT) ; Filter by ICD Diagnosis/Procedure System
+1 ;
+2 ; Input
+3 ;
+4 ; LEX IEN of file 757.01 (required)
+5 ; LEXT ICD Type (optional)
+6 ; 1 ICD Diagnosis (default)
+7 ; 2 ICD Procedures
+8 ; LEXVDT Date to use for screening by codes
+9 ; Date before Oct 1, 2013, ICD-9 assumed
+10 ; Date after Sep 30, 2013, ICD-10 assumed
+11 ; Output
+12 ;
+13 ; $$ICDDP 1/0
+14 ;
+15 NEW LEXEI,LEXF,LEXMC,LEXMCE,LEXSRC,LEXSRI,ICD10
SET (LEXSRC,LEXSRI)=""
+16 SET LEXEI=+LEX
IF '$DATA(^LEX(757.01,LEXEI,0))
QUIT 0
SET ICD10=$$IMPDATE("10D")
+17 SET LEXT=$GET(LEXT)
IF +LEXT<0!(LEXT>2)
SET LEXT=1
DO VDT
+18 IF LEXT=1&(LEXVDT<ICD10)
SET LEXSRC="ICD"
SET LEXSRI=1
+19 IF LEXT=1&(LEXVDT'<ICD10)
SET LEXSRC="10D"
SET LEXSRI=30
+20 IF LEXT=2&(LEXVDT<ICD10)
SET LEXSRC="ICP"
SET LEXSRI=2
+21 IF LEXT=2&(LEXVDT'<ICD10)
SET LEXSRC="10P"
SET LEXSRI=31
+22 IF '$LENGTH(LEXSRC)
QUIT 0
IF LEXSRI'>0
QUIT 0
+23 SET LEXF=0
SET LEXMC=+($PIECE(^LEX(757.01,LEXEI,1),U,1))
IF LEXMC'>0
QUIT 0
+24 SET LEXMCE=+(^LEX(757,+($PIECE(^LEX(757.01,LEXEI,1),U,1)),0))
IF LEXMCE'>0
QUIT 0
+25 SET LEXF=0
IF LEXEI+LEXMCE>0
Begin DoDot:1
+26 NEW LEXSI
SET LEXSI=0
+27 FOR
SET LEXSI=$ORDER(^LEX(757.02,"AMC",LEXMC,LEXSI))
IF +LEXSI=0!(LEXF)
QUIT
Begin DoDot:2
+28 NEW LEXN0,LEXSAB,LEXSO,LEXSTA
+29 SET LEXN0=$GET(^LEX(757.02,LEXSI,0))
SET LEXSAB=+($PIECE(LEXN0,U,3))
+30 IF LEXSAB'=LEXSRI
QUIT
IF "^1^2^30^31^"'[("^"_LEXSAB_"^")
QUIT
+31 SET LEXSO=$PIECE(LEXN0,U,2)
+32 SET LEXSTA=$$STATCHK^LEXSRC2(LEXSO,LEXVDT,,LEXSAB)
+33 IF +LEXSTA'>0
QUIT
SET LEXF=1
End DoDot:2
IF LEXF
QUIT
End DoDot:1
+34 SET LEX=$GET(LEXF)
+35 QUIT LEX
DX(LEX,LEXVDT) ; Filter by Diagnosis System
+1 ;
+2 ; Input
+3 ;
+4 ; LEX IEN of file 757.01
+5 ; LEXVDT Date to use for screening by codes
+6 ;
+7 ; Output
+8 ;
+9 ; $$DX 1/0
+10 ;
+11 NEW LEXEI,LEXF,LEXMC,LEXMCE,LEXSRC,LEXSRI,ICD10
+12 SET LEXEI=+LEX
IF '$DATA(^LEX(757.01,LEXEI,0))
QUIT 0
+13 DO VDT
SET LEXSRC="ICD"
SET LEXSRI=1
SET ICD10=$$IMPDATE("10D")
+14 IF +($GET(LEXVDT))'<ICD10
SET LEXSRC="10D"
SET LEXSRI=30
+15 SET LEXF=0
SET LEXMC=+($PIECE(^LEX(757.01,LEXEI,1),U,1))
IF LEXMC'>0
QUIT 0
+16 SET LEXMCE=+(^LEX(757,+($PIECE(^LEX(757.01,LEXEI,1),U,1)),0))
IF LEXMCE'>0
QUIT 0
+17 SET LEXF=0
IF LEXEI+LEXMCE>0
Begin DoDot:1
+18 NEW LEXSI
SET LEXSI=0
+19 FOR
SET LEXSI=$ORDER(^LEX(757.02,"AMC",LEXMC,LEXSI))
IF +LEXSI=0!(LEXF)
QUIT
Begin DoDot:2
+20 NEW LEXN0,LEXSAB,LEXSO,LEXSTA
+21 SET LEXN0=$GET(^LEX(757.02,LEXSI,0))
SET LEXSAB=+($PIECE(LEXN0,U,3))
+22 IF LEXSAB'=LEXSRI
QUIT
IF "^1^30^"'[("^"_LEXSAB_"^")
QUIT
+23 SET LEXSO=$PIECE(LEXN0,U,2)
+24 SET LEXSTA=$$STATCHK^LEXSRC2(LEXSO,LEXVDT,,LEXSAB)
+25 IF +LEXSTA'>0
QUIT
SET LEXF=1
End DoDot:2
End DoDot:1
+26 KILL LEX
SET LEX=$GET(LEXF)
+27 QUIT LEX
SO(LEX,LEXS,LEXVDT) ; Filter by Source
+1 ;
+2 ; Input
+3 ;
+4 ; LEX IEN of file 757.01
+5 ; LEXS Filter
+6 ; LEXVDT Date to use for screening by codes
+7 ;
+8 ; Output
+9 ;
+10 ; $$SO 1/0
+11 ;
+12 NEW LEXABR,LEXCR,LEXF,LEXMC,LEXMCE,LEXN0,LEXSAB,LEXSO,LEXSR,LEXSTA,LEXTR
+13 SET LEXTR=+LEX
SET LEXF=0
IF '$DATA(^LEX(757.01,LEXTR,0))
QUIT LEXF
+14 IF '$DATA(^LEX(757.01,LEXTR))
QUIT LEXF
+15 SET LEXMC=$PIECE(^LEX(757.01,LEXTR,1),U,1)
+16 SET LEXMCE=+(^LEX(757,+($PIECE(^LEX(757.01,LEXTR,1),U,1)),0))
+17 DO VDT
IF LEXTR>0
IF LEXMCE>0
IF LEXTR=LEXMCE
Begin DoDot:1
+18 SET LEXF=0
FOR LEXSR=1:1:$LENGTH(LEXS,"/")
Begin DoDot:2
+19 SET LEXABR=$PIECE(LEXS,"/",LEXSR)
SET LEXCR=0
+20 FOR
SET LEXCR=$ORDER(^LEX(757.02,"AMC",LEXMC,LEXCR))
IF +LEXCR=0
QUIT
Begin DoDot:3
+21 NEW LEXN0,LEXSAB,LEXQ
SET LEXQ=0
+22 SET LEXN0=$GET(^LEX(757.02,LEXCR,0))
+23 SET LEXSAB=+($PIECE(LEXN0,U,3))
SET LEXSO=$PIECE(LEXN0,U,2)
+24 IF $GET(LEXLKT)["BC"
Begin DoDot:4
+25 NEW LEXNAR
SET LEXNAR=$GET(^TMP("LEXSCH",$JOB,"NAR",0))
+26 IF $LENGTH($GET(LEXNAR))
IF $EXTRACT(LEXSO,1,$LENGTH($GET(LEXNAR)))'=$GET(LEXNAR)
SET LEXQ=1
End DoDot:4
IF LEXQ
QUIT
+27 SET LEXSTA=$$STATCHK^LEXSRC2(LEXSO,$GET(LEXVDT),,LEXSAB)
+28 IF +LEXSTA'>0
QUIT
IF $PIECE(LEXSTA,U,2)'=LEXCR
QUIT
+29 IF '$DATA(^LEX(757.03,LEXSAB,0))
QUIT
+30 SET LEXSAB=$EXTRACT(^LEX(757.03,LEXSAB,0),1,3)
+31 IF LEXSAB=LEXABR
SET LEXF=1
End DoDot:3
IF LEXF>0
QUIT
End DoDot:2
IF LEXF>0
QUIT
End DoDot:1
GOTO SOQ
SOQ ; Quit Source Filter
+1 KILL LEXCR,LEXMC,LEXMCE,LEXN0,LEXSAB,LEXABR,LEXSO,LEXSR,LEXSTA,LEXTR
+2 QUIT LEXF
SRC(LEX,LEXS) ; Filter by Expression Source
+1 ; LEX Expression IEN of file 757.01
+2 ; LEXS Source IEN of 757.14
+3 SET LEX=+($GET(LEX))
SET LEXS=+($GET(LEXS))
IF LEX=0
QUIT 0
IF LEXS=0
QUIT 0
+4 IF '$DATA(^LEX(757.01,LEX,0))
QUIT 0
IF '$DATA(^LEX(757.14,LEXS,0))
QUIT 0
+5 SET LEXSR=$PIECE($GET(^LEX(757.01,LEX,1)),U,12)
IF LEXSR=LEXS
QUIT 1
+6 NEW LEXSR,LEXMC,LEXMCE
SET LEXMC=+($GET(^LEX(757.01,LEX,1)))
+7 SET LEXMCE=+($GET(^LEX(757,+LEXMC,0)))
+8 SET LEXSR=$PIECE($GET(^LEX(757.01,LEXMCE,1)),U,12)
IF LEXSR=LEXS
QUIT 1
+9 QUIT 0
DEF(LEX) ; Display expression definition
+1 ; LEX IEN of file 757.01
+2 IF $DATA(^LEX(757.01,LEX,3,0))
Begin DoDot:1
+3 NEW LEXLN
FOR LEXLN=1:1:$PIECE(^LEX(757.01,LEX,3,0),U,4)
Begin DoDot:2
+4 IF $DATA(^LEX(757.01,LEX,3,LEXLN,0))
WRITE !,?2,^LEX(757.01,LEX,3,LEXLN,0)
End DoDot:2
+5 KILL LEX,LEXLN
WRITE !
End DoDot:1
+6 QUIT
ID(LEX) ; ICD Diagnosis retained - ICD procedures ignored
+1 ; LEX Code
+2 IF '$LENGTH($GET(LEX))
QUIT ""
IF $LENGTH($PIECE(LEX,".",1))<3
QUIT ""
+3 IF '$DATA(^LEX(757.02,"AVA",(LEX_" ")))
QUIT ""
+4 NEW LEXO,LEXR
SET (LEXO,LEXR)=0
+5 FOR
SET LEXR=$ORDER(^LEX(757.02,"AVA",(LEX_" "),LEXR))
IF +LEXR=0
QUIT
Begin DoDot:1
+6 IF $DATA(^LEX(757.02,"AVA",(LEX_" "),LEXR,"ICD"))
SET LEXO=1
End DoDot:1
IF LEXO=1
QUIT
+7 IF 'LEXO
QUIT ""
QUIT LEX
ICDONE(LEX,LEXVDT) ; Get One ICD-9 Diagnosis Code for a Term
+1 ;
+2 ; Input
+3 ;
+4 ; LEX IEN of file 757.01
+5 ; LEXVDT Date to use for screening by codes
+6 ;
+7 ; Output
+8 ;
+9 ; $$ICDONE ICD-9 Code
+10 ;
+11 NEW LEXICD
DO VDT
SET LEXICD=$$ONE($GET(LEX),$GET(LEXVDT),"ICD")
+12 IF '$LENGTH($PIECE(LEXICD,"^",1))
QUIT ""
SET LEX=LEXICD
+13 QUIT LEX
D10ONE(LEX,LEXVDT) ; Get One ICD-10 Diagosis Code for a Term
+1 ;
+2 ; Input
+3 ;
+4 ; LEX IEN of file 757.01
+5 ; LEXVDT Date to use for screening by codes
+6 ;
+7 ; Output
+8 ;
+9 ; $$D10ONE ICD-10-CM Diagnosis Code or Null
+10 ;
+11 NEW LEXICD
DO VDT
SET LEXICD=$$ONE($GET(LEX),$GET(LEXVDT),"10D")
+12 IF '$LENGTH($PIECE(LEXICD,"^",1))
QUIT ""
SET LEX=LEXICD
+13 QUIT LEX
P10ONE(LEX,LEXVDT) ; Get One ICD-10 Procedure Code for a Term
+1 ;
+2 ; Input
+3 ;
+4 ; LEX IEN of file 757.01
+5 ; LEXVDT Date to use for screening by codes
+6 ;
+7 ; Output
+8 ;
+9 ; $$P10ONE ICD-10-PCS Procedure Code or Null
+10 ;
+11 NEW LEXICD
DO VDT
SET LEXICD=$$ONE($GET(LEX),$GET(LEXVDT),"10P")
+12 IF '$LENGTH($PIECE(LEXICD,"^",1))
QUIT ""
SET LEX=LEXICD
+13 QUIT LEX
CPTONE(LEX,LEXVDT) ; Get One CPT Code for a Term
+1 ;
+2 ; Input
+3 ;
+4 ; LEX IEN of file 757.01
+5 ; LEXVDT Date to use for screening by codes
+6 ;
+7 ; Output
+8 ;
+9 ; $$CPTONE CPT Code or Null
+10 ;
+11 NEW LEXCPT
DO VDT
SET LEXCPT=$$ONE($GET(LEX),$GET(LEXVDT),"CPT")
+12 IF '$LENGTH($PIECE(LEXCPT,"^",1))
QUIT ""
SET LEX=LEXCPT
+13 QUIT LEX
CPCONE(LEX,LEXVDT) ; Get One HCPCS Code for a Term
+1 ;
+2 ; Input
+3 ;
+4 ; LEX IEN of file 757.01
+5 ; LEXVDT Date to use for screening by codes
+6 ;
+7 ; Output
+8 ;
+9 ; $$CPCONE HCPCS Code or Null
+10 ;
+11 NEW LEXCPT
DO VDT
SET LEXCPT=$$ONE($GET(LEX),$GET(LEXVDT),"CPC")
+12 IF '$LENGTH($PIECE(LEXCPT,"^",1))
QUIT ""
SET LEX=LEXCPT
+13 QUIT LEX
DSMONE(LEX,LEXVDT) ; Get One DSM Code for a Term
+1 ;
+2 ; Input
+3 ;
+4 ; LEX IEN of file 757.01
+5 ; LEXVDT Date to use for screening by codes
+6 ;
+7 ; Output
+8 ;
+9 ; $$DSMONE DSM-IV Code or Null
+10 ;
+11 NEW LEXDSM
DO VDT
SET LEXDSM=$$ONE^LEXSRC(LEX,"DS4")
+12 IF LEXDSM'=""
Begin DoDot:1
+13 SET LEX=LEXDSM
NEW LEXDAT
SET LEXDAT=$$ICDDX^ICDEX(LEXDSM,$GET(LEXVDT),1,"E")
+14 IF $PIECE(LEXDAT,"^",10)'>0
SET LEX=""
End DoDot:1
QUIT LEX
+15 SET LEXDSM=$$ONE^LEXSRC(LEX,"DS3")
IF LEXDSM'=""
Begin DoDot:1
+16 SET LEX=LEXDSM
NEW LEXDAT
SET LEXDAT=$$ICDDX^ICDEX(LEXDSM,$GET(LEXVDT),1,"E")
+17 IF $PIECE(LEXDAT,"^",10)'>0
SET LEX=""
End DoDot:1
QUIT LEX
+18 QUIT ""
+19 ;
SCT(X,LEXVDT) ; Filter by SNOMED CT (SCT) (Human only)
+1 ;
+2 ; Input
+3 ;
+4 ; X IEN of file 757.01
+5 ; LEXVDT Date to use for screening by codes
+6 ;
+7 ; Output
+8 ;
+9 ; $$SCT Human SNOMED Code or Null
+10 ; Excludes Veterinary SNOMED codes
+11 ;
+12 NEW LEXEX,LEXMC,LEXD,LEXC,LEXI,LEXO,LEXPL,LEXVT
SET LEXEX=+($GET(X))
SET LEXD=$GET(LEXVDT)
IF LEXEX'>0
QUIT 0
+13 SET LEXC=$SELECT(LEXD?7N:$$ONE^LEXU(+LEXEX,LEXD,"SCT"),1:$$ONE^LEXU(+LEXEX,,"SCT"))
+14 IF '$LENGTH(LEXC)
QUIT 0
SET LEXMC=+($GET(^LEX(757.01,+LEXEX,1)))
IF LEXMC'>0
QUIT 0
IF '$DATA(^LEX(757.1,"B",LEXMC))
QUIT 0
+15 SET LEXVT=0
SET LEXI=0
FOR
SET LEXI=$ORDER(^LEX(757.1,"B",LEXMC,LEXI))
IF +LEXI'>0
QUIT
Begin DoDot:1
+16 NEW LEXT,LEXN
SET LEXT=$PIECE($GET(^LEX(757.1,LEXI,0)),"^",3)
SET LEXN=$$UP^XLFSTR($PIECE($GET(^LEX(757.12,+LEXT,0)),"^",2))
IF LEXN["VETERINARY"
SET LEXVT=1
End DoDot:1
IF LEXVT>0
QUIT
+17 SET LEXPL=0
SET LEXI=0
FOR
SET LEXI=$ORDER(^LEX(757.21,"B",LEXEX,LEXI))
IF +LEXI'>0
QUIT
Begin DoDot:1
+18 NEW LEXT,LEXN
SET LEXT=$PIECE($GET(^LEX(757.21,LEXI,0)),"^",2)
SET LEXN=$PIECE($GET(^LEXT(757.2,+LEXT,0)),"^",2)
IF LEXN="PLS"
SET LEXPL=1
End DoDot:1
IF LEXPL>0
QUIT
+19 SET LEXO=1
IF LEXVT=1
SET LEXO=0
IF LEXPL'>0
SET LEXO=0
+20 SET X=LEXO
+21 QUIT X
ONE(LEX,LEXVDT,LEXSAB) ; Get One Code for a Term by Source
+1 ;
+2 ; Input
+3 ; LEX IEN of file 757.01
+4 ; LEXVDT Date to use for screening by codes
+5 ; LEXSAB Source Abbreviation
+6 ;
+7 ; Output
+8 ;
+9 ; $$ONE Code or Null
+10 ;
+11 NEW LEXDAT,LEXIEN
DO VDT
SET LEXIEN=$GET(LEX)
IF +($GET(LEXIEN))'>0
QUIT ""
+12 SET LEXSAB=$GET(LEXSAB)
IF '$LENGTH(LEXSAB)
QUIT ""
+13 IF LEXSAB?1N.N
IF '$DATA(^LEX(757.03,"ASAB",LEXSAB))
IF $DATA(^LEX(757.03,+LEXSAB,0))
Begin DoDot:1
+14 SET LEXSAB=$PIECE($GET(^LEX(757.03,+LEXSAB,0)),"^",1)
End DoDot:1
+15 SET LEXSAB=$EXTRACT($GET(LEXSAB),1,3)
IF $LENGTH(LEXSAB)'=3
QUIT ""
+16 SET LEX=$$ONE^LEXSRC(LEXIEN,LEXSAB,LEXVDT)
SET LEXDAT=""
+17 IF LEXSAB="ICD"!(LEXSAB="DS4")
SET LEXDAT=$$ICDDX^ICDEX(LEX,LEXVDT,1,"E")
+18 IF LEXSAB="10D"
SET LEXDAT=$$ICDDX^ICDEX(LEX,LEXVDT,30,"E")
+19 IF LEXSAB="ICP"
SET LEXDAT=$$ICDOP^ICDEX(LEX,LEXVDT,2,"E")
+20 IF LEXSAB="10P"
SET LEXDAT=$$ICDOP^ICDEX(LEX,LEXVDT,31,"E")
+21 IF LEXSAB="CPT"
SET LEXDAT=$$CPT^ICPTCOD(LEX,LEXVDT)
+22 IF LEXSAB="CPC"
SET LEXDAT=$$CPT^ICPTCOD(LEX,LEXVDT)
+23 IF "^CPT^CPC"[("^"_LEXSAB_"^")&($PIECE(LEXDAT,"^",7)'>0)
QUIT ""
+24 IF "^ICD^ICP^10D^10P^"[("^"_LEXSAB_"^")&($PIECE(LEXDAT,"^",10)'>0)
QUIT ""
+25 SET LEX=""
IF +LEXDAT'>0
Begin DoDot:1
+26 NEW LEXSIEN
SET LEXSIEN=0
+27 FOR
SET LEXSIEN=$ORDER(^LEX(757.02,"B",LEXIEN,LEXSIEN))
IF +LEXSIEN'>0
QUIT
Begin DoDot:2
+28 IF '$DATA(^LEX(757.02,"ASRC",LEXSAB,LEXSIEN))
QUIT
NEW LEXEF,LEXHI,LEXST,LEXCD
+29 SET LEXEF=$ORDER(^LEX(757.02,LEXSIEN,4,"B",(LEXVDT+.001)),-1)
IF '$LENGTH(LEXEF)
QUIT
+30 SET LEXHI=$ORDER(^LEX(757.02,LEXSIEN,4,"B",+LEXEF," "),-1)
+31 SET LEXST=$PIECE($GET(^LEX(757.02,LEXSIEN,4,+LEXHI,0)),"^",2)
IF LEXST'>0
QUIT
+32 SET LEXCD=$PIECE($GET(^LEX(757.02,+LEXSIEN,0)),"^",2)
+33 IF $LENGTH(LEXCD)&(+LEXIEN>0)
SET LEXDAT=LEXIEN_"^"_LEXCD
End DoDot:2
IF +LEXDAT>0
QUIT
End DoDot:1
+34 IF +LEXDAT'>0
QUIT ""
SET LEX=$PIECE(LEXDAT,"^",2)
+35 IF $GET(LEXLKT)["BC"
Begin DoDot:1
+36 NEW LEXNAR
SET LEXNAR=$$UP^XLFSTR($GET(^TMP("LEXSCH",$JOB,"NAR",0)))
+37 IF $LENGTH($GET(LEXNAR))
IF $EXTRACT(LEX,1,$LENGTH($GET(LEXNAR)))'=$GET(LEXNAR)
SET LEX=""
End DoDot:1
+38 QUIT LEX
ICD(LEX,LEXVDT) ; Get All ICD-9 Diagnosis Codes for a Term
+1 ;
+2 ; Input
+3 ;
+4 ; LEX IEN of file 757.01
+5 ; LEXVDT Date to use for screening by codes
+6 ;
+7 ; Output
+8 ;
+9 ; $$ICD <ICD-9 code><ICD-9 code><etc>
+10 ;
+11 DO VDT
SET LEX=$$ALL^LEXU($GET(LEX),$GET(LEXVDT),"ICD")
+12 QUIT LEX
D10(LEX,LEXVDT) ; Get All ICD-10 Diagnosis Codes for a Term
+1 ;
+2 ; Input
+3 ;
+4 ; LEX IEN of file 757.01
+5 ; LEXVDT Date to use for screening by codes
+6 ;
+7 ; Output
+8 ;
+9 ; $$D10 <ICD-10 code><ICD-10 code><etc>
+10 ;
+11 DO VDT
SET LEX=$$ALL^LEXU($GET(LEX),$GET(LEXVDT),"10D")
+12 QUIT LEX
+13 ;
ALL(LEX,LEXVDT,LEXSAB) ; Get All Codes for a Term by Source
+1 ;
+2 ; Input
+3 ;
+4 ; LEX IEN of file 757.01
+5 ; LEXVDT Date to use for screening by codes
+6 ; LEXSAB Source Abbreviation
+7 ;
+8 ; Output
+9 ;
+10 ; $$ALL A ";" delimited string of codes
+11 ; of the specified coding system
+12 ; for the term
+13 ;
+14 NEW LEXDAT,LEXIEN,LEXSRC,LEXI,LEXT,LEXS
DO VDT
+15 SET LEXIEN=+($GET(LEX))
IF +($GET(LEXIEN))'>0
QUIT ""
+16 SET LEXSAB=$EXTRACT($GET(LEXSAB),1,3)
IF $LENGTH(LEXSAB)'=3
QUIT ""
+17 DO ALL^LEXSRC(LEX,LEXSAB,LEXVDT)
+18 IF +$GET(LEXSRC(0))'>0
QUIT ""
SET LEXI=0
SET LEXT=""
+19 FOR
SET LEXI=$ORDER(LEXSRC(LEXI))
IF +LEXI=0
QUIT
Begin DoDot:1
+20 SET LEXS=LEXSRC(LEXI)
+21 IF LEXSAB="ICD"
SET LEXDAT=$$ICDDX^ICDEX(LEXS,$GET(LEXVDT),1,"E")
+22 IF LEXSAB="10D"
SET LEXDAT=$$ICDDX^ICDEX(LEXS,$GET(LEXVDT),30,"E")
+23 IF LEXSAB="10P"
SET LEXDAT=$$ICDOP^ICDEX(LEXS,$GET(LEXVDT),31,"E")
+24 IF LEXSAB="CPT"
SET LEXDAT=$$CPT^ICPTCOD(LEXS,LEXVDT)
+25 IF LEXSAB="CPC"
SET LEXDAT=$$CPT^ICPTCOD(LEXS,LEXVDT)
+26 IF +($GET(LEXDAT))'>0
QUIT
+27 IF "^CPT^CPT"[("^"_LEXSAB_"^")&($PIECE($GET(LEXDAT),"^",7)'>0)
QUIT
+28 IF "^ICD^ICP^10D^10P^"[("^"_LEXSAB_"^")&($PIECE($GET(LEXDAT),"^",10)'>0)
QUIT
+29 IF (LEXT_";")[(";"_LEXS_";")
QUIT
SET LEXT=LEXT_";"_LEXS
End DoDot:1
+30 SET LEX=""
IF $EXTRACT(LEXT,1)=";"
SET LEXT=$EXTRACT(LEXT,2,$LENGTH(LEXT))
SET LEX=LEXT
+31 QUIT LEX
HIST(CODE,SYS,ARY) ; Activation History
+1 QUIT $$HIST^LEXU4($GET(CODE),$GET(SYS),.ARY)
PERIOD(CODE,SYS,ARY) ; Return Activation Periods
+1 QUIT $$PERIOD^LEXU4($GET(CODE),$GET(SYS),.ARY)
CSDATA(CODE,CSYS,CDT,ARY) ; Code Data
+1 NEW X
SET X=$$CSDATA^LEXU2($GET(CODE),$GET(CSYS),$GET(CDT),.ARY)
QUIT X
ADR(LEX) ; Mailing Address
+1 QUIT $$ADR^LEXU3($GET(LEX))
VDT ; Resolve LEXVDT
+1 DO VDT^LEXU3
QUIT
IMPDATE(CSYS) ; Return the implementation date for a coding system
+1 QUIT $$IMPDATE^LEXU3($GET(CSYS))
CSYS(SYS) ; Coding System Info
+1 QUIT $$CSYS^LEXU3($GET(SYS))
FREQ(TXT) ; Frequency of text - ICR 5679
+1 QUIT $$FREQ^LEXU3($GET(TXT))
MAX(SYS) ; Coding System search Threshold - ICR 5679
+1 QUIT $$MAX^LEXU3($GET(SYS))
PAR(TXT,ARY) ; Parse Text into Words (for indexing)
+1 QUIT $$PAR^LEXU3(TXT,.ARY)
CAT(CODE) ; Get Category of Dx Code - ICR 5679
+1 QUIT $$CAT^LEX10DU($GET(CODE))
ISCAT(CODE) ; Get Category of Dx Code - ICR 5679
+1 QUIT $$ISCAT^LEX10DU($GET(CODE))
PFI(FRAG,CDT,ARY) ; ICD-10 Procedure Code Fragment Information - ICR 5679
+1 QUIT $$PFI^LEXU4($GET(FRAG),$GET(CDT),.ARY)
NXSAB(X,Y) ; Next Source Abbreviation
+1 QUIT $$NXSAB^LEXU3($GET(X),$GET(Y))
INC(X) ; Increment Concept Usage for a term (by subscription only)
+1 DO INC^LEXU3($GET(X))
+2 QUIT
RECENT(X) ; Recently Updated (90 day window)
+1 QUIT $$RECENT^LEXU3($GET(X))
RUPD(X) ; Recent Update Date
+1 QUIT $$RUPD^LEXU3($GET(X))
LUPD(X,Y) ; Last Update
+1 QUIT $$LUPD^LEXU3($GET(X),$GET(Y))
