- 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))