LEXQID4 ;ISL/KER - Query - ICD Diagnosis - Save ;05/23/2017
;;2.0;LEXICON UTILITY;**62,80,103**;Sep 23, 1996;Build 2
;
; Global Variables
; ^TMP("LEXQID") SACC 2.3.2.5.1
; ^TMP("LEXQIDO") SACC 2.3.2.5.1
;
; External References
; $$UPDX^ICDEX ICR 5747
; $$VAGEH^ICDEXD ICR 5747
; $$VAGEL^ICDEXD ICR 5747
; $$VSEX^ICDEXD ICR 5747
; $$UP^XLFSTR ICR 10104
;
; Local Variables NEWed or KILLed in LEXQID
; LEXIEN ICD Internal Entry Number
; LEXIIEN Include IENs flag
; LEXCDT Code Set Date
; LEXLEN Offset Length
; LEXST ICD Status and Effective Dates
; LEXSD Versioned Short Description
; LEXLD Versioned Long Description
; LEXLX Versioned Lexicon Term
; LEXWN Warning
; LEXCC Code CC Status
; LEXMC Major Diagnostic Category
; LEXELDT External Last Date
;
EN ; Main Entry Point
K ^TMP("LEXQIDO",$J) Q:'$L($G(LEXELDT)) I +($G(LEXST))<0 D FUT D:$D(^TMP("LEXQIDO",$J)) DSP^LEXQO("LEXQIDO") Q
D FUL D:$D(^TMP("LEXQIDO",$J)) DSP^LEXQO("LEXQIDO")
Q
FUT ; Future Activation
N LEX1,LEX2,LEX3,LEXEFF,LEXI,LEXL,LEXSTA S LEXI=+($G(LEXIEN)) Q:+LEXI'>0
S LEXL=+($G(LEXLEN)) Q:+LEXL'>0 S:LEXL>62 LEXL=62
Q:'$L($G(LEXSO)) Q:'$L($G(LEXNAM)) S LEXSTA=$G(LEXST)
S LEXEFF=$P(LEXSTA,"^",5),LEXSTA=$P(LEXSTA,"^",4)
Q:'$L(LEXSTA) Q:'$L(LEXEFF) S (LEX1,LEX2,LEX3)=""
D BOD(LEXELDT),COD(LEXSO,LEXNAM,$G(LEXCDT),+($G(LEXL))),STA(.LEXST,+($G(LEXL)))
Q
BOD(X) ; Based on Date
N LEXBOD S LEXBOD=$G(X),X="Display based on date: "_LEXBOD D BL,TL(X)
Q
COD(X,Y,LEXD,LEXLEN) ; Code Line
N LEXC,LEXN,LEXT,LEXIEN,LEXNAM S LEXC=$G(X),LEXN=$G(Y),LEXD=$G(LEXD),LEXIEN=$$CI(LEXC,LEXD)
S LEXNAM=$P(LEXN," (IEN ",1) S:$D(LEXIIEN)&($L(LEXIEN)) LEXNAM=LEXIEN
S LEXT="Code: "_LEXC,LEXT=LEXT_$J(" ",((79-+($G(LEXLEN)))-$L(LEXT)))_LEXNAM D BL,TL(LEXT)
Q
STA(X,LEXLEN) ; Status Line
N LEX,LEXC,LEXX,LEXE,LEXI,LEXN,LEXS,LEXT,LEXW,LEXEFF,LEXSTA
S LEXX=$G(X),LEXSTA=$P(LEXX,"^",4),LEXEFF=$P(LEXX,"^",5)
S LEXEFF=$TR(LEXEFF,"()",""),LEXW=$P(LEXX,"^",6)
S LEXT=" Status: ",LEXT=LEXT_$J(" ",((79-+($G(LEXLEN)))-$L(LEXT)))_LEXSTA
S LEXT=LEXT_$J(" ",(35-$L(LEXT)))
S:LEXEFF'["future" LEXT=LEXT_"Effective: "
S LEXT=LEXT_$$UP^XLFSTR($E(LEXEFF,1))_$E(LEXEFF,2,$L(LEXEFF)) D BL,TL(LEXT)
I $L(LEXW) D
. N LEX,LEXT,LEXC,LEXI,LEXN S LEX(1)=LEXW D PR^LEXU(.LEX,(LEXLEN-7))
. Q:+($O(LEX(" "),-1))'>0 S LEXT=$J(" ",((79-+($G(LEXLEN)))))
. S (LEXC,LEXI)=0 F S LEXI=$O(LEX(LEXI)) Q:+LEXI'>0 D
. . N LEXN S LEXN=$$TM^LEXQM($G(LEX(LEXI))) S:$L(LEXN) LEXC=LEXC+1
. . D:LEXC=1 BL D TL((LEXT_LEXN))
Q
FUL ; Full Display
N LEXFUL,LEX,LEXL S LEXL=+($G(LEXLEN)) S:LEXL>62 LEXL=62
S LEXFUL="" D FUT
D LIM(+($G(LEXIEN)),+($G(LEXL)))
D SD(.LEXSD,+($G(LEXL)))
D LD(.LEXLD,+($G(LEXL)))
D LX(.LEXLX,+($G(LEXL)))
D WN(.LEXWN,+($G(LEXL)))
D:$L($G(LEXCC(1)))!($L($G(LEXMC(1)))) BL
;D CC(.LEXCC,+($G(LEXL)))
;D MC(.LEXMC,+($G(LEXL)))
;D DRG(+($G(LEXL)))
;D NOT(+($G(LEXL)))
;D REQ(+($G(LEXL)))
;D NCC(+($G(LEXL)))
Q
LIM(X,LEXLEN) ; Limitations - Age Low, Age High and Sex
N LEXC,LEXI,LEXH,LEXL,LEXS,LEXT,LEXU,LEXP S LEXC=0,LEXI=+($G(X))
S LEXL=$$VAGEL^ICDEX(+($G(LEXIEN)),$G(LEXCDT)) S:'$L(LEXL) LEXL="N/A"
S LEXH=$$VAGEH^ICDEX(+($G(LEXIEN)),$G(LEXCDT)) S:'$L(LEXH) LEXH="N/A"
S LEXS=$$VSEX^ICDEX(80,+($G(LEXIEN)),$G(LEXCDT))
S LEXS=$S(LEXS="M":"Male",LEXS="F":"Female",1:"") S:'$L(LEXS) LEXS="N/A"
S LEXU=$$UPDX^ICDEX(+($G(LEXIEN))) S:'$L(LEXU)!(LEXU=0) LEXU="N/A"
I (LEXH_LEXL_LEXS+LEXU)'="N/AN/AN/AN/A" D
. N LEXLDR S LEXLDR=" Limitations: ",LEXC=0
. I LEXL'="N/A" D
. . S LEXT="" S LEXT=LEXLDR_$J(" ",((79-+($G(LEXLEN)))-$L(LEXLDR)))_"Minimum Age: "_LEXL
. . S LEXLDR=" " I $L(LEXT) D BL,TL(LEXT) S LEXC=1
. I LEXH'="N/A" D
. . S LEXT="" S LEXT=LEXLDR_$J(" ",((79-+($G(LEXLEN)))-$L(LEXLDR)))_"Maximum Age: "_LEXH
. . S LEXLDR=" " I $L(LEXT) D:'LEXC BL D TL(LEXT) S LEXC=1
. I LEXS'="N/A" D
. . S LEXT="" S LEXT=LEXLDR_$J(" ",((79-+($G(LEXLEN)))-$L(LEXLDR)))_"Applies to: "_LEXS_" patients"
. . S LEXLDR=" " I $L(LEXT) D:'LEXC BL D TL(LEXT) S LEXC=1
. I LEXU'="N/A" D
. . S LEXT="" S LEXT=LEXLDR_$J(" ",((79-+($G(LEXLEN)))-$L(LEXLDR)))_"Principle DX: "_"Code is unacceptable as a principal DX"
. . S LEXLDR=" " I $L(LEXT) D:'LEXC BL D TL(LEXT) S LEXC=1
Q
SD(X,LEXLEN) ; Short Description
N LEXI,LEXH,LEXE,LEXN,LEXT Q:'$D(X(1)) S LEXN=$G(X(1)),LEXT=" Short Name: ",LEXT=LEXT_$J(" ",((79-+($G(LEXLEN)))-$L(LEXT)))_LEXN D BL,TL(LEXT)
S LEXE=$G(X(0)),LEXT=" "_LEXE,LEXN=$G(X(2)),LEXT=LEXT_$J(" ",((79-+($G(LEXLEN)))-$L(LEXT)))_LEXN D TL(LEXT)
Q
LD(X,LEXLEN) ; Long Description
N LEXI,LEXH,LEXE,LEXN,LEXT Q:'$D(X(1)) S LEXN=$G(X(1)),LEXT=" Description: ",LEXT=LEXT_$J(" ",((79-+($G(LEXLEN)))-$L(LEXT)))_LEXN D BL,TL(LEXT)
S LEXE=$G(X(0)),LEXT=" "_LEXE,LEXN=$G(X(2)),LEXT=LEXT_$J(" ",((79-+($G(LEXLEN)))-$L(LEXT)))_LEXN D TL(LEXT)
S LEXT=$J(" ",((79-+($G(LEXLEN))))) S LEXI=2 F S LEXI=$O(X(LEXI)) Q:+LEXI'>0 S LEXN=LEXT_$G(X(LEXI)) D TL(LEXN)
Q
LX(X,LEXLEN) ; Lexicon Expression
N LEXI,LEXH,LEXE,LEXN,LEXT Q:'$D(X(1)) S LEXN=$G(X(1)),LEXT=" Lexicon Term:",LEXT=LEXT_$J(" ",((79-+($G(LEXLEN)))-$L(LEXT)))_LEXN D BL,TL(LEXT)
S LEXE=$G(X(0)),LEXT=" "_LEXE,LEXN=$G(X(2)),LEXT=LEXT_$J(" ",((79-+($G(LEXLEN)))-$L(LEXT)))_LEXN D TL(LEXT)
S LEXT=$J(" ",((79-+($G(LEXLEN))))),LEXI=2 F S LEXI=$O(X(LEXI)) Q:+LEXI'>0 S LEXN=LEXT_$G(X(LEXI)) D TL(LEXN)
Q
WN(X,LEXLEN) ; Warning
N LEXI,LEXH,LEXE,LEXN,LEXT,LEXC Q:'$D(X(1)) S LEXC=0,LEXN=$G(X(1)),LEXT="",LEXT=LEXT_$J(" ",((79-+($G(LEXLEN)))-$L(LEXT)))_LEXN D BL,TL(LEXT)
S LEXT=$J(" ",((79-+($G(LEXLEN))))),LEXI=1 F S LEXI=$O(X(LEXI)) Q:+LEXI'>0 S LEXN=LEXT_$G(X(LEXI)) D TL(LEXN)
Q
CC(X,LEXLEN) ; Complication/Comorbidity
Q
N LEXI,LEXH,LEXE,LEXN,LEXT Q:'$D(X(1)) S LEXN=$G(X(1)),LEXE=$G(X(0)),LEXT=" CC:",LEXT=LEXT_$J(" ",((79-+($G(LEXLEN)))-$L(LEXT)))_LEXN
S LEXT=LEXT_$J(" ",(66-$L(LEXT)))_LEXE D TL(LEXT)
Q
MC(X,LEXLEN) ; Major Diagnostic Category
Q
N LEXI,LEXH,LEXE,LEXN,LEXT Q:'$D(X(1)) S LEXN=$G(X(1)),LEXE=$G(X(0)),LEXT=" MDC:",LEXT=LEXT_$J(" ",((79-+($G(LEXLEN)))-$L(LEXT)))_LEXN
S LEXT=LEXT_$J(" ",(66-$L(LEXT)))_LEXE D TL(LEXT)
Q
DRG(LEXLEN) ; Diagnosis Related Groups
Q
Q:$O(^TMP("LEXQID",$J,"DRG",3,0))'>0 Q:'$D(^TMP("LEXQID",$J,"DRG",3,1)) Q:'$D(^TMP("LEXQID",$J,"DRG",1,1))
Q:'$D(^TMP("LEXQID",$J,"DRG",1,2)) Q:'$D(^TMP("LEXQID",$J,"DRG",2,1)) N LEXI,LEXH,LEXE,LEXN,LEXT
S LEXT=" "_$G(^TMP("LEXQID",$J,"DRG",1,1))_":",LEXN=$G(^TMP("LEXQID",$J,"DRG",2,1)) S LEXT=LEXT_$J(" ",((79-+($G(LEXLEN)))-$L(LEXT)))_LEXN D BL,TL(LEXT)
S LEXE=$G(^TMP("LEXQID",$J,"DRG",1,2)),LEXT=" "_LEXE,LEXN=$G(^TMP("LEXQID",$J,"DRG",3,1)) S LEXT=LEXT_$J(" ",((79-+($G(LEXLEN)))-$L(LEXT)))_LEXN D TL(LEXT)
S LEXT=$J(" ",((79-+($G(LEXLEN))))),LEXI=1 F S LEXI=$O(^TMP("LEXQID",$J,"DRG",3,LEXI)) Q:+LEXI'>0 D
. S LEXN=LEXT_$G(^TMP("LEXQID",$J,"DRG",3,LEXI)) D TL(LEXN)
K ^TMP("LEXQID",$J,"DRG")
Q
NOT(LEXLEN) ; ICD codes not used with
Q
Q:'$L($O(^TMP("LEXQID",$J,"NOT",3,""))) Q:'$D(^TMP("LEXQID",$J,"NOT",1,1)) Q:'$D(^TMP("LEXQID",$J,"NOT",2,1))
N LEXI,LEXH,LEXE,LEXN,LEXT S LEXT=" "_$G(^TMP("LEXQID",$J,"NOT",1,1))_":",LEXN=$G(^TMP("LEXQID",$J,"NOT",2,1))
S LEXT=LEXT_$J(" ",((79-+($G(LEXLEN)))-$L(LEXT)))_LEXN D BL,TL(LEXT)
S LEXT=$J(" ",((79-+($G(LEXLEN))))),LEXN=$$TM^LEXQM($G(^TMP("LEXQID",$J,"NOT",2,2))) I $L(LEXN) D TL((LEXT_LEXN))
S LEXI=" " F S LEXI=$O(^TMP("LEXQID",$J,"NOT",3,LEXI)) Q:'$L(LEXI) D
. S LEXN=$G(^TMP("LEXQID",$J,"NOT",3,LEXI)) I $L(LEXN)'>62 D TL((LEXT_LEXN)) Q
. N LEXC,LEXD,LEXA,LEXS,LEXI,LEXLEN S LEXLEN=50,LEXD=$$TM^LEXQM($P(LEXN," ",2,4000)) Q:'$L(LEXD)
. S LEXC=$P(LEXN,LEXD,1) Q:'$L(LEXC) S LEXS=$L(LEXC) K LEXA S LEXA(1)=LEXD D PR^LEXU(.LEXA,LEXLEN)
. F LEXI=1:1:3 D
. . D:$L($G(LEXA(LEXI))) TL((LEXT_LEXC_$G(LEXA(LEXI)))) S LEXC=$J(" ",LEXS)
K ^TMP("LEXQID",$J,"NOT")
Q
REQ(LEXLEN) ; ICD codes requried with
Q
Q:'$L($O(^TMP("LEXQID",$J,"REQ",3,""))) Q:'$D(^TMP("LEXQID",$J,"REQ",1,1)) Q:'$D(^TMP("LEXQID",$J,"REQ",2,1))
N LEXI,LEXH,LEXE,LEXN,LEXT S LEXT=" "_$G(^TMP("LEXQID",$J,"REQ",1,1))_":",LEXN=$G(^TMP("LEXQID",$J,"REQ",2,1))
S LEXT=LEXT_$J(" ",((79-+($G(LEXLEN)))-$L(LEXT)))_LEXN D BL,TL(LEXT)
S LEXT=$J(" ",((79-+($G(LEXLEN))))),LEXN=$$TM^LEXQM($G(^TMP("LEXQID",$J,"REQ",2,2))) I $L(LEXN) D TL((LEXT_LEXN))
S LEXI=" " F S LEXI=$O(^TMP("LEXQID",$J,"REQ",3,LEXI)) Q:'$L(LEXI) D
. S LEXN=$G(^TMP("LEXQID",$J,"REQ",3,LEXI)) I $L(LEXN)'>62 D TL((LEXT_LEXN)) Q
. N LEXC,LEXD,LEXA,LEXS,LEXI,LEXLEN S LEXLEN=50,LEXD=$$TM^LEXQM($P(LEXN," ",2,4000)) Q:'$L(LEXD)
. S LEXC=$P(LEXN,LEXD,1) Q:'$L(LEXC) S LEXS=$L(LEXC) K LEXA S LEXA(1)=LEXD D PR^LEXU(.LEXA,LEXLEN)
. F LEXI=1:1:3 D
. . D:$L($G(LEXA(LEXI))) TL((LEXT_LEXC_$G(LEXA(LEXI)))) S LEXC=$J(" ",LEXS)
K ^TMP("LEXQID",$J,"REQ")
Q
NCC(LEXLEN) ; Not CC with
Q
Q:'$L($O(^TMP("LEXQID",$J,"NCC",3,""))) Q:'$D(^TMP("LEXQID",$J,"NCC",1,1)) Q:'$D(^TMP("LEXQID",$J,"NCC",2,1))
N LEXI,LEXH,LEXE,LEXN,LEXT S LEXT=" "_$G(^TMP("LEXQID",$J,"NCC",1,1))_":",LEXN=$G(^TMP("LEXQID",$J,"NCC",2,1))
S LEXT=LEXT_$J(" ",((79-+($G(LEXLEN)))-$L(LEXT)))_LEXN D BL,TL(LEXT)
S LEXT=$J(" ",((79-+($G(LEXLEN))))),LEXN=$$TM^LEXQM($G(^TMP("LEXQID",$J,"NCC",2,2))) I $L(LEXN) D TL((LEXT_LEXN))
S LEXI=" " F S LEXI=$O(^TMP("LEXQID",$J,"NCC",3,LEXI)) Q:'$L(LEXI) D
. S LEXN=$G(^TMP("LEXQID",$J,"NCC",3,LEXI)) I $L(LEXN)'>62 D TL((LEXT_LEXN)) Q
. N LEXC,LEXD,LEXA,LEXS,LEXI,LEXLEN S LEXLEN=50,LEXD=$$TM^LEXQM($P(LEXN," ",2,4000)) Q:'$L(LEXD)
. S LEXC=$P(LEXN,LEXD,1) Q:'$L(LEXC) S LEXS=$L(LEXC) K LEXA S LEXA(1)=LEXD D PR^LEXU(.LEXA,LEXLEN)
. F LEXI=1:1:3 D
. . D:$L($G(LEXA(LEXI))) TL((LEXT_LEXC_$G(LEXA(LEXI)))) S LEXC=$J(" ",LEXS)
K ^TMP("LEXQID",$J,"NCC")
Q
;
; Miscellaneous
CI(X,LEXD) ; Code IENs
N LEXSO,LEXSDO,LEXLEX,LEXSAB S LEXSO=$G(X) Q:'$L(LEXSO) S LEXD=$G(LEXD) I LEXD'?7N D
. N LEXEF,LEXTD S LEXTD="",LEXEF=9999999 F S LEXEF=$O(^LEX(757.02,"ACT",(LEXSO_" "),3,LEXEF),-1) Q:+LEXEF'>0 D
. . N LEXIE S LEXIE=$O(^LEX(757.02," "),-1) F S LEXIE=$O(^LEX(757.02,"ACT",(LEXSO_" "),3,+LEXEF,LEXIE),-1) Q:+LEXIE'>0 D
. . . N LEXSR S LEXSR=$P($G(^LEX(757.02,+LEXIE,0)),"^",3) S:"^1^30^"[("^"_LEXSR_"^") LEXTD=LEXEF
. S:LEXTD?7N LEXD=LEXTD
S:LEXD'?7N LEXD=$$DT^XLFDT S LEXSDO=$O(^ICD9("BA",(LEXSO_" "),0)),LEXSAB=+($G(^ICD9(+LEXSDO,1))),LEXSAB=$S(LEXSAB=1:"ICD",1:"10D")
S LEXLEX=$$STATCHK^LEXSRC2(LEXSO,LEXD,,LEXSAB),LEXLEX=$P(LEXLEX,"^",2)
S LEXSDO=$S(+LEXSDO>0:("ICD Diagnosis IEN "_+LEXSDO),1:"") S LEXLEX=$S(+LEXLEX>0:("Lexicon IEN "_+LEXLEX),1:"")
S X="" S:$L(LEXSDO)&('$L(LEXLEX)) X=LEXSDO S:'$L(LEXSDO)&($L(LEXLEX)) X=LEXLEX S:$L(LEXSDO)&($L(LEXLEX)) X=(LEXSDO_"/"_LEXLEX)
Q X
BL ; Blank Line
D TL(" ") Q
TL(X) ; Text Line
I $D(LEXTEST) W !,$G(X) Q
N LEXI,LEXTEST S LEXI=+($O(^TMP("LEXQIDO",$J," "),-1))+1 S ^TMP("LEXQIDO",$J,LEXI)=$G(X),^TMP("LEXQIDO",$J,0)=LEXI
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLEXQID4 11338 printed Nov 22, 2024@17:18:55 Page 2
LEXQID4 ;ISL/KER - Query - ICD Diagnosis - Save ;05/23/2017
+1 ;;2.0;LEXICON UTILITY;**62,80,103**;Sep 23, 1996;Build 2
+2 ;
+3 ; Global Variables
+4 ; ^TMP("LEXQID") SACC 2.3.2.5.1
+5 ; ^TMP("LEXQIDO") SACC 2.3.2.5.1
+6 ;
+7 ; External References
+8 ; $$UPDX^ICDEX ICR 5747
+9 ; $$VAGEH^ICDEXD ICR 5747
+10 ; $$VAGEL^ICDEXD ICR 5747
+11 ; $$VSEX^ICDEXD ICR 5747
+12 ; $$UP^XLFSTR ICR 10104
+13 ;
+14 ; Local Variables NEWed or KILLed in LEXQID
+15 ; LEXIEN ICD Internal Entry Number
+16 ; LEXIIEN Include IENs flag
+17 ; LEXCDT Code Set Date
+18 ; LEXLEN Offset Length
+19 ; LEXST ICD Status and Effective Dates
+20 ; LEXSD Versioned Short Description
+21 ; LEXLD Versioned Long Description
+22 ; LEXLX Versioned Lexicon Term
+23 ; LEXWN Warning
+24 ; LEXCC Code CC Status
+25 ; LEXMC Major Diagnostic Category
+26 ; LEXELDT External Last Date
+27 ;
EN ; Main Entry Point
+1 KILL ^TMP("LEXQIDO",$JOB)
if '$LENGTH($GET(LEXELDT))
QUIT
IF +($GET(LEXST))<0
DO FUT
if $DATA(^TMP("LEXQIDO",$JOB))
DO DSP^LEXQO("LEXQIDO")
QUIT
+2 DO FUL
if $DATA(^TMP("LEXQIDO",$JOB))
DO DSP^LEXQO("LEXQIDO")
+3 QUIT
FUT ; Future Activation
+1 NEW LEX1,LEX2,LEX3,LEXEFF,LEXI,LEXL,LEXSTA
SET LEXI=+($GET(LEXIEN))
if +LEXI'>0
QUIT
+2 SET LEXL=+($GET(LEXLEN))
if +LEXL'>0
QUIT
if LEXL>62
SET LEXL=62
+3 if '$LENGTH($GET(LEXSO))
QUIT
if '$LENGTH($GET(LEXNAM))
QUIT
SET LEXSTA=$GET(LEXST)
+4 SET LEXEFF=$PIECE(LEXSTA,"^",5)
SET LEXSTA=$PIECE(LEXSTA,"^",4)
+5 if '$LENGTH(LEXSTA)
QUIT
if '$LENGTH(LEXEFF)
QUIT
SET (LEX1,LEX2,LEX3)=""
+6 DO BOD(LEXELDT)
DO COD(LEXSO,LEXNAM,$GET(LEXCDT),+($GET(LEXL)))
DO STA(.LEXST,+($GET(LEXL)))
+7 QUIT
BOD(X) ; Based on Date
+1 NEW LEXBOD
SET LEXBOD=$GET(X)
SET X="Display based on date: "_LEXBOD
DO BL
DO TL(X)
+2 QUIT
COD(X,Y,LEXD,LEXLEN) ; Code Line
+1 NEW LEXC,LEXN,LEXT,LEXIEN,LEXNAM
SET LEXC=$GET(X)
SET LEXN=$GET(Y)
SET LEXD=$GET(LEXD)
SET LEXIEN=$$CI(LEXC,LEXD)
+2 SET LEXNAM=$PIECE(LEXN," (IEN ",1)
if $DATA(LEXIIEN)&($LENGTH(LEXIEN))
SET LEXNAM=LEXIEN
+3 SET LEXT="Code: "_LEXC
SET LEXT=LEXT_$JUSTIFY(" ",((79-+($GET(LEXLEN)))-$LENGTH(LEXT)))_LEXNAM
DO BL
DO TL(LEXT)
+4 QUIT
STA(X,LEXLEN) ; Status Line
+1 NEW LEX,LEXC,LEXX,LEXE,LEXI,LEXN,LEXS,LEXT,LEXW,LEXEFF,LEXSTA
+2 SET LEXX=$GET(X)
SET LEXSTA=$PIECE(LEXX,"^",4)
SET LEXEFF=$PIECE(LEXX,"^",5)
+3 SET LEXEFF=$TRANSLATE(LEXEFF,"()","")
SET LEXW=$PIECE(LEXX,"^",6)
+4 SET LEXT=" Status: "
SET LEXT=LEXT_$JUSTIFY(" ",((79-+($GET(LEXLEN)))-$LENGTH(LEXT)))_LEXSTA
+5 SET LEXT=LEXT_$JUSTIFY(" ",(35-$LENGTH(LEXT)))
+6 if LEXEFF'["future"
SET LEXT=LEXT_"Effective: "
+7 SET LEXT=LEXT_$$UP^XLFSTR($EXTRACT(LEXEFF,1))_$EXTRACT(LEXEFF,2,$LENGTH(LEXEFF))
DO BL
DO TL(LEXT)
+8 IF $LENGTH(LEXW)
Begin DoDot:1
+9 NEW LEX,LEXT,LEXC,LEXI,LEXN
SET LEX(1)=LEXW
DO PR^LEXU(.LEX,(LEXLEN-7))
+10 if +($ORDER(LEX(" "),-1))'>0
QUIT
SET LEXT=$JUSTIFY(" ",((79-+($GET(LEXLEN)))))
+11 SET (LEXC,LEXI)=0
FOR
SET LEXI=$ORDER(LEX(LEXI))
if +LEXI'>0
QUIT
Begin DoDot:2
+12 NEW LEXN
SET LEXN=$$TM^LEXQM($GET(LEX(LEXI)))
if $LENGTH(LEXN)
SET LEXC=LEXC+1
+13 if LEXC=1
DO BL
DO TL((LEXT_LEXN))
End DoDot:2
End DoDot:1
+14 QUIT
FUL ; Full Display
+1 NEW LEXFUL,LEX,LEXL
SET LEXL=+($GET(LEXLEN))
if LEXL>62
SET LEXL=62
+2 SET LEXFUL=""
DO FUT
+3 DO LIM(+($GET(LEXIEN)),+($GET(LEXL)))
+4 DO SD(.LEXSD,+($GET(LEXL)))
+5 DO LD(.LEXLD,+($GET(LEXL)))
+6 DO LX(.LEXLX,+($GET(LEXL)))
+7 DO WN(.LEXWN,+($GET(LEXL)))
+8 if $LENGTH($GET(LEXCC(1)))!($LENGTH($GET(LEXMC(1))))
DO BL
+9 ;D CC(.LEXCC,+($G(LEXL)))
+10 ;D MC(.LEXMC,+($G(LEXL)))
+11 ;D DRG(+($G(LEXL)))
+12 ;D NOT(+($G(LEXL)))
+13 ;D REQ(+($G(LEXL)))
+14 ;D NCC(+($G(LEXL)))
+15 QUIT
LIM(X,LEXLEN) ; Limitations - Age Low, Age High and Sex
+1 NEW LEXC,LEXI,LEXH,LEXL,LEXS,LEXT,LEXU,LEXP
SET LEXC=0
SET LEXI=+($GET(X))
+2 SET LEXL=$$VAGEL^ICDEX(+($GET(LEXIEN)),$GET(LEXCDT))
if '$LENGTH(LEXL)
SET LEXL="N/A"
+3 SET LEXH=$$VAGEH^ICDEX(+($GET(LEXIEN)),$GET(LEXCDT))
if '$LENGTH(LEXH)
SET LEXH="N/A"
+4 SET LEXS=$$VSEX^ICDEX(80,+($GET(LEXIEN)),$GET(LEXCDT))
+5 SET LEXS=$SELECT(LEXS="M":"Male",LEXS="F":"Female",1:"")
if '$LENGTH(LEXS)
SET LEXS="N/A"
+6 SET LEXU=$$UPDX^ICDEX(+($GET(LEXIEN)))
if '$LENGTH(LEXU)!(LEXU=0)
SET LEXU="N/A"
+7 IF (LEXH_LEXL_LEXS+LEXU)'="N/AN/AN/AN/A"
Begin DoDot:1
+8 NEW LEXLDR
SET LEXLDR=" Limitations: "
SET LEXC=0
+9 IF LEXL'="N/A"
Begin DoDot:2
+10 SET LEXT=""
SET LEXT=LEXLDR_$JUSTIFY(" ",((79-+($GET(LEXLEN)))-$LENGTH(LEXLDR)))_"Minimum Age: "_LEXL
+11 SET LEXLDR=" "
IF $LENGTH(LEXT)
DO BL
DO TL(LEXT)
SET LEXC=1
End DoDot:2
+12 IF LEXH'="N/A"
Begin DoDot:2
+13 SET LEXT=""
SET LEXT=LEXLDR_$JUSTIFY(" ",((79-+($GET(LEXLEN)))-$LENGTH(LEXLDR)))_"Maximum Age: "_LEXH
+14 SET LEXLDR=" "
IF $LENGTH(LEXT)
if 'LEXC
DO BL
DO TL(LEXT)
SET LEXC=1
End DoDot:2
+15 IF LEXS'="N/A"
Begin DoDot:2
+16 SET LEXT=""
SET LEXT=LEXLDR_$JUSTIFY(" ",((79-+($GET(LEXLEN)))-$LENGTH(LEXLDR)))_"Applies to: "_LEXS_" patients"
+17 SET LEXLDR=" "
IF $LENGTH(LEXT)
if 'LEXC
DO BL
DO TL(LEXT)
SET LEXC=1
End DoDot:2
+18 IF LEXU'="N/A"
Begin DoDot:2
+19 SET LEXT=""
SET LEXT=LEXLDR_$JUSTIFY(" ",((79-+($GET(LEXLEN)))-$LENGTH(LEXLDR)))_"Principle DX: "_"Code is unacceptable as a principal DX"
+20 SET LEXLDR=" "
IF $LENGTH(LEXT)
if 'LEXC
DO BL
DO TL(LEXT)
SET LEXC=1
End DoDot:2
End DoDot:1
+21 QUIT
SD(X,LEXLEN) ; Short Description
+1 NEW LEXI,LEXH,LEXE,LEXN,LEXT
if '$DATA(X(1))
QUIT
SET LEXN=$GET(X(1))
SET LEXT=" Short Name: "
SET LEXT=LEXT_$JUSTIFY(" ",((79-+($GET(LEXLEN)))-$LENGTH(LEXT)))_LEXN
DO BL
DO TL(LEXT)
+2 SET LEXE=$GET(X(0))
SET LEXT=" "_LEXE
SET LEXN=$GET(X(2))
SET LEXT=LEXT_$JUSTIFY(" ",((79-+($GET(LEXLEN)))-$LENGTH(LEXT)))_LEXN
DO TL(LEXT)
+3 QUIT
LD(X,LEXLEN) ; Long Description
+1 NEW LEXI,LEXH,LEXE,LEXN,LEXT
if '$DATA(X(1))
QUIT
SET LEXN=$GET(X(1))
SET LEXT=" Description: "
SET LEXT=LEXT_$JUSTIFY(" ",((79-+($GET(LEXLEN)))-$LENGTH(LEXT)))_LEXN
DO BL
DO TL(LEXT)
+2 SET LEXE=$GET(X(0))
SET LEXT=" "_LEXE
SET LEXN=$GET(X(2))
SET LEXT=LEXT_$JUSTIFY(" ",((79-+($GET(LEXLEN)))-$LENGTH(LEXT)))_LEXN
DO TL(LEXT)
+3 SET LEXT=$JUSTIFY(" ",((79-+($GET(LEXLEN)))))
SET LEXI=2
FOR
SET LEXI=$ORDER(X(LEXI))
if +LEXI'>0
QUIT
SET LEXN=LEXT_$GET(X(LEXI))
DO TL(LEXN)
+4 QUIT
LX(X,LEXLEN) ; Lexicon Expression
+1 NEW LEXI,LEXH,LEXE,LEXN,LEXT
if '$DATA(X(1))
QUIT
SET LEXN=$GET(X(1))
SET LEXT=" Lexicon Term:"
SET LEXT=LEXT_$JUSTIFY(" ",((79-+($GET(LEXLEN)))-$LENGTH(LEXT)))_LEXN
DO BL
DO TL(LEXT)
+2 SET LEXE=$GET(X(0))
SET LEXT=" "_LEXE
SET LEXN=$GET(X(2))
SET LEXT=LEXT_$JUSTIFY(" ",((79-+($GET(LEXLEN)))-$LENGTH(LEXT)))_LEXN
DO TL(LEXT)
+3 SET LEXT=$JUSTIFY(" ",((79-+($GET(LEXLEN)))))
SET LEXI=2
FOR
SET LEXI=$ORDER(X(LEXI))
if +LEXI'>0
QUIT
SET LEXN=LEXT_$GET(X(LEXI))
DO TL(LEXN)
+4 QUIT
WN(X,LEXLEN) ; Warning
+1 NEW LEXI,LEXH,LEXE,LEXN,LEXT,LEXC
if '$DATA(X(1))
QUIT
SET LEXC=0
SET LEXN=$GET(X(1))
SET LEXT=""
SET LEXT=LEXT_$JUSTIFY(" ",((79-+($GET(LEXLEN)))-$LENGTH(LEXT)))_LEXN
DO BL
DO TL(LEXT)
+2 SET LEXT=$JUSTIFY(" ",((79-+($GET(LEXLEN)))))
SET LEXI=1
FOR
SET LEXI=$ORDER(X(LEXI))
if +LEXI'>0
QUIT
SET LEXN=LEXT_$GET(X(LEXI))
DO TL(LEXN)
+3 QUIT
CC(X,LEXLEN) ; Complication/Comorbidity
+1 QUIT
+2 NEW LEXI,LEXH,LEXE,LEXN,LEXT
if '$DATA(X(1))
QUIT
SET LEXN=$GET(X(1))
SET LEXE=$GET(X(0))
SET LEXT=" CC:"
SET LEXT=LEXT_$JUSTIFY(" ",((79-+($GET(LEXLEN)))-$LENGTH(LEXT)))_LEXN
+3 SET LEXT=LEXT_$JUSTIFY(" ",(66-$LENGTH(LEXT)))_LEXE
DO TL(LEXT)
+4 QUIT
MC(X,LEXLEN) ; Major Diagnostic Category
+1 QUIT
+2 NEW LEXI,LEXH,LEXE,LEXN,LEXT
if '$DATA(X(1))
QUIT
SET LEXN=$GET(X(1))
SET LEXE=$GET(X(0))
SET LEXT=" MDC:"
SET LEXT=LEXT_$JUSTIFY(" ",((79-+($GET(LEXLEN)))-$LENGTH(LEXT)))_LEXN
+3 SET LEXT=LEXT_$JUSTIFY(" ",(66-$LENGTH(LEXT)))_LEXE
DO TL(LEXT)
+4 QUIT
DRG(LEXLEN) ; Diagnosis Related Groups
+1 QUIT
+2 if $ORDER(^TMP("LEXQID",$JOB,"DRG",3,0))'>0
QUIT
if '$DATA(^TMP("LEXQID",$JOB,"DRG",3,1))
QUIT
if '$DATA(^TMP("LEXQID",$JOB,"DRG",1,1))
QUIT
+3 if '$DATA(^TMP("LEXQID",$JOB,"DRG",1,2))
QUIT
if '$DATA(^TMP("LEXQID",$JOB,"DRG",2,1))
QUIT
NEW LEXI,LEXH,LEXE,LEXN,LEXT
+4 SET LEXT=" "_$GET(^TMP("LEXQID",$JOB,"DRG",1,1))_":"
SET LEXN=$GET(^TMP("LEXQID",$JOB,"DRG",2,1))
SET LEXT=LEXT_$JUSTIFY(" ",((79-+($GET(LEXLEN)))-$LENGTH(LEXT)))_LEXN
DO BL
DO TL(LEXT)
+5 SET LEXE=$GET(^TMP("LEXQID",$JOB,"DRG",1,2))
SET LEXT=" "_LEXE
SET LEXN=$GET(^TMP("LEXQID",$JOB,"DRG",3,1))
SET LEXT=LEXT_$JUSTIFY(" ",((79-+($GET(LEXLEN)))-$LENGTH(LEXT)))_LEXN
DO TL(LEXT)
+6 SET LEXT=$JUSTIFY(" ",((79-+($GET(LEXLEN)))))
SET LEXI=1
FOR
SET LEXI=$ORDER(^TMP("LEXQID",$JOB,"DRG",3,LEXI))
if +LEXI'>0
QUIT
Begin DoDot:1
+7 SET LEXN=LEXT_$GET(^TMP("LEXQID",$JOB,"DRG",3,LEXI))
DO TL(LEXN)
End DoDot:1
+8 KILL ^TMP("LEXQID",$JOB,"DRG")
+9 QUIT
NOT(LEXLEN) ; ICD codes not used with
+1 QUIT
+2 if '$LENGTH($ORDER(^TMP("LEXQID",$JOB,"NOT",3,"")))
QUIT
if '$DATA(^TMP("LEXQID",$JOB,"NOT",1,1))
QUIT
if '$DATA(^TMP("LEXQID",$JOB,"NOT",2,1))
QUIT
+3 NEW LEXI,LEXH,LEXE,LEXN,LEXT
SET LEXT=" "_$GET(^TMP("LEXQID",$JOB,"NOT",1,1))_":"
SET LEXN=$GET(^TMP("LEXQID",$JOB,"NOT",2,1))
+4 SET LEXT=LEXT_$JUSTIFY(" ",((79-+($GET(LEXLEN)))-$LENGTH(LEXT)))_LEXN
DO BL
DO TL(LEXT)
+5 SET LEXT=$JUSTIFY(" ",((79-+($GET(LEXLEN)))))
SET LEXN=$$TM^LEXQM($GET(^TMP("LEXQID",$JOB,"NOT",2,2)))
IF $LENGTH(LEXN)
DO TL((LEXT_LEXN))
+6 SET LEXI=" "
FOR
SET LEXI=$ORDER(^TMP("LEXQID",$JOB,"NOT",3,LEXI))
if '$LENGTH(LEXI)
QUIT
Begin DoDot:1
+7 SET LEXN=$GET(^TMP("LEXQID",$JOB,"NOT",3,LEXI))
IF $LENGTH(LEXN)'>62
DO TL((LEXT_LEXN))
QUIT
+8 NEW LEXC,LEXD,LEXA,LEXS,LEXI,LEXLEN
SET LEXLEN=50
SET LEXD=$$TM^LEXQM($PIECE(LEXN," ",2,4000))
if '$LENGTH(LEXD)
QUIT
+9 SET LEXC=$PIECE(LEXN,LEXD,1)
if '$LENGTH(LEXC)
QUIT
SET LEXS=$LENGTH(LEXC)
KILL LEXA
SET LEXA(1)=LEXD
DO PR^LEXU(.LEXA,LEXLEN)
+10 FOR LEXI=1:1:3
Begin DoDot:2
+11 if $LENGTH($GET(LEXA(LEXI)))
DO TL((LEXT_LEXC_$GET(LEXA(LEXI))))
SET LEXC=$JUSTIFY(" ",LEXS)
End DoDot:2
End DoDot:1
+12 KILL ^TMP("LEXQID",$JOB,"NOT")
+13 QUIT
REQ(LEXLEN) ; ICD codes requried with
+1 QUIT
+2 if '$LENGTH($ORDER(^TMP("LEXQID",$JOB,"REQ",3,"")))
QUIT
if '$DATA(^TMP("LEXQID",$JOB,"REQ",1,1))
QUIT
if '$DATA(^TMP("LEXQID",$JOB,"REQ",2,1))
QUIT
+3 NEW LEXI,LEXH,LEXE,LEXN,LEXT
SET LEXT=" "_$GET(^TMP("LEXQID",$JOB,"REQ",1,1))_":"
SET LEXN=$GET(^TMP("LEXQID",$JOB,"REQ",2,1))
+4 SET LEXT=LEXT_$JUSTIFY(" ",((79-+($GET(LEXLEN)))-$LENGTH(LEXT)))_LEXN
DO BL
DO TL(LEXT)
+5 SET LEXT=$JUSTIFY(" ",((79-+($GET(LEXLEN)))))
SET LEXN=$$TM^LEXQM($GET(^TMP("LEXQID",$JOB,"REQ",2,2)))
IF $LENGTH(LEXN)
DO TL((LEXT_LEXN))
+6 SET LEXI=" "
FOR
SET LEXI=$ORDER(^TMP("LEXQID",$JOB,"REQ",3,LEXI))
if '$LENGTH(LEXI)
QUIT
Begin DoDot:1
+7 SET LEXN=$GET(^TMP("LEXQID",$JOB,"REQ",3,LEXI))
IF $LENGTH(LEXN)'>62
DO TL((LEXT_LEXN))
QUIT
+8 NEW LEXC,LEXD,LEXA,LEXS,LEXI,LEXLEN
SET LEXLEN=50
SET LEXD=$$TM^LEXQM($PIECE(LEXN," ",2,4000))
if '$LENGTH(LEXD)
QUIT
+9 SET LEXC=$PIECE(LEXN,LEXD,1)
if '$LENGTH(LEXC)
QUIT
SET LEXS=$LENGTH(LEXC)
KILL LEXA
SET LEXA(1)=LEXD
DO PR^LEXU(.LEXA,LEXLEN)
+10 FOR LEXI=1:1:3
Begin DoDot:2
+11 if $LENGTH($GET(LEXA(LEXI)))
DO TL((LEXT_LEXC_$GET(LEXA(LEXI))))
SET LEXC=$JUSTIFY(" ",LEXS)
End DoDot:2
End DoDot:1
+12 KILL ^TMP("LEXQID",$JOB,"REQ")
+13 QUIT
NCC(LEXLEN) ; Not CC with
+1 QUIT
+2 if '$LENGTH($ORDER(^TMP("LEXQID",$JOB,"NCC",3,"")))
QUIT
if '$DATA(^TMP("LEXQID",$JOB,"NCC",1,1))
QUIT
if '$DATA(^TMP("LEXQID",$JOB,"NCC",2,1))
QUIT
+3 NEW LEXI,LEXH,LEXE,LEXN,LEXT
SET LEXT=" "_$GET(^TMP("LEXQID",$JOB,"NCC",1,1))_":"
SET LEXN=$GET(^TMP("LEXQID",$JOB,"NCC",2,1))
+4 SET LEXT=LEXT_$JUSTIFY(" ",((79-+($GET(LEXLEN)))-$LENGTH(LEXT)))_LEXN
DO BL
DO TL(LEXT)
+5 SET LEXT=$JUSTIFY(" ",((79-+($GET(LEXLEN)))))
SET LEXN=$$TM^LEXQM($GET(^TMP("LEXQID",$JOB,"NCC",2,2)))
IF $LENGTH(LEXN)
DO TL((LEXT_LEXN))
+6 SET LEXI=" "
FOR
SET LEXI=$ORDER(^TMP("LEXQID",$JOB,"NCC",3,LEXI))
if '$LENGTH(LEXI)
QUIT
Begin DoDot:1
+7 SET LEXN=$GET(^TMP("LEXQID",$JOB,"NCC",3,LEXI))
IF $LENGTH(LEXN)'>62
DO TL((LEXT_LEXN))
QUIT
+8 NEW LEXC,LEXD,LEXA,LEXS,LEXI,LEXLEN
SET LEXLEN=50
SET LEXD=$$TM^LEXQM($PIECE(LEXN," ",2,4000))
if '$LENGTH(LEXD)
QUIT
+9 SET LEXC=$PIECE(LEXN,LEXD,1)
if '$LENGTH(LEXC)
QUIT
SET LEXS=$LENGTH(LEXC)
KILL LEXA
SET LEXA(1)=LEXD
DO PR^LEXU(.LEXA,LEXLEN)
+10 FOR LEXI=1:1:3
Begin DoDot:2
+11 if $LENGTH($GET(LEXA(LEXI)))
DO TL((LEXT_LEXC_$GET(LEXA(LEXI))))
SET LEXC=$JUSTIFY(" ",LEXS)
End DoDot:2
End DoDot:1
+12 KILL ^TMP("LEXQID",$JOB,"NCC")
+13 QUIT
+14 ;
+15 ; Miscellaneous
CI(X,LEXD) ; Code IENs
+1 NEW LEXSO,LEXSDO,LEXLEX,LEXSAB
SET LEXSO=$GET(X)
if '$LENGTH(LEXSO)
QUIT
SET LEXD=$GET(LEXD)
IF LEXD'?7N
Begin DoDot:1
+2 NEW LEXEF,LEXTD
SET LEXTD=""
SET LEXEF=9999999
FOR
SET LEXEF=$ORDER(^LEX(757.02,"ACT",(LEXSO_" "),3,LEXEF),-1)
if +LEXEF'>0
QUIT
Begin DoDot:2
+3 NEW LEXIE
SET LEXIE=$ORDER(^LEX(757.02," "),-1)
FOR
SET LEXIE=$ORDER(^LEX(757.02,"ACT",(LEXSO_" "),3,+LEXEF,LEXIE),-1)
if +LEXIE'>0
QUIT
Begin DoDot:3
+4 NEW LEXSR
SET LEXSR=$PIECE($GET(^LEX(757.02,+LEXIE,0)),"^",3)
if "^1^30^"[("^"_LEXSR_"^")
SET LEXTD=LEXEF
End DoDot:3
End DoDot:2
+5 if LEXTD?7N
SET LEXD=LEXTD
End DoDot:1
+6 if LEXD'?7N
SET LEXD=$$DT^XLFDT
SET LEXSDO=$ORDER(^ICD9("BA",(LEXSO_" "),0))
SET LEXSAB=+($GET(^ICD9(+LEXSDO,1)))
SET LEXSAB=$SELECT(LEXSAB=1:"ICD",1:"10D")
+7 SET LEXLEX=$$STATCHK^LEXSRC2(LEXSO,LEXD,,LEXSAB)
SET LEXLEX=$PIECE(LEXLEX,"^",2)
+8 SET LEXSDO=$SELECT(+LEXSDO>0:("ICD Diagnosis IEN "_+LEXSDO),1:"")
SET LEXLEX=$SELECT(+LEXLEX>0:("Lexicon IEN "_+LEXLEX),1:"")
+9 SET X=""
if $LENGTH(LEXSDO)&('$LENGTH(LEXLEX))
SET X=LEXSDO
if '$LENGTH(LEXSDO)&($LENGTH(LEXLEX))
SET X=LEXLEX
if $LENGTH(LEXSDO)&($LENGTH(LEXLEX))
SET X=(LEXSDO_"/"_LEXLEX)
+10 QUIT X
BL ; Blank Line
+1 DO TL(" ")
QUIT
TL(X) ; Text Line
+1 IF $DATA(LEXTEST)
WRITE !,$GET(X)
QUIT
+2 NEW LEXI,LEXTEST
SET LEXI=+($ORDER(^TMP("LEXQIDO",$JOB," "),-1))+1
SET ^TMP("LEXQIDO",$JOB,LEXI)=$GET(X)
SET ^TMP("LEXQIDO",$JOB,0)=LEXI
+3 QUIT
