LEXQID ;ISL/KER - Query - ICD Diagnosis - Extract ;10/10/2017
;;2.0;LEXICON UTILITY;**62,73,80,103,114**;Sep 23, 1996;Build 1
;
; Global Variables
; ^TMP("LEXQID") SACC 2.3.2.5.1
; ^TMP("LEXQIDA" SACC 2.3.2.5.1
; ^TMP("LEXQIDC" SACC 2.3.2.5.1
; ^TMP("LEXQIDN" SACC 2.3.2.5.1
; ^TMP("LEXQIDO" SACC 2.3.2.5.1
; ^TMP("LEXQIDR" SACC 2.3.2.5.1
;
; External References
; $$CODEC^ICDEX ICR 5747
; $$CSI^ICDEX ICR 5747
; $$DTBR^ICDEX ICR 5747
; $$EXIST^ICDEX ICR 5747
; $$HIST^ICDEX ICR 5747
; $$ICDDX^ICDEX ICR 5747
; $$LA^ICDEX ICR 5747
; $$SD^ICDEX ICR 5747
; $$SYS^ICDEX ICR 5747
; $$DT^XLFDT ICR 10103
;
; Local Variables NEWed or KILLed Elsewhere
; LEXIIEN Include IENs flag
;
EN ; Main Entry Point
N LEXENV S LEXENV=$$EV^LEXQM Q:+LEXENV'>0
N DIC,DIR,DIRB,DIROUT,DIRUT,DTOUT,DO,DUOUT,EXD,ICDFMT,ICDSYS,ICDVDT,LEX,LEX1,LEX2,LEX3,LEXAD,LEXBOD,LEXBRD,LEXBRW,LEXC,LEXCC,LEXCCD,LEXCCE,LEXCCI,LEXCDT
N LEXCT,LEXCTE,LEXD,LEXDAT,LEXDDD,LEXDDE,LEXDDI,LEXDDT,LEXDEF,LEXDRG,LEXDRG1,LEXDRG2,LEXDRGC,LEXDRGD,LEXDRP,LEXDTXT,LEXDX,LEXE,LEXEDT,LEXEE,LEXEF
N LEXEFF,LEXELDT,LEXENV,LEXES,LEXEVDT,LEXEXIT,LEXFA,LEXFUL,LEXGET,LEXH,LEXHIS,LEXI,LEXIA,LEXICD,LEXICDC,LEXID,LEXIEN,LEXIENS,LEXINC,LEXINCC
N LEXINOT,LEXIREQ,LEXISO,LEXL,LEXLA,LEXLAST,LEXLD,LEXLDD,LEXLDR,LEXLDT,LEXLEF,LEXLEN,LEXLHI,LEXLHS,LEXLS,LEXLSD,LEXLSO,LEXLST,LEXLTXT,LEXLX,LEXM
N LEXMC,LEXMD,LEXMDC,LEXMH,LEXN,LEXN0,LEXNAM,LEXNCC,LEXO,LEXOD,LEXODD,LEXP,LEXPF,LEXPIE,LEXR,LEXREF,LEXS,LEXSAB,LEXSD,LEXSDD,LEXSDT,LEXSIEN,LEXSO
N LEXST,LEXSTA,LEXSTAT,LEXSTR,LEXSY,LEXSYS,LEXT,LEXTMP,LEXU,LEXVDT,LEXVTMP,LEXVTXT,LEXW,LEXWN,LEXX,TXT,TX1,TX2,I,X,Y,Z S LEXEXIT=0
K ^TMP("LEXQID",$J),^TMP("LEXQIDO",$J),^TMP("LEXQIDA",$J),^TMP("LEXQIDN",$J),^TMP("LEXQIDR",$J),^TMP("LEXQIDC",$J)
W ! F S LEXCDT=$$AD^LEXQM,LEXAD=LEXCDT Q:'$L(LEXCDT) S LEXEDT=$P(LEXCDT,"^",1),LEXCDT=$P(LEXCDT,"^",2) Q:LEXCDT'?7N D LOOK Q:LEXCDT'?7N Q:+LEXEXIT>0
K ^TMP("LEXQID",$J),^TMP("LEXQIDO",$J),^TMP("LEXQIDA",$J),^TMP("LEXQIDN",$J),^TMP("LEXQIDR",$J),^TMP("LEXQIDC",$J)
Q
IEN ; Display with IENs
N LEXIIEN S LEXIIEN=1 D EN
Q
LOOK ; ICD Lookup Loop
N LEXGET,LEXST,LEXSD,LEXLD,LEXMD,LEXLX,LEXWN,LEXCC,LEXMC,LEXICD,LEXICDC
S LEXCDT=$G(LEXCDT),LEXEDT=$$ED^LEXQM(LEXCDT) I LEXCDT'?7N S LEXCDT="" Q
S LEXLEN=62 F S LEXICD=$$ICD^LEXQIL D Q:LEXICD="^"!(LEXICD="^^")
. S:$E(LEXICD,1,2)="^^" LEXICD="^^",LEXEXIT=1 Q:+($G(LEXEXIT))>0!(LEXICD="^^")
. S:$E(LEXICD,1)="^" LEXICD="^" Q:LEXICD="^"
. K LEXGET,LEXST,LEXSD,LEXLD,LEXMD,LEXLX,LEXWN,LEXCC,LEXMC,^TMP("LEXQID",$J)
. N LEXIEN,LEXLDT,LEXELDT,LEXINC,LEXINOT,LEXIREQ,LEXINCC,LEXFA
. S LEXIEN=+($G(LEXICD)),LEXLDT=+($G(LEXCDT)),LEXFA=$$FA(+LEXIEN) Q:+LEXIEN'>0 Q:LEXLDT'?7N
. S LEXELDT=$$SD^LEXQM(LEXLDT) Q:'$L(LEXELDT)
. S (LEXINOT,LEXIREQ,LEXINCC)=0
. ;I LEXFA?7N,LEXCDT?7N,LEXFA'>LEXCDT D
. ;. S LEXINOT=$$EXIST^ICDEX(+($G(LEXIEN)),20) S:+LEXINOT>0 LEXINOT=$$NOT^LEXQIDA(+($G(LEXIEN))) S:LEXINOT["^^" LEXEXIT=1 Q:LEXINOT["^"
. ;. S LEXIREQ=$$EXIST^ICDEX(+($G(LEXIEN)),30) S:+LEXIREQ>0 LEXIREQ=$$REQ^LEXQIDA(+($G(LEXIEN))) S:LEXIREQ["^^" LEXEXIT=1 Q:LEXIREQ["^"
. ;. S LEXINCC=$$EXIST^ICDEX(+($G(LEXIEN)),40) S:LEXINCC>0 LEXINCC=$$NCC^LEXQIDA(+($G(LEXIEN))) S:LEXINCC["^^" LEXEXIT=1 Q:LEXINCC["^"
. D CSV,EN^LEXQID4
Q
CSV ; Code Set Versioning Display
N LEXEDT,LEXIEN,LEXIENS,LEXLTXT,LEXSTAT,LEXDAT
S LEXCDT=$G(LEXCDT),LEXEDT=$$ED^LEXQM(LEXCDT) I LEXCDT'?7N S (LEXICD,LEXCDT)="" Q
S LEXIEN=+($G(LEXICD)),LEXSO=$$CODEC^ICDEX(80,+LEXIEN)
S LEXLTXT=$P($G(LEXICD),"^",3) S LEXSYS=$$CSI^ICDEX(80,+LEXIEN)
Q:+LEXIEN'>0 Q:'$L(LEXSO) Q:+LEXSYS'>0
S LEXDAT=$$ICDDX^ICDEX(LEXSO,LEXCDT,LEXSYS,"E")
S LEXSO=$P(LEXDAT,"^",2),LEXNAM=$P(LEXDAT,"^",4)
I '$L(LEXNAM) D
. N LEXLA S LEXLA=$$LA^ICDEX(80,+LEXIEN,9999999)
. S LEXNAM=$$SD^ICDEX(80,+LEXIEN,LEXLA)
Q:'$L($G(LEXNAM))
;
; Get the "Versioned" Fields
;
; Date/Status 80.066 (66)
S LEXST=$$EF(+($G(LEXIEN)),+LEXCDT),LEXSTAT=+($P(LEXST,"^",2))
; Diagnosis Name 80.067 (67)
D SDS(+($G(LEXIEN)),+LEXCDT,.LEXSD,62,LEXSTAT)
; Description 80.068 (68)
D LDS^LEXQID2(+($G(LEXIEN)),+LEXCDT,.LEXLD,62,LEXSTAT)
; Lexicon Expression
D LX^LEXQID2(+($G(LEXIEN)),+LEXCDT,.LEXLX,62,LEXSTAT)
; Warning Message
D WN^LEXQID2(+LEXCDT,.LEXWN,62)
; DRG Groups 80.071 (71)
;D DRG^LEXQID3(+LEXIEN,+LEXCDT,LEXLEN)
; CC 80.0103 (103)
;D CC^LEXQID3(+($G(LEXIEN)),+LEXCDT,.LEXCC)
; MDC 80.072 (72)
;D MDC^LEXQID2(+($G(LEXIEN)),LEXCDT,.LEXMC)
;
; Get the "Asked for" Fields
;
; Codes not to use 80.01 (20)
;D:+($G(LEXINOT))>0 NOT^LEXQID3(+LEXIEN,+LEXCDT,LEXLEN)
; Codes required with 80.02 (30)
;D:+($G(LEXIREQ))>0 REQ^LEXQID3(+LEXIEN,+LEXCDT,LEXLEN)
; Codes not CC with 80.03 (40)
;D:+($G(LEXINCC))>0 NCC^LEXQID3(+LEXIEN,+LEXCDT,LEXLEN)
Q
;
EF(X,LEXCDT) ; Effective Dates
N LEX,LEXAD,LEXBRD,LEXBRW,LEXEE,LEXEF,LEXES,LEXFA,LEXH,LEXI,LEXID,LEXIEN,LEXLS,LEXSO,LEXST,LEXSY S LEXIEN=+($G(X)),LEXCDT=+($G(LEXCDT))
Q:+LEXIEN'>0 "^^" Q:LEXCDT'?7N "^^" S LEXSO=$$CODEC^ICDEX(80,+LEXIEN),LEXSY=$$SYS^ICDEX(LEXSO,LEXCDT),LEX=$$ICDDX^ICDEX(LEXSO,LEXCDT,LEXSY,"E")
S LEXFA=$$FA(+LEXIEN),(LEXLS,LEXST)=$P(LEX,"^",10),LEXID=$P(LEX,"^",12),LEXBRD=$$IMPDATE^LEXU("ICD"),LEXBRW=""
I LEXCDT<LEXBRD&(+LEXFA=LEXBRD) D
. S LEXBRW="Warning: The 'Based on Date' provided precedes the initial Code Set Business Rule date of "
. S LEXBRW=LEXBRW_$$SD^LEXQM(LEXBRD)_", the Effective date may be inaccurate."
S LEXAD=$P(LEX,"^",17),LEXES=$S(+LEXST>0:"Active",1:"Inactive")
S:+LEXST'>0&(+LEXAD'>0) LEXES="Not Applicable",LEXLS=-1
S:+LEXFA>0&(+LEXCDT>0)&(LEXFA>LEXCDT) LEXES="Pending",LEXLS=-1,LEXST=0,LEXBRW=""
S:LEXST>0 LEXEF=LEXAD S:LEXST'>0 LEXEF=LEXID
S:LEXST'>0&(+LEXID'>0) LEXEF=LEXFA S LEXEE=$$SD^LEXQM(LEXEF)
I LEXST'>0,+LEXID'>0,$L(LEXEE),+LEXEF>LEXCDT S LEXEE="(future activation of "_LEXEE_")",LEXEF=""
S X=LEXLS_"^"_LEXST_"^"_LEXEF_"^"_LEXES_"^"_LEXEE S:$L(LEXBRW) $P(X,"^",6)=LEXBRW
Q X
;
SDS(X,LEXVDT,LEX,LEXLEN,LEXSTA) ; Diagnosis (short description)
;
; LEX=# of Lines
; LEX(0)=External Date of Diagnosis Name
; LEX(#)=Diagnosis Name
;
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,LEXSD,LEXSDD
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 LEXLAST=$$ICDDX^ICDEX(LEXSO,LEXLA,LEXSY,"E")
S LEXLSD=$P(LEXLAST,"^",5),LEXBRD=$$DTBR^ICDEX(LEXVDT,0,LEXSY),LEXBRW=""
S LEXSD=$$SD^ICDEX(80,+LEXIEN,LEXVDT,.LEXS)
S LEXSD=$G(LEXS(1)),LEXSDD=$P($G(LEXS(0)),"^",2)
S:'$L(LEXSD) LEXSDD="--/--/----" S LEXM=""
I $P(LEXSD,"^",1)="-1"!('$L(LEXSD)) D
. S LEXM="Diagnosis Short Name 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(LEXSD)&($P(LEXSD,"^",1)'="-1") D
. S:LEXSDD?7N LEXSIEN=$O(@("^ICD9("_LEXIEN_",67,""B"","_LEXSDD_",0)"))
. S:LEXSIEN>0 LEXAIEN=LEXAIEN_";"_LEXSIEN
. S LEXM="" S LEXOD=LEXSD S:$L(LEXOD)&($D(LEXIIEN)) LEXOD=LEXOD_" (IEN "_LEXAIEN_")"
. S LEXODD=$S(LEXSDD?7N:$$ED^LEXQM(LEXSDD),1:"--/--/----")
S:'$L(LEXOD) LEXOD="Diagnosis Short Name 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
;
; 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[HLEXQID 9212 printed Sep 23, 2025@19:44:39 Page 2
LEXQID ;ISL/KER - Query - ICD Diagnosis - Extract ;10/10/2017
+1 ;;2.0;LEXICON UTILITY;**62,73,80,103,114**;Sep 23, 1996;Build 1
+2 ;
+3 ; Global Variables
+4 ; ^TMP("LEXQID") SACC 2.3.2.5.1
+5 ; ^TMP("LEXQIDA" SACC 2.3.2.5.1
+6 ; ^TMP("LEXQIDC" SACC 2.3.2.5.1
+7 ; ^TMP("LEXQIDN" SACC 2.3.2.5.1
+8 ; ^TMP("LEXQIDO" SACC 2.3.2.5.1
+9 ; ^TMP("LEXQIDR" SACC 2.3.2.5.1
+10 ;
+11 ; External References
+12 ; $$CODEC^ICDEX ICR 5747
+13 ; $$CSI^ICDEX ICR 5747
+14 ; $$DTBR^ICDEX ICR 5747
+15 ; $$EXIST^ICDEX ICR 5747
+16 ; $$HIST^ICDEX ICR 5747
+17 ; $$ICDDX^ICDEX ICR 5747
+18 ; $$LA^ICDEX ICR 5747
+19 ; $$SD^ICDEX ICR 5747
+20 ; $$SYS^ICDEX ICR 5747
+21 ; $$DT^XLFDT ICR 10103
+22 ;
+23 ; Local Variables NEWed or KILLed Elsewhere
+24 ; LEXIIEN Include IENs flag
+25 ;
EN ; Main Entry Point
+1 NEW LEXENV
SET LEXENV=$$EV^LEXQM
if +LEXENV'>0
QUIT
+2 NEW DIC,DIR,DIRB,DIROUT,DIRUT,DTOUT,DO,DUOUT,EXD,ICDFMT,ICDSYS,ICDVDT,LEX,LEX1,LEX2,LEX3,LEXAD,LEXBOD,LEXBRD,LEXBRW,LEXC,LEXCC,LEXCCD,LEXCCE,LEXCCI,LEXCDT
+3 NEW LEXCT,LEXCTE,LEXD,LEXDAT,LEXDDD,LEXDDE,LEXDDI,LEXDDT,LEXDEF,LEXDRG,LEXDRG1,LEXDRG2,LEXDRGC,LEXDRGD,LEXDRP,LEXDTXT,LEXDX,LEXE,LEXEDT,LEXEE,LEXEF
+4 NEW LEXEFF,LEXELDT,LEXENV,LEXES,LEXEVDT,LEXEXIT,LEXFA,LEXFUL,LEXGET,LEXH,LEXHIS,LEXI,LEXIA,LEXICD,LEXICDC,LEXID,LEXIEN,LEXIENS,LEXINC,LEXINCC
+5 NEW LEXINOT,LEXIREQ,LEXISO,LEXL,LEXLA,LEXLAST,LEXLD,LEXLDD,LEXLDR,LEXLDT,LEXLEF,LEXLEN,LEXLHI,LEXLHS,LEXLS,LEXLSD,LEXLSO,LEXLST,LEXLTXT,LEXLX,LEXM
+6 NEW LEXMC,LEXMD,LEXMDC,LEXMH,LEXN,LEXN0,LEXNAM,LEXNCC,LEXO,LEXOD,LEXODD,LEXP,LEXPF,LEXPIE,LEXR,LEXREF,LEXS,LEXSAB,LEXSD,LEXSDD,LEXSDT,LEXSIEN,LEXSO
+7 NEW LEXST,LEXSTA,LEXSTAT,LEXSTR,LEXSY,LEXSYS,LEXT,LEXTMP,LEXU,LEXVDT,LEXVTMP,LEXVTXT,LEXW,LEXWN,LEXX,TXT,TX1,TX2,I,X,Y,Z
SET LEXEXIT=0
+8 KILL ^TMP("LEXQID",$JOB),^TMP("LEXQIDO",$JOB),^TMP("LEXQIDA",$JOB),^TMP("LEXQIDN",$JOB),^TMP("LEXQIDR",$JOB),^TMP("LEXQIDC",$JOB)
+9 WRITE !
FOR
SET LEXCDT=$$AD^LEXQM
SET LEXAD=LEXCDT
if '$LENGTH(LEXCDT)
QUIT
SET LEXEDT=$PIECE(LEXCDT,"^",1)
SET LEXCDT=$PIECE(LEXCDT,"^",2)
if LEXCDT'?7N
QUIT
DO LOOK
if LEXCDT'?7N
QUIT
if +LEXEXIT>0
QUIT
+10 KILL ^TMP("LEXQID",$JOB),^TMP("LEXQIDO",$JOB),^TMP("LEXQIDA",$JOB),^TMP("LEXQIDN",$JOB),^TMP("LEXQIDR",$JOB),^TMP("LEXQIDC",$JOB)
+11 QUIT
IEN ; Display with IENs
+1 NEW LEXIIEN
SET LEXIIEN=1
DO EN
+2 QUIT
LOOK ; ICD Lookup Loop
+1 NEW LEXGET,LEXST,LEXSD,LEXLD,LEXMD,LEXLX,LEXWN,LEXCC,LEXMC,LEXICD,LEXICDC
+2 SET LEXCDT=$GET(LEXCDT)
SET LEXEDT=$$ED^LEXQM(LEXCDT)
IF LEXCDT'?7N
SET LEXCDT=""
QUIT
+3 SET LEXLEN=62
FOR
SET LEXICD=$$ICD^LEXQIL
Begin DoDot:1
+4 if $EXTRACT(LEXICD,1,2)="^^"
SET LEXICD="^^"
SET LEXEXIT=1
if +($GET(LEXEXIT))>0!(LEXICD="^^")
QUIT
+5 if $EXTRACT(LEXICD,1)="^"
SET LEXICD="^"
if LEXICD="^"
QUIT
+6 KILL LEXGET,LEXST,LEXSD,LEXLD,LEXMD,LEXLX,LEXWN,LEXCC,LEXMC,^TMP("LEXQID",$JOB)
+7 NEW LEXIEN,LEXLDT,LEXELDT,LEXINC,LEXINOT,LEXIREQ,LEXINCC,LEXFA
+8 SET LEXIEN=+($GET(LEXICD))
SET LEXLDT=+($GET(LEXCDT))
SET LEXFA=$$FA(+LEXIEN)
if +LEXIEN'>0
QUIT
if LEXLDT'?7N
QUIT
+9 SET LEXELDT=$$SD^LEXQM(LEXLDT)
if '$LENGTH(LEXELDT)
QUIT
+10 SET (LEXINOT,LEXIREQ,LEXINCC)=0
+11 ;I LEXFA?7N,LEXCDT?7N,LEXFA'>LEXCDT D
+12 ;. S LEXINOT=$$EXIST^ICDEX(+($G(LEXIEN)),20) S:+LEXINOT>0 LEXINOT=$$NOT^LEXQIDA(+($G(LEXIEN))) S:LEXINOT["^^" LEXEXIT=1 Q:LEXINOT["^"
+13 ;. S LEXIREQ=$$EXIST^ICDEX(+($G(LEXIEN)),30) S:+LEXIREQ>0 LEXIREQ=$$REQ^LEXQIDA(+($G(LEXIEN))) S:LEXIREQ["^^" LEXEXIT=1 Q:LEXIREQ["^"
+14 ;. S LEXINCC=$$EXIST^ICDEX(+($G(LEXIEN)),40) S:LEXINCC>0 LEXINCC=$$NCC^LEXQIDA(+($G(LEXIEN))) S:LEXINCC["^^" LEXEXIT=1 Q:LEXINCC["^"
+15 DO CSV
DO EN^LEXQID4
End DoDot:1
if LEXICD="^"!(LEXICD="^^")
QUIT
+16 QUIT
CSV ; Code Set Versioning Display
+1 NEW LEXEDT,LEXIEN,LEXIENS,LEXLTXT,LEXSTAT,LEXDAT
+2 SET LEXCDT=$GET(LEXCDT)
SET LEXEDT=$$ED^LEXQM(LEXCDT)
IF LEXCDT'?7N
SET (LEXICD,LEXCDT)=""
QUIT
+3 SET LEXIEN=+($GET(LEXICD))
SET LEXSO=$$CODEC^ICDEX(80,+LEXIEN)
+4 SET LEXLTXT=$PIECE($GET(LEXICD),"^",3)
SET LEXSYS=$$CSI^ICDEX(80,+LEXIEN)
+5 if +LEXIEN'>0
QUIT
if '$LENGTH(LEXSO)
QUIT
if +LEXSYS'>0
QUIT
+6 SET LEXDAT=$$ICDDX^ICDEX(LEXSO,LEXCDT,LEXSYS,"E")
+7 SET LEXSO=$PIECE(LEXDAT,"^",2)
SET LEXNAM=$PIECE(LEXDAT,"^",4)
+8 IF '$LENGTH(LEXNAM)
Begin DoDot:1
+9 NEW LEXLA
SET LEXLA=$$LA^ICDEX(80,+LEXIEN,9999999)
+10 SET LEXNAM=$$SD^ICDEX(80,+LEXIEN,LEXLA)
End DoDot:1
+11 if '$LENGTH($GET(LEXNAM))
QUIT
+12 ;
+13 ; Get the "Versioned" Fields
+14 ;
+15 ; Date/Status 80.066 (66)
+16 SET LEXST=$$EF(+($GET(LEXIEN)),+LEXCDT)
SET LEXSTAT=+($PIECE(LEXST,"^",2))
+17 ; Diagnosis Name 80.067 (67)
+18 DO SDS(+($GET(LEXIEN)),+LEXCDT,.LEXSD,62,LEXSTAT)
+19 ; Description 80.068 (68)
+20 DO LDS^LEXQID2(+($GET(LEXIEN)),+LEXCDT,.LEXLD,62,LEXSTAT)
+21 ; Lexicon Expression
+22 DO LX^LEXQID2(+($GET(LEXIEN)),+LEXCDT,.LEXLX,62,LEXSTAT)
+23 ; Warning Message
+24 DO WN^LEXQID2(+LEXCDT,.LEXWN,62)
+25 ; DRG Groups 80.071 (71)
+26 ;D DRG^LEXQID3(+LEXIEN,+LEXCDT,LEXLEN)
+27 ; CC 80.0103 (103)
+28 ;D CC^LEXQID3(+($G(LEXIEN)),+LEXCDT,.LEXCC)
+29 ; MDC 80.072 (72)
+30 ;D MDC^LEXQID2(+($G(LEXIEN)),LEXCDT,.LEXMC)
+31 ;
+32 ; Get the "Asked for" Fields
+33 ;
+34 ; Codes not to use 80.01 (20)
+35 ;D:+($G(LEXINOT))>0 NOT^LEXQID3(+LEXIEN,+LEXCDT,LEXLEN)
+36 ; Codes required with 80.02 (30)
+37 ;D:+($G(LEXIREQ))>0 REQ^LEXQID3(+LEXIEN,+LEXCDT,LEXLEN)
+38 ; Codes not CC with 80.03 (40)
+39 ;D:+($G(LEXINCC))>0 NCC^LEXQID3(+LEXIEN,+LEXCDT,LEXLEN)
+40 QUIT
+41 ;
EF(X,LEXCDT) ; Effective Dates
+1 NEW LEX,LEXAD,LEXBRD,LEXBRW,LEXEE,LEXEF,LEXES,LEXFA,LEXH,LEXI,LEXID,LEXIEN,LEXLS,LEXSO,LEXST,LEXSY
SET LEXIEN=+($GET(X))
SET LEXCDT=+($GET(LEXCDT))
+2 if +LEXIEN'>0
QUIT "^^"
if LEXCDT'?7N
QUIT "^^"
SET LEXSO=$$CODEC^ICDEX(80,+LEXIEN)
SET LEXSY=$$SYS^ICDEX(LEXSO,LEXCDT)
SET LEX=$$ICDDX^ICDEX(LEXSO,LEXCDT,LEXSY,"E")
+3 SET LEXFA=$$FA(+LEXIEN)
SET (LEXLS,LEXST)=$PIECE(LEX,"^",10)
SET LEXID=$PIECE(LEX,"^",12)
SET LEXBRD=$$IMPDATE^LEXU("ICD")
SET LEXBRW=""
+4 IF LEXCDT<LEXBRD&(+LEXFA=LEXBRD)
Begin DoDot:1
+5 SET LEXBRW="Warning: The 'Based on Date' provided precedes the initial Code Set Business Rule date of "
+6 SET LEXBRW=LEXBRW_$$SD^LEXQM(LEXBRD)_", the Effective date may be inaccurate."
End DoDot:1
+7 SET LEXAD=$PIECE(LEX,"^",17)
SET LEXES=$SELECT(+LEXST>0:"Active",1:"Inactive")
+8 if +LEXST'>0&(+LEXAD'>0)
SET LEXES="Not Applicable"
SET LEXLS=-1
+9 if +LEXFA>0&(+LEXCDT>0)&(LEXFA>LEXCDT)
SET LEXES="Pending"
SET LEXLS=-1
SET LEXST=0
SET LEXBRW=""
+10 if LEXST>0
SET LEXEF=LEXAD
if LEXST'>0
SET LEXEF=LEXID
+11 if LEXST'>0&(+LEXID'>0)
SET LEXEF=LEXFA
SET LEXEE=$$SD^LEXQM(LEXEF)
+12 IF LEXST'>0
IF +LEXID'>0
IF $LENGTH(LEXEE)
IF +LEXEF>LEXCDT
SET LEXEE="(future activation of "_LEXEE_")"
SET LEXEF=""
+13 SET X=LEXLS_"^"_LEXST_"^"_LEXEF_"^"_LEXES_"^"_LEXEE
if $LENGTH(LEXBRW)
SET $PIECE(X,"^",6)=LEXBRW
+14 QUIT X
+15 ;
SDS(X,LEXVDT,LEX,LEXLEN,LEXSTA) ; Diagnosis (short description)
+1 ;
+2 ; LEX=# of Lines
+3 ; LEX(0)=External Date of Diagnosis Name
+4 ; LEX(#)=Diagnosis Name
+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,LEXSD,LEXSDD
+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 LEXLAST=$$ICDDX^ICDEX(LEXSO,LEXLA,LEXSY,"E")
+15 SET LEXLSD=$PIECE(LEXLAST,"^",5)
SET LEXBRD=$$DTBR^ICDEX(LEXVDT,0,LEXSY)
SET LEXBRW=""
+16 SET LEXSD=$$SD^ICDEX(80,+LEXIEN,LEXVDT,.LEXS)
+17 SET LEXSD=$GET(LEXS(1))
SET LEXSDD=$PIECE($GET(LEXS(0)),"^",2)
+18 if '$LENGTH(LEXSD)
SET LEXSDD="--/--/----"
SET LEXM=""
+19 IF $PIECE(LEXSD,"^",1)="-1"!('$LENGTH(LEXSD))
Begin DoDot:1
+20 SET LEXM="Diagnosis Short Name 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(LEXSD)&($PIECE(LEXSD,"^",1)'="-1")
Begin DoDot:1
+27 if LEXSDD?7N
SET LEXSIEN=$ORDER(@("^ICD9("_LEXIEN_",67,""B"","_LEXSDD_",0)"))
+28 if LEXSIEN>0
SET LEXAIEN=LEXAIEN_";"_LEXSIEN
+29 SET LEXM=""
SET LEXOD=LEXSD
if $LENGTH(LEXOD)&($DATA(LEXIIEN))
SET LEXOD=LEXOD_" (IEN "_LEXAIEN_")"
+30 SET LEXODD=$SELECT(LEXSDD?7N:$$ED^LEXQM(LEXSDD),1:"--/--/----")
End DoDot:1
+31 if '$LENGTH(LEXOD)
SET LEXOD="Diagnosis Short Name 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
+40 ;
+41 ; 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
