- LEXQHL1 ;ISL/KER - Query History - ICD-9/10 Diagnosis Extract ;05/23/2017
- ;;2.0;LEXICON UTILITY;**62,80,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
- ; $$ICDDX^ICDEX ICR 5747
- ; $$ROOT^ICDEX ICR 5747
- ; $$CODEABA^ICDEX ICR 5747
- ; $$UP^XLFSTR ICR 10104
- ;
- Q
- EN(X,Y) ; ICD-9 Diagnosis 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,+LEXIEN) Q:'$L(LEXC) S LEXSYS=0 S LEXTIEN=$$CODEABA^ICDEX(LEXC,80,1) I LEXTIEN>0 S LEXSYS=1 Q:LEXTIEN'=LEXIEN
- I LEXSYS'>0 S LEXTIEN=$$CODEABA^ICDEX(LEXC,80,30) I LEXTIEN>0 S LEXSYS=30 Q:LEXTIEN'=LEXIEN
- Q:+($G(LEXSYS))'>0 K ^TMP("LEXQHL",$J) S ^TMP("LEXQHL",$J,"IEN")=LEXIEN,^TMP("LEXQHL",$J,"CODE")=LEXC
- S LEXTMP=$$ICDDX^ICDEX(LEXIEN,,LEXSYS,"I"),^TMP("LEXQHL",$J,"NAME")=$P(LEXTMP,U,4)
- S:'$L(LEXDISP) LEXDISP="SB" D ST,DX,DS,ID^LEXQHL5(LEXC),DG,MC,CC D:$L($G(LEXDISP)) DP K ^TMP("LEXQHL",$J)
- Q
- ST ; 1 Status
- N LEXCT,LEXD,LEXE,LEXEF,LEXH,LEXMS,LEXN,LEXRT,LEXS,LEXT,LEXARY S LEXRT=$$ROOT^ICDEX(80)
- 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
- DX ; 2 Diagnosis
- N LEX,LEXC,LEXCT,LEXD,LEXE,LEXEF,LEXH,LEXI,LEXN,LEXRT,LEXS,LEXT,LEXARY S LEXRT=$$ROOT^ICDEX(80)
- 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 Diagnosis",+LEXCT>1:"Updated Diagnosis",1:"Diagnosis")
- . . S:$O(LEXARY("B",LEXEF))=""&(LEXCT>1) LEXT=LEXT_" (final diagnosis 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,LEXRT,LEXS,LEXT,LEXARY S LEXRT=$$ROOT^ICDEX(80)
- 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
- DG ; 5 DRG Groups
- N LEX,LEXCT,LEXD,LEXDI,LEXDR,LEXDRG,LEXE,LEXEF,LEXH,LEXI,LEXN,LEXRT,LEXS,LEXT,LEXUN,LEXUND,LEXARY
- S LEXRT=$$ROOT^ICDEX(80) M LEXARY=@(LEXRT_+LEXIEN_",3)")
- 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:LEXE=$G(LEXIA) LEXUN=0
- . . S LEXS=$S(+LEXCT=1&(LEXE'=$G(LEXIA)):"Initial Versioned DRG Groups",+LEXCT=1&(LEXE=$G(LEXIA)):"Initial DRG Groups",+LEXCT>1:"Updated DRG Groups",1:"DRG Groups")
- . . S:$O(LEXARY("B",LEXEF))=""&(LEXCT>1) LEXT=LEXT_" (final DRG change)"
- . . N LEXDRG,LEXDR,LEXDI
- . . S LEXDRG="",LEXDR="" F S LEXDR=$O(LEXARY(+LEXH,1,"B",LEXDR)) Q:'$L(LEXDR) D
- . . . S LEXDI=0 F S LEXDI=$O(LEXARY(+LEXH,1,"B",LEXDR,LEXDI)) Q:+LEXDI'>0 D
- . . . . N LEXN,LEXD S LEXN=+($G(LEXARY(+LEXH,1,+LEXDI,0)))
- . . . . S LEXDRG=LEXDRG_", "_LEXN S:$E(LEXDRG,1,2)=", " LEXDRG=$E(LEXDRG,3,$L(LEXDRG))
- . . S LEXDRG=$$CS^LEXQHLM(LEXDRG),LEXDRG=$$AND^LEXQHLM(LEXDRG) S:$L(LEXDRG) LEXDRG="DRG "_LEXDRG Q:'$L(LEXDRG)
- . . K LEX S LEX(1)=LEXDRG D PR^LEXU(.LEX,63)
- . . S LEXD=$$SD^LEXQHLM(LEXE) S ^TMP("LEXQHL",$J,LEXEF,5,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,5," "),-1)+1
- . . . S ^TMP("LEXQHL",$J,LEXEF,5,LEXC)=U_LEXT
- I +($G(LEXUN))>0,$L($G(LEXUND)),+($G(LEXIA))?7N D
- . N LEXI,LEXD,LEXS,LEX S LEXD=$$SD^LEXQHLM(+($G(LEXIA))),LEXS="Initial Unversioned DRG Groups"
- . K LEX S LEX(1)=LEXUND D PR^LEXU(.LEX,63) S ^TMP("LEXQHL",$J,LEXIA,5,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,LEXIA,5," "),-1)+1
- . . S ^TMP("LEXQHL",$J,LEXIA,5,LEXC)=U_LEXT
- Q
- MC ; 6 Major Diagnostic Category
- N LEX,LEXB,LEXC,LEXCT,LEXD,LEXE,LEXEF,LEXH,LEXI,LEXM,LEXN,LEXRT,LEXS,LEXT,LEXUN,LEXUND,LEXARY
- S LEXRT=$$ROOT^ICDEX(80) M LEXARY=@(LEXRT_+LEXIEN_",4)")
- 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 LEXB,LEXN,LEXS,LEXE,LEXT,LEXD,LEXM S LEXN=$G(LEXARY(+LEXH,0)),LEXE=$P(LEXN,U,1),LEXS=$P(LEXN,U,2)
- . . S LEXM=$$UP^XLFSTR($P($G(^ICM(+LEXS,0)),U,1)) Q:'$L(LEXM) Q:+LEXS'>0&(LEXCT'>0) S LEXCT=LEXCT+1
- . . S:LEXE=$G(LEXIA) LEXUN=0 S LEXT=""
- . . S:+LEXCT=1&(LEXE'=$G(LEXIA)) LEXT="Initial Versioned Major Diagnostic Category"
- . . S:'$L(LEXT)&(+LEXCT=1)&(LEXE=$G(LEXIA)) LEXT="Initial Major Diagnostic Category"
- . . S:'$L(LEXT)&(+LEXCT>1) LEXT="Updated Major Diagnostic Category"
- . . S:'$L(LEXT) LEXT="Major Diagnostic Category"
- . . S:$O(LEXARY("B",LEXEF))=""&(LEXCT>1) LEXT=LEXT_" (final category change)"
- . . S LEXD=$$SD^LEXQHLM(LEXE) S ^TMP("LEXQHL",$J,LEXEF,6,1)=LEXD_U_LEXT
- . . S ^TMP("LEXQHL",$J,LEXEF,6,2)=U_LEXM
- I +($G(LEXUN))>0,$L($G(LEXUND)),+($G(LEXIA))?7N D
- . N LEXI,LEXD,LEXS,LEX S LEXD=$$SD^LEXQHLM(+($G(LEXIA))),LEXS="Initial Unversioned Major Diagnostic Category"
- . K LEX S LEX(1)=LEXUND D PR^LEXU(.LEX,63) S ^TMP("LEXQHL",$J,LEXIA,6,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,LEXIA,6," "),-1)+1
- . . S ^TMP("LEXQHL",$J,LEXIA,6,LEXC)=U_LEXT
- Q
- CC ; 7 Complication/Comorbidity
- N LEX,LEXB,LEXC,LEXCT,LEXD,LEXE,LEXEF,LEXH,LEXI,LEXM,LEXN,LEXRT,LEXS,LEXT,LEXUN,LEXUND,LEXARY
- S LEXRT=$$ROOT^ICDEX(80) M LEXARY=@(LEXRT_+LEXIEN_",69)")
- 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 LEXB,LEXN,LEXS,LEXE,LEXT,LEXD,LEXM S LEXN=$G(LEXARY(+LEXH,0)),LEXE=$P(LEXN,U,1),LEXS=$P(LEXN,U,2)
- . . S LEXM=$S(LEXS=1:"COMPLICATION/COMORBIDITY",LEXS=2:"MAJOR COMPLICATION/COMORBIDITY",LEXS="0":"NON-COMPLICATION/COMORBIDITY",1:"") Q:'$L(LEXM)
- . . Q:'$L(LEXS)&(LEXCT'>0) S LEXCT=LEXCT+1
- . . S:LEXE=$G(LEXIA) LEXUN=0
- . . S LEXT=$S(+LEXCT=1&(LEXE'=$G(LEXIA)):"Initial Versioned Complication/Comorbidity",+LEXCT=1&(LEXE=$G(LEXIA)):"Initial Complication/Comorbidity",+LEXCT>1:"Updated Complication/Comorbidity",1:"Complication/Comorbidity")
- . . S:$O(LEXARY("B",LEXEF))=""&(LEXCT>1) LEXT=LEXT_" (final CC change)"
- . . S LEXD=$$SD^LEXQHLM(LEXE) S ^TMP("LEXQHL",$J,LEXEF,7,1)=LEXD_U_LEXT
- . . S ^TMP("LEXQHL",$J,LEXEF,7,2)=U_LEXM
- I +($G(LEXUN))>0,$L($G(LEXUND)),+($G(LEXIA))?7N D
- . N LEXI,LEXD,LEXS,LEX S LEXD=$$SD^LEXQHLM(+($G(LEXIA))),LEXS="Initial Unversioned Complication/Comorbidity"
- . K LEX S LEX(1)=LEXUND D PR^LEXU(.LEX,63) S ^TMP("LEXQHL",$J,LEXIA,7,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,LEXIA,7," "),-1)+1
- . . S ^TMP("LEXQHL",$J,LEXIA,7,LEXC)=U_LEXT
- 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,LEXE,LEXHDR,LEXI,LEXID,LEXN,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:4 D
- . N LEXHDR,LEXCT S LEXCT=0,LEXHDR=$$HD(LEXID) Q:'$L(LEXHDR) S LEXP="",LEX1=0 F S LEX1=$O(^TMP("LEXQHL",$J,LEX1)) Q:+LEX1'>0 D
- . . 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:$L(LEXE) LEXE=$G(BOLD)_LEXE_$G(NORM)
- . . . S LEXT=LEXE,LEXT=LEXT_$J(" ",(11-$L(LEXT)))_" "_LEXS,LEXT=" "_LEXT D TL^LEXQHLM(LEXT)
- . . 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:$L(LEXE) 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,LEXI,LEXN,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)))
- S LEXP="",LEX1=0 F S LEX1=$O(^TMP("LEXQHL",$J,LEX1)) Q:+LEX1'>0 D
- . D BL^LEXQHLM N LEX2 S LEX2=0 F S LEX2=$O(^TMP("LEXQHL",$J,LEX1,LEX2)) Q:+LEX2'>0 D
- . . Q:LEX2>4 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
- HD(X) ; Header
- Q:+($G(X))=1 "Status" Q:+($G(X))=2 "Diagnosis" Q:+($G(X))=3 "Description" Q:+($G(X))=4 "Lexicon Expression" Q:+($G(X))=5 "DRG Groups"
- Q:+($G(X))=6 "Major Diagnostic Category" Q:+($G(X))=7 "Complication/Comorbidity"
- Q ""
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLEXQHL1 11901 printed Feb 18, 2025@23:34:44 Page 2
- LEXQHL1 ;ISL/KER - Query History - ICD-9/10 Diagnosis Extract ;05/23/2017
- +1 ;;2.0;LEXICON UTILITY;**62,80,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 ; $$ICDDX^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-9 Diagnosis 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,+LEXIEN)
- if '$LENGTH(LEXC)
- QUIT
- SET LEXSYS=0
- SET LEXTIEN=$$CODEABA^ICDEX(LEXC,80,1)
- IF LEXTIEN>0
- SET LEXSYS=1
- if LEXTIEN'=LEXIEN
- QUIT
- +3 IF LEXSYS'>0
- SET LEXTIEN=$$CODEABA^ICDEX(LEXC,80,30)
- IF LEXTIEN>0
- SET LEXSYS=30
- 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=$$ICDDX^ICDEX(LEXIEN,,LEXSYS,"I")
- SET ^TMP("LEXQHL",$JOB,"NAME")=$PIECE(LEXTMP,U,4)
- +6 if '$LENGTH(LEXDISP)
- SET LEXDISP="SB"
- DO ST
- DO DX
- DO DS
- DO ID^LEXQHL5(LEXC)
- DO DG
- DO MC
- DO CC
- if $LENGTH($GET(LEXDISP))
- DO DP
- KILL ^TMP("LEXQHL",$JOB)
- +7 QUIT
- ST ; 1 Status
- +1 NEW LEXCT,LEXD,LEXE,LEXEF,LEXH,LEXMS,LEXN,LEXRT,LEXS,LEXT,LEXARY
- SET LEXRT=$$ROOT^ICDEX(80)
- +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
- DX ; 2 Diagnosis
- +1 NEW LEX,LEXC,LEXCT,LEXD,LEXE,LEXEF,LEXH,LEXI,LEXN,LEXRT,LEXS,LEXT,LEXARY
- SET LEXRT=$$ROOT^ICDEX(80)
- +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 Diagnosis",+LEXCT>1:"Updated Diagnosis",1:"Diagnosis")
- +7 if $ORDER(LEXARY("B",LEXEF))=""&(LEXCT>1)
- SET LEXT=LEXT_" (final diagnosis 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,LEXRT,LEXS,LEXT,LEXARY
- SET LEXRT=$$ROOT^ICDEX(80)
- +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
- DG ; 5 DRG Groups
- +1 NEW LEX,LEXCT,LEXD,LEXDI,LEXDR,LEXDRG,LEXE,LEXEF,LEXH,LEXI,LEXN,LEXRT,LEXS,LEXT,LEXUN,LEXUND,LEXARY
- +2 SET LEXRT=$$ROOT^ICDEX(80)
- MERGE LEXARY=@(LEXRT_+LEXIEN_",3)")
- +3 SET LEXCT=0
- SET LEXEF=""
- FOR
- SET LEXEF=$ORDER(LEXARY("B",LEXEF))
- if '$LENGTH(LEXEF)
- QUIT
- Begin DoDot:1
- +4 NEW LEXH
- SET LEXH=0
- FOR
- SET LEXH=$ORDER(LEXARY("B",LEXEF,LEXH))
- if +LEXH'>0
- QUIT
- Begin DoDot:2
- +5 NEW LEXN,LEXS,LEXE,LEXT,LEXD,LEX,LEXI
- SET LEXN=$GET(LEXARY(+LEXH,0))
- +6 SET LEXE=$PIECE(LEXN,U,1)
- SET LEXT=$$UP^XLFSTR($GET(LEXARY(+LEXH,1)))
- +7 SET LEXCT=LEXCT+1
- SET LEX(1)=LEXT
- DO PR^LEXU(.LEX,63)
- if LEXE=$GET(LEXIA)
- SET LEXUN=0
- +8 SET LEXS=$SELECT(+LEXCT=1&(LEXE'=$GET(LEXIA)):"Initial Versioned DRG Groups",+LEXCT=1&(LEXE=$GET(LEXIA)):"Initial DRG Groups",+LEXCT>1:"Updated DRG Groups",1:"DRG Groups")
- +9 if $ORDER(LEXARY("B",LEXEF))=""&(LEXCT>1)
- SET LEXT=LEXT_" (final DRG change)"
- +10 NEW LEXDRG,LEXDR,LEXDI
- +11 SET LEXDRG=""
- SET LEXDR=""
- FOR
- SET LEXDR=$ORDER(LEXARY(+LEXH,1,"B",LEXDR))
- if '$LENGTH(LEXDR)
- QUIT
- Begin DoDot:3
- +12 SET LEXDI=0
- FOR
- SET LEXDI=$ORDER(LEXARY(+LEXH,1,"B",LEXDR,LEXDI))
- if +LEXDI'>0
- QUIT
- Begin DoDot:4
- +13 NEW LEXN,LEXD
- SET LEXN=+($GET(LEXARY(+LEXH,1,+LEXDI,0)))
- +14 SET LEXDRG=LEXDRG_", "_LEXN
- if $EXTRACT(LEXDRG,1,2)=", "
- SET LEXDRG=$EXTRACT(LEXDRG,3,$LENGTH(LEXDRG))
- End DoDot:4
- End DoDot:3
- +15 SET LEXDRG=$$CS^LEXQHLM(LEXDRG)
- SET LEXDRG=$$AND^LEXQHLM(LEXDRG)
- if $LENGTH(LEXDRG)
- SET LEXDRG="DRG "_LEXDRG
- if '$LENGTH(LEXDRG)
- QUIT
- +16 KILL LEX
- SET LEX(1)=LEXDRG
- DO PR^LEXU(.LEX,63)
- +17 SET LEXD=$$SD^LEXQHLM(LEXE)
- SET ^TMP("LEXQHL",$JOB,LEXEF,5,1)=LEXD_U_LEXS
- +18 SET LEXI=0
- FOR
- SET LEXI=$ORDER(LEX(LEXI))
- if +LEXI'>0
- QUIT
- Begin DoDot:3
- +19 NEW LEXC
- SET LEXT=$GET(LEX(LEXI))
- if '$LENGTH(LEXT)
- QUIT
- SET LEXC=$ORDER(^TMP("LEXQHL",$JOB,LEXEF,5," "),-1)+1
- +20 SET ^TMP("LEXQHL",$JOB,LEXEF,5,LEXC)=U_LEXT
- End DoDot:3
- End DoDot:2
- End DoDot:1
- +21 IF +($GET(LEXUN))>0
- IF $LENGTH($GET(LEXUND))
- IF +($GET(LEXIA))?7N
- Begin DoDot:1
- +22 NEW LEXI,LEXD,LEXS,LEX
- SET LEXD=$$SD^LEXQHLM(+($GET(LEXIA)))
- SET LEXS="Initial Unversioned DRG Groups"
- +23 KILL LEX
- SET LEX(1)=LEXUND
- DO PR^LEXU(.LEX,63)
- SET ^TMP("LEXQHL",$JOB,LEXIA,5,1)=LEXD_U_LEXS
- +24 SET LEXI=0
- FOR
- SET LEXI=$ORDER(LEX(LEXI))
- if +LEXI'>0
- QUIT
- Begin DoDot:2
- +25 NEW LEXC
- SET LEXT=$GET(LEX(LEXI))
- if '$LENGTH(LEXT)
- QUIT
- SET LEXC=$ORDER(^TMP("LEXQHL",$JOB,LEXIA,5," "),-1)+1
- +26 SET ^TMP("LEXQHL",$JOB,LEXIA,5,LEXC)=U_LEXT
- End DoDot:2
- End DoDot:1
- +27 QUIT
- MC ; 6 Major Diagnostic Category
- +1 NEW LEX,LEXB,LEXC,LEXCT,LEXD,LEXE,LEXEF,LEXH,LEXI,LEXM,LEXN,LEXRT,LEXS,LEXT,LEXUN,LEXUND,LEXARY
- +2 SET LEXRT=$$ROOT^ICDEX(80)
- MERGE LEXARY=@(LEXRT_+LEXIEN_",4)")
- +3 SET LEXCT=0
- SET LEXEF=""
- FOR
- SET LEXEF=$ORDER(LEXARY("B",LEXEF))
- if '$LENGTH(LEXEF)
- QUIT
- Begin DoDot:1
- +4 NEW LEXH
- SET LEXH=0
- FOR
- SET LEXH=$ORDER(LEXARY("B",LEXEF,LEXH))
- if +LEXH'>0
- QUIT
- Begin DoDot:2
- +5 NEW LEXB,LEXN,LEXS,LEXE,LEXT,LEXD,LEXM
- SET LEXN=$GET(LEXARY(+LEXH,0))
- SET LEXE=$PIECE(LEXN,U,1)
- SET LEXS=$PIECE(LEXN,U,2)
- +6 SET LEXM=$$UP^XLFSTR($PIECE($GET(^ICM(+LEXS,0)),U,1))
- if '$LENGTH(LEXM)
- QUIT
- if +LEXS'>0&(LEXCT'>0)
- QUIT
- SET LEXCT=LEXCT+1
- +7 if LEXE=$GET(LEXIA)
- SET LEXUN=0
- SET LEXT=""
- +8 if +LEXCT=1&(LEXE'=$GET(LEXIA))
- SET LEXT="Initial Versioned Major Diagnostic Category"
- +9 if '$LENGTH(LEXT)&(+LEXCT=1)&(LEXE=$GET(LEXIA))
- SET LEXT="Initial Major Diagnostic Category"
- +10 if '$LENGTH(LEXT)&(+LEXCT>1)
- SET LEXT="Updated Major Diagnostic Category"
- +11 if '$LENGTH(LEXT)
- SET LEXT="Major Diagnostic Category"
- +12 if $ORDER(LEXARY("B",LEXEF))=""&(LEXCT>1)
- SET LEXT=LEXT_" (final category change)"
- +13 SET LEXD=$$SD^LEXQHLM(LEXE)
- SET ^TMP("LEXQHL",$JOB,LEXEF,6,1)=LEXD_U_LEXT
- +14 SET ^TMP("LEXQHL",$JOB,LEXEF,6,2)=U_LEXM
- End DoDot:2
- End DoDot:1
- +15 IF +($GET(LEXUN))>0
- IF $LENGTH($GET(LEXUND))
- IF +($GET(LEXIA))?7N
- Begin DoDot:1
- +16 NEW LEXI,LEXD,LEXS,LEX
- SET LEXD=$$SD^LEXQHLM(+($GET(LEXIA)))
- SET LEXS="Initial Unversioned Major Diagnostic Category"
- +17 KILL LEX
- SET LEX(1)=LEXUND
- DO PR^LEXU(.LEX,63)
- SET ^TMP("LEXQHL",$JOB,LEXIA,6,1)=LEXD_U_LEXS
- +18 SET LEXI=0
- FOR
- SET LEXI=$ORDER(LEX(LEXI))
- if +LEXI'>0
- QUIT
- Begin DoDot:2
- +19 NEW LEXC
- SET LEXT=$GET(LEX(LEXI))
- if '$LENGTH(LEXT)
- QUIT
- SET LEXC=$ORDER(^TMP("LEXQHL",$JOB,LEXIA,6," "),-1)+1
- +20 SET ^TMP("LEXQHL",$JOB,LEXIA,6,LEXC)=U_LEXT
- End DoDot:2
- End DoDot:1
- +21 QUIT
- CC ; 7 Complication/Comorbidity
- +1 NEW LEX,LEXB,LEXC,LEXCT,LEXD,LEXE,LEXEF,LEXH,LEXI,LEXM,LEXN,LEXRT,LEXS,LEXT,LEXUN,LEXUND,LEXARY
- +2 SET LEXRT=$$ROOT^ICDEX(80)
- MERGE LEXARY=@(LEXRT_+LEXIEN_",69)")
- +3 SET LEXCT=0
- SET LEXEF=""
- FOR
- SET LEXEF=$ORDER(LEXARY("B",LEXEF))
- if '$LENGTH(LEXEF)
- QUIT
- Begin DoDot:1
- +4 NEW LEXH
- SET LEXH=0
- FOR
- SET LEXH=$ORDER(LEXARY("B",LEXEF,LEXH))
- if +LEXH'>0
- QUIT
- Begin DoDot:2
- +5 NEW LEXB,LEXN,LEXS,LEXE,LEXT,LEXD,LEXM
- SET LEXN=$GET(LEXARY(+LEXH,0))
- SET LEXE=$PIECE(LEXN,U,1)
- SET LEXS=$PIECE(LEXN,U,2)
- +6 SET LEXM=$SELECT(LEXS=1:"COMPLICATION/COMORBIDITY",LEXS=2:"MAJOR COMPLICATION/COMORBIDITY",LEXS="0":"NON-COMPLICATION/COMORBIDITY",1:"")
- if '$LENGTH(LEXM)
- QUIT
- +7 if '$LENGTH(LEXS)&(LEXCT'>0)
- QUIT
- SET LEXCT=LEXCT+1
- +8 if LEXE=$GET(LEXIA)
- SET LEXUN=0
- +9 SET LEXT=$SELECT(+LEXCT=1&(LEXE'=$GET(LEXIA)):"Initial Versioned Complication/Comorbidity",+LEXCT=1&(LEXE=$GET(LEXIA)):"Initial Complication/Comorbidity",+LEXCT>1:"Updated Complication/Comorbidity",1:"Complication/Comorbidity")
- +10 if $ORDER(LEXARY("B",LEXEF))=""&(LEXCT>1)
- SET LEXT=LEXT_" (final CC change)"
- +11 SET LEXD=$$SD^LEXQHLM(LEXE)
- SET ^TMP("LEXQHL",$JOB,LEXEF,7,1)=LEXD_U_LEXT
- +12 SET ^TMP("LEXQHL",$JOB,LEXEF,7,2)=U_LEXM
- End DoDot:2
- End DoDot:1
- +13 IF +($GET(LEXUN))>0
- IF $LENGTH($GET(LEXUND))
- IF +($GET(LEXIA))?7N
- Begin DoDot:1
- +14 NEW LEXI,LEXD,LEXS,LEX
- SET LEXD=$$SD^LEXQHLM(+($GET(LEXIA)))
- SET LEXS="Initial Unversioned Complication/Comorbidity"
- +15 KILL LEX
- SET LEX(1)=LEXUND
- DO PR^LEXU(.LEX,63)
- SET ^TMP("LEXQHL",$JOB,LEXIA,7,1)=LEXD_U_LEXS
- +16 SET LEXI=0
- FOR
- SET LEXI=$ORDER(LEX(LEXI))
- if +LEXI'>0
- QUIT
- Begin DoDot:2
- +17 NEW LEXC
- SET LEXT=$GET(LEX(LEXI))
- if '$LENGTH(LEXT)
- QUIT
- SET LEXC=$ORDER(^TMP("LEXQHL",$JOB,LEXIA,7," "),-1)+1
- +18 SET ^TMP("LEXQHL",$JOB,LEXIA,7,LEXC)=U_LEXT
- End DoDot:2
- End DoDot:1
- +19 QUIT
- +20 ;
- 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
- DO @LEXDISP
- +2 QUIT
- SB ; Subjective
- +1 DO ATTR^LEXQM
- NEW LEX1,LEX2,LEX3,LEXC,LEXCT,LEXE,LEXHDR,LEXI,LEXID,LEXN,LEXP,LEXS,LEXT
- +2 SET LEXC=$GET(^TMP("LEXQHL",$JOB,"CODE"))
- SET LEXI=$GET(^TMP("LEXQHL",$JOB,"IEN"))
- SET LEXN=$GET(^TMP("LEXQHL",$JOB,"NAME"))
- +3 SET LEXT="Code: "_LEXC
- SET LEXT=LEXT_$JUSTIFY(" ",(16-$LENGTH(LEXT)))_LEXN
- DO TL^LEXQHLM(($GET(BOLD)_LEXT_$GET(NORM)))
- +4 SET LEXT=""
- SET LEXT=LEXT_$JUSTIFY(" ",(16-$LENGTH(LEXT)))_"IEN: "_LEXI
- DO TL^LEXQHLM(($GET(BOLD)_LEXT_$GET(NORM)))
- +5 FOR LEXID=1:1:4
- Begin DoDot:1
- +6 NEW LEXHDR,LEXCT
- SET 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
- +7 IF LEXID=1
- Begin DoDot:3
- +8 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
- +9 if LEXCT=1
- DO BL^LEXQHLM
- DO TL^LEXQHLM(($GET(BOLD)_" "_LEXHDR_$GET(NORM)))
- if $LENGTH(LEXE)
- SET LEXE=$GET(BOLD)_LEXE_$GET(NORM)
- +10 SET LEXT=LEXE
- SET LEXT=LEXT_$JUSTIFY(" ",(11-$LENGTH(LEXT)))_" "_LEXS
- SET LEXT=" "_LEXT
- DO TL^LEXQHLM(LEXT)
- End DoDot:3
- QUIT
- +11 NEW LEX2
- SET LEX2=0
- SET LEXE=""
- FOR
- SET LEX2=$ORDER(^TMP("LEXQHL",$JOB,LEX1,LEXID,LEX2))
- if +LEX2'>0
- QUIT
- Begin DoDot:3
- +12 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
- +13 if $LENGTH(LEXE)
- SET LEXE=$GET(BOLD)_LEXE_$GET(NORM)
- +14 IF LEX2=2
- Begin DoDot:4
- +15 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
- +16 if LEXCT=1
- DO BL^LEXQHLM
- DO TL^LEXQHLM(($GET(BOLD)_" "_LEXHDR_$GET(NORM)))
- DO TL^LEXQHLM(LEXT)
- End DoDot:4
- QUIT
- +17 IF LEX2>2
- Begin DoDot:4
- +18 SET LEXCT=LEXCT+1
- SET LEXT=""
- SET LEXS=$PIECE(LEXN,U,2)
- SET LEXT=LEXT_$JUSTIFY(" ",(11-$LENGTH(LEXT)))_" "_LEXS
- SET LEXT=" "_LEXT
- +19 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
- +20 DO KATTR^LEXQM
- +21 QUIT
- CH ; Chronological
- +1 DO ATTR^LEXQM
- NEW LEX1,LEX2,LEX3,LEXC,LEXD,LEXI,LEXN,LEXP,LEXS,LEXT
- +2 SET LEXC=$GET(^TMP("LEXQHL",$JOB,"CODE"))
- SET LEXI=$GET(^TMP("LEXQHL",$JOB,"IEN"))
- SET LEXN=$GET(^TMP("LEXQHL",$JOB,"NAME"))
- +3 SET LEXT="Code: "_LEXC
- SET LEXT=LEXT_$JUSTIFY(" ",(16-$LENGTH(LEXT)))_LEXN
- DO TL^LEXQHLM(($GET(BOLD)_LEXT_$GET(NORM)))
- +4 SET LEXT=""
- SET LEXT=LEXT_$JUSTIFY(" ",(16-$LENGTH(LEXT)))_"IEN: "_LEXI
- DO TL^LEXQHLM(($GET(BOLD)_LEXT_$GET(NORM)))
- +5 SET LEXP=""
- SET LEX1=0
- FOR
- SET LEX1=$ORDER(^TMP("LEXQHL",$JOB,LEX1))
- if +LEX1'>0
- QUIT
- Begin DoDot:1
- +6 DO BL^LEXQHLM
- NEW LEX2
- SET LEX2=0
- FOR
- SET LEX2=$ORDER(^TMP("LEXQHL",$JOB,LEX1,LEX2))
- if +LEX2'>0
- QUIT
- Begin DoDot:2
- +7 if LEX2>4
- QUIT
- NEW LEX3
- SET LEX3=0
- FOR
- SET LEX3=$ORDER(^TMP("LEXQHL",$JOB,LEX1,LEX2,LEX3))
- if +LEX3'>0
- QUIT
- Begin DoDot:3
- +8 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=" "
- +9 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)
- +10 SET LEXT=$SELECT(LEXD'=LEXP:LEXD,1:"")
- SET LEXT=LEXT_$JUSTIFY(" ",(11-$LENGTH(LEXT)))_LEXSPC_LEXS
- +11 SET LEXT=" "_LEXT
- DO TL^LEXQHLM(LEXT)
- if LEXD'=""
- SET LEXP=LEXD
- End DoDot:3
- End DoDot:2
- End DoDot:1
- +12 DO KATTR^LEXQM
- +13 QUIT
- +14 ;
- +15 ; Miscellaneous
- HD(X) ; Header
- +1 if +($GET(X))=1
- QUIT "Status"
- if +($GET(X))=2
- QUIT "Diagnosis"
- if +($GET(X))=3
- QUIT "Description"
- if +($GET(X))=4
- QUIT "Lexicon Expression"
- if +($GET(X))=5
- QUIT "DRG Groups"
- +2 if +($GET(X))=6
- QUIT "Major Diagnostic Category"
- if +($GET(X))=7
- QUIT "Complication/Comorbidity"
- +3 QUIT ""