LEXU ;ISL/KER - Miscellaneous Lexicon Utilities ;05/23/2017
;;2.0;LEXICON UTILITY;**2,6,9,15,25,36,73,51,80,86,103**;Sep 23, 1996;Build 2
;
; Global Variables
; ^TMP("LEXSCH",$J) SACC 2.3.2.5.1
;
; External References
; $$ICDDX^ICDEX ICR 5747
; $$ICDOP^ICDEX ICR 5747
; $$CPT^ICPTCOD ICR 1995
; $$UP^XLFSTR ICR 10104
;
; Local Variables NEWed or KILLed Elsewhere
; LEXLKT Lookup Type
;
HELP ; API Help
D EN^LEXUH
Q
SC(LEX,LEXS,LEXVDT) ; Filter by Semantic Class
Q $$SC^LEXU6($G(LEX),$G(LEXS),$G(LEXVDT))
SO(LEX,LEXS,LEXVDT) ; Filter by Source
Q $$SO^LEXU6($G(LEX),$G(LEXS),$G(LEXVDT))
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
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,LEXCD,LEXDAT D VDT S LEXDSM=$$ONE^LEXSRC($G(LEX),"DS4")
I LEXDSM'="" D Q LEX
. S LEX=LEXDSM N LEXDAT,LEXCD S LEXCD=LEXDSM S:$L(LEXCD)=3 LEXCD=LEXCD_"."
. S LEXDAT=$$ICDDX^ICDEX(LEXCD,$G(LEXVDT),1,"E")
. S:$P(LEXDAT,"^",10)'>0 LEX=""
S LEXDSM=$$ONE^LEXSRC($G(LEX),"DS3") I LEXDSM'="" D Q LEX
. S LEX=LEXDSM N LEXDAT,LEXCD S LEXCD=LEXDSM S:$L(LEXCD)=3 LEXCD=LEXCD_"."
. S LEXDAT=$$ICDDX^ICDEX(LEXCD,$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
PRF(LEX,LEXVDT,LEXSAB) ; Get One Code for a Preferred Term by Source
Q $$PRF^LEXU3($G(LEX),$G(LEXVDT),$G(LEXSAB))
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)
EXP(IEN) ; Get Expression for IEN
Q $$EXP^LEXU3($G(IEN))
EXPS(IEN,CDT,ARY) ; Get Expression and Codes for IEN
D EXPS^LEXU3($G(IEN),$G(CDT),.ARY) Q
PREF(CODE,SAB,CDT) ; Get Preferred Expression for an Active Code
Q $$PREF^LEXU3($G(CODE),$G(SAB),$G(CDT))
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^LEXU5($G(CSYS))
CSYS(SYS) ; Coding System Info
Q $$CSYS^LEXU5($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
PR(LEX,X) ; Parse Array LEX into X length strings
D PR^LEXU5(.LEX,$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))
REUSE(X,SYS) ; Is a code "re-used" (1/0)
Q $$REUSE^LEXU4($G(X),$G(SYS))
REVISE(X,SYS) ; Is a code "revised" (1/0)
Q $$REVISE^LEXU4($G(X),$G(SYS))
LAST(X,SYS,CDT) ; Last Activation ^ Last Inactivation Date
Q $$LAST^LEXU4($G(X),$G(SYS),$G(CDT))
IENS(CODE,ARY,CDT) ; Get Lexicon/National File IENS for a Code
Q $$IENS^LEXU7($G(CODE),.ARY,$G(CDT))
SOS(IEN,ARY,SYN) ; Get Codes for an Expression
Q $$SOS^LEXU6($G(IEN),.ARY,$G(SYN))
EXM(X,ARY,LEXD,LEXM) ; Exact Match
Q $$EXM^LEXU6($G(X),.ARY,+($G(LEXD)),+($G(LEXM)))
SUBSETS(CODE,SRC,LEX) ; Get Subsets for a Code
Q $$SUBSETS^LEXU5($G(CODE),$G(SRC),.LEX)
CODE(CODE,SRC,CDT,ARY,OUT) ;
D CODE^LEXINF($G(CODE),$G(SRC),$G(CDT),.ARY,$G(OUT)) Q
TERM(IEN,CDT,ARY,OUT) ;
D TERM^LEXINF($G(IEN),$G(CDT),.ARY,$G(OUT)) Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLEXU 13885 printed Apr 09, 2024@21:10:36 Page 2
LEXU ;ISL/KER - Miscellaneous Lexicon Utilities ;05/23/2017
+1 ;;2.0;LEXICON UTILITY;**2,6,9,15,25,36,73,51,80,86,103**;Sep 23, 1996;Build 2
+2 ;
+3 ; Global Variables
+4 ; ^TMP("LEXSCH",$J) SACC 2.3.2.5.1
+5 ;
+6 ; External References
+7 ; $$ICDDX^ICDEX ICR 5747
+8 ; $$ICDOP^ICDEX ICR 5747
+9 ; $$CPT^ICPTCOD ICR 1995
+10 ; $$UP^XLFSTR ICR 10104
+11 ;
+12 ; Local Variables NEWed or KILLed Elsewhere
+13 ; LEXLKT Lookup Type
+14 ;
HELP ; API Help
+1 DO EN^LEXUH
+2 QUIT
SC(LEX,LEXS,LEXVDT) ; Filter by Semantic Class
+1 QUIT $$SC^LEXU6($GET(LEX),$GET(LEXS),$GET(LEXVDT))
SO(LEX,LEXS,LEXVDT) ; Filter by Source
+1 QUIT $$SO^LEXU6($GET(LEX),$GET(LEXS),$GET(LEXVDT))
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
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,LEXCD,LEXDAT
DO VDT
SET LEXDSM=$$ONE^LEXSRC($GET(LEX),"DS4")
+12 IF LEXDSM'=""
Begin DoDot:1
+13 SET LEX=LEXDSM
NEW LEXDAT,LEXCD
SET LEXCD=LEXDSM
if $LENGTH(LEXCD)=3
SET LEXCD=LEXCD_"."
+14 SET LEXDAT=$$ICDDX^ICDEX(LEXCD,$GET(LEXVDT),1,"E")
+15 if $PIECE(LEXDAT,"^",10)'>0
SET LEX=""
End DoDot:1
QUIT LEX
+16 SET LEXDSM=$$ONE^LEXSRC($GET(LEX),"DS3")
IF LEXDSM'=""
Begin DoDot:1
+17 SET LEX=LEXDSM
NEW LEXDAT,LEXCD
SET LEXCD=LEXDSM
if $LENGTH(LEXCD)=3
SET LEXCD=LEXCD_"."
+18 SET LEXDAT=$$ICDDX^ICDEX(LEXCD,$GET(LEXVDT),1,"E")
+19 if $PIECE(LEXDAT,"^",10)'>0
SET LEX=""
End DoDot:1
QUIT LEX
+20 QUIT ""
+21 ;
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
PRF(LEX,LEXVDT,LEXSAB) ; Get One Code for a Preferred Term by Source
+1 QUIT $$PRF^LEXU3($GET(LEX),$GET(LEXVDT),$GET(LEXSAB))
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)
EXP(IEN) ; Get Expression for IEN
+1 QUIT $$EXP^LEXU3($GET(IEN))
EXPS(IEN,CDT,ARY) ; Get Expression and Codes for IEN
+1 DO EXPS^LEXU3($GET(IEN),$GET(CDT),.ARY)
QUIT
PREF(CODE,SAB,CDT) ; Get Preferred Expression for an Active Code
+1 QUIT $$PREF^LEXU3($GET(CODE),$GET(SAB),$GET(CDT))
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^LEXU5($GET(CSYS))
CSYS(SYS) ; Coding System Info
+1 QUIT $$CSYS^LEXU5($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
PR(LEX,X) ; Parse Array LEX into X length strings
+1 DO PR^LEXU5(.LEX,$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))
REUSE(X,SYS) ; Is a code "re-used" (1/0)
+1 QUIT $$REUSE^LEXU4($GET(X),$GET(SYS))
REVISE(X,SYS) ; Is a code "revised" (1/0)
+1 QUIT $$REVISE^LEXU4($GET(X),$GET(SYS))
LAST(X,SYS,CDT) ; Last Activation ^ Last Inactivation Date
+1 QUIT $$LAST^LEXU4($GET(X),$GET(SYS),$GET(CDT))
IENS(CODE,ARY,CDT) ; Get Lexicon/National File IENS for a Code
+1 QUIT $$IENS^LEXU7($GET(CODE),.ARY,$GET(CDT))
SOS(IEN,ARY,SYN) ; Get Codes for an Expression
+1 QUIT $$SOS^LEXU6($GET(IEN),.ARY,$GET(SYN))
EXM(X,ARY,LEXD,LEXM) ; Exact Match
+1 QUIT $$EXM^LEXU6($GET(X),.ARY,+($GET(LEXD)),+($GET(LEXM)))
SUBSETS(CODE,SRC,LEX) ; Get Subsets for a Code
+1 QUIT $$SUBSETS^LEXU5($GET(CODE),$GET(SRC),.LEX)
CODE(CODE,SRC,CDT,ARY,OUT) ;
+1 DO CODE^LEXINF($GET(CODE),$GET(SRC),$GET(CDT),.ARY,$GET(OUT))
QUIT
TERM(IEN,CDT,ARY,OUT) ;
+1 DO TERM^LEXINF($GET(IEN),$GET(CDT),.ARY,$GET(OUT))
QUIT
