LEXQHL4 ;ISL/KER - Query History - CPT Modifier Extract ;04/21/2014
;;2.0;LEXICON UTILITY;**62,80**;Sep 23, 1996;Build 10
;
; Global Variables
; ^DIC(81.3, ICR 4492
; ^TMP("LEXQHL") SACC 2.3.2.5.1
; ^TMP("LEXQHLA") SACC 2.3.2.5.1
;
; External References
; $$MOD^ICPTMOD ICR 1996
; $$UP^XLFSTR ICR 10104
;
Q
EN(X,Y,LEX) ; CPT Modifier File
N LEXDISP,LEXRAN,LEXIEN,LEXIA,LEXEF,LEXCT,LEXC S LEXIEN=$G(X),LEXDISP=$G(Y),LEXRAN=$G(LEX),LEXIA="" Q:+LEXIEN'>0 Q:'$D(^DIC(81.3,+LEXIEN,0))
S LEXC=$P($G(^DIC(81.3,+LEXIEN,0)),U,1) K ^TMP("LEXQHL",$J) S ^TMP("LEXQHL",$J,"IEN")=LEXIEN,^TMP("LEXQHL",$J,"CODE")=LEXC
S ^TMP("LEXQHL",$J,"NAME")=$P($$MOD^ICPTMOD(LEXIEN,"I"),U,3) S:'$L(LEXDISP) LEXDISP="SB" D ST,NM,DS,AR,IR D:$L($G(LEXDISP)) DP
Q
ST ; 1 Status
N LEXCT,LEXD,LEXE,LEXEF,LEXH,LEXMS,LEXN,LEXS,LEXT
S LEXCT=0,LEXEF="" F S LEXEF=$O(^DIC(81.3,+LEXIEN,60,"B",LEXEF)) Q:'$L(LEXEF) D
. N LEXH S LEXH=0 F S LEXH=$O(^DIC(81.3,+LEXIEN,60,"B",LEXEF,LEXH)) Q:+LEXH'>0 D
. . N LEXN,LEXS,LEXE,LEXT,LEXD,LEXMS S LEXN=$G(^DIC(81.3,+LEXIEN,60,+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,1),LEXT=$S(+LEXS>0:"Activation",1:"Inactivation")
. . S:+LEXS>0&(LEXCT=1) LEXT="Initial Activation"_LEXMS,LEXIA=LEXE
. . S:$O(^DIC(81.3,+LEXIEN,60,"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
NM ; 2 Modifier Name
N LEX,LEXC,LEXCT,LEXD,LEXE,LEXEF,LEXH,LEXI,LEXN,LEXS,LEXT
S LEXCT=0,LEXEF="" F S LEXEF=$O(^DIC(81.3,+LEXIEN,61,"B",LEXEF)) Q:'$L(LEXEF) D
. N LEXH S LEXH=0 F S LEXH=$O(^DIC(81.3,+LEXIEN,61,"B",LEXEF,LEXH)) Q:+LEXH'>0 D
. . N LEXN,LEXS,LEXE,LEXT,LEXD,LEX,LEXI S LEXN=$G(^DIC(81.3,+LEXIEN,61,+LEXH,0)),LEXE=$P(LEXN,U,1),LEXT=$$UP^XLFSTR($P(LEXN,U,2))
. . S LEXCT=LEXCT+1,LEX(1)=LEXT D PR^LEXQHLM(.LEX,63)
. . S LEXS=$S(+LEXCT=1:"Initial Modifier Name",+LEXCT>1:"Updated Modifier Name",1:"Modifier Name")
. . S:$O(^DIC(81.3,+LEXIEN,61,"B",LEXEF))=""&(LEXCT>1) LEXT=LEXT_" (final Modifier Name 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
S LEXCT=0,LEXEF="" F S LEXEF=$O(^DIC(81.3,+LEXIEN,62,"B",LEXEF)) Q:'$L(LEXEF) D
. N LEXH S LEXH=0 F S LEXH=$O(^DIC(81.3,+LEXIEN,62,"B",LEXEF,LEXH)) Q:+LEXH'>0 D
. . N LEXC,LEXN,LEXS,LEXE,LEXT,LEXD,LEX,LEXI S LEXN=$G(^DIC(81.3,+LEXIEN,62,+LEXH,0))
. . S LEXE=$P(LEXN,U,1) S (LEXC,LEXI)=0 F S LEXI=$O(^DIC(81.3,+LEXIEN,62,+LEXH,1,LEXI)) Q:+LEXI'>0 D
. . . S LEXT=$$TM^LEXQHLM($$UP^XLFSTR($G(^DIC(81.3,+LEXIEN,62,+LEXH,1,LEXI,0)))) Q:'$L(LEXT) S LEXC=LEXC+1,LEX(LEXC)=LEXT
. . S LEXCT=LEXCT+1 D PR^LEXQHLM(.LEX,63)
. . S LEXS=$S(+LEXCT=1:"Initial Description",+LEXCT>1:"Updated Description",1:"Description")
. . S:$O(^DIC(81.3,+LEXIEN,62,"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
AR ; 4 Active Ranges
K ^TMP("LEXQHLA",$J) N LEXACT,LEXAT,LEXATD,LEXB,LEXC,LEXD,LEXE,LEXI,LEXIA,LEXIAD,LEXICT,LEXN,LEXR
S (LEXACT,LEXICT)=0,LEXI=0 F S LEXI=$O(^DIC(81.3,+LEXIEN,10,LEXI)) Q:+LEXI'>0 D
. N LEXN,LEXAT,LEXATD,LEXIA,LEXIAD,LEXB,LEXE,LEXR S LEXN=$G(^DIC(81.3,+LEXIEN,10,+LEXI,0)),LEXB=$P(LEXN,U,1) Q:$L(LEXB)'=5
. S LEXE=$P(LEXN,U,2) S:'$L(LEXE) LEXE=LEXB S LEXAT=$P(LEXN,U,3) Q:'$L(LEXAT) Q:LEXAT'?7N S LEXATD=$$SD^LEXQHLM(LEXAT) Q:'$L(LEXATD)
. S LEXIA=$P(LEXN,U,4) S:$L(LEXIA) LEXIAD=$$SD^LEXQHLM(LEXIA) Q:$L($G(LEXIA))&('$L($G(LEXIAD))) S LEXR=LEXB_" - "_LEXE Q:LEXIA?7N
. S LEXACT=LEXACT+1,^TMP("LEXQHLA",$J,LEXAT,LEXACT)=LEXATD_U_LEXR,^TMP("LEXQHLA",$J,"B",LEXR,LEXAT,LEXACT)=""
S LEXC=0,LEXB="" F S LEXB=$O(^TMP("LEXQHLA",$J,"B",LEXB)) Q:'$L(LEXB) D
. N LEXAT S LEXAT="" F S LEXAT=$O(^TMP("LEXQHLA",$J,"B",LEXB,LEXAT)) Q:'$L(LEXAT) D
. . N LEXACT S LEXACT=0 F S LEXACT=$O(^TMP("LEXQHLA",$J,"B",LEXB,LEXAT,LEXACT)) Q:+LEXACT'>0 D
. . . N LEXN,LEXD,LEXR S LEXN=$G(^TMP("LEXQHLA",$J,LEXAT,LEXACT)),LEXD=$P(LEXN,U,1),LEXR=$P(LEXN,U,2) Q:'$L(LEXD) Q:'$L(LEXR)
. . . S LEXC=LEXC+1,^TMP("LEXQHL",$J,LEXAT,4,LEXC)=LEXN
K ^TMP("LEXQHLA",$J)
Q
IR ; 5 Inactive Ranges
K ^TMP("LEXQHLA",$J) N LEXACT,LEXAT,LEXATD,LEXB,LEXC,LEXD,LEXE,LEXI,LEXIA,LEXIAD,LEXICT,LEXN,LEXR
S (LEXACT,LEXICT)=0,LEXI=0 F S LEXI=$O(^DIC(81.3,+LEXIEN,10,LEXI)) Q:+LEXI'>0 D
. N LEXN,LEXAT,LEXATD,LEXIA,LEXIAD,LEXB,LEXE,LEXR S LEXN=$G(^DIC(81.3,+LEXIEN,10,+LEXI,0)),LEXB=$P(LEXN,U,1) Q:$L(LEXB)'=5
. S LEXE=$P(LEXN,U,2) S:'$L(LEXE) LEXE=LEXB S LEXAT=$P(LEXN,U,3) Q:'$L(LEXAT) Q:LEXAT'?7N S LEXATD=$$SD^LEXQHLM(LEXAT) Q:'$L(LEXATD)
. S LEXIA=$P(LEXN,U,4) S:$L(LEXIA) LEXIAD=$$SD^LEXQHLM(LEXIA) Q:$L($G(LEXIA))&('$L($G(LEXIAD))) S LEXR=LEXB_" - "_LEXE Q:LEXIA'?7N
. S LEXACT=LEXACT+1,^TMP("LEXQHLA",$J,LEXAT,LEXACT)=LEXATD_U_LEXR,^TMP("LEXQHLA",$J,"B",LEXR,LEXAT,LEXACT)=""
S LEXC=0,LEXB="" F S LEXB=$O(^TMP("LEXQHLA",$J,"B",LEXB)) Q:'$L(LEXB) D
. N LEXAT S LEXAT="" F S LEXAT=$O(^TMP("LEXQHLA",$J,"B",LEXB,LEXAT)) Q:'$L(LEXAT) D
. . N LEXACT S LEXACT=0 F S LEXACT=$O(^TMP("LEXQHLA",$J,"B",LEXB,LEXAT,LEXACT)) Q:+LEXACT'>0 D
. . . N LEXN,LEXD,LEXR S LEXN=$G(^TMP("LEXQHLA",$J,LEXAT,LEXACT)),LEXD=$P(LEXN,U,1),LEXR=$P(LEXN,U,2) Q:'$L(LEXD) Q:'$L(LEXR)
. . . S LEXC=LEXC+1,^TMP("LEXQHL",$J,LEXAT,5,LEXC)=LEXN
K ^TMP("LEXQHLA",$J)
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
N LEX1,LEX2,LEX3,LEXC,LEXCT,LEXD,LEXE,LEXEC,LEXG,LEXHD,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(LEXT) S LEXT="",LEXT=LEXT_$J(" ",(16-$L(LEXT)))_"IEN: "_LEXI D TL^LEXQHLM(LEXT)
F LEXID=1:1:5 D
. N LEXHD,LEXCT,LEXEC S (LEXEC,LEXCT)=0,LEXHD=$$HD(LEXID) Q:'$L(LEXHD) S LEXP=""
. S 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((" "_LEXHD)) S LEXT=LEXE,LEXT=LEXT_$J(" ",(11-$L(LEXT)))_" "_LEXS,LEXT=" "_LEXT D TL^LEXQHLM(LEXT)
. . I LEXID=4 D Q
. . . Q:+($G(LEXRAN))'>0 N LEXP,LEX2,LEXSTR,LEXL S LEXSTR="",(LEXL,LEXP)="",LEX2=0 F S LEX2=$O(^TMP("LEXQHL",$J,LEX1,4,LEX2)) Q:+LEX2'>0 D
. . . . N LEXN,LEXD,LEXE,LEXM,LEXT S LEXN=$G(^TMP("LEXQHL",$J,LEX1,4,LEX2)) S (LEXE,LEXD,LEXL)=$P(LEXN,U,1),LEXM=$P(LEXN,U,2) Q:'$L(LEXD) Q:'$L(LEXM)
. . . . I ($L(LEXSTR)+$L(LEXM)+3)'>63 S LEXSTR=$$TM^LEXQHLM(LEXSTR_" "_LEXM) Q
. . . . I ($L(LEXSTR)+$L(LEXM)+3)>63 D
. . . . . S LEXSTR=$$TM^LEXQHLM(LEXSTR) S:LEXD=LEXP LEXD="" S:$L(LEXE) LEXP=LEXE S LEXT=LEXD,LEXT=LEXT_$J(" ",(11-$L(LEXT)))_" "_LEXSTR,LEXT=" "_LEXT
. . . . . S LEXCT=LEXCT+1 D:LEXCT=1 BL^LEXQHLM,TL^LEXQHLM((" "_LEXHD)) D TL^LEXQHLM(LEXT) S LEXSTR=LEXM
. . . S LEXSTR=$$TM^LEXQHLM(LEXSTR) I $L(LEXSTR) D
. . . . S:$G(LEXL)=$G(LEXP)&($L(LEXP)) LEXL="" S:$L(LEXL) LEXP=LEXL S LEXT=LEXL,LEXT=LEXT_$J(" ",(11-$L(LEXT)))_" "_LEXSTR,LEXT=" "_LEXT
. . . . S LEXCT=LEXCT+1 D:LEXCT=1 BL^LEXQHLM,TL^LEXQHLM((" "_LEXHD)) D TL^LEXQHLM(LEXT)
. . I LEXID=5 D Q
. . . Q:+($G(LEXRAN))'>0 N LEXP,LEX2,LEXSTR,LEXL S LEXSTR="",(LEXL,LEXP)="",LEX2=0 F S LEX2=$O(^TMP("LEXQHL",$J,LEX1,5,LEX2)) Q:+LEX2'>0 D
. . . . N LEXN,LEXD,LEXE,LEXM,LEXT S LEXN=$G(^TMP("LEXQHL",$J,LEX1,5,LEX2))
. . . . S (LEXE,LEXD,LEXL)=$P(LEXN,U,1),LEXM=$P(LEXN,U,2) Q:'$L(LEXD) Q:'$L(LEXM)
. . . . I ($L(LEXSTR)+$L(LEXM)+3)'>63 S LEXSTR=$$TM^LEXQHLM(LEXSTR_" "_LEXM) Q
. . . . I ($L(LEXSTR)+$L(LEXM)+3)>63 D
. . . . . S LEXSTR=$$TM^LEXQHLM(LEXSTR) S:LEXD=LEXP LEXD="" S:$L(LEXE) LEXP=LEXE S LEXT=LEXD,LEXT=LEXT_$J(" ",(11-$L(LEXT)))_" "_LEXSTR,LEXT=" "_LEXT
. . . . . S LEXCT=LEXCT+1 D:LEXCT=1 BL^LEXQHLM,TL^LEXQHLM((" "_LEXHD)) D TL^LEXQHLM(LEXT) S LEXSTR=LEXM
. . . S LEXSTR=$$TM^LEXQHLM(LEXSTR) I $L(LEXSTR) D
. . . . S:$G(LEXL)=$G(LEXP)&($L(LEXP)) LEXL="" S:$L(LEXL) LEXP=LEXL S LEXT=LEXL,LEXT=LEXT_$J(" ",(11-$L(LEXT)))_" "_LEXSTR,LEXT=" "_LEXT
. . . . S LEXCT=LEXCT+1 D:LEXCT=1 BL^LEXQHLM,TL^LEXQHLM((" "_LEXHD)) 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)
. . . 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((" "_LEXHD)) 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((" "_LEXHD)) D TL^LEXQHLM(LEXT)
Q
CH ; Chronological
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(LEXT) S LEXT="",LEXT=LEXT_$J(" ",(16-$L(LEXT)))_"IEN: "_LEXI D TL^LEXQHLM(LEXT)
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!(LEX2=5) D Q
. . . Q:+($G(LEXRAN))'>0 N LEXHD,LEXEC,LEXSTR,LEXCT S LEXHD=$$HD(LEX2),(LEXCT,LEXEC)=0,LEXSTR=""
. . . S LEX3=0 F S LEX3=$O(^TMP("LEXQHL",$J,LEX1,LEX2,LEX3)) Q:+LEX3'>0 D
. . . . N LEXN,LEXD,LEXM S LEXN=$G(^TMP("LEXQHL",$J,LEX1,LEX2,LEX3)),LEXD=$P(LEXN,U,1),LEXM=$P(LEXN,U,2)
. . . . S LEXEC=LEXEC+1 I LEXEC=1 D
. . . . . S LEXT=$S(LEXD'=LEXP:LEXD,1:""),LEXT=LEXT_$J(" ",(11-$L(LEXT)))_$S($L(LEXD):"- ",1:" ")_LEXHD,LEXT=" "_LEXT D TL^LEXQHLM(LEXT) S LEXCT=LEXCT+1
. . . . S:LEXD'="" LEXP=LEXD I ($L(LEXSTR)+$L(LEXM)+3)'>63 S LEXSTR=$$TM^LEXQHLM(LEXSTR_" "_LEXM) Q
. . . . I ($L(LEXSTR)+$L(LEXM)+3)>63 S LEXSTR=$$TM^LEXQHLM(LEXSTR),LEXT=$J(" ",11)_" "_LEXSTR,LEXT=" "_LEXT D TL^LEXQHLM(LEXT) S LEXCT=LEXCT+1 S LEXSTR=LEXM
. . . S LEXSTR=$$TM^LEXQHLM(LEXSTR) I $L(LEXSTR) D
. . . . S:$G(LEXL)=$G(LEXP)&($L(LEXP)) LEXL="" S:$L(LEXL) LEXP=LEXL S LEXT=$J(" ",11)_" "_LEXSTR,LEXT=" "_LEXT S LEXCT=LEXCT+1 D TL^LEXQHLM(LEXT)
. . N LEX3 S LEX3=0 F S LEX3=$O(^TMP("LEXQHL",$J,LEX1,LEX2,LEX3)) Q:+LEX3'>0 D
. . . N LEXN,LEXD,LEXS S LEXN=$G(^TMP("LEXQHL",$J,LEX1,LEX2,LEX3)),LEXD=$P(LEXN,U,1),LEXS=$P(LEXN,U,2)
. . . S LEXT=$S(LEXD'=LEXP:LEXD,1:""),LEXT=LEXT_$J(" ",(11-$L(LEXT)))_$S($L(LEXD):"- ",1:" ")_LEXS S LEXT=" "_LEXT D TL^LEXQHLM(LEXT)
. . . S:LEXD'="" LEXP=LEXD
Q
;
; Miscellaneous
IA(X) ; Initial Activation
N LEXEF,LEXH,LEXN,LEXS,LEXE,LEXIEN S LEXIEN=+($G(X)),LEXE="" Q:+LEXIEN'>0 "" Q:'$D(^DIC(81.3,+LEXIEN,60,0)) "" S LEXEF="" F S LEXEF=$O(^DIC(81.3,+LEXIEN,60,"B",LEXEF)) Q:'$L(LEXEF) D Q:$G(LEXE)?7N
. S LEXH=0 F S LEXH=$O(^DIC(81.3,+LEXIEN,60,"B",LEXEF,LEXH)) Q:+LEXH'>0 S LEXN=$G(^DIC(81.3,+LEXIEN,60,+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 "Modifier Name" Q:+($G(X))=3 "Description" Q:+($G(X))=4 "Activated Ranges" Q:+($G(X))=5 "Inactivated Ranges"
Q ""
LEXQHL4 ;ISL/KER - Query History - CPT Modifier Extract ;04/21/2014
+1 ;;2.0;LEXICON UTILITY;**62,80**;Sep 23, 1996;Build 10
+2 ;
+3 ; Global Variables
+4 ; ^DIC(81.3, ICR 4492
+5 ; ^TMP("LEXQHL") SACC 2.3.2.5.1
+6 ; ^TMP("LEXQHLA") SACC 2.3.2.5.1
+7 ;
+8 ; External References
+9 ; $$MOD^ICPTMOD ICR 1996
+10 ; $$UP^XLFSTR ICR 10104
+11 ;
+12 QUIT
EN(X,Y,LEX) ; CPT Modifier File
+1 NEW LEXDISP,LEXRAN,LEXIEN,LEXIA,LEXEF,LEXCT,LEXC
SET LEXIEN=$GET(X)
SET LEXDISP=$GET(Y)
SET LEXRAN=$GET(LEX)
SET LEXIA=""
IF +LEXIEN'>0
QUIT
IF '$DATA(^DIC(81.3,+LEXIEN,0))
QUIT
+2 SET LEXC=$PIECE($GET(^DIC(81.3,+LEXIEN,0)),U,1)
KILL ^TMP("LEXQHL",$JOB)
SET ^TMP("LEXQHL",$JOB,"IEN")=LEXIEN
SET ^TMP("LEXQHL",$JOB,"CODE")=LEXC
+3 SET ^TMP("LEXQHL",$JOB,"NAME")=$PIECE($$MOD^ICPTMOD(LEXIEN,"I"),U,3)
IF '$LENGTH(LEXDISP)
SET LEXDISP="SB"
DO ST
DO NM
DO DS
DO AR
DO IR
IF $LENGTH($GET(LEXDISP))
DO DP
+4 QUIT
ST ; 1 Status
+1 NEW LEXCT,LEXD,LEXE,LEXEF,LEXH,LEXMS,LEXN,LEXS,LEXT
+2 SET LEXCT=0
SET LEXEF=""
FOR
SET LEXEF=$ORDER(^DIC(81.3,+LEXIEN,60,"B",LEXEF))
IF '$LENGTH(LEXEF)
QUIT
Begin DoDot:1
+3 NEW LEXH
SET LEXH=0
FOR
SET LEXH=$ORDER(^DIC(81.3,+LEXIEN,60,"B",LEXEF,LEXH))
IF +LEXH'>0
QUIT
Begin DoDot:2
+4 NEW LEXN,LEXS,LEXE,LEXT,LEXD,LEXMS
SET LEXN=$GET(^DIC(81.3,+LEXIEN,60,+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,1)
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(^DIC(81.3,+LEXIEN,60,"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
NM ; 2 Modifier Name
+1 NEW LEX,LEXC,LEXCT,LEXD,LEXE,LEXEF,LEXH,LEXI,LEXN,LEXS,LEXT
+2 SET LEXCT=0
SET LEXEF=""
FOR
SET LEXEF=$ORDER(^DIC(81.3,+LEXIEN,61,"B",LEXEF))
IF '$LENGTH(LEXEF)
QUIT
Begin DoDot:1
+3 NEW LEXH
SET LEXH=0
FOR
SET LEXH=$ORDER(^DIC(81.3,+LEXIEN,61,"B",LEXEF,LEXH))
IF +LEXH'>0
QUIT
Begin DoDot:2
+4 NEW LEXN,LEXS,LEXE,LEXT,LEXD,LEX,LEXI
SET LEXN=$GET(^DIC(81.3,+LEXIEN,61,+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^LEXQHLM(.LEX,63)
+6 SET LEXS=$SELECT(+LEXCT=1:"Initial Modifier Name",+LEXCT>1:"Updated Modifier Name",1:"Modifier Name")
+7 IF $ORDER(^DIC(81.3,+LEXIEN,61,"B",LEXEF))=""&(LEXCT>1)
SET LEXT=LEXT_" (final Modifier Name 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
+2 SET LEXCT=0
SET LEXEF=""
FOR
SET LEXEF=$ORDER(^DIC(81.3,+LEXIEN,62,"B",LEXEF))
IF '$LENGTH(LEXEF)
QUIT
Begin DoDot:1
+3 NEW LEXH
SET LEXH=0
FOR
SET LEXH=$ORDER(^DIC(81.3,+LEXIEN,62,"B",LEXEF,LEXH))
IF +LEXH'>0
QUIT
Begin DoDot:2
+4 NEW LEXC,LEXN,LEXS,LEXE,LEXT,LEXD,LEX,LEXI
SET LEXN=$GET(^DIC(81.3,+LEXIEN,62,+LEXH,0))
+5 SET LEXE=$PIECE(LEXN,U,1)
SET (LEXC,LEXI)=0
FOR
SET LEXI=$ORDER(^DIC(81.3,+LEXIEN,62,+LEXH,1,LEXI))
IF +LEXI'>0
QUIT
Begin DoDot:3
+6 SET LEXT=$$TM^LEXQHLM($$UP^XLFSTR($GET(^DIC(81.3,+LEXIEN,62,+LEXH,1,LEXI,0))))
IF '$LENGTH(LEXT)
QUIT
SET LEXC=LEXC+1
SET LEX(LEXC)=LEXT
End DoDot:3
+7 SET LEXCT=LEXCT+1
DO PR^LEXQHLM(.LEX,63)
+8 SET LEXS=$SELECT(+LEXCT=1:"Initial Description",+LEXCT>1:"Updated Description",1:"Description")
+9 IF $ORDER(^DIC(81.3,+LEXIEN,62,"B",LEXEF))=""&(LEXCT>1)
SET LEXT=LEXT_" (final description change)"
+10 SET LEXD=$$SD^LEXQHLM(LEXE)
SET ^TMP("LEXQHL",$JOB,LEXEF,3,1)=LEXD_U_LEXS
+11 SET LEXI=0
FOR
SET LEXI=$ORDER(LEX(LEXI))
IF +LEXI'>0
QUIT
Begin DoDot:3
+12 NEW LEXC
SET LEXT=$GET(LEX(LEXI))
IF '$LENGTH(LEXT)
QUIT
SET LEXC=$ORDER(^TMP("LEXQHL",$JOB,LEXEF,3," "),-1)+1
+13 SET ^TMP("LEXQHL",$JOB,LEXEF,3,LEXC)=U_LEXT
End DoDot:3
End DoDot:2
End DoDot:1
+14 QUIT
AR ; 4 Active Ranges
+1 KILL ^TMP("LEXQHLA",$JOB)
NEW LEXACT,LEXAT,LEXATD,LEXB,LEXC,LEXD,LEXE,LEXI,LEXIA,LEXIAD,LEXICT,LEXN,LEXR
+2 SET (LEXACT,LEXICT)=0
SET LEXI=0
FOR
SET LEXI=$ORDER(^DIC(81.3,+LEXIEN,10,LEXI))
IF +LEXI'>0
QUIT
Begin DoDot:1
+3 NEW LEXN,LEXAT,LEXATD,LEXIA,LEXIAD,LEXB,LEXE,LEXR
SET LEXN=$GET(^DIC(81.3,+LEXIEN,10,+LEXI,0))
SET LEXB=$PIECE(LEXN,U,1)
IF $LENGTH(LEXB)'=5
QUIT
+4 SET LEXE=$PIECE(LEXN,U,2)
IF '$LENGTH(LEXE)
SET LEXE=LEXB
SET LEXAT=$PIECE(LEXN,U,3)
IF '$LENGTH(LEXAT)
QUIT
IF LEXAT'?7N
QUIT
SET LEXATD=$$SD^LEXQHLM(LEXAT)
IF '$LENGTH(LEXATD)
QUIT
+5 SET LEXIA=$PIECE(LEXN,U,4)
IF $LENGTH(LEXIA)
SET LEXIAD=$$SD^LEXQHLM(LEXIA)
IF $LENGTH($GET(LEXIA))&('$LENGTH($GET(LEXIAD)))
QUIT
SET LEXR=LEXB_" - "_LEXE
IF LEXIA?7N
QUIT
+6 SET LEXACT=LEXACT+1
SET ^TMP("LEXQHLA",$JOB,LEXAT,LEXACT)=LEXATD_U_LEXR
SET ^TMP("LEXQHLA",$JOB,"B",LEXR,LEXAT,LEXACT)=""
End DoDot:1
+7 SET LEXC=0
SET LEXB=""
FOR
SET LEXB=$ORDER(^TMP("LEXQHLA",$JOB,"B",LEXB))
IF '$LENGTH(LEXB)
QUIT
Begin DoDot:1
+8 NEW LEXAT
SET LEXAT=""
FOR
SET LEXAT=$ORDER(^TMP("LEXQHLA",$JOB,"B",LEXB,LEXAT))
IF '$LENGTH(LEXAT)
QUIT
Begin DoDot:2
+9 NEW LEXACT
SET LEXACT=0
FOR
SET LEXACT=$ORDER(^TMP("LEXQHLA",$JOB,"B",LEXB,LEXAT,LEXACT))
IF +LEXACT'>0
QUIT
Begin DoDot:3
+10 NEW LEXN,LEXD,LEXR
SET LEXN=$GET(^TMP("LEXQHLA",$JOB,LEXAT,LEXACT))
SET LEXD=$PIECE(LEXN,U,1)
SET LEXR=$PIECE(LEXN,U,2)
IF '$LENGTH(LEXD)
QUIT
IF '$LENGTH(LEXR)
QUIT
+11 SET LEXC=LEXC+1
SET ^TMP("LEXQHL",$JOB,LEXAT,4,LEXC)=LEXN
End DoDot:3
End DoDot:2
End DoDot:1
+12 KILL ^TMP("LEXQHLA",$JOB)
+13 QUIT
IR ; 5 Inactive Ranges
+1 KILL ^TMP("LEXQHLA",$JOB)
NEW LEXACT,LEXAT,LEXATD,LEXB,LEXC,LEXD,LEXE,LEXI,LEXIA,LEXIAD,LEXICT,LEXN,LEXR
+2 SET (LEXACT,LEXICT)=0
SET LEXI=0
FOR
SET LEXI=$ORDER(^DIC(81.3,+LEXIEN,10,LEXI))
IF +LEXI'>0
QUIT
Begin DoDot:1
+3 NEW LEXN,LEXAT,LEXATD,LEXIA,LEXIAD,LEXB,LEXE,LEXR
SET LEXN=$GET(^DIC(81.3,+LEXIEN,10,+LEXI,0))
SET LEXB=$PIECE(LEXN,U,1)
IF $LENGTH(LEXB)'=5
QUIT
+4 SET LEXE=$PIECE(LEXN,U,2)
IF '$LENGTH(LEXE)
SET LEXE=LEXB
SET LEXAT=$PIECE(LEXN,U,3)
IF '$LENGTH(LEXAT)
QUIT
IF LEXAT'?7N
QUIT
SET LEXATD=$$SD^LEXQHLM(LEXAT)
IF '$LENGTH(LEXATD)
QUIT
+5 SET LEXIA=$PIECE(LEXN,U,4)
IF $LENGTH(LEXIA)
SET LEXIAD=$$SD^LEXQHLM(LEXIA)
IF $LENGTH($GET(LEXIA))&('$LENGTH($GET(LEXIAD)))
QUIT
SET LEXR=LEXB_" - "_LEXE
IF LEXIA'?7N
QUIT
+6 SET LEXACT=LEXACT+1
SET ^TMP("LEXQHLA",$JOB,LEXAT,LEXACT)=LEXATD_U_LEXR
SET ^TMP("LEXQHLA",$JOB,"B",LEXR,LEXAT,LEXACT)=""
End DoDot:1
+7 SET LEXC=0
SET LEXB=""
FOR
SET LEXB=$ORDER(^TMP("LEXQHLA",$JOB,"B",LEXB))
IF '$LENGTH(LEXB)
QUIT
Begin DoDot:1
+8 NEW LEXAT
SET LEXAT=""
FOR
SET LEXAT=$ORDER(^TMP("LEXQHLA",$JOB,"B",LEXB,LEXAT))
IF '$LENGTH(LEXAT)
QUIT
Begin DoDot:2
+9 NEW LEXACT
SET LEXACT=0
FOR
SET LEXACT=$ORDER(^TMP("LEXQHLA",$JOB,"B",LEXB,LEXAT,LEXACT))
IF +LEXACT'>0
QUIT
Begin DoDot:3
+10 NEW LEXN,LEXD,LEXR
SET LEXN=$GET(^TMP("LEXQHLA",$JOB,LEXAT,LEXACT))
SET LEXD=$PIECE(LEXN,U,1)
SET LEXR=$PIECE(LEXN,U,2)
IF '$LENGTH(LEXD)
QUIT
IF '$LENGTH(LEXR)
QUIT
+11 SET LEXC=LEXC+1
SET ^TMP("LEXQHL",$JOB,LEXAT,5,LEXC)=LEXN
End DoDot:3
End DoDot:2
End DoDot:1
+12 KILL ^TMP("LEXQHLA",$JOB)
+13 QUIT
+14 ;
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 NEW LEX1,LEX2,LEX3,LEXC,LEXCT,LEXD,LEXE,LEXEC,LEXG,LEXHD,LEXI,LEXID,LEXM,LEXN,LEXN1,LEXN2,LEXN3,LEXO1,LEXO2,LEXO3,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(LEXT)
SET LEXT=""
SET LEXT=LEXT_$JUSTIFY(" ",(16-$LENGTH(LEXT)))_"IEN: "_LEXI
DO TL^LEXQHLM(LEXT)
+4 FOR LEXID=1:1:5
Begin DoDot:1
+5 NEW LEXHD,LEXCT,LEXEC
SET (LEXEC,LEXCT)=0
SET LEXHD=$$HD(LEXID)
IF '$LENGTH(LEXHD)
QUIT
SET LEXP=""
+6 SET LEX1=0
FOR
SET LEX1=$ORDER(^TMP("LEXQHL",$JOB,LEX1))
IF +LEX1'>0
QUIT
Begin DoDot:2
+7 SET LEXEC=LEXEC+1
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((" "_LEXHD))
SET LEXT=LEXE
SET LEXT=LEXT_$JUSTIFY(" ",(11-$LENGTH(LEXT)))_" "_LEXS
SET LEXT=" "_LEXT
DO TL^LEXQHLM(LEXT)
End DoDot:3
QUIT
+10 IF LEXID=4
Begin DoDot:3
+11 IF +($GET(LEXRAN))'>0
QUIT
NEW LEXP,LEX2,LEXSTR,LEXL
SET LEXSTR=""
SET (LEXL,LEXP)=""
SET LEX2=0
FOR
SET LEX2=$ORDER(^TMP("LEXQHL",$JOB,LEX1,4,LEX2))
IF +LEX2'>0
QUIT
Begin DoDot:4
+12 NEW LEXN,LEXD,LEXE,LEXM,LEXT
SET LEXN=$GET(^TMP("LEXQHL",$JOB,LEX1,4,LEX2))
SET (LEXE,LEXD,LEXL)=$PIECE(LEXN,U,1)
SET LEXM=$PIECE(LEXN,U,2)
IF '$LENGTH(LEXD)
QUIT
IF '$LENGTH(LEXM)
QUIT
+13 IF ($LENGTH(LEXSTR)+$LENGTH(LEXM)+3)'>63
SET LEXSTR=$$TM^LEXQHLM(LEXSTR_" "_LEXM)
QUIT
+14 IF ($LENGTH(LEXSTR)+$LENGTH(LEXM)+3)>63
Begin DoDot:5
+15 SET LEXSTR=$$TM^LEXQHLM(LEXSTR)
IF LEXD=LEXP
SET LEXD=""
IF $LENGTH(LEXE)
SET LEXP=LEXE
SET LEXT=LEXD
SET LEXT=LEXT_$JUSTIFY(" ",(11-$LENGTH(LEXT)))_" "_LEXSTR
SET LEXT=" "_LEXT
+16 SET LEXCT=LEXCT+1
IF LEXCT=1
DO BL^LEXQHLM
DO TL^LEXQHLM((" "_LEXHD))
DO TL^LEXQHLM(LEXT)
SET LEXSTR=LEXM
End DoDot:5
End DoDot:4
+17 SET LEXSTR=$$TM^LEXQHLM(LEXSTR)
IF $LENGTH(LEXSTR)
Begin DoDot:4
+18 IF $GET(LEXL)=$GET(LEXP)&($LENGTH(LEXP))
SET LEXL=""
IF $LENGTH(LEXL)
SET LEXP=LEXL
SET LEXT=LEXL
SET LEXT=LEXT_$JUSTIFY(" ",(11-$LENGTH(LEXT)))_" "_LEXSTR
SET LEXT=" "_LEXT
+19 SET LEXCT=LEXCT+1
IF LEXCT=1
DO BL^LEXQHLM
DO TL^LEXQHLM((" "_LEXHD))
DO TL^LEXQHLM(LEXT)
End DoDot:4
End DoDot:3
QUIT
+20 IF LEXID=5
Begin DoDot:3
+21 IF +($GET(LEXRAN))'>0
QUIT
NEW LEXP,LEX2,LEXSTR,LEXL
SET LEXSTR=""
SET (LEXL,LEXP)=""
SET LEX2=0
FOR
SET LEX2=$ORDER(^TMP("LEXQHL",$JOB,LEX1,5,LEX2))
IF +LEX2'>0
QUIT
Begin DoDot:4
+22 NEW LEXN,LEXD,LEXE,LEXM,LEXT
SET LEXN=$GET(^TMP("LEXQHL",$JOB,LEX1,5,LEX2))
+23 SET (LEXE,LEXD,LEXL)=$PIECE(LEXN,U,1)
SET LEXM=$PIECE(LEXN,U,2)
IF '$LENGTH(LEXD)
QUIT
IF '$LENGTH(LEXM)
QUIT
+24 IF ($LENGTH(LEXSTR)+$LENGTH(LEXM)+3)'>63
SET LEXSTR=$$TM^LEXQHLM(LEXSTR_" "_LEXM)
QUIT
+25 IF ($LENGTH(LEXSTR)+$LENGTH(LEXM)+3)>63
Begin DoDot:5
+26 SET LEXSTR=$$TM^LEXQHLM(LEXSTR)
IF LEXD=LEXP
SET LEXD=""
IF $LENGTH(LEXE)
SET LEXP=LEXE
SET LEXT=LEXD
SET LEXT=LEXT_$JUSTIFY(" ",(11-$LENGTH(LEXT)))_" "_LEXSTR
SET LEXT=" "_LEXT
+27 SET LEXCT=LEXCT+1
IF LEXCT=1
DO BL^LEXQHLM
DO TL^LEXQHLM((" "_LEXHD))
DO TL^LEXQHLM(LEXT)
SET LEXSTR=LEXM
End DoDot:5
End DoDot:4
+28 SET LEXSTR=$$TM^LEXQHLM(LEXSTR)
IF $LENGTH(LEXSTR)
Begin DoDot:4
+29 IF $GET(LEXL)=$GET(LEXP)&($LENGTH(LEXP))
SET LEXL=""
IF $LENGTH(LEXL)
SET LEXP=LEXL
SET LEXT=LEXL
SET LEXT=LEXT_$JUSTIFY(" ",(11-$LENGTH(LEXT)))_" "_LEXSTR
SET LEXT=" "_LEXT
+30 SET LEXCT=LEXCT+1
IF LEXCT=1
DO BL^LEXQHLM
DO TL^LEXQHLM((" "_LEXHD))
DO TL^LEXQHLM(LEXT)
End DoDot:4
End DoDot:3
QUIT
+31 NEW LEX2
SET LEX2=0
SET LEXE=""
FOR
SET LEX2=$ORDER(^TMP("LEXQHL",$JOB,LEX1,LEXID,LEX2))
IF +LEX2'>0
QUIT
Begin DoDot:3
+32 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
+33 IF LEX2=2
Begin DoDot:4
+34 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
+35 IF LEXCT=1
DO BL^LEXQHLM
DO TL^LEXQHLM((" "_LEXHD))
DO TL^LEXQHLM(LEXT)
End DoDot:4
QUIT
+36 IF LEX2>2
Begin DoDot:4
+37 SET LEXCT=LEXCT+1
SET LEXT=""
SET LEXS=$PIECE(LEXN,U,2)
SET LEXT=LEXT_$JUSTIFY(" ",(11-$LENGTH(LEXT)))_" "_LEXS
SET LEXT=" "_LEXT
+38 IF LEXCT=1
DO BL^LEXQHLM
DO TL^LEXQHLM((" "_LEXHD))
DO TL^LEXQHLM(LEXT)
End DoDot:4
QUIT
End DoDot:3
End DoDot:2
End DoDot:1
+39 QUIT
CH ; Chronological
+1 NEW LEX1,LEX2,LEX3,LEXC,LEXD,LEXDC,LEXI,LEXL1,LEXL2,LEXL3,LEXN,LEXP,LEXS,LEXT,LEXT1,LEXT2,LEXT3
+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(LEXT)
SET LEXT=""
SET LEXT=LEXT_$JUSTIFY(" ",(16-$LENGTH(LEXT)))_"IEN: "_LEXI
DO TL^LEXQHLM(LEXT)
+4 SET LEXP=""
SET LEX1=0
FOR
SET LEX1=$ORDER(^TMP("LEXQHL",$JOB,LEX1))
IF +LEX1'>0
QUIT
Begin DoDot:1
+5 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
+6 IF LEX2=4!(LEX2=5)
Begin DoDot:3
+7 IF +($GET(LEXRAN))'>0
QUIT
NEW LEXHD,LEXEC,LEXSTR,LEXCT
SET LEXHD=$$HD(LEX2)
SET (LEXCT,LEXEC)=0
SET LEXSTR=""
+8 SET LEX3=0
FOR
SET LEX3=$ORDER(^TMP("LEXQHL",$JOB,LEX1,LEX2,LEX3))
IF +LEX3'>0
QUIT
Begin DoDot:4
+9 NEW LEXN,LEXD,LEXM
SET LEXN=$GET(^TMP("LEXQHL",$JOB,LEX1,LEX2,LEX3))
SET LEXD=$PIECE(LEXN,U,1)
SET LEXM=$PIECE(LEXN,U,2)
+10 SET LEXEC=LEXEC+1
IF LEXEC=1
Begin DoDot:5
+11 SET LEXT=$SELECT(LEXD'=LEXP:LEXD,1:"")
SET LEXT=LEXT_$JUSTIFY(" ",(11-$LENGTH(LEXT)))_$SELECT($LENGTH(LEXD):"- ",1:" ")_LEXHD
SET LEXT=" "_LEXT
DO TL^LEXQHLM(LEXT)
SET LEXCT=LEXCT+1
End DoDot:5
+12 IF LEXD'=""
SET LEXP=LEXD
IF ($LENGTH(LEXSTR)+$LENGTH(LEXM)+3)'>63
SET LEXSTR=$$TM^LEXQHLM(LEXSTR_" "_LEXM)
QUIT
+13 IF ($LENGTH(LEXSTR)+$LENGTH(LEXM)+3)>63
SET LEXSTR=$$TM^LEXQHLM(LEXSTR)
SET LEXT=$JUSTIFY(" ",11)_" "_LEXSTR
SET LEXT=" "_LEXT
DO TL^LEXQHLM(LEXT)
SET LEXCT=LEXCT+1
SET LEXSTR=LEXM
End DoDot:4
+14 SET LEXSTR=$$TM^LEXQHLM(LEXSTR)
IF $LENGTH(LEXSTR)
Begin DoDot:4
+15 IF $GET(LEXL)=$GET(LEXP)&($LENGTH(LEXP))
SET LEXL=""
IF $LENGTH(LEXL)
SET LEXP=LEXL
SET LEXT=$JUSTIFY(" ",11)_" "_LEXSTR
SET LEXT=" "_LEXT
SET LEXCT=LEXCT+1
DO TL^LEXQHLM(LEXT)
End DoDot:4
End DoDot:3
QUIT
+16 NEW LEX3
SET LEX3=0
FOR
SET LEX3=$ORDER(^TMP("LEXQHL",$JOB,LEX1,LEX2,LEX3))
IF +LEX3'>0
QUIT
Begin DoDot:3
+17 NEW LEXN,LEXD,LEXS
SET LEXN=$GET(^TMP("LEXQHL",$JOB,LEX1,LEX2,LEX3))
SET LEXD=$PIECE(LEXN,U,1)
SET LEXS=$PIECE(LEXN,U,2)
+18 SET LEXT=$SELECT(LEXD'=LEXP:LEXD,1:"")
SET LEXT=LEXT_$JUSTIFY(" ",(11-$LENGTH(LEXT)))_$SELECT($LENGTH(LEXD):"- ",1:" ")_LEXS
SET LEXT=" "_LEXT
DO TL^LEXQHLM(LEXT)
+19 IF LEXD'=""
SET LEXP=LEXD
End DoDot:3
End DoDot:2
End DoDot:1
+20 QUIT
+21 ;
+22 ; Miscellaneous
IA(X) ; Initial Activation
+1 NEW LEXEF,LEXH,LEXN,LEXS,LEXE,LEXIEN
SET LEXIEN=+($GET(X))
SET LEXE=""
IF +LEXIEN'>0
QUIT ""
IF '$DATA(^DIC(81.3,+LEXIEN,60,0))
QUIT ""
SET LEXEF=""
FOR
SET LEXEF=$ORDER(^DIC(81.3,+LEXIEN,60,"B",LEXEF))
IF '$LENGTH(LEXEF)
QUIT
Begin DoDot:1
+2 SET LEXH=0
FOR
SET LEXH=$ORDER(^DIC(81.3,+LEXIEN,60,"B",LEXEF,LEXH))
IF +LEXH'>0
QUIT
SET LEXN=$GET(^DIC(81.3,+LEXIEN,60,+LEXH,0))
IF +($PIECE(LEXN,U,2))>0
SET LEXE=$PIECE(LEXN,U,1)
IF $GET(LEXE)?7N
QUIT
End DoDot:1
IF $GET(LEXE)?7N
QUIT
+3 SET X=""
IF $GET(LEXE)?7N
SET X=$GET(LEXE)
+4 QUIT X
HD(X) ; Header
+1 IF +($GET(X))=1
QUIT "Status"
IF +($GET(X))=2
QUIT "Modifier Name"
IF +($GET(X))=3
QUIT "Description"
IF +($GET(X))=4
QUIT "Activated Ranges"
IF +($GET(X))=5
QUIT "Inactivated Ranges"
+2 QUIT ""
