LEXQHL2 ;ISL/KER - Query History - ICD-9/10 Procedure Extract ;05/23/2017
;;2.0;LEXICON UTILITY;**62,80,86,103**;Sep 23, 1996;Build 2
;
; Global Variables
; ^ICM( ICR 4488
; ^TMP("LEXQHL") SACC 2.3.2.5.1
;
; External References
; $$CODEC^ICDEX ICR 5747
; $$ICDOP^ICDEX ICR 5747
; $$ROOT^ICDEX ICR 5747
; $$CODEABA^ICDEX ICR 5747
; $$UP^XLFSTR ICR 10104
;
Q
EN(X,Y) ; ICD Procedure File
N LEXIEN,LEXTIEN,LEXDISP,LEXIA,LEXEF,LEXCT,LEXC,LEXSYS,LEXTMP S LEXIEN=$G(X),LEXDISP=$G(Y),LEXIA="" Q:+LEXIEN'>0
S LEXC=$$CODEC^ICDEX(80.1,+LEXIEN) Q:'$L(LEXC) S LEXSYS=0 S LEXTIEN=$$CODEABA^ICDEX(LEXC,80.1,2) I LEXTIEN>0 S LEXSYS=2 Q:LEXTIEN'=LEXIEN
I LEXSYS'>0 S LEXTIEN=$$CODEABA^ICDEX(LEXC,80.1,31) I LEXTIEN>0 S LEXSYS=31 Q:LEXTIEN'=LEXIEN
Q:+($G(LEXSYS))'>0 K ^TMP("LEXQHL",$J) S ^TMP("LEXQHL",$J,"IEN")=LEXIEN,^TMP("LEXQHL",$J,"CODE")=LEXC
S LEXTMP=$$ICDOP^ICDEX(LEXIEN,,LEXSYS,"I"),^TMP("LEXQHL",$J,"NAME")=$P(LEXTMP,U,5)
S:'$L(LEXDISP) LEXDISP="SB" D ST,OP,DS,MD D:$L($G(LEXDISP)) DP K ^TMP("LEXQHL",$J)
Q
ST ; 1 Status
N LEXCT,LEXD,LEXE,LEXEF,LEXH,LEXMS,LEXN,LEXS,LEXT,LEXRT,LEXARY S LEXRT=$$ROOT^ICDEX(80.1)
M LEXARY=@(LEXRT_+LEXIEN_",66)") S LEXCT=0,LEXEF="" F S LEXEF=$O(LEXARY("B",LEXEF)) Q:'$L(LEXEF) D
. N LEXH S LEXH=0 F S LEXH=$O(LEXARY("B",LEXEF,LEXH)) Q:+LEXH'>0 D
. . N LEXN,LEXS,LEXE,LEXT,LEXD,LEXMS S LEXN=$G(LEXARY(+LEXH,0)),LEXE=$P(LEXN,U,1),LEXS=$P(LEXN,U,2)
. . Q:+LEXS'>0&(LEXCT'>0) S LEXCT=LEXCT+1,LEXMS=$$MS^LEXQHLM(LEXE,0),LEXT=$S(+LEXS>0:"Activation",1:"Inactivation")
. . S:+LEXS>0&(LEXCT=1) LEXT="Initial Activation"_LEXMS,LEXIA=LEXE
. . S:$O(LEXARY("B",LEXEF))=""&(LEXCT>1) LEXT=LEXT_" (final status change)"
. . S LEXD=$$SD^LEXQHLM(LEXE) S ^TMP("LEXQHL",$J,LEXEF,1,1)=LEXD_U_LEXT
Q
OP ; 2 Operation/Procedure
N LEX,LEXC,LEXCT,LEXD,LEXE,LEXEF,LEXH,LEXI,LEXN,LEXS,LEXT,LEXRT,LEXARY S LEXRT=$$ROOT^ICDEX(80.1)
M LEXARY=@(LEXRT_+LEXIEN_",67)") S LEXCT=0,LEXEF="" F S LEXEF=$O(LEXARY("B",LEXEF)) Q:'$L(LEXEF) D
. N LEXH S LEXH=0 F S LEXH=$O(LEXARY("B",LEXEF,LEXH)) Q:+LEXH'>0 D
. . N LEXN,LEXS,LEXE,LEXT,LEXD,LEX,LEXI S LEXN=$G(LEXARY(+LEXH,0)),LEXE=$P(LEXN,U,1),LEXT=$$UP^XLFSTR($P(LEXN,U,2))
. . S LEXCT=LEXCT+1,LEX(1)=LEXT D PR^LEXU(.LEX,63)
. . S LEXS=$S(+LEXCT=1:"Initial Operation/Procedure",+LEXCT>1:"Updated Operation/Procedure",1:"Operation/Procedure")
. . S:$O(LEXARY("B",LEXEF))=""&(LEXCT>1) LEXT=LEXT_" (final operation/procedure change)"
. . S LEXD=$$SD^LEXQHLM(LEXE) S ^TMP("LEXQHL",$J,LEXEF,2,1)=LEXD_U_LEXS
. . S LEXI=0 F S LEXI=$O(LEX(LEXI)) Q:+LEXI'>0 D
. . . N LEXC S LEXT=$G(LEX(LEXI)) Q:'$L(LEXT) S LEXC=$O(^TMP("LEXQHL",$J,LEXEF,2," "),-1)+1
. . . S ^TMP("LEXQHL",$J,LEXEF,2,LEXC)=U_LEXT
Q
DS ; 3 Description
N LEX,LEXC,LEXCT,LEXD,LEXE,LEXEF,LEXH,LEXI,LEXN,LEXS,LEXT,LEXRT,LEXARY S LEXRT=$$ROOT^ICDEX(80.1)
M LEXARY=@(LEXRT_+LEXIEN_",68)") S LEXCT=0,LEXEF="" F S LEXEF=$O(LEXARY("B",LEXEF)) Q:'$L(LEXEF) D
. N LEXH S LEXH=0 F S LEXH=$O(LEXARY("B",LEXEF,LEXH)) Q:+LEXH'>0 D
. . N LEXN,LEXS,LEXE,LEXT,LEXD,LEX,LEXI S LEXN=$G(LEXARY(+LEXH,0))
. . S LEXE=$P(LEXN,U,1),LEXT=$$UP^XLFSTR($G(LEXARY(+LEXH,1)))
. . S LEXCT=LEXCT+1,LEX(1)=LEXT D PR^LEXU(.LEX,63)
. . S LEXS=$S(+LEXCT=1:"Initial Description",+LEXCT>1:"Updated Description",1:"Description")
. . S:$O(LEXARY("B",LEXEF))=""&(LEXCT>1) LEXT=LEXT_" (final description change)"
. . S LEXD=$$SD^LEXQHLM(LEXE) S ^TMP("LEXQHL",$J,LEXEF,3,1)=LEXD_U_LEXS
. . S LEXI=0 F S LEXI=$O(LEX(LEXI)) Q:+LEXI'>0 D
. . . N LEXC S LEXT=$G(LEX(LEXI)) Q:'$L(LEXT) S LEXC=$O(^TMP("LEXQHL",$J,LEXEF,3," "),-1)+1
. . . S ^TMP("LEXQHL",$J,LEXEF,3,LEXC)=U_LEXT
Q
MD ; 4 MDC/DRG Groups
N LEX1,LEX2,LEX,LEXC1,LEXC2,LEXCMD,LEXCT,LEXD,LEXDG,LEXDI,LEXDR,LEXDRG,LEXE,LEXEF,LEXG
N EXH,LEXI,LEXM,LEXMC,LEXMCI,LEXMCT,LEXMD,LEXMDG,LEXMDRG,LEXN,LEXNMD,LEXOMD,LEXP,LEXS
N LEXT,LEXUN,LEXUND,LEXVT,LEXRT,LEXARY S LEXRT=$$ROOT^ICDEX(80.1)
S:$G(LEXIA)'?7N LEXIA=$$IA(+LEXIEN) S LEXUND="",LEXUN=1,(LEXMCT,LEXMC)=0 K LEXMCI
M LEXARY=@(LEXRT_+LEXIEN_",2)") S (LEXMCT,LEXCT)=0,(LEXP,LEXEF)=""
F S LEXEF=$O(LEXARY("B",LEXEF)) Q:'$L(LEXEF) D
. N LEXH S LEXH=0 F S LEXH=$O(LEXARY("B",LEXEF,LEXH)) Q:+LEXH'>0 D
. . N LEXN,LEXS,LEXE,LEXT,LEXD,LEX,LEXI S LEXN=$G(LEXARY(+LEXH,0)),LEXE=$P(LEXN,U,1) Q:LEXE'?7N S:LEXE=$G(LEXIA) LEXUN=0
. . S LEXMC=0 F S LEXMC=$O(LEXARY(+LEXH,1,LEXMC)) Q:+LEXMC'>0 D
. . . N LEXDG,LEXDRG,LEXN,LEXM S LEXN=$G(LEXARY(+LEXH,1,LEXMC,0)),LEXM=$P(LEXN,U,1)
. . . Q:+LEXM'>0 S LEXM=$$UP^XLFSTR($P($G(^ICM(+LEXM,0)),U,1)) Q:'$L(LEXM)
. . . S LEXDRG="",LEXDG=0 F S LEXDG=$O(LEXARY(+LEXH,1,LEXMC,1,LEXDG)) Q:+LEXDG'>0 D
. . . . S LEXN=$G(LEXARY(+LEXH,1,LEXMC,1,LEXDG,0)),LEXD=$P(LEXN,U,1) Q:'$L(LEXD)
. . . . S:$E(LEXDRG,1,$L(LEXD))'=LEXD&(LEXDRG'[(" "_LEXD)) LEXDRG=$G(LEXDRG)_", "_LEXD
. . . S LEXDRG=$$TM^LEXQHLM($$AND^LEXQHLM($$CS^LEXQHLM(LEXDRG))) S:$L(LEXDRG) LEXDRG="DRG "_LEXDRG Q:'$L(LEXDRG)
. . . S LEXMCT=+($G(LEXMCT))+1 S LEXNMD(LEXE,LEXMCT,1)=LEXM,LEXNMD(LEXE,LEXMCT,2)=LEXDRG
K LEXCMD S LEXEF="",(LEXC1,LEXC2)=0 I LEXIA?7N,+($G(LEXUN))>0 F S LEXEF=$O(LEXOMD(LEXEF)) Q:'$L(LEXEF) D
. K LEXNMD(LEXEF) S LEX1=0 F S LEX1=$O(LEXOMD(LEXEF,LEX1)) Q:+LEX1'>0 S LEXC1=LEXC1+1,LEX2=0 F S LEX2=$O(LEXOMD(LEXEF,LEX1,LEX2)) Q:+LEX2'>0 D
. . S LEXC2=LEXC2+1 S:LEX2=1 LEXCMD(+LEXC1,1)=LEXEF_U_$G(LEXOMD(LEXEF,LEX1,LEX2)) S:LEX2=2 LEXCMD(+LEXC1,2)=$G(LEXOMD(LEXEF,LEX1,LEX2))
S LEXEF="" F S LEXEF=$O(LEXNMD(LEXEF)) Q:'$L(LEXEF) D
. S LEX1=0 F S LEX1=$O(LEXNMD(LEXEF,LEX1)) Q:+LEX1'>0 S LEXC1=LEXC1+1,LEX2=0,LEXC2=0 F S LEX2=$O(LEXNMD(LEXEF,LEX1,LEX2)) Q:+LEX2'>0 D
. . S LEXC2=LEXC2+1 S:LEX2=1 LEXCMD(+LEXC1,1)=LEXEF_U_$G(LEXNMD(LEXEF,LEX1,LEX2)) S:LEX2=2 LEXCMD(+LEXC1,2)=$G(LEXNMD(LEXEF,LEX1,LEX2))
S (LEXCT,LEXVT,LEXMC,LEX1)=0,LEXP="" F S LEX1=$O(LEXCMD(LEX1)) Q:+LEX1'>0 D
. N LEXS S LEXN=$G(LEXCMD(LEX1,1)) S LEXE=$P(LEXN,U,1),LEXM=$P(LEXN,U,2) Q:LEXE'?7N Q:'$L(LEXM) S LEXG=$G(LEXCMD(LEX1,2)) Q:'$L(LEXG)
. I LEXE'=LEXP S LEXCT=LEXCT+1 S:LEXE'=LEXIA LEXVT=LEXVT+1
. S LEXMC=0,LEXMC=LEXMC+1 I +($G(LEXUN))'>0,LEXE=LEXIA S LEXS="Initial Unversioned Major Diagnostic Category/DRG Groups"
. I +($G(LEXUN))>0,LEXE'=LEXIA,LEXVT=1 S LEXS="Initial Versioned Major Diagnostic Category/DRG Groups"
. I LEXCT>1 S LEXS="Updated Major Diagnostic Category/DRG Groups"
. S LEXD=$$SD^LEXQHLM(LEXE),^TMP("LEXQHL",$J,LEXE,4,LEX1,1)=LEXD_U_LEXS,^TMP("LEXQHL",$J,LEXE,4,LEX1,2)=U_LEXM,^TMP("LEXQHL",$J,LEXE,4,LEX1,3)=U_(" "_LEXG)
. S LEXP=LEXE
Q
;
DP ; Display
S LEXDISP=$G(LEXDISP) Q:$L(LEXDISP)>8 Q:$L(LEXDISP)<2 Q:LEXDISP["^" N LEXL S LEXL=$T(@LEXDISP+0) Q:'$L(LEXL)
D @LEXDISP
Q
SB ; Subjective
D ATTR^LEXQM
N LEX1,LEX2,LEX3,LEXC,LEXCT,LEXD,LEXE,LEXEC,LEXG,LEXHDR,LEXI,LEXID,LEXM,LEXN,LEXN1,LEXN2,LEXN3,LEXO1,LEXO2,LEXO3,LEXP,LEXS,LEXT
S LEXC=$G(^TMP("LEXQHL",$J,"CODE")),LEXI=$G(^TMP("LEXQHL",$J,"IEN")),LEXN=$G(^TMP("LEXQHL",$J,"NAME"))
S LEXT="Code: "_LEXC,LEXT=LEXT_$J(" ",(16-$L(LEXT)))_LEXN D TL^LEXQHLM(($G(BOLD)_LEXT_$G(NORM)))
S LEXT="",LEXT=LEXT_$J(" ",(16-$L(LEXT)))_"IEN: "_LEXI D TL^LEXQHLM(($G(BOLD)_LEXT_$G(NORM)))
F LEXID=1:1:3 D
. N LEXHDR,LEXCT,LEXEC S (LEXEC,LEXCT)=0,LEXHDR=$$HD(LEXID) Q:'$L(LEXHDR) S LEXP="",LEX1=0 F S LEX1=$O(^TMP("LEXQHL",$J,LEX1)) Q:+LEX1'>0 D
. . S LEXEC=LEXEC+1 I LEXID=1 D Q
. . . S LEXN=$G(^TMP("LEXQHL",$J,LEX1,LEXID,1)) Q:'$L(LEXN) S LEXE=$P(LEXN,U,1),LEXS=$P(LEXN,U,2) Q:'$L(LEXE) Q:'$L(LEXS) S LEXCT=LEXCT+1
. . . D:LEXCT=1 BL^LEXQHLM,TL^LEXQHLM(($G(BOLD)_" "_LEXHDR_$G(NORM))) S LEXT=$G(BOLD)_LEXE_$G(NORM)
. . . S LEXT=LEXT_$J(" ",(11-$L(LEXT)))_" "_LEXS,LEXT=" "_LEXT D TL^LEXQHLM(LEXT)
. . I LEXID=4 D Q
. . . N LEX2,LEXHDR,LEXC,LEXP,LEXO1,LEXO2,LEXO3 S LEXHDR=$$HD(4),(LEXC,LEX2)=0,LEXP="" F S LEX2=$O(^TMP("LEXQHL",$J,LEX1,4,LEX2)) Q:+LEX2'>0 D
. . . . N LEXN1,LEXN2,LEXN3,LEXD,LEXS,LEXM,LEXG
. . . . S LEXN1=$G(^TMP("LEXQHL",$J,LEX1,4,LEX2,1)) S LEXD=$P(LEXN1,U,1),LEXS=$P(LEXN1,U,2) Q:'$L(LEXD) Q:'$L(LEXS)
. . . . S LEXN2=$G(^TMP("LEXQHL",$J,LEX1,4,LEX2,2)) S LEXM=$P(LEXN2,U,2) Q:'$L(LEXM)
. . . . S LEXN3=$G(^TMP("LEXQHL",$J,LEX1,4,LEX2,3)) S LEXG=$P(LEXN3,U,2) Q:'$L(LEXG)
. . . . S LEXO1=$G(LEXD),LEXO1=LEXO1_$J(" ",(11-$L(LEXO1)))_" "_LEXS,LEXO1=" "_LEXO1
. . . . S LEXO2=$J(" ",11)_" "_LEXM,LEXO2=" "_LEXO2
. . . . S LEXO3=$J(" ",11)_" "_LEXG,LEXO3=" "_LEXO3
. . . . S LEXC=LEXC+1 I LEXEC=1,LEXC=1 D BL^LEXQHLM,TL^LEXQHLM(($G(BOLD)_" "_LEXHDR_$G(NORM)))
. . . . D:LEXP'=LEXD TL^LEXQHLM(LEXO1) D TL^LEXQHLM(LEXO2),TL^LEXQHLM(LEXO3)
. . . . S LEXP=LEXD
. . N LEX2 S LEX2=0,LEXE="" F S LEX2=$O(^TMP("LEXQHL",$J,LEX1,LEXID,LEX2)) Q:+LEX2'>0 D
. . . S LEXN=$G(^TMP("LEXQHL",$J,LEX1,LEXID,LEX2)) S:LEX2=1 LEXE=$P(LEXN,U,1) Q:LEX2=1 Q:'$L(LEXE)
. . . S LEXE=$G(BOLD)_LEXE_$G(NORM)
. . . I LEX2=2 D Q
. . . . S LEXCT=LEXCT+1,LEXT=$G(LEXE),LEXS=$P(LEXN,U,2),LEXT=LEXT_$J(" ",(11-$L(LEXT)))_" "_LEXS,LEXT=" "_LEXT
. . . . D:LEXCT=1 BL^LEXQHLM,TL^LEXQHLM(($G(BOLD)_" "_LEXHDR_$G(NORM))) D TL^LEXQHLM(LEXT)
. . . I LEX2>2 D Q
. . . . S LEXCT=LEXCT+1,LEXT="",LEXS=$P(LEXN,U,2),LEXT=LEXT_$J(" ",(11-$L(LEXT)))_" "_LEXS,LEXT=" "_LEXT
. . . . D:LEXCT=1 BL^LEXQHLM,TL^LEXQHLM(($G(BOLD)_" "_LEXHDR_$G(NORM))) D TL^LEXQHLM(LEXT)
D KATTR^LEXQM
Q
CH ; Chronological
D ATTR^LEXQM
N LEX1,LEX2,LEX3,LEXC,LEXD,LEXDC,LEXI,LEXL1,LEXL2,LEXL3,LEXN,LEXP,LEXS,LEXT,LEXT1,LEXT2,LEXT3
S LEXC=$G(^TMP("LEXQHL",$J,"CODE")),LEXI=$G(^TMP("LEXQHL",$J,"IEN")),LEXN=$G(^TMP("LEXQHL",$J,"NAME"))
S LEXT="Code: "_LEXC,LEXT=LEXT_$J(" ",(16-$L(LEXT)))_LEXN D TL^LEXQHLM(($G(BOLD)_LEXT_$G(NORM)))
S LEXT="",LEXT=LEXT_$J(" ",(16-$L(LEXT)))_"IEN: "_LEXI D TL^LEXQHLM(($G(BOLD)_LEXT_$G(NORM)))
S LEXP="",LEX1=0 F S LEX1=$O(^TMP("LEXQHL",$J,LEX1)) Q:+LEX1'>0 D
. D BL^LEXQHLM N LEX2,LEXDC S (LEXDC,LEX2)=0 F S LEX2=$O(^TMP("LEXQHL",$J,LEX1,LEX2)) Q:+LEX2'>0 D
. . I LEX2=4 D Q
. . . Q N LEX3 S LEX3=0 F S LEX3=$O(^TMP("LEXQHL",$J,LEX1,LEX2,LEX3)) Q:+LEX3'>0 D
. . . . S LEXL1=$G(^TMP("LEXQHL",$J,LEX1,LEX2,LEX3,1))
. . . . S LEXD=$P(LEXL1,U,1),LEXS=$P(LEXL1,U,2) Q:'$L(LEXD) Q:'$L(LEXS)
. . . . S LEXL2=$P($G(^TMP("LEXQHL",$J,LEX1,LEX2,LEX3,2)),U,2) Q:'$L(LEXL2)
. . . . S LEXL3=$P($G(^TMP("LEXQHL",$J,LEX1,LEX2,LEX3,3)),U,2) Q:'$L(LEXL3)
. . . . S LEXT1=$S(LEXD'=LEXP:LEXD,1:""),LEXT1=LEXT1_$J(" ",(11-$L(LEXT1)))_$S($L(LEXD):"- ",1:" ")_LEXS
. . . . S LEXDC=LEXDC+1,LEXT1=" "_LEXT1 D:LEXDC=1 TL^LEXQHLM(LEXT1)
. . . . S LEXT2=$J(" ",16)_LEXL2 D TL^LEXQHLM(LEXT2)
. . . . S LEXT3=$J(" ",16)_LEXL3 D TL^LEXQHLM(LEXT3)
. . . . S:LEXD'="" LEXP=LEXD
. . N LEX3 S LEX3=0 F S LEX3=$O(^TMP("LEXQHL",$J,LEX1,LEX2,LEX3)) Q:+LEX3'>0 D
. . . N LEXN,LEXD,LEXS,LEXSPC S LEXN=$G(^TMP("LEXQHL",$J,LEX1,LEX2,LEX3)),LEXD=$P(LEXN,U,1),LEXS=$P(LEXN,U,2),LEXSPC=" "
. . . I $L($$TM^LEXQM(LEXD)) S LEXD=$G(BOLD)_LEXD_$G(NORM),LEXSPC=$G(BOLD)_"- "_$G(NORM),LEXS=$G(BOLD)_LEXS_$G(NORM)
. . . S LEXT=$S(LEXD'=LEXP:LEXD,1:""),LEXT=LEXT_$J(" ",(11-$L(LEXT)))_LEXSPC_LEXS S LEXT=" "_LEXT D TL^LEXQHLM(LEXT)
. . . S:LEXD'="" LEXP=LEXD
D KATTR^LEXQM
Q
;
; Miscellaneous
IA(X) ; Initial Activation
N LEXEF,LEXH,LEXN,LEXS,LEXE,LEXIEN,LEXRT,LEXARY S LEXIEN=+($G(X)),LEXE="" Q:+LEXIEN'>0 ""
S LEXRT=$$ROOT^ICDEX(80.1) M LEXARY=@(LEXRT_+LEXIEN_",66)") Q:'$D(LEXARY(0)) ""
S LEXEF="" F S LEXEF=$O(LEXARY("B",LEXEF)) Q:'$L(LEXEF) D Q:$G(LEXE)?7N
. S LEXH=0 F S LEXH=$O(LEXARY("B",LEXEF,LEXH)) Q:+LEXH'>0 D
. . S LEXN=$G(LEXARY(+LEXH,0)) S:+($P(LEXN,U,2))>0 LEXE=$P(LEXN,U,1) Q:$G(LEXE)?7N
S X="" S:$G(LEXE)?7N X=$G(LEXE)
Q X
HD(X) ; Header
Q:+($G(X))=1 "Status" Q:+($G(X))=2 "Operation/Procedure" Q:+($G(X))=3 "Description" Q:+($G(X))=4 "Major Diagnostic Category/DRG Groups"
Q ""
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLEXQHL2 11905 printed Apr 09, 2024@21:12:59 Page 2
LEXQHL2 ;ISL/KER - Query History - ICD-9/10 Procedure Extract ;05/23/2017
+1 ;;2.0;LEXICON UTILITY;**62,80,86,103**;Sep 23, 1996;Build 2
+2 ;
+3 ; Global Variables
+4 ; ^ICM( ICR 4488
+5 ; ^TMP("LEXQHL") SACC 2.3.2.5.1
+6 ;
+7 ; External References
+8 ; $$CODEC^ICDEX ICR 5747
+9 ; $$ICDOP^ICDEX ICR 5747
+10 ; $$ROOT^ICDEX ICR 5747
+11 ; $$CODEABA^ICDEX ICR 5747
+12 ; $$UP^XLFSTR ICR 10104
+13 ;
+14 QUIT
EN(X,Y) ; ICD Procedure File
+1 NEW LEXIEN,LEXTIEN,LEXDISP,LEXIA,LEXEF,LEXCT,LEXC,LEXSYS,LEXTMP
SET LEXIEN=$GET(X)
SET LEXDISP=$GET(Y)
SET LEXIA=""
if +LEXIEN'>0
QUIT
+2 SET LEXC=$$CODEC^ICDEX(80.1,+LEXIEN)
if '$LENGTH(LEXC)
QUIT
SET LEXSYS=0
SET LEXTIEN=$$CODEABA^ICDEX(LEXC,80.1,2)
IF LEXTIEN>0
SET LEXSYS=2
if LEXTIEN'=LEXIEN
QUIT
+3 IF LEXSYS'>0
SET LEXTIEN=$$CODEABA^ICDEX(LEXC,80.1,31)
IF LEXTIEN>0
SET LEXSYS=31
if LEXTIEN'=LEXIEN
QUIT
+4 if +($GET(LEXSYS))'>0
QUIT
KILL ^TMP("LEXQHL",$JOB)
SET ^TMP("LEXQHL",$JOB,"IEN")=LEXIEN
SET ^TMP("LEXQHL",$JOB,"CODE")=LEXC
+5 SET LEXTMP=$$ICDOP^ICDEX(LEXIEN,,LEXSYS,"I")
SET ^TMP("LEXQHL",$JOB,"NAME")=$PIECE(LEXTMP,U,5)
+6 if '$LENGTH(LEXDISP)
SET LEXDISP="SB"
DO ST
DO OP
DO DS
DO MD
if $LENGTH($GET(LEXDISP))
DO DP
KILL ^TMP("LEXQHL",$JOB)
+7 QUIT
ST ; 1 Status
+1 NEW LEXCT,LEXD,LEXE,LEXEF,LEXH,LEXMS,LEXN,LEXS,LEXT,LEXRT,LEXARY
SET LEXRT=$$ROOT^ICDEX(80.1)
+2 MERGE LEXARY=@(LEXRT_+LEXIEN_",66)")
SET LEXCT=0
SET LEXEF=""
FOR
SET LEXEF=$ORDER(LEXARY("B",LEXEF))
if '$LENGTH(LEXEF)
QUIT
Begin DoDot:1
+3 NEW LEXH
SET LEXH=0
FOR
SET LEXH=$ORDER(LEXARY("B",LEXEF,LEXH))
if +LEXH'>0
QUIT
Begin DoDot:2
+4 NEW LEXN,LEXS,LEXE,LEXT,LEXD,LEXMS
SET LEXN=$GET(LEXARY(+LEXH,0))
SET LEXE=$PIECE(LEXN,U,1)
SET LEXS=$PIECE(LEXN,U,2)
+5 if +LEXS'>0&(LEXCT'>0)
QUIT
SET LEXCT=LEXCT+1
SET LEXMS=$$MS^LEXQHLM(LEXE,0)
SET LEXT=$SELECT(+LEXS>0:"Activation",1:"Inactivation")
+6 if +LEXS>0&(LEXCT=1)
SET LEXT="Initial Activation"_LEXMS
SET LEXIA=LEXE
+7 if $ORDER(LEXARY("B",LEXEF))=""&(LEXCT>1)
SET LEXT=LEXT_" (final status change)"
+8 SET LEXD=$$SD^LEXQHLM(LEXE)
SET ^TMP("LEXQHL",$JOB,LEXEF,1,1)=LEXD_U_LEXT
End DoDot:2
End DoDot:1
+9 QUIT
OP ; 2 Operation/Procedure
+1 NEW LEX,LEXC,LEXCT,LEXD,LEXE,LEXEF,LEXH,LEXI,LEXN,LEXS,LEXT,LEXRT,LEXARY
SET LEXRT=$$ROOT^ICDEX(80.1)
+2 MERGE LEXARY=@(LEXRT_+LEXIEN_",67)")
SET LEXCT=0
SET LEXEF=""
FOR
SET LEXEF=$ORDER(LEXARY("B",LEXEF))
if '$LENGTH(LEXEF)
QUIT
Begin DoDot:1
+3 NEW LEXH
SET LEXH=0
FOR
SET LEXH=$ORDER(LEXARY("B",LEXEF,LEXH))
if +LEXH'>0
QUIT
Begin DoDot:2
+4 NEW LEXN,LEXS,LEXE,LEXT,LEXD,LEX,LEXI
SET LEXN=$GET(LEXARY(+LEXH,0))
SET LEXE=$PIECE(LEXN,U,1)
SET LEXT=$$UP^XLFSTR($PIECE(LEXN,U,2))
+5 SET LEXCT=LEXCT+1
SET LEX(1)=LEXT
DO PR^LEXU(.LEX,63)
+6 SET LEXS=$SELECT(+LEXCT=1:"Initial Operation/Procedure",+LEXCT>1:"Updated Operation/Procedure",1:"Operation/Procedure")
+7 if $ORDER(LEXARY("B",LEXEF))=""&(LEXCT>1)
SET LEXT=LEXT_" (final operation/procedure change)"
+8 SET LEXD=$$SD^LEXQHLM(LEXE)
SET ^TMP("LEXQHL",$JOB,LEXEF,2,1)=LEXD_U_LEXS
+9 SET LEXI=0
FOR
SET LEXI=$ORDER(LEX(LEXI))
if +LEXI'>0
QUIT
Begin DoDot:3
+10 NEW LEXC
SET LEXT=$GET(LEX(LEXI))
if '$LENGTH(LEXT)
QUIT
SET LEXC=$ORDER(^TMP("LEXQHL",$JOB,LEXEF,2," "),-1)+1
+11 SET ^TMP("LEXQHL",$JOB,LEXEF,2,LEXC)=U_LEXT
End DoDot:3
End DoDot:2
End DoDot:1
+12 QUIT
DS ; 3 Description
+1 NEW LEX,LEXC,LEXCT,LEXD,LEXE,LEXEF,LEXH,LEXI,LEXN,LEXS,LEXT,LEXRT,LEXARY
SET LEXRT=$$ROOT^ICDEX(80.1)
+2 MERGE LEXARY=@(LEXRT_+LEXIEN_",68)")
SET LEXCT=0
SET LEXEF=""
FOR
SET LEXEF=$ORDER(LEXARY("B",LEXEF))
if '$LENGTH(LEXEF)
QUIT
Begin DoDot:1
+3 NEW LEXH
SET LEXH=0
FOR
SET LEXH=$ORDER(LEXARY("B",LEXEF,LEXH))
if +LEXH'>0
QUIT
Begin DoDot:2
+4 NEW LEXN,LEXS,LEXE,LEXT,LEXD,LEX,LEXI
SET LEXN=$GET(LEXARY(+LEXH,0))
+5 SET LEXE=$PIECE(LEXN,U,1)
SET LEXT=$$UP^XLFSTR($GET(LEXARY(+LEXH,1)))
+6 SET LEXCT=LEXCT+1
SET LEX(1)=LEXT
DO PR^LEXU(.LEX,63)
+7 SET LEXS=$SELECT(+LEXCT=1:"Initial Description",+LEXCT>1:"Updated Description",1:"Description")
+8 if $ORDER(LEXARY("B",LEXEF))=""&(LEXCT>1)
SET LEXT=LEXT_" (final description change)"
+9 SET LEXD=$$SD^LEXQHLM(LEXE)
SET ^TMP("LEXQHL",$JOB,LEXEF,3,1)=LEXD_U_LEXS
+10 SET LEXI=0
FOR
SET LEXI=$ORDER(LEX(LEXI))
if +LEXI'>0
QUIT
Begin DoDot:3
+11 NEW LEXC
SET LEXT=$GET(LEX(LEXI))
if '$LENGTH(LEXT)
QUIT
SET LEXC=$ORDER(^TMP("LEXQHL",$JOB,LEXEF,3," "),-1)+1
+12 SET ^TMP("LEXQHL",$JOB,LEXEF,3,LEXC)=U_LEXT
End DoDot:3
End DoDot:2
End DoDot:1
+13 QUIT
MD ; 4 MDC/DRG Groups
+1 NEW LEX1,LEX2,LEX,LEXC1,LEXC2,LEXCMD,LEXCT,LEXD,LEXDG,LEXDI,LEXDR,LEXDRG,LEXE,LEXEF,LEXG
+2 NEW EXH,LEXI,LEXM,LEXMC,LEXMCI,LEXMCT,LEXMD,LEXMDG,LEXMDRG,LEXN,LEXNMD,LEXOMD,LEXP,LEXS
+3 NEW LEXT,LEXUN,LEXUND,LEXVT,LEXRT,LEXARY
SET LEXRT=$$ROOT^ICDEX(80.1)
+4 if $GET(LEXIA)'?7N
SET LEXIA=$$IA(+LEXIEN)
SET LEXUND=""
SET LEXUN=1
SET (LEXMCT,LEXMC)=0
KILL LEXMCI
+5 MERGE LEXARY=@(LEXRT_+LEXIEN_",2)")
SET (LEXMCT,LEXCT)=0
SET (LEXP,LEXEF)=""
+6 FOR
SET LEXEF=$ORDER(LEXARY("B",LEXEF))
if '$LENGTH(LEXEF)
QUIT
Begin DoDot:1
+7 NEW LEXH
SET LEXH=0
FOR
SET LEXH=$ORDER(LEXARY("B",LEXEF,LEXH))
if +LEXH'>0
QUIT
Begin DoDot:2
+8 NEW LEXN,LEXS,LEXE,LEXT,LEXD,LEX,LEXI
SET LEXN=$GET(LEXARY(+LEXH,0))
SET LEXE=$PIECE(LEXN,U,1)
if LEXE'?7N
QUIT
if LEXE=$GET(LEXIA)
SET LEXUN=0
+9 SET LEXMC=0
FOR
SET LEXMC=$ORDER(LEXARY(+LEXH,1,LEXMC))
if +LEXMC'>0
QUIT
Begin DoDot:3
+10 NEW LEXDG,LEXDRG,LEXN,LEXM
SET LEXN=$GET(LEXARY(+LEXH,1,LEXMC,0))
SET LEXM=$PIECE(LEXN,U,1)
+11 if +LEXM'>0
QUIT
SET LEXM=$$UP^XLFSTR($PIECE($GET(^ICM(+LEXM,0)),U,1))
if '$LENGTH(LEXM)
QUIT
+12 SET LEXDRG=""
SET LEXDG=0
FOR
SET LEXDG=$ORDER(LEXARY(+LEXH,1,LEXMC,1,LEXDG))
if +LEXDG'>0
QUIT
Begin DoDot:4
+13 SET LEXN=$GET(LEXARY(+LEXH,1,LEXMC,1,LEXDG,0))
SET LEXD=$PIECE(LEXN,U,1)
if '$LENGTH(LEXD)
QUIT
+14 if $EXTRACT(LEXDRG,1,$LENGTH(LEXD))'=LEXD&(LEXDRG'[(" "_LEXD))
SET LEXDRG=$GET(LEXDRG)_", "_LEXD
End DoDot:4
+15 SET LEXDRG=$$TM^LEXQHLM($$AND^LEXQHLM($$CS^LEXQHLM(LEXDRG)))
if $LENGTH(LEXDRG)
SET LEXDRG="DRG "_LEXDRG
if '$LENGTH(LEXDRG)
QUIT
+16 SET LEXMCT=+($GET(LEXMCT))+1
SET LEXNMD(LEXE,LEXMCT,1)=LEXM
SET LEXNMD(LEXE,LEXMCT,2)=LEXDRG
End DoDot:3
End DoDot:2
End DoDot:1
+17 KILL LEXCMD
SET LEXEF=""
SET (LEXC1,LEXC2)=0
IF LEXIA?7N
IF +($GET(LEXUN))>0
FOR
SET LEXEF=$ORDER(LEXOMD(LEXEF))
if '$LENGTH(LEXEF)
QUIT
Begin DoDot:1
+18 KILL LEXNMD(LEXEF)
SET LEX1=0
FOR
SET LEX1=$ORDER(LEXOMD(LEXEF,LEX1))
if +LEX1'>0
QUIT
SET LEXC1=LEXC1+1
SET LEX2=0
FOR
SET LEX2=$ORDER(LEXOMD(LEXEF,LEX1,LEX2))
if +LEX2'>0
QUIT
Begin DoDot:2
+19 SET LEXC2=LEXC2+1
if LEX2=1
SET LEXCMD(+LEXC1,1)=LEXEF_U_$GET(LEXOMD(LEXEF,LEX1,LEX2))
if LEX2=2
SET LEXCMD(+LEXC1,2)=$GET(LEXOMD(LEXEF,LEX1,LEX2))
End DoDot:2
End DoDot:1
+20 SET LEXEF=""
FOR
SET LEXEF=$ORDER(LEXNMD(LEXEF))
if '$LENGTH(LEXEF)
QUIT
Begin DoDot:1
+21 SET LEX1=0
FOR
SET LEX1=$ORDER(LEXNMD(LEXEF,LEX1))
if +LEX1'>0
QUIT
SET LEXC1=LEXC1+1
SET LEX2=0
SET LEXC2=0
FOR
SET LEX2=$ORDER(LEXNMD(LEXEF,LEX1,LEX2))
if +LEX2'>0
QUIT
Begin DoDot:2
+22 SET LEXC2=LEXC2+1
if LEX2=1
SET LEXCMD(+LEXC1,1)=LEXEF_U_$GET(LEXNMD(LEXEF,LEX1,LEX2))
if LEX2=2
SET LEXCMD(+LEXC1,2)=$GET(LEXNMD(LEXEF,LEX1,LEX2))
End DoDot:2
End DoDot:1
+23 SET (LEXCT,LEXVT,LEXMC,LEX1)=0
SET LEXP=""
FOR
SET LEX1=$ORDER(LEXCMD(LEX1))
if +LEX1'>0
QUIT
Begin DoDot:1
+24 NEW LEXS
SET LEXN=$GET(LEXCMD(LEX1,1))
SET LEXE=$PIECE(LEXN,U,1)
SET LEXM=$PIECE(LEXN,U,2)
if LEXE'?7N
QUIT
if '$LENGTH(LEXM)
QUIT
SET LEXG=$GET(LEXCMD(LEX1,2))
if '$LENGTH(LEXG)
QUIT
+25 IF LEXE'=LEXP
SET LEXCT=LEXCT+1
if LEXE'=LEXIA
SET LEXVT=LEXVT+1
+26 SET LEXMC=0
SET LEXMC=LEXMC+1
IF +($GET(LEXUN))'>0
IF LEXE=LEXIA
SET LEXS="Initial Unversioned Major Diagnostic Category/DRG Groups"
+27 IF +($GET(LEXUN))>0
IF LEXE'=LEXIA
IF LEXVT=1
SET LEXS="Initial Versioned Major Diagnostic Category/DRG Groups"
+28 IF LEXCT>1
SET LEXS="Updated Major Diagnostic Category/DRG Groups"
+29 SET LEXD=$$SD^LEXQHLM(LEXE)
SET ^TMP("LEXQHL",$JOB,LEXE,4,LEX1,1)=LEXD_U_LEXS
SET ^TMP("LEXQHL",$JOB,LEXE,4,LEX1,2)=U_LEXM
SET ^TMP("LEXQHL",$JOB,LEXE,4,LEX1,3)=U_(" "_LEXG)
+30 SET LEXP=LEXE
End DoDot:1
+31 QUIT
+32 ;
DP ; Display
+1 SET LEXDISP=$GET(LEXDISP)
if $LENGTH(LEXDISP)>8
QUIT
if $LENGTH(LEXDISP)<2
QUIT
if LEXDISP["^"
QUIT
NEW LEXL
SET LEXL=$TEXT(@LEXDISP+0)
if '$LENGTH(LEXL)
QUIT
+2 DO @LEXDISP
+3 QUIT
SB ; Subjective
+1 DO ATTR^LEXQM
+2 NEW LEX1,LEX2,LEX3,LEXC,LEXCT,LEXD,LEXE,LEXEC,LEXG,LEXHDR,LEXI,LEXID,LEXM,LEXN,LEXN1,LEXN2,LEXN3,LEXO1,LEXO2,LEXO3,LEXP,LEXS,LEXT
+3 SET LEXC=$GET(^TMP("LEXQHL",$JOB,"CODE"))
SET LEXI=$GET(^TMP("LEXQHL",$JOB,"IEN"))
SET LEXN=$GET(^TMP("LEXQHL",$JOB,"NAME"))
+4 SET LEXT="Code: "_LEXC
SET LEXT=LEXT_$JUSTIFY(" ",(16-$LENGTH(LEXT)))_LEXN
DO TL^LEXQHLM(($GET(BOLD)_LEXT_$GET(NORM)))
+5 SET LEXT=""
SET LEXT=LEXT_$JUSTIFY(" ",(16-$LENGTH(LEXT)))_"IEN: "_LEXI
DO TL^LEXQHLM(($GET(BOLD)_LEXT_$GET(NORM)))
+6 FOR LEXID=1:1:3
Begin DoDot:1
+7 NEW LEXHDR,LEXCT,LEXEC
SET (LEXEC,LEXCT)=0
SET LEXHDR=$$HD(LEXID)
if '$LENGTH(LEXHDR)
QUIT
SET LEXP=""
SET LEX1=0
FOR
SET LEX1=$ORDER(^TMP("LEXQHL",$JOB,LEX1))
if +LEX1'>0
QUIT
Begin DoDot:2
+8 SET LEXEC=LEXEC+1
IF LEXID=1
Begin DoDot:3
+9 SET LEXN=$GET(^TMP("LEXQHL",$JOB,LEX1,LEXID,1))
if '$LENGTH(LEXN)
QUIT
SET LEXE=$PIECE(LEXN,U,1)
SET LEXS=$PIECE(LEXN,U,2)
if '$LENGTH(LEXE)
QUIT
if '$LENGTH(LEXS)
QUIT
SET LEXCT=LEXCT+1
+10 if LEXCT=1
DO BL^LEXQHLM
DO TL^LEXQHLM(($GET(BOLD)_" "_LEXHDR_$GET(NORM)))
SET LEXT=$GET(BOLD)_LEXE_$GET(NORM)
+11 SET LEXT=LEXT_$JUSTIFY(" ",(11-$LENGTH(LEXT)))_" "_LEXS
SET LEXT=" "_LEXT
DO TL^LEXQHLM(LEXT)
End DoDot:3
QUIT
+12 IF LEXID=4
Begin DoDot:3
+13 NEW LEX2,LEXHDR,LEXC,LEXP,LEXO1,LEXO2,LEXO3
SET LEXHDR=$$HD(4)
SET (LEXC,LEX2)=0
SET LEXP=""
FOR
SET LEX2=$ORDER(^TMP("LEXQHL",$JOB,LEX1,4,LEX2))
if +LEX2'>0
QUIT
Begin DoDot:4
+14 NEW LEXN1,LEXN2,LEXN3,LEXD,LEXS,LEXM,LEXG
+15 SET LEXN1=$GET(^TMP("LEXQHL",$JOB,LEX1,4,LEX2,1))
SET LEXD=$PIECE(LEXN1,U,1)
SET LEXS=$PIECE(LEXN1,U,2)
if '$LENGTH(LEXD)
QUIT
if '$LENGTH(LEXS)
QUIT
+16 SET LEXN2=$GET(^TMP("LEXQHL",$JOB,LEX1,4,LEX2,2))
SET LEXM=$PIECE(LEXN2,U,2)
if '$LENGTH(LEXM)
QUIT
+17 SET LEXN3=$GET(^TMP("LEXQHL",$JOB,LEX1,4,LEX2,3))
SET LEXG=$PIECE(LEXN3,U,2)
if '$LENGTH(LEXG)
QUIT
+18 SET LEXO1=$GET(LEXD)
SET LEXO1=LEXO1_$JUSTIFY(" ",(11-$LENGTH(LEXO1)))_" "_LEXS
SET LEXO1=" "_LEXO1
+19 SET LEXO2=$JUSTIFY(" ",11)_" "_LEXM
SET LEXO2=" "_LEXO2
+20 SET LEXO3=$JUSTIFY(" ",11)_" "_LEXG
SET LEXO3=" "_LEXO3
+21 SET LEXC=LEXC+1
IF LEXEC=1
IF LEXC=1
DO BL^LEXQHLM
DO TL^LEXQHLM(($GET(BOLD)_" "_LEXHDR_$GET(NORM)))
+22 if LEXP'=LEXD
DO TL^LEXQHLM(LEXO1)
DO TL^LEXQHLM(LEXO2)
DO TL^LEXQHLM(LEXO3)
+23 SET LEXP=LEXD
End DoDot:4
End DoDot:3
QUIT
+24 NEW LEX2
SET LEX2=0
SET LEXE=""
FOR
SET LEX2=$ORDER(^TMP("LEXQHL",$JOB,LEX1,LEXID,LEX2))
if +LEX2'>0
QUIT
Begin DoDot:3
+25 SET LEXN=$GET(^TMP("LEXQHL",$JOB,LEX1,LEXID,LEX2))
if LEX2=1
SET LEXE=$PIECE(LEXN,U,1)
if LEX2=1
QUIT
if '$LENGTH(LEXE)
QUIT
+26 SET LEXE=$GET(BOLD)_LEXE_$GET(NORM)
+27 IF LEX2=2
Begin DoDot:4
+28 SET LEXCT=LEXCT+1
SET LEXT=$GET(LEXE)
SET LEXS=$PIECE(LEXN,U,2)
SET LEXT=LEXT_$JUSTIFY(" ",(11-$LENGTH(LEXT)))_" "_LEXS
SET LEXT=" "_LEXT
+29 if LEXCT=1
DO BL^LEXQHLM
DO TL^LEXQHLM(($GET(BOLD)_" "_LEXHDR_$GET(NORM)))
DO TL^LEXQHLM(LEXT)
End DoDot:4
QUIT
+30 IF LEX2>2
Begin DoDot:4
+31 SET LEXCT=LEXCT+1
SET LEXT=""
SET LEXS=$PIECE(LEXN,U,2)
SET LEXT=LEXT_$JUSTIFY(" ",(11-$LENGTH(LEXT)))_" "_LEXS
SET LEXT=" "_LEXT
+32 if LEXCT=1
DO BL^LEXQHLM
DO TL^LEXQHLM(($GET(BOLD)_" "_LEXHDR_$GET(NORM)))
DO TL^LEXQHLM(LEXT)
End DoDot:4
QUIT
End DoDot:3
End DoDot:2
End DoDot:1
+33 DO KATTR^LEXQM
+34 QUIT
CH ; Chronological
+1 DO ATTR^LEXQM
+2 NEW LEX1,LEX2,LEX3,LEXC,LEXD,LEXDC,LEXI,LEXL1,LEXL2,LEXL3,LEXN,LEXP,LEXS,LEXT,LEXT1,LEXT2,LEXT3
+3 SET LEXC=$GET(^TMP("LEXQHL",$JOB,"CODE"))
SET LEXI=$GET(^TMP("LEXQHL",$JOB,"IEN"))
SET LEXN=$GET(^TMP("LEXQHL",$JOB,"NAME"))
+4 SET LEXT="Code: "_LEXC
SET LEXT=LEXT_$JUSTIFY(" ",(16-$LENGTH(LEXT)))_LEXN
DO TL^LEXQHLM(($GET(BOLD)_LEXT_$GET(NORM)))
+5 SET LEXT=""
SET LEXT=LEXT_$JUSTIFY(" ",(16-$LENGTH(LEXT)))_"IEN: "_LEXI
DO TL^LEXQHLM(($GET(BOLD)_LEXT_$GET(NORM)))
+6 SET LEXP=""
SET LEX1=0
FOR
SET LEX1=$ORDER(^TMP("LEXQHL",$JOB,LEX1))
if +LEX1'>0
QUIT
Begin DoDot:1
+7 DO BL^LEXQHLM
NEW LEX2,LEXDC
SET (LEXDC,LEX2)=0
FOR
SET LEX2=$ORDER(^TMP("LEXQHL",$JOB,LEX1,LEX2))
if +LEX2'>0
QUIT
Begin DoDot:2
+8 IF LEX2=4
Begin DoDot:3
+9 QUIT
NEW LEX3
SET LEX3=0
FOR
SET LEX3=$ORDER(^TMP("LEXQHL",$JOB,LEX1,LEX2,LEX3))
if +LEX3'>0
QUIT
Begin DoDot:4
+10 SET LEXL1=$GET(^TMP("LEXQHL",$JOB,LEX1,LEX2,LEX3,1))
+11 SET LEXD=$PIECE(LEXL1,U,1)
SET LEXS=$PIECE(LEXL1,U,2)
if '$LENGTH(LEXD)
QUIT
if '$LENGTH(LEXS)
QUIT
+12 SET LEXL2=$PIECE($GET(^TMP("LEXQHL",$JOB,LEX1,LEX2,LEX3,2)),U,2)
if '$LENGTH(LEXL2)
QUIT
+13 SET LEXL3=$PIECE($GET(^TMP("LEXQHL",$JOB,LEX1,LEX2,LEX3,3)),U,2)
if '$LENGTH(LEXL3)
QUIT
+14 SET LEXT1=$SELECT(LEXD'=LEXP:LEXD,1:"")
SET LEXT1=LEXT1_$JUSTIFY(" ",(11-$LENGTH(LEXT1)))_$SELECT($LENGTH(LEXD):"- ",1:" ")_LEXS
+15 SET LEXDC=LEXDC+1
SET LEXT1=" "_LEXT1
if LEXDC=1
DO TL^LEXQHLM(LEXT1)
+16 SET LEXT2=$JUSTIFY(" ",16)_LEXL2
DO TL^LEXQHLM(LEXT2)
+17 SET LEXT3=$JUSTIFY(" ",16)_LEXL3
DO TL^LEXQHLM(LEXT3)
+18 if LEXD'=""
SET LEXP=LEXD
End DoDot:4
End DoDot:3
QUIT
+19 NEW LEX3
SET LEX3=0
FOR
SET LEX3=$ORDER(^TMP("LEXQHL",$JOB,LEX1,LEX2,LEX3))
if +LEX3'>0
QUIT
Begin DoDot:3
+20 NEW LEXN,LEXD,LEXS,LEXSPC
SET LEXN=$GET(^TMP("LEXQHL",$JOB,LEX1,LEX2,LEX3))
SET LEXD=$PIECE(LEXN,U,1)
SET LEXS=$PIECE(LEXN,U,2)
SET LEXSPC=" "
+21 IF $LENGTH($$TM^LEXQM(LEXD))
SET LEXD=$GET(BOLD)_LEXD_$GET(NORM)
SET LEXSPC=$GET(BOLD)_"- "_$GET(NORM)
SET LEXS=$GET(BOLD)_LEXS_$GET(NORM)
+22 SET LEXT=$SELECT(LEXD'=LEXP:LEXD,1:"")
SET LEXT=LEXT_$JUSTIFY(" ",(11-$LENGTH(LEXT)))_LEXSPC_LEXS
SET LEXT=" "_LEXT
DO TL^LEXQHLM(LEXT)
+23 if LEXD'=""
SET LEXP=LEXD
End DoDot:3
End DoDot:2
End DoDot:1
+24 DO KATTR^LEXQM
+25 QUIT
+26 ;
+27 ; Miscellaneous
IA(X) ; Initial Activation
+1 NEW LEXEF,LEXH,LEXN,LEXS,LEXE,LEXIEN,LEXRT,LEXARY
SET LEXIEN=+($GET(X))
SET LEXE=""
if +LEXIEN'>0
QUIT ""
+2 SET LEXRT=$$ROOT^ICDEX(80.1)
MERGE LEXARY=@(LEXRT_+LEXIEN_",66)")
if '$DATA(LEXARY(0))
QUIT ""
+3 SET LEXEF=""
FOR
SET LEXEF=$ORDER(LEXARY("B",LEXEF))
if '$LENGTH(LEXEF)
QUIT
Begin DoDot:1
+4 SET LEXH=0
FOR
SET LEXH=$ORDER(LEXARY("B",LEXEF,LEXH))
if +LEXH'>0
QUIT
Begin DoDot:2
+5 SET LEXN=$GET(LEXARY(+LEXH,0))
if +($PIECE(LEXN,U,2))>0
SET LEXE=$PIECE(LEXN,U,1)
if $GET(LEXE)?7N
QUIT
End DoDot:2
End DoDot:1
if $GET(LEXE)?7N
QUIT
+6 SET X=""
if $GET(LEXE)?7N
SET X=$GET(LEXE)
+7 QUIT X
HD(X) ; Header
+1 if +($GET(X))=1
QUIT "Status"
if +($GET(X))=2
QUIT "Operation/Procedure"
if +($GET(X))=3
QUIT "Description"
if +($GET(X))=4
QUIT "Major Diagnostic Category/DRG Groups"
+2 QUIT ""
