LEXQIP ;ISL/KER - Query - ICD Procedure - Extract ;10/10/2017
;;2.0;LEXICON UTILITY;**62,73,80,86,103,114**;Sep 23, 1996;Build 1
;
; Global Variables
; ^TMP("LEXQIP") SACC 2.3.2.5.1
; ^TMP("LEXQIPA") SACC 2.3.2.5.1
; ^TMP("LEXQIPO") SACC 2.3.2.5.1
;
; External References
; GETS^DIQ ICR 2056
; $$CODEC^ICDEX ICR 5747
; $$CSI^ICDEX ICR 5747
; $$DTBR^ICDEX ICR 5747
; $$HIST^ICDEX ICR 5747
; $$ICDOP^ICDEX ICR 5747
; $$LA^ICDEX ICR 5747
; $$LD^ICDEX ICR 5747
; $$MOR^ICDEX ICR 5747
; $$ROOT^ICDEX ICR 5747
; $$SD^ICDEX ICR 5747
; $$DT^XLFDT ICR 10103
; $$UP^XLFSTR ICR 10104
;
; 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,DTOUT,DUOUT,DO,ICDFMT,ICDSYS,ICDVDT,LEX,LEX1,LEX2,LEX3,LEXAD,LEXBOD,LEXBRD
N LEXBRW,LEXC,LEXCC,LEXCDT,LEXCHR,LEXD,LEXDAT,LEXDDT,LEXDG,LEXDI,LEXDR,LEXDRG,LEXDRG1,LEXDRG2,LEXDRGC,LEXDRGD,LEXDRGI
N LEXDRI,LEXDTXT,LEXDX,LEXE,LEXEDT,LEXEE,LEXEF,LEXEFF,LEXELDT,LEXENV,LEXES,LEXEXIT,LEXFA,LEXFUL,LEXH,LEXHDR,LEXHIS,LEXHR
N LEXI,LEXI1,LEXI2,LEXIA,LEXICP,LEXICPC,LEXID,LEXIDI,LEXIEN,LEXIENS,LEXINC,LEXINCC,LEXINOT,LEXINT,LEXIREQ,LEXL,LEXLA
N LEXLAST,LEXLC,LEXLD,LEXLDD,LEXLDT,LEXLEF,LEXLEN,LEXLHI,LEXLS,LEXLSD,LEXLTXT,LEXLX,LEXM,LEXMC,LEXMDCC,LEXMDCE,LEXMDCI,LEXMI
N LEXMOR,LEXMR,LEXMSG,LEXN,LEXNAM,LEXOD,LEXODD,LEXPC,LEXR,LEXREF,LEXRT,LEXS,LEXSD,LEXSDD,LEXSDT,LEXSO,LEXST,LEXSTA
N LEXSTAT,LEXSTR,LEXSY,LEXSYS,LEXT,LEXTEST,LEXTMP,LEXUD,LEXUM,LEXVDT,LEXVTXT,LEXW,LEXWN,LEXX,TXT,TX1,TX2,I,X,Y,Z
S LEXEXIT=0,LEXCDT="" K ^TMP("LEXQIP",$J),^TMP("LEXQIPO",$J),^TMP("LEXQIPA",$J)
F S LEXCDT=$$AD^LEXQM,LEXAD=LEXCDT Q:'$L(LEXCDT) Q:+($G(LEXEXIT))>0 S LEXEDT=$P(LEXCDT,"^",1),LEXCDT=$P(LEXCDT,"^",2) Q:LEXCDT'?7N D LOOK Q:LEXCDT'?7N Q:+($G(LEXEXIT))>0
K ^TMP("LEXQIP",$J),^TMP("LEXQIPO",$J),^TMP("LEXQIPA",$J)
Q
IEN ; Display with IENs
N LEXIIEN S LEXIIEN=1 D EN
Q
LOOK ; ICD Lookup Loop
N LEXDG,LEXST,LEXSD,LEXLD,LEXMOR,LEXWN,LEXCC,LEXMC,LEXICP,LEXICPC
S LEXCDT=$G(LEXCDT),LEXEDT=$$ED^LEXQM(LEXCDT) I LEXCDT'?7N S LEXCDT="" Q
S LEXLEN=62 F S LEXICP=$$ICP^LEXQIL D Q:LEXICP="^"!(LEXICP="^^")
. S:$E(LEXICP,1,2)="^^" LEXICP="^^",LEXEXIT=1 Q:+($G(LEXEXIT))>0!(LEXICP="^^")
. S:$E(LEXICP,1)="^" LEXICP="^" Q:LEXICP="^"
. K LEXST,LEXSD,LEXLD,LEXWN,LEXCC,LEXMOR,LEXMC,^TMP("LEXQIP",$J)
. N LEXIEN,LEXLDT,LEXELDT,LEXINC,LEXINOT,LEXIREQ,LEXINCC,LEXSO,LEXNAM
. S LEXIEN=+($G(LEXICP)),LEXLDT=+($G(LEXCDT)) Q:+LEXIEN'>0 Q:LEXLDT'?7N
. S LEXELDT=$$SD^LEXQM(LEXLDT) Q:'$L(LEXELDT)
. D CSV,EN^LEXQIP3
Q
CSV ; Code Set Versioning Display
N LEXEDT,LEXIEN,LEXIENS,LEXLTXT,LEXSTAT,LEXSYS,LEXMSG,LEXDAT
N LEXT,LEXTMP S LEXCDT=$G(LEXCDT),LEXEDT=$$ED^LEXQM(LEXCDT)
I LEXCDT'?7N S (LEXICP,LEXCDT)="" Q
S LEXIEN=+($G(LEXICP)),LEXSO=$$CODEC^ICDEX(80.1,+LEXIEN)
S LEXLTXT=$P($G(LEXICP),"^",3) S LEXSYS=$$CSI^ICDEX(80.1,+LEXIEN)
Q:+LEXIEN'>0 Q:'$L(LEXSO) Q:+LEXSYS'>0
S LEXDAT=$$ICDOP^ICDEX(LEXSO,LEXCDT,LEXSYS,"E")
S LEXSO=$P(LEXDAT,"^",2),LEXNAM=$P(LEXDAT,"^",5)
I '$L(LEXNAM)!($P(LEXNAM,"^",1)=-1) D
. N LEXLA S LEXLA=$$LA^ICDEX(80.1,+LEXIEN,9999999)
. S LEXNAM=$$SD^ICDEX(80.1,+LEXIEN,LEXLA)
Q:'$L($G(LEXNAM))
;
; "Unversioned" Fields
;
; ,01 Code
; 1.1 Coding System
; 1.2 Identifier
; 1.4 MDC24
; 1.7 ICD Expanded
; 1.8 Exclude from Lookup
; 20 MAJOR O.R. PROC
;
S LEXTMP=$$MOR^ICDEX(+LEXIEN) D:$L(LEXTMP) OR^LEXQIP2(LEXTMP,.LEXMOR)
;
; Get the "Versioned" Fields
;
; Date/Status 80.166 (66)
S LEXST=$$EF(+($G(LEXIEN)),+LEXCDT),LEXSTAT=+($P(LEXST,"^",2))
; Procedure Name 80.167 (67)
D SDS(+($G(LEXIEN)),+LEXCDT,.LEXSD,62,LEXSTAT)
; Description 80.168 (68)
D LDS(+($G(LEXIEN)),+LEXCDT,.LEXLD,62,LEXSTAT)
; Lexicon Expression
D LX^LEXQIP2(+($G(LEXIEN)),+LEXCDT,.LEXLX,62,LEXSTAT)
; Warning Message
D WN(+LEXCDT,.LEXWN,62)
; MDC/DRG Groups 80.171 (71)
;D MDCDRG^LEXQIP2(+LEXIEN,+LEXCDT,.LEXDG,LEXLEN)
Q
;
EF(X,LEXCDT) ; Effective Dates
N LEX,LEXAD,LEXBRD,LEXBRW,LEXEE,LEXEF,LEXES,LEXFA,LEXH,LEXI,LEXID,LEXIEN,LEXRT,LEXLS,LEXSO,LEXSYS,LEXST S LEXIEN=+($G(X)),LEXCDT=+($G(LEXCDT))
S LEXRT=$$ROOT^ICDEX(80.1) Q:+LEXIEN'>0 "^^" S LEXSO=$$CODEC^ICDEX(80.1,+LEXIEN) Q:'$L(LEXSO)!($P(LEXSO,"^",1)="-1") Q:LEXCDT'?7N "^^"
S LEXSYS=$$CSI^ICDEX(80.1,+LEXIEN),LEX=$$ICDOP^ICDEX(LEXSO,LEXCDT,LEXSYS,"E")
S LEXFA=$$FA(+LEXIEN),(LEXLS,LEXST)=$P(LEX,"^",10),LEXID=$P(LEX,"^",12),LEXAD=$P(LEX,"^",13),LEXBRD=2781001,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 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) ; Operation/Procedure (short description)
;
; LEX=# of Lines
; LEX(0)=External Date of Operation/Procedure Name
; LEX(#)=Operation/Procedure 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.1,+LEXIEN)
S LEXSY=$$CSI^ICDEX(80.1,+LEXIEN)
S LEXLA=$$LA^ICDEX(80.1,+LEXIEN,9999999),LEXFA=$$FA(+LEXIEN)
S LEXLAST=$$ICDOP^ICDEX(LEXSO,LEXLA,LEXSY,"E")
S LEXLSD=$P(LEXLAST,"^",5),LEXBRD=$$DTBR^ICDEX(LEXVDT,0,LEXSY),LEXBRW=""
S LEXSD=$$SD^ICDEX(80.1,+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="Operation/Procedure 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(@("^ICD0("_+LEXIEN_",67,""B"","_+LEXSDD_",0)"))
. S:+LEXSIEN>0 LEXAIEN=LEXAIEN_";"_LEXSIEN
. S LEXM="" S LEXOD=LEXSD S:$D(LEXIIEN) LEXOD=LEXOD_" (IEN "_LEXAIEN_")"
. S LEXODD=$S(LEXSDD?7N:$$ED^LEXQM(LEXSDD),1:"--/--/----")
S:'$L(LEXOD) LEXOD="Operation/Procedure 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
LDS(X,LEXVDT,LEX,LEXLEN,LEXSTA) ; Operation/Procedure (short description)
;
; LEX=# of Lines
; LEX(0)=External Date of Operation/Procedure Name
; LEX(#)=Operation/Procedure 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,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.1,+LEXIEN)
S LEXSY=$$CSI^ICDEX(80.1,+LEXIEN)
S LEXLA=$$LA^ICDEX(80.1,+LEXIEN,9999999),LEXFA=$$FA(+LEXIEN)
S LEXLSD=$$LD^ICDEX(80.1,+LEXIEN,LEXLA)
S LEXBRD=$$DTBR^ICDEX(LEXVDT,0,LEXSY),LEXBRW=""
S LEXLD=$$LD^ICDEX(80.1,+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="Operation/Procedure 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(@("^ICD0("_+LEXIEN_",68,""B"","_+LEXLDD_",0)"))
. S:+LEXSIEN>0 LEXAIEN=LEXAIEN_";"_LEXSIEN
. S LEXM="" S LEXOD=LEXLD S:$D(LEXIIEN) LEXOD=LEXOD_" (IEN "_LEXAIEN_")"
. S LEXODD=$S(LEXLDD?7N:$$ED^LEXQM(LEXLDD),1:"--/--/----")
S:'$L(LEXOD) LEXOD="Operation/Procedure 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
;
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 LEXLEN=+$G(LEXLEN) S LEXIA=$$IA(LEXVDT,LEXIEN) Q:+LEXIA'>0 S:+LEXLEN>62 LEXLEN=62
S LEXTMP(1)="Warning: The 'Based on Date' provided precedes Code Set Versioning. The Operation/Procedure (Short Name) and Description 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
; Miscellaneous
FA(X) ; First Activation
N LEXFA,LEXH,LEXI,LEXIEN,LEXSO,LEXSY
S LEXIEN=+($G(X)) S X="",LEXSO=$$CODEC^ICDEX(80.1,+LEXIEN),LEXSY=$$CSI^ICDEX(80.1,+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.1,+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[HLEXQIP 11263 printed Nov 22, 2024@17:18:58 Page 2
LEXQIP ;ISL/KER - Query - ICD Procedure - Extract ;10/10/2017
+1 ;;2.0;LEXICON UTILITY;**62,73,80,86,103,114**;Sep 23, 1996;Build 1
+2 ;
+3 ; Global Variables
+4 ; ^TMP("LEXQIP") SACC 2.3.2.5.1
+5 ; ^TMP("LEXQIPA") SACC 2.3.2.5.1
+6 ; ^TMP("LEXQIPO") SACC 2.3.2.5.1
+7 ;
+8 ; External References
+9 ; GETS^DIQ ICR 2056
+10 ; $$CODEC^ICDEX ICR 5747
+11 ; $$CSI^ICDEX ICR 5747
+12 ; $$DTBR^ICDEX ICR 5747
+13 ; $$HIST^ICDEX ICR 5747
+14 ; $$ICDOP^ICDEX ICR 5747
+15 ; $$LA^ICDEX ICR 5747
+16 ; $$LD^ICDEX ICR 5747
+17 ; $$MOR^ICDEX ICR 5747
+18 ; $$ROOT^ICDEX ICR 5747
+19 ; $$SD^ICDEX ICR 5747
+20 ; $$DT^XLFDT ICR 10103
+21 ; $$UP^XLFSTR ICR 10104
+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
NEW DIC,DTOUT,DUOUT,DO,ICDFMT,ICDSYS,ICDVDT,LEX,LEX1,LEX2,LEX3,LEXAD,LEXBOD,LEXBRD
+2 NEW LEXBRW,LEXC,LEXCC,LEXCDT,LEXCHR,LEXD,LEXDAT,LEXDDT,LEXDG,LEXDI,LEXDR,LEXDRG,LEXDRG1,LEXDRG2,LEXDRGC,LEXDRGD,LEXDRGI
+3 NEW LEXDRI,LEXDTXT,LEXDX,LEXE,LEXEDT,LEXEE,LEXEF,LEXEFF,LEXELDT,LEXENV,LEXES,LEXEXIT,LEXFA,LEXFUL,LEXH,LEXHDR,LEXHIS,LEXHR
+4 NEW LEXI,LEXI1,LEXI2,LEXIA,LEXICP,LEXICPC,LEXID,LEXIDI,LEXIEN,LEXIENS,LEXINC,LEXINCC,LEXINOT,LEXINT,LEXIREQ,LEXL,LEXLA
+5 NEW LEXLAST,LEXLC,LEXLD,LEXLDD,LEXLDT,LEXLEF,LEXLEN,LEXLHI,LEXLS,LEXLSD,LEXLTXT,LEXLX,LEXM,LEXMC,LEXMDCC,LEXMDCE,LEXMDCI,LEXMI
+6 NEW LEXMOR,LEXMR,LEXMSG,LEXN,LEXNAM,LEXOD,LEXODD,LEXPC,LEXR,LEXREF,LEXRT,LEXS,LEXSD,LEXSDD,LEXSDT,LEXSO,LEXST,LEXSTA
+7 NEW LEXSTAT,LEXSTR,LEXSY,LEXSYS,LEXT,LEXTEST,LEXTMP,LEXUD,LEXUM,LEXVDT,LEXVTXT,LEXW,LEXWN,LEXX,TXT,TX1,TX2,I,X,Y,Z
+8 SET LEXEXIT=0
SET LEXCDT=""
KILL ^TMP("LEXQIP",$JOB),^TMP("LEXQIPO",$JOB),^TMP("LEXQIPA",$JOB)
+9 FOR
SET LEXCDT=$$AD^LEXQM
SET LEXAD=LEXCDT
if '$LENGTH(LEXCDT)
QUIT
if +($GET(LEXEXIT))>0
QUIT
SET LEXEDT=$PIECE(LEXCDT,"^",1)
SET LEXCDT=$PIECE(LEXCDT,"^",2)
if LEXCDT'?7N
QUIT
DO LOOK
if LEXCDT'?7N
QUIT
if +($GET(LEXEXIT))>0
QUIT
+10 KILL ^TMP("LEXQIP",$JOB),^TMP("LEXQIPO",$JOB),^TMP("LEXQIPA",$JOB)
+11 QUIT
IEN ; Display with IENs
+1 NEW LEXIIEN
SET LEXIIEN=1
DO EN
+2 QUIT
LOOK ; ICD Lookup Loop
+1 NEW LEXDG,LEXST,LEXSD,LEXLD,LEXMOR,LEXWN,LEXCC,LEXMC,LEXICP,LEXICPC
+2 SET LEXCDT=$GET(LEXCDT)
SET LEXEDT=$$ED^LEXQM(LEXCDT)
IF LEXCDT'?7N
SET LEXCDT=""
QUIT
+3 SET LEXLEN=62
FOR
SET LEXICP=$$ICP^LEXQIL
Begin DoDot:1
+4 if $EXTRACT(LEXICP,1,2)="^^"
SET LEXICP="^^"
SET LEXEXIT=1
if +($GET(LEXEXIT))>0!(LEXICP="^^")
QUIT
+5 if $EXTRACT(LEXICP,1)="^"
SET LEXICP="^"
if LEXICP="^"
QUIT
+6 KILL LEXST,LEXSD,LEXLD,LEXWN,LEXCC,LEXMOR,LEXMC,^TMP("LEXQIP",$JOB)
+7 NEW LEXIEN,LEXLDT,LEXELDT,LEXINC,LEXINOT,LEXIREQ,LEXINCC,LEXSO,LEXNAM
+8 SET LEXIEN=+($GET(LEXICP))
SET LEXLDT=+($GET(LEXCDT))
if +LEXIEN'>0
QUIT
if LEXLDT'?7N
QUIT
+9 SET LEXELDT=$$SD^LEXQM(LEXLDT)
if '$LENGTH(LEXELDT)
QUIT
+10 DO CSV
DO EN^LEXQIP3
End DoDot:1
if LEXICP="^"!(LEXICP="^^")
QUIT
+11 QUIT
CSV ; Code Set Versioning Display
+1 NEW LEXEDT,LEXIEN,LEXIENS,LEXLTXT,LEXSTAT,LEXSYS,LEXMSG,LEXDAT
+2 NEW LEXT,LEXTMP
SET LEXCDT=$GET(LEXCDT)
SET LEXEDT=$$ED^LEXQM(LEXCDT)
+3 IF LEXCDT'?7N
SET (LEXICP,LEXCDT)=""
QUIT
+4 SET LEXIEN=+($GET(LEXICP))
SET LEXSO=$$CODEC^ICDEX(80.1,+LEXIEN)
+5 SET LEXLTXT=$PIECE($GET(LEXICP),"^",3)
SET LEXSYS=$$CSI^ICDEX(80.1,+LEXIEN)
+6 if +LEXIEN'>0
QUIT
if '$LENGTH(LEXSO)
QUIT
if +LEXSYS'>0
QUIT
+7 SET LEXDAT=$$ICDOP^ICDEX(LEXSO,LEXCDT,LEXSYS,"E")
+8 SET LEXSO=$PIECE(LEXDAT,"^",2)
SET LEXNAM=$PIECE(LEXDAT,"^",5)
+9 IF '$LENGTH(LEXNAM)!($PIECE(LEXNAM,"^",1)=-1)
Begin DoDot:1
+10 NEW LEXLA
SET LEXLA=$$LA^ICDEX(80.1,+LEXIEN,9999999)
+11 SET LEXNAM=$$SD^ICDEX(80.1,+LEXIEN,LEXLA)
End DoDot:1
+12 if '$LENGTH($GET(LEXNAM))
QUIT
+13 ;
+14 ; "Unversioned" Fields
+15 ;
+16 ; ,01 Code
+17 ; 1.1 Coding System
+18 ; 1.2 Identifier
+19 ; 1.4 MDC24
+20 ; 1.7 ICD Expanded
+21 ; 1.8 Exclude from Lookup
+22 ; 20 MAJOR O.R. PROC
+23 ;
+24 SET LEXTMP=$$MOR^ICDEX(+LEXIEN)
if $LENGTH(LEXTMP)
DO OR^LEXQIP2(LEXTMP,.LEXMOR)
+25 ;
+26 ; Get the "Versioned" Fields
+27 ;
+28 ; Date/Status 80.166 (66)
+29 SET LEXST=$$EF(+($GET(LEXIEN)),+LEXCDT)
SET LEXSTAT=+($PIECE(LEXST,"^",2))
+30 ; Procedure Name 80.167 (67)
+31 DO SDS(+($GET(LEXIEN)),+LEXCDT,.LEXSD,62,LEXSTAT)
+32 ; Description 80.168 (68)
+33 DO LDS(+($GET(LEXIEN)),+LEXCDT,.LEXLD,62,LEXSTAT)
+34 ; Lexicon Expression
+35 DO LX^LEXQIP2(+($GET(LEXIEN)),+LEXCDT,.LEXLX,62,LEXSTAT)
+36 ; Warning Message
+37 DO WN(+LEXCDT,.LEXWN,62)
+38 ; MDC/DRG Groups 80.171 (71)
+39 ;D MDCDRG^LEXQIP2(+LEXIEN,+LEXCDT,.LEXDG,LEXLEN)
+40 QUIT
+41 ;
EF(X,LEXCDT) ; Effective Dates
+1 NEW LEX,LEXAD,LEXBRD,LEXBRW,LEXEE,LEXEF,LEXES,LEXFA,LEXH,LEXI,LEXID,LEXIEN,LEXRT,LEXLS,LEXSO,LEXSYS,LEXST
SET LEXIEN=+($GET(X))
SET LEXCDT=+($GET(LEXCDT))
+2 SET LEXRT=$$ROOT^ICDEX(80.1)
if +LEXIEN'>0
QUIT "^^"
SET LEXSO=$$CODEC^ICDEX(80.1,+LEXIEN)
if '$LENGTH(LEXSO)!($PIECE(LEXSO,"^",1)="-1")
QUIT
if LEXCDT'?7N
QUIT "^^"
+3 SET LEXSYS=$$CSI^ICDEX(80.1,+LEXIEN)
SET LEX=$$ICDOP^ICDEX(LEXSO,LEXCDT,LEXSYS,"E")
+4 SET LEXFA=$$FA(+LEXIEN)
SET (LEXLS,LEXST)=$PIECE(LEX,"^",10)
SET LEXID=$PIECE(LEX,"^",12)
SET LEXAD=$PIECE(LEX,"^",13)
SET LEXBRD=2781001
SET LEXBRW=""
+5 IF LEXCDT<LEXBRD&(+LEXFA=LEXBRD)
Begin DoDot:1
+6 SET LEXBRW="Warning: The 'Based on Date' provided precedes the initial Code Set Business Rule date of "
+7 SET LEXBRW=LEXBRW_$$SD^LEXQM(LEXBRD)_", the Effective date may be inaccurate."
End DoDot:1
+8 SET LEXES=$SELECT(+LEXST>0:"Active",1:"Inactive")
+9 if +LEXST'>0&(+LEXAD'>0)
SET LEXES="Not Applicable"
SET LEXLS=-1
+10 if +LEXFA>0&(+LEXCDT>0)&(LEXFA>LEXCDT)
SET LEXES="Pending"
SET LEXLS=-1
SET LEXST=0
SET LEXBRW=""
+11 if LEXST>0
SET LEXEF=LEXAD
if LEXST'>0
SET LEXEF=LEXID
+12 if LEXST'>0&(+LEXID'>0)
SET LEXEF=LEXFA
SET LEXEE=$$SD^LEXQM(LEXEF)
+13 IF LEXST'>0
IF +LEXID'>0
IF $LENGTH(LEXEE)
IF +LEXEF>LEXCDT
SET LEXEE="(future activation of "_LEXEE_")"
SET LEXEF=""
+14 SET X=LEXLS_"^"_LEXST_"^"_LEXEF_"^"_LEXES_"^"_LEXEE
if $LENGTH(LEXBRW)
SET $PIECE(X,"^",6)=LEXBRW
+15 QUIT X
+16 ;
SDS(X,LEXVDT,LEX,LEXLEN,LEXSTA) ; Operation/Procedure (short description)
+1 ;
+2 ; LEX=# of Lines
+3 ; LEX(0)=External Date of Operation/Procedure Name
+4 ; LEX(#)=Operation/Procedure 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.1,+LEXIEN)
+12 SET LEXSY=$$CSI^ICDEX(80.1,+LEXIEN)
+13 SET LEXLA=$$LA^ICDEX(80.1,+LEXIEN,9999999)
SET LEXFA=$$FA(+LEXIEN)
+14 SET LEXLAST=$$ICDOP^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.1,+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="Operation/Procedure 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(@("^ICD0("_+LEXIEN_",67,""B"","_+LEXSDD_",0)"))
+28 if +LEXSIEN>0
SET LEXAIEN=LEXAIEN_";"_LEXSIEN
+29 SET LEXM=""
SET LEXOD=LEXSD
if $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="Operation/Procedure 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
LDS(X,LEXVDT,LEX,LEXLEN,LEXSTA) ; Operation/Procedure (short description)
+1 ;
+2 ; LEX=# of Lines
+3 ; LEX(0)=External Date of Operation/Procedure Name
+4 ; LEX(#)=Operation/Procedure 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,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.1,+LEXIEN)
+12 SET LEXSY=$$CSI^ICDEX(80.1,+LEXIEN)
+13 SET LEXLA=$$LA^ICDEX(80.1,+LEXIEN,9999999)
SET LEXFA=$$FA(+LEXIEN)
+14 SET LEXLSD=$$LD^ICDEX(80.1,+LEXIEN,LEXLA)
+15 SET LEXBRD=$$DTBR^ICDEX(LEXVDT,0,LEXSY)
SET LEXBRW=""
+16 SET LEXLD=$$LD^ICDEX(80.1,+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="Operation/Procedure 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=""
+27 IF $LENGTH(LEXLD)&($PIECE(LEXLD,"^",1)'="-1")
Begin DoDot:1
+28 if LEXLDD?7N
SET LEXSIEN=$ORDER(@("^ICD0("_+LEXIEN_",68,""B"","_+LEXLDD_",0)"))
+29 if +LEXSIEN>0
SET LEXAIEN=LEXAIEN_";"_LEXSIEN
+30 SET LEXM=""
SET LEXOD=LEXLD
if $DATA(LEXIIEN)
SET LEXOD=LEXOD_" (IEN "_LEXAIEN_")"
+31 SET LEXODD=$SELECT(LEXLDD?7N:$$ED^LEXQM(LEXLDD),1:"--/--/----")
End DoDot:1
+32 if '$LENGTH(LEXOD)
SET LEXOD="Operation/Procedure Description not found"
+33 if '$LENGTH(LEXODD)
SET LEXODD="--/--/----"
+34 KILL LEX,LEXT
SET LEXT(1)=LEXOD
DO PR^LEXU(.LEXT,(LEXLEN-7))
+35 SET LEXI=0
FOR
SET LEXI=$ORDER(LEXT(LEXI))
if +LEXI'>0
QUIT
SET LEXT=$GET(LEXT(LEXI))
SET LEX(LEXI)=LEXT
+36 IF $LENGTH($GET(LEXM))
Begin DoDot:1
+37 KILL LEX,LEXT
NEW LEXC
SET LEXT(1)=LEXM
DO PR^LEXU(.LEXT,(LEXLEN-7))
+38 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
+39 if $DATA(LEX(1))
SET LEX(0)=LEXODD
+40 QUIT
+41 ;
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 LEXLEN=+$GET(LEXLEN)
SET LEXIA=$$IA(LEXVDT,LEXIEN)
if +LEXIA'>0
QUIT
if +LEXLEN>62
SET LEXLEN=62
+7 SET LEXTMP(1)="Warning: The 'Based on Date' provided precedes Code Set Versioning. The Operation/Procedure (Short Name) and Description may be inaccurate for "_$$SD^LEXQM(LEXVDT)
+8 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))
+9 SET LEX=$ORDER(LEX(" "),-1)
SET LEX(0)=$$SD^LEXQM(LEXVDT)
+10 QUIT
+11 ; 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.1,+LEXIEN)
SET LEXSY=$$CSI^ICDEX(80.1,+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.1,+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
