- 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 Jan 18, 2025@03:10:44 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