LEXQID2 ;ISL/KER - Query - ICD Diagnosis - Extract (cont) ;05/23/2017
;;2.0;LEXICON UTILITY;**62,73,80,86,103**;Sep 23, 1996;Build 2
;
; Global Variables
; ^ICM( ICR 4488
;
; External References
; $$CODEC^ICDEX ICR 5747
; $$CSI^ICDEX ICR 5747
; $$DTBR^ICDEX ICR 5747
; $$HIST^ICDEX ICR 5747
; $$LA^ICDEX ICR 5747
; $$LD^ICDEX ICR 5747
; $$VMDC^ICDEX ICR 5747
; $$DT^XLFDT ICR 10103
; $$UP^XLFSTR ICR 10104
;
; Local Variables NEWed or KILLed in LEXQID
; LEXIIEN Include IENs flag
; LEXLX Local Array containing Lexicon term
;
Q
LDS(X,LEXVDT,LEX,LEXLEN,LEXSTA) ; Long Description
;
; LEX=# of Lines
; LEX(0)=External Date of Description
; LEX(#)=Description
;
N LEXBRD,LEXBRW,LEXC,LEXD,LEXDDT,LEXE,LEXEE,LEXEFF,LEXFA
N LEXHIS,LEXI,LEXIA,LEXIEN,LEXAIEN,LEXSIEN,LEXL,LEXLA,LEXLAST
N LEXLEF,LEXLHI,LEXLSD,LEXM,LEXOD,LEXODD,LEXR,LEXS,LEXLD,LEXLDD
N LEXSDT,LEXSO,LEXSY,LEXT S LEXIEN=$G(X) Q:+LEXIEN'>0
S LEXVDT=+($G(LEXVDT)) S:LEXVDT'?7N LEXVDT=$$DT^XLFDT
S LEXSTA=+($G(LEXSTA)) S LEXSO=$$CODEC^ICDEX(80,+LEXIEN)
S LEXSY=$$CSI^ICDEX(80,+LEXIEN)
S LEXLA=$$LA^ICDEX(80,+LEXIEN,9999999),LEXFA=$$FA(+LEXIEN)
S LEXLSD=$$LD^ICDEX(80,+LEXIEN,LEXLA)
S LEXBRD=$$DTBR^ICDEX(LEXVDT,0,LEXSY),LEXBRW=""
S LEXLD=$$LD^ICDEX(80,+LEXIEN,LEXVDT,.LEXS,245)
S LEXLD=$G(LEXS(1)),LEXLDD=$P($G(LEXS(0)),"^",2)
S:'$L(LEXLD) LEXLDD="--/--/----" S LEXM=""
I $P(LEXLD,"^",1)="-1"!('$L(LEXLD)) D
. S LEXM="Diagnosis Description is not available."
. I (LEXVDT'?7N!(LEXFA'?7N)),LEXVDT<LEXFA D
. . S LEXM=LEXM_" The date provided precedes the initial activation of the code"
. I LEXVDT?7N&(LEXFA?7N),LEXVDT<LEXFA D
. . S LEXM=LEXM_" The date provided ("_$$ED^LEXQM(LEXVDT)_") precedes the initial activation ("_$$ED^LEXQM(LEXFA)_") of the code"
. S:$L(LEXM) LEXM="NOTE: "_LEXM S LEXOD=LEXLSD,LEXODD="--/--/----"
S LEXAIEN=LEXIEN,LEXSIEN="" I $L(LEXLD)&($P(LEXLD,"^",1)'="-1") D
. S:LEXLDD?7N LEXSIEN=$O(@("^ICD9("_LEXIEN_",68,""B"","_LEXLDD_",0)"))
. S:LEXSIEN>0 LEXAIEN=LEXAIEN_";"_LEXSIEN
. S LEXM="" S LEXOD=LEXLD S:$L(LEXOD)&($D(LEXIIEN)) LEXOD=LEXOD_" (IEN "_LEXAIEN_")"
. S LEXODD=$S(LEXLDD?7N:$$ED^LEXQM(LEXLDD),1:"--/--/----")
S:'$L(LEXOD) LEXOD="Diagnosis Description not found"
S:'$L(LEXODD) LEXODD="--/--/----"
K LEX,LEXT S LEXT(1)=LEXOD D PR^LEXU(.LEXT,(LEXLEN-7))
S LEXI=0 F S LEXI=$O(LEXT(LEXI)) Q:+LEXI'>0 S LEXT=$G(LEXT(LEXI)) S LEX(LEXI)=LEXT
I $L($G(LEXM)) D
. K LEX,LEXT N LEXC S LEXT(1)=LEXM D PR^LEXU(.LEXT,(LEXLEN-7))
. S LEXI=0 F S LEXI=$O(LEXT(LEXI)) Q:+LEXI'>0 S LEXT=$G(LEXT(LEXI)) S LEXC=$O(LEX(" "),-1)+1,LEX(LEXC)=LEXT
S:$D(LEX(1)) LEX(0)=LEXODD
Q
LX(X,LEXVDT,LEX,LEXLEN,LEXSTA) ; Lexicon Expression
;
; LEX=# of Lines
; LEX(0)=External Date of Expression
; LEX(#)=Expression
;
N LEXEF,LEXEVDT,LEXLEX,LEXEE,LEXFA,LEXI,LEXIA,LEXIEN,LEXAIEN,LEXLEF,LEXLHS,LEXLST,LEXM,LEXN0
N LEXPF,LEXSAB,LEXSRC,LEXSIEN,LEXSO,LEXTSRC,LEXT,LEXTE,LEXTEXP,LEXTEF,LEXTEFE,LEXTS,LEXTSTA,LEXVTMP
S LEXIEN=$G(X) Q:+LEXIEN'>0
S LEXVDT=+($G(LEXVDT)) S:LEXVDT'?7N LEXVDT=$$DT^XLFDT S LEXSTA=+($G(LEXSTA))
S LEXEVDT=$$SD^LEXQM(LEXVDT),LEXLEN=+($G(LEXLEN)) S:+LEXLEN'>0 LEXLEN=62
Q:'$L(LEXEVDT) S LEXSO=$$CODEC^ICDEX(80,+LEXIEN)
Q:'$L(LEXSO) S LEXFA=$$FA(+LEXIEN),LEXM="",LEXIA=$$IA(LEXVDT)
S LEXTSRC=$$SAB^ICDEX($$CSI^ICDEX(80,+LEXIEN)) S:$L(LEXTSRC)'=3 LEXTSRC="" S LEXTSTA=$$STATCHK^LEXSRC2(LEXSO,LEXVDT,,LEXTSRC)
S LEXTS=$P($G(LEXTSTA),"^",2),LEXTE=+($G(^LEX(757.02,+LEXTS,0))),LEXTEXP=$G(^LEX(757.01,+LEXTE,0))
S (LEXTEF,LEXTEFE)="",LEXEF="" F S LEXEF=$O(^LEX(757.02,+LEXTS,4,"B",LEXEF)) Q:+LEXEF'>0 D
. N LEXH S LEXH=0 F S LEXH=$O(^LEX(757.02,+LEXTS,4,"B",LEXEF,LEXH)) Q:+LEXH'>0 D
. . S:$P($G(^LEX(757.02,+LEXTS,4,+LEXH,0)),"^",2)>0&(LEXEF?7N) LEXTEF=LEXEF
. . S:LEXTEF?7N LEXTEFE=$$SD^LEXQM(LEXTEF)
I LEXSTA'>0,$L($G(LEXTEXP)),$G(LEXTEF)?7N,$L($G(LEXTEFE)) D Q
. K LEX N LEXT,LEXM,LEXI S LEXT(1)=LEXTEXP S:$D(LEXIIEN) LEXT(1)=$G(LEXT(1))_" (IEN "_LEXTE_")"
. D PR^LEXU(.LEXT,(LEXLEN-7)) S LEXI=0 F S LEXI=$O(LEXT(LEXI)) Q:+LEXI'>0 S:$L($G(LEXT(LEXI))) LEX(+LEXI)=$G(LEXT(LEXI))
. S LEX=+($O(LEX(" "),-1)) S LEX(0)=LEXTEFE
S LEXSIEN=0 F S LEXSIEN=$O(^LEX(757.02,"CODE",(LEXSO_" "),LEXSIEN)) Q:+LEXSIEN'>0 D
. N LEXN0 S LEXN0=$G(^LEX(757.02,+LEXSIEN,0)),LEXSAB=$P(LEXN0,"^",3)
. Q:"^1^30^"'[("^"_LEXSAB_"^") S LEXPF=+($P(LEXN0,"^",5)) S LEXLEF=$O(^LEX(757.02,+LEXSIEN,4,"B",(LEXVDT+.99999)),-1)
. I LEXLEF?7N D
. . S LEXLHS=$O(^LEX(757.02,+LEXSIEN,4,"B",+LEXLEF," "),-1) I +LEXLHS>0 D
. . . S LEXLST=$G(^LEX(757.02,+LEXSIEN,4,+LEXLHS,0)),LEXLST=$P(LEXLST,"^",2)
. . . S:LEXLST>0 LEXVTMP(+LEXPF,LEXSIEN)=+LEXN0_"^"_LEXLEF
S (LEXLEX,LEXEF)="",LEXSIEN=$O(LEXVTMP(1,0)),LEXLEX=+($G(LEXVTMP(1,+LEXSIEN))),LEXEF=$P($G(LEXVTMP(1,+LEXSIEN)),"^",2)
S:+LEXSIEN'>0!(+LEXLEX'>0) LEXSIEN=$O(LEXVTMP(0,0)),LEXLEX=+($G(LEXVTMP(0,+LEXSIEN))),LEXEF=$P($G(LEXVTMP(0,+LEXSIEN)),"^",2)
K LEX I +LEXLEX>0,$L($G(^LEX(757.01,+LEXLEX,0))),$L(LEXEF),LEXEF?7N D Q
. S LEXAIEN=LEXLEX
. K LEX N LEXT,LEXM,LEXI S LEXT(1)=$G(^LEX(757.01,+LEXLEX,0))
. S:$D(LEXIIEN) LEXT(1)=$G(LEXT(1))_" (IEN "_LEXAIEN_")"
. D PR^LEXU(.LEXT,(LEXLEN-7))
. S LEXI=0 F S LEXI=$O(LEXT(LEXI)) Q:+LEXI'>0 S:$L($G(LEXT(LEXI))) LEX(+LEXI)=$G(LEXT(LEXI))
. S LEX=+($O(LEX(" "),-1)) S LEXEE=$$SD^LEXQM(LEXEF) S LEX(0)=LEXEE
Q
WN(X,LEX,LEXLEN) ; Warning
;
; LEX=# of Lines
; LEX(0)=External Date
; LEX(#)=Warning
;
N LEXVDT,LEXREF,LEXIA,LEXTMP K LEX S LEXVDT=$G(X) Q:LEXVDT'?7N S LEXIA=$$IA(LEXVDT) Q:+LEXIA'>0 S LEXLEN=+$G(LEXLEN) S:+LEXLEN>62 LEXLEN=62
S LEXREF="Diagnosis (Short Name) and Description" S:$D(LEXLX) LEXREF="Diagnosis (Short Name), Description and Lexicon Term"
S LEXTMP(1)="Warning: The 'Based on Date' provided precedes Code Set Versioning. The "_LEXREF_" may be inaccurate for "_$$SD^LEXQM(LEXVDT)
D PR^LEXU(.LEXTMP,LEXLEN) K LEX S LEXI=0 F S LEXI=$O(LEXTMP(LEXI)) Q:+LEXI'>0 S LEX(LEXI)=$G(LEXTMP(LEXI))
S LEX=$O(LEX(" "),-1),LEX(0)=$$SD^LEXQM(LEXVDT)
Q
MDC(X,LEXVDT,LEX) ; Major Diagnostic Category
;
; LEX=# of Lines
; LEX(0)=External Date of MDC
; LEX(#)=MDC
;
Q
N LEXEF,LEXMDC,LEXMH,LEXN0,LEXNAM
K LEX S LEX=0,LEXIEN=+($G(X)) Q:+LEXIEN'>0
S LEXVDT=+($G(LEXVDT)) S:LEXVDT'?7N LEXVDT=$$DT^XLFDT
S LEXMDC=$$VMDC^ICDEX(+LEXIEN,+LEXVDT,1)
S LEXEF=$P(LEXMDC,"^",2),LEXMDC=$P(LEXMDC,"^",1)
Q:+LEXMDC'>0 Q:'$D(^ICM(+LEXMDC,0))
S LEXNAM=$$UP^XLFSTR($P($G(^ICM(+LEXMDC,0)),"^",1)) Q:'$L(LEXNAM)
S:$D(LEXIIEN) LEXNAM=LEXNAM_" (IEN "_+LEXMDC_")"
S LEX=1,LEX(0)=$$SD^LEXQM(LEXEF),LEX(1)=LEXNAM
Q
; Miscellaneous
FA(X) ; First Activation
N LEXFA,LEXH,LEXI,LEXIEN,LEXSO,LEXSY
S LEXIEN=+($G(X)) S X="",LEXSO=$$CODEC^ICDEX(80,+LEXIEN),LEXSY=$$CSI^ICDEX(80,+LEXIEN)
K LEXH S X=$$HIST^ICDEX(LEXSO,.LEXH,LEXSY) S LEXFA="",LEXI=0
F S LEXI=$O(LEXH(LEXI)) Q:+LEXI'>0!($L(LEXFA)) S:+($G(LEXH(LEXI)))>0&(LEXI?7N) LEXFA=LEXI Q:$L(LEXFA)
S X=LEXFA
Q X
IA(X,Y) ; Inaccurate
N LEXBRD,LEXVDT,LEXIEN,LEXSYS S LEXVDT=+($G(X)),LEXIEN=+($G(Y)) Q:+LEXIEN'>0 0
S LEXSYS=$$CSI^ICDEX(80,+LEXIEN) Q:+LEXSYS'>0 0 S:'$L(LEXVDT) LEXVDT=$$DT^XLFDT
S:LEXVDT#10000=0 LEXVDT=LEXVDT+101 S:LEXVDT#100=0 LEXVDT=LEXVDT+1
S LEXBRD=$$DTBR^ICDEX(LEXVDT,0,LEXSYS) S X=$S(LEXVDT<LEXBRD:1,1:0)
Q X
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLEXQID2 7550 printed Apr 09, 2024@21:08:47 Page 2
LEXQID2 ;ISL/KER - Query - ICD Diagnosis - Extract (cont) ;05/23/2017
+1 ;;2.0;LEXICON UTILITY;**62,73,80,86,103**;Sep 23, 1996;Build 2
+2 ;
+3 ; Global Variables
+4 ; ^ICM( ICR 4488
+5 ;
+6 ; External References
+7 ; $$CODEC^ICDEX ICR 5747
+8 ; $$CSI^ICDEX ICR 5747
+9 ; $$DTBR^ICDEX ICR 5747
+10 ; $$HIST^ICDEX ICR 5747
+11 ; $$LA^ICDEX ICR 5747
+12 ; $$LD^ICDEX ICR 5747
+13 ; $$VMDC^ICDEX ICR 5747
+14 ; $$DT^XLFDT ICR 10103
+15 ; $$UP^XLFSTR ICR 10104
+16 ;
+17 ; Local Variables NEWed or KILLed in LEXQID
+18 ; LEXIIEN Include IENs flag
+19 ; LEXLX Local Array containing Lexicon term
+20 ;
+21 QUIT
LDS(X,LEXVDT,LEX,LEXLEN,LEXSTA) ; Long Description
+1 ;
+2 ; LEX=# of Lines
+3 ; LEX(0)=External Date of Description
+4 ; LEX(#)=Description
+5 ;
+6 NEW LEXBRD,LEXBRW,LEXC,LEXD,LEXDDT,LEXE,LEXEE,LEXEFF,LEXFA
+7 NEW LEXHIS,LEXI,LEXIA,LEXIEN,LEXAIEN,LEXSIEN,LEXL,LEXLA,LEXLAST
+8 NEW LEXLEF,LEXLHI,LEXLSD,LEXM,LEXOD,LEXODD,LEXR,LEXS,LEXLD,LEXLDD
+9 NEW LEXSDT,LEXSO,LEXSY,LEXT
SET LEXIEN=$GET(X)
if +LEXIEN'>0
QUIT
+10 SET LEXVDT=+($GET(LEXVDT))
if LEXVDT'?7N
SET LEXVDT=$$DT^XLFDT
+11 SET LEXSTA=+($GET(LEXSTA))
SET LEXSO=$$CODEC^ICDEX(80,+LEXIEN)
+12 SET LEXSY=$$CSI^ICDEX(80,+LEXIEN)
+13 SET LEXLA=$$LA^ICDEX(80,+LEXIEN,9999999)
SET LEXFA=$$FA(+LEXIEN)
+14 SET LEXLSD=$$LD^ICDEX(80,+LEXIEN,LEXLA)
+15 SET LEXBRD=$$DTBR^ICDEX(LEXVDT,0,LEXSY)
SET LEXBRW=""
+16 SET LEXLD=$$LD^ICDEX(80,+LEXIEN,LEXVDT,.LEXS,245)
+17 SET LEXLD=$GET(LEXS(1))
SET LEXLDD=$PIECE($GET(LEXS(0)),"^",2)
+18 if '$LENGTH(LEXLD)
SET LEXLDD="--/--/----"
SET LEXM=""
+19 IF $PIECE(LEXLD,"^",1)="-1"!('$LENGTH(LEXLD))
Begin DoDot:1
+20 SET LEXM="Diagnosis Description is not available."
+21 IF (LEXVDT'?7N!(LEXFA'?7N))
IF LEXVDT<LEXFA
Begin DoDot:2
+22 SET LEXM=LEXM_" The date provided precedes the initial activation of the code"
End DoDot:2
+23 IF LEXVDT?7N&(LEXFA?7N)
IF LEXVDT<LEXFA
Begin DoDot:2
+24 SET LEXM=LEXM_" The date provided ("_$$ED^LEXQM(LEXVDT)_") precedes the initial activation ("_$$ED^LEXQM(LEXFA)_") of the code"
End DoDot:2
+25 if $LENGTH(LEXM)
SET LEXM="NOTE: "_LEXM
SET LEXOD=LEXLSD
SET LEXODD="--/--/----"
End DoDot:1
+26 SET LEXAIEN=LEXIEN
SET LEXSIEN=""
IF $LENGTH(LEXLD)&($PIECE(LEXLD,"^",1)'="-1")
Begin DoDot:1
+27 if LEXLDD?7N
SET LEXSIEN=$ORDER(@("^ICD9("_LEXIEN_",68,""B"","_LEXLDD_",0)"))
+28 if LEXSIEN>0
SET LEXAIEN=LEXAIEN_";"_LEXSIEN
+29 SET LEXM=""
SET LEXOD=LEXLD
if $LENGTH(LEXOD)&($DATA(LEXIIEN))
SET LEXOD=LEXOD_" (IEN "_LEXAIEN_")"
+30 SET LEXODD=$SELECT(LEXLDD?7N:$$ED^LEXQM(LEXLDD),1:"--/--/----")
End DoDot:1
+31 if '$LENGTH(LEXOD)
SET LEXOD="Diagnosis Description not found"
+32 if '$LENGTH(LEXODD)
SET LEXODD="--/--/----"
+33 KILL LEX,LEXT
SET LEXT(1)=LEXOD
DO PR^LEXU(.LEXT,(LEXLEN-7))
+34 SET LEXI=0
FOR
SET LEXI=$ORDER(LEXT(LEXI))
if +LEXI'>0
QUIT
SET LEXT=$GET(LEXT(LEXI))
SET LEX(LEXI)=LEXT
+35 IF $LENGTH($GET(LEXM))
Begin DoDot:1
+36 KILL LEX,LEXT
NEW LEXC
SET LEXT(1)=LEXM
DO PR^LEXU(.LEXT,(LEXLEN-7))
+37 SET LEXI=0
FOR
SET LEXI=$ORDER(LEXT(LEXI))
if +LEXI'>0
QUIT
SET LEXT=$GET(LEXT(LEXI))
SET LEXC=$ORDER(LEX(" "),-1)+1
SET LEX(LEXC)=LEXT
End DoDot:1
+38 if $DATA(LEX(1))
SET LEX(0)=LEXODD
+39 QUIT
LX(X,LEXVDT,LEX,LEXLEN,LEXSTA) ; Lexicon Expression
+1 ;
+2 ; LEX=# of Lines
+3 ; LEX(0)=External Date of Expression
+4 ; LEX(#)=Expression
+5 ;
+6 NEW LEXEF,LEXEVDT,LEXLEX,LEXEE,LEXFA,LEXI,LEXIA,LEXIEN,LEXAIEN,LEXLEF,LEXLHS,LEXLST,LEXM,LEXN0
+7 NEW LEXPF,LEXSAB,LEXSRC,LEXSIEN,LEXSO,LEXTSRC,LEXT,LEXTE,LEXTEXP,LEXTEF,LEXTEFE,LEXTS,LEXTSTA,LEXVTMP
+8 SET LEXIEN=$GET(X)
if +LEXIEN'>0
QUIT
+9 SET LEXVDT=+($GET(LEXVDT))
if LEXVDT'?7N
SET LEXVDT=$$DT^XLFDT
SET LEXSTA=+($GET(LEXSTA))
+10 SET LEXEVDT=$$SD^LEXQM(LEXVDT)
SET LEXLEN=+($GET(LEXLEN))
if +LEXLEN'>0
SET LEXLEN=62
+11 if '$LENGTH(LEXEVDT)
QUIT
SET LEXSO=$$CODEC^ICDEX(80,+LEXIEN)
+12 if '$LENGTH(LEXSO)
QUIT
SET LEXFA=$$FA(+LEXIEN)
SET LEXM=""
SET LEXIA=$$IA(LEXVDT)
+13 SET LEXTSRC=$$SAB^ICDEX($$CSI^ICDEX(80,+LEXIEN))
if $LENGTH(LEXTSRC)'=3
SET LEXTSRC=""
SET LEXTSTA=$$STATCHK^LEXSRC2(LEXSO,LEXVDT,,LEXTSRC)
+14 SET LEXTS=$PIECE($GET(LEXTSTA),"^",2)
SET LEXTE=+($GET(^LEX(757.02,+LEXTS,0)))
SET LEXTEXP=$GET(^LEX(757.01,+LEXTE,0))
+15 SET (LEXTEF,LEXTEFE)=""
SET LEXEF=""
FOR
SET LEXEF=$ORDER(^LEX(757.02,+LEXTS,4,"B",LEXEF))
if +LEXEF'>0
QUIT
Begin DoDot:1
+16 NEW LEXH
SET LEXH=0
FOR
SET LEXH=$ORDER(^LEX(757.02,+LEXTS,4,"B",LEXEF,LEXH))
if +LEXH'>0
QUIT
Begin DoDot:2
+17 if $PIECE($GET(^LEX(757.02,+LEXTS,4,+LEXH,0)),"^",2)>0&(LEXEF?7N)
SET LEXTEF=LEXEF
+18 if LEXTEF?7N
SET LEXTEFE=$$SD^LEXQM(LEXTEF)
End DoDot:2
End DoDot:1
+19 IF LEXSTA'>0
IF $LENGTH($GET(LEXTEXP))
IF $GET(LEXTEF)?7N
IF $LENGTH($GET(LEXTEFE))
Begin DoDot:1
+20 KILL LEX
NEW LEXT,LEXM,LEXI
SET LEXT(1)=LEXTEXP
if $DATA(LEXIIEN)
SET LEXT(1)=$GET(LEXT(1))_" (IEN "_LEXTE_")"
+21 DO PR^LEXU(.LEXT,(LEXLEN-7))
SET LEXI=0
FOR
SET LEXI=$ORDER(LEXT(LEXI))
if +LEXI'>0
QUIT
if $LENGTH($GET(LEXT(LEXI)))
SET LEX(+LEXI)=$GET(LEXT(LEXI))
+22 SET LEX=+($ORDER(LEX(" "),-1))
SET LEX(0)=LEXTEFE
End DoDot:1
QUIT
+23 SET LEXSIEN=0
FOR
SET LEXSIEN=$ORDER(^LEX(757.02,"CODE",(LEXSO_" "),LEXSIEN))
if +LEXSIEN'>0
QUIT
Begin DoDot:1
+24 NEW LEXN0
SET LEXN0=$GET(^LEX(757.02,+LEXSIEN,0))
SET LEXSAB=$PIECE(LEXN0,"^",3)
+25 if "^1^30^"'[("^"_LEXSAB_"^")
QUIT
SET LEXPF=+($PIECE(LEXN0,"^",5))
SET LEXLEF=$ORDER(^LEX(757.02,+LEXSIEN,4,"B",(LEXVDT+.99999)),-1)
+26 IF LEXLEF?7N
Begin DoDot:2
+27 SET LEXLHS=$ORDER(^LEX(757.02,+LEXSIEN,4,"B",+LEXLEF," "),-1)
IF +LEXLHS>0
Begin DoDot:3
+28 SET LEXLST=$GET(^LEX(757.02,+LEXSIEN,4,+LEXLHS,0))
SET LEXLST=$PIECE(LEXLST,"^",2)
+29 if LEXLST>0
SET LEXVTMP(+LEXPF,LEXSIEN)=+LEXN0_"^"_LEXLEF
End DoDot:3
End DoDot:2
End DoDot:1
+30 SET (LEXLEX,LEXEF)=""
SET LEXSIEN=$ORDER(LEXVTMP(1,0))
SET LEXLEX=+($GET(LEXVTMP(1,+LEXSIEN)))
SET LEXEF=$PIECE($GET(LEXVTMP(1,+LEXSIEN)),"^",2)
+31 if +LEXSIEN'>0!(+LEXLEX'>0)
SET LEXSIEN=$ORDER(LEXVTMP(0,0))
SET LEXLEX=+($GET(LEXVTMP(0,+LEXSIEN)))
SET LEXEF=$PIECE($GET(LEXVTMP(0,+LEXSIEN)),"^",2)
+32 KILL LEX
IF +LEXLEX>0
IF $LENGTH($GET(^LEX(757.01,+LEXLEX,0)))
IF $LENGTH(LEXEF)
IF LEXEF?7N
Begin DoDot:1
+33 SET LEXAIEN=LEXLEX
+34 KILL LEX
NEW LEXT,LEXM,LEXI
SET LEXT(1)=$GET(^LEX(757.01,+LEXLEX,0))
+35 if $DATA(LEXIIEN)
SET LEXT(1)=$GET(LEXT(1))_" (IEN "_LEXAIEN_")"
+36 DO PR^LEXU(.LEXT,(LEXLEN-7))
+37 SET LEXI=0
FOR
SET LEXI=$ORDER(LEXT(LEXI))
if +LEXI'>0
QUIT
if $LENGTH($GET(LEXT(LEXI)))
SET LEX(+LEXI)=$GET(LEXT(LEXI))
+38 SET LEX=+($ORDER(LEX(" "),-1))
SET LEXEE=$$SD^LEXQM(LEXEF)
SET LEX(0)=LEXEE
End DoDot:1
QUIT
+39 QUIT
WN(X,LEX,LEXLEN) ; Warning
+1 ;
+2 ; LEX=# of Lines
+3 ; LEX(0)=External Date
+4 ; LEX(#)=Warning
+5 ;
+6 NEW LEXVDT,LEXREF,LEXIA,LEXTMP
KILL LEX
SET LEXVDT=$GET(X)
if LEXVDT'?7N
QUIT
SET LEXIA=$$IA(LEXVDT)
if +LEXIA'>0
QUIT
SET LEXLEN=+$GET(LEXLEN)
if +LEXLEN>62
SET LEXLEN=62
+7 SET LEXREF="Diagnosis (Short Name) and Description"
if $DATA(LEXLX)
SET LEXREF="Diagnosis (Short Name), Description and Lexicon Term"
+8 SET LEXTMP(1)="Warning: The 'Based on Date' provided precedes Code Set Versioning. The "_LEXREF_" may be inaccurate for "_$$SD^LEXQM(LEXVDT)
+9 DO PR^LEXU(.LEXTMP,LEXLEN)
KILL LEX
SET LEXI=0
FOR
SET LEXI=$ORDER(LEXTMP(LEXI))
if +LEXI'>0
QUIT
SET LEX(LEXI)=$GET(LEXTMP(LEXI))
+10 SET LEX=$ORDER(LEX(" "),-1)
SET LEX(0)=$$SD^LEXQM(LEXVDT)
+11 QUIT
MDC(X,LEXVDT,LEX) ; Major Diagnostic Category
+1 ;
+2 ; LEX=# of Lines
+3 ; LEX(0)=External Date of MDC
+4 ; LEX(#)=MDC
+5 ;
+6 QUIT
+7 NEW LEXEF,LEXMDC,LEXMH,LEXN0,LEXNAM
+8 KILL LEX
SET LEX=0
SET LEXIEN=+($GET(X))
if +LEXIEN'>0
QUIT
+9 SET LEXVDT=+($GET(LEXVDT))
if LEXVDT'?7N
SET LEXVDT=$$DT^XLFDT
+10 SET LEXMDC=$$VMDC^ICDEX(+LEXIEN,+LEXVDT,1)
+11 SET LEXEF=$PIECE(LEXMDC,"^",2)
SET LEXMDC=$PIECE(LEXMDC,"^",1)
+12 if +LEXMDC'>0
QUIT
if '$DATA(^ICM(+LEXMDC,0))
QUIT
+13 SET LEXNAM=$$UP^XLFSTR($PIECE($GET(^ICM(+LEXMDC,0)),"^",1))
if '$LENGTH(LEXNAM)
QUIT
+14 if $DATA(LEXIIEN)
SET LEXNAM=LEXNAM_" (IEN "_+LEXMDC_")"
+15 SET LEX=1
SET LEX(0)=$$SD^LEXQM(LEXEF)
SET LEX(1)=LEXNAM
+16 QUIT
+17 ; Miscellaneous
FA(X) ; First Activation
+1 NEW LEXFA,LEXH,LEXI,LEXIEN,LEXSO,LEXSY
+2 SET LEXIEN=+($GET(X))
SET X=""
SET LEXSO=$$CODEC^ICDEX(80,+LEXIEN)
SET LEXSY=$$CSI^ICDEX(80,+LEXIEN)
+3 KILL LEXH
SET X=$$HIST^ICDEX(LEXSO,.LEXH,LEXSY)
SET LEXFA=""
SET LEXI=0
+4 FOR
SET LEXI=$ORDER(LEXH(LEXI))
if +LEXI'>0!($LENGTH(LEXFA))
QUIT
if +($GET(LEXH(LEXI)))>0&(LEXI?7N)
SET LEXFA=LEXI
if $LENGTH(LEXFA)
QUIT
+5 SET X=LEXFA
+6 QUIT X
IA(X,Y) ; Inaccurate
+1 NEW LEXBRD,LEXVDT,LEXIEN,LEXSYS
SET LEXVDT=+($GET(X))
SET LEXIEN=+($GET(Y))
if +LEXIEN'>0
QUIT 0
+2 SET LEXSYS=$$CSI^ICDEX(80,+LEXIEN)
if +LEXSYS'>0
QUIT 0
if '$LENGTH(LEXVDT)
SET LEXVDT=$$DT^XLFDT
+3 if LEXVDT#10000=0
SET LEXVDT=LEXVDT+101
if LEXVDT#100=0
SET LEXVDT=LEXVDT+1
+4 SET LEXBRD=$$DTBR^ICDEX(LEXVDT,0,LEXSYS)
SET X=$SELECT(LEXVDT<LEXBRD:1,1:0)
+5 QUIT X
