LEXQHL2.m

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 ---LEXQHL2   11905     printed  Feb 18, 2025@23:34:45                                                                                                                                                                                                    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))