- LEXQHL4 ;ISL/KER - Query History - CPT Modifier Extract ;05/23/2017
- ;;2.0;LEXICON UTILITY;**62,80,103**;Sep 23, 1996;Build 2
- ;
- ; 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^LEXU(.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^LEXU(.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,LEXIA,LEXACT)=LEXIAD_U_LEXR,^TMP("LEXQHLA",$J,"B",LEXR,LEXIA,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
- D ATTR^LEXQM 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(($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: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 S LEXE=$G(BOLD)_LEXE_$G(NORM)
- . . . D:LEXCT=1 BL^LEXQHLM,TL^LEXQHLM(($G(BOLD)_" "_LEXHD_$G(NORM)))
- . . . 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($$TM^LEXQHLM(LEXD)) LEXD=$G(BOLD)_LEXD_$G(NORM)
- . . . . . 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(($G(BOLD)_" "_LEXHD_$G(NORM))) 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:$L($$TM^LEXQHLM(LEXL)) LEXL=$G(BOLD)_LEXL_$G(NORM)
- . . . . S LEXT=LEXL,LEXT=LEXT_$J(" ",(11-$L(LEXT)))_" "_LEXSTR,LEXT=" "_LEXT
- . . . . S LEXCT=LEXCT+1 D:LEXCT=1 BL^LEXQHLM,TL^LEXQHLM(($G(BOLD)_" "_LEXHD_$G(NORM))) 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($$TM^LEXQHLM(LEXD)) LEXD=$G(BOLD)_LEXD_$G(NORM)
- . . . . . 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(($G(BOLD)_" "_LEXHD_$G(NORM))) 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
- . . . . S LEXT=LEXT_$J(" ",(11-$L(LEXT)))_" "_LEXSTR,LEXT=" "_LEXT
- . . . . S LEXCT=LEXCT+1 D:LEXCT=1 BL^LEXQHLM,TL^LEXQHLM(($G(BOLD)_" "_LEXHD_$G(NORM))) 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
- . . . . N LEXD S LEXD=LEXE S:$L($$TM^LEXQHLM(LEXD)) LEXD=$G(BOLD)_LEXD_$G(NORM) S LEXCT=LEXCT+1,LEXT=$G(LEXD)
- . . . . S LEXS=$P(LEXN,U,2),LEXT=LEXT_$J(" ",(11-$L(LEXT)))_" "_LEXS,LEXT=" "_LEXT
- . . . . D:LEXCT=1 BL^LEXQHLM,TL^LEXQHLM(($G(BOLD)_" "_LEXHD_$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)_" "_LEXHD_$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!(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,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)
- . . . . S LEXEC=LEXEC+1 I LEXEC=1 D
- . . . . . S LEXT=$S(LEXD'=LEXP:LEXD,1:""),LEXT=LEXT_$J(" ",(11-$L(LEXT)))_LEXSPC_$G(BOLD)_LEXHD_$G(NORM),LEXT=" "_LEXT D TL^LEXQHLM(LEXT) S LEXCT=LEXCT+1
- . . . . S:LEXD'="" LEXP=LEXD I ($L(LEXSTR)+$L(LEXS)+3)'>63 S LEXSTR=$$TM^LEXQHLM(LEXSTR_" "_LEXS)
- . . . . I ($L(LEXSTR)+$L(LEXS)+3)>63 S LEXSTR=$$TM^LEXQHLM(LEXSTR),LEXT=$J(" ",11)_" "_LEXSTR,LEXT=" "_LEXT D TL^LEXQHLM(LEXT) S LEXSTR="",LEXCT=LEXCT+1
- . . . 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,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)))_$S($L(LEXD):"- ",1:" ")_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 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 ""
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLEXQHL4 12998 printed Feb 18, 2025@23:34:47 Page 2
- LEXQHL4 ;ISL/KER - Query History - CPT Modifier Extract ;05/23/2017
- +1 ;;2.0;LEXICON UTILITY;**62,80,103**;Sep 23, 1996;Build 2
- +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^LEXU(.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^LEXU(.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,LEXIA,LEXACT)=LEXIAD_U_LEXR
- SET ^TMP("LEXQHLA",$JOB,"B",LEXR,LEXIA,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 DO ATTR^LEXQM
- 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(($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:5
- Begin DoDot:1
- +6 NEW LEXHD,LEXCT,LEXEC
- SET (LEXEC,LEXCT)=0
- SET LEXHD=$$HD(LEXID)
- if '$LENGTH(LEXHD)
- QUIT
- SET LEXP=""
- +7 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)
- +10 if '$LENGTH(LEXE)
- QUIT
- if '$LENGTH(LEXS)
- QUIT
- SET LEXCT=LEXCT+1
- SET LEXE=$GET(BOLD)_LEXE_$GET(NORM)
- +11 if LEXCT=1
- DO BL^LEXQHLM
- DO TL^LEXQHLM(($GET(BOLD)_" "_LEXHD_$GET(NORM)))
- +12 SET LEXT=LEXE
- SET LEXT=LEXT_$JUSTIFY(" ",(11-$LENGTH(LEXT)))_" "_LEXS
- SET LEXT=" "_LEXT
- DO TL^LEXQHLM(LEXT)
- End DoDot:3
- QUIT
- +13 IF LEXID=4
- Begin DoDot:3
- +14 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
- +15 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
- +16 IF ($LENGTH(LEXSTR)+$LENGTH(LEXM)+3)'>63
- SET LEXSTR=$$TM^LEXQHLM(LEXSTR_" "_LEXM)
- QUIT
- +17 IF ($LENGTH(LEXSTR)+$LENGTH(LEXM)+3)>63
- Begin DoDot:5
- +18 SET LEXSTR=$$TM^LEXQHLM(LEXSTR)
- if LEXD=LEXP
- SET LEXD=""
- if $LENGTH($$TM^LEXQHLM(LEXD))
- SET LEXD=$GET(BOLD)_LEXD_$GET(NORM)
- +19 if $LENGTH(LEXE)
- SET LEXP=LEXE
- SET LEXT=LEXD
- SET LEXT=LEXT_$JUSTIFY(" ",(11-$LENGTH(LEXT)))_" "_LEXSTR
- SET LEXT=" "_LEXT
- +20 SET LEXCT=LEXCT+1
- if LEXCT=1
- DO BL^LEXQHLM
- DO TL^LEXQHLM(($GET(BOLD)_" "_LEXHD_$GET(NORM)))
- DO TL^LEXQHLM(LEXT)
- SET LEXSTR=LEXM
- End DoDot:5
- End DoDot:4
- +21 SET LEXSTR=$$TM^LEXQHLM(LEXSTR)
- IF $LENGTH(LEXSTR)
- Begin DoDot:4
- +22 if $GET(LEXL)=$GET(LEXP)&($LENGTH(LEXP))
- SET LEXL=""
- if $LENGTH(LEXL)
- SET LEXP=LEXL
- if $LENGTH($$TM^LEXQHLM(LEXL))
- SET LEXL=$GET(BOLD)_LEXL_$GET(NORM)
- +23 SET LEXT=LEXL
- SET LEXT=LEXT_$JUSTIFY(" ",(11-$LENGTH(LEXT)))_" "_LEXSTR
- SET LEXT=" "_LEXT
- +24 SET LEXCT=LEXCT+1
- if LEXCT=1
- DO BL^LEXQHLM
- DO TL^LEXQHLM(($GET(BOLD)_" "_LEXHD_$GET(NORM)))
- DO TL^LEXQHLM(LEXT)
- End DoDot:4
- End DoDot:3
- QUIT
- +25 IF LEXID=5
- Begin DoDot:3
- +26 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
- +27 NEW LEXN,LEXD,LEXE,LEXM,LEXT
- SET LEXN=$GET(^TMP("LEXQHL",$JOB,LEX1,5,LEX2))
- +28 SET (LEXE,LEXD,LEXL)=$PIECE(LEXN,U,1)
- SET LEXM=$PIECE(LEXN,U,2)
- if '$LENGTH(LEXD)
- QUIT
- if '$LENGTH(LEXM)
- QUIT
- +29 IF ($LENGTH(LEXSTR)+$LENGTH(LEXM)+3)'>63
- SET LEXSTR=$$TM^LEXQHLM(LEXSTR_" "_LEXM)
- QUIT
- +30 IF ($LENGTH(LEXSTR)+$LENGTH(LEXM)+3)>63
- Begin DoDot:5
- +31 SET LEXSTR=$$TM^LEXQHLM(LEXSTR)
- if LEXD=LEXP
- SET LEXD=""
- if $LENGTH($$TM^LEXQHLM(LEXD))
- SET LEXD=$GET(BOLD)_LEXD_$GET(NORM)
- +32 if $LENGTH(LEXE)
- SET LEXP=LEXE
- SET LEXT=LEXD
- SET LEXT=LEXT_$JUSTIFY(" ",(11-$LENGTH(LEXT)))_" "_LEXSTR
- SET LEXT=" "_LEXT
- +33 SET LEXCT=LEXCT+1
- if LEXCT=1
- DO BL^LEXQHLM
- DO TL^LEXQHLM(($GET(BOLD)_" "_LEXHD_$GET(NORM)))
- DO TL^LEXQHLM(LEXT)
- SET LEXSTR=LEXM
- End DoDot:5
- End DoDot:4
- +34 SET LEXSTR=$$TM^LEXQHLM(LEXSTR)
- IF $LENGTH(LEXSTR)
- Begin DoDot:4
- +35 if $GET(LEXL)=$GET(LEXP)&($LENGTH(LEXP))
- SET LEXL=""
- if $LENGTH(LEXL)
- SET LEXP=LEXL
- SET LEXT=LEXL
- +36 SET LEXT=LEXT_$JUSTIFY(" ",(11-$LENGTH(LEXT)))_" "_LEXSTR
- SET LEXT=" "_LEXT
- +37 SET LEXCT=LEXCT+1
- if LEXCT=1
- DO BL^LEXQHLM
- DO TL^LEXQHLM(($GET(BOLD)_" "_LEXHD_$GET(NORM)))
- DO TL^LEXQHLM(LEXT)
- End DoDot:4
- End DoDot:3
- QUIT
- +38 NEW LEX2
- SET LEX2=0
- SET LEXE=""
- FOR
- SET LEX2=$ORDER(^TMP("LEXQHL",$JOB,LEX1,LEXID,LEX2))
- if +LEX2'>0
- QUIT
- Begin DoDot:3
- +39 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
- +40 IF LEX2=2
- Begin DoDot:4
- +41 NEW LEXD
- SET LEXD=LEXE
- if $LENGTH($$TM^LEXQHLM(LEXD))
- SET LEXD=$GET(BOLD)_LEXD_$GET(NORM)
- SET LEXCT=LEXCT+1
- SET LEXT=$GET(LEXD)
- +42 SET LEXS=$PIECE(LEXN,U,2)
- SET LEXT=LEXT_$JUSTIFY(" ",(11-$LENGTH(LEXT)))_" "_LEXS
- SET LEXT=" "_LEXT
- +43 if LEXCT=1
- DO BL^LEXQHLM
- DO TL^LEXQHLM(($GET(BOLD)_" "_LEXHD_$GET(NORM)))
- DO TL^LEXQHLM(LEXT)
- End DoDot:4
- QUIT
- +44 IF LEX2>2
- Begin DoDot:4
- +45 SET LEXCT=LEXCT+1
- SET LEXT=""
- SET LEXS=$PIECE(LEXN,U,2)
- SET LEXT=LEXT_$JUSTIFY(" ",(11-$LENGTH(LEXT)))_" "_LEXS
- SET LEXT=" "_LEXT
- +46 if LEXCT=1
- DO BL^LEXQHLM
- DO TL^LEXQHLM(($GET(BOLD)_" "_LEXHD_$GET(NORM)))
- DO TL^LEXQHLM(LEXT)
- End DoDot:4
- QUIT
- End DoDot:3
- End DoDot:2
- End DoDot:1
- +47 DO KATTR^LEXQM
- +48 QUIT
- CH ; Chronological
- +1 DO ATTR^LEXQM
- 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(($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,LEXDC
- SET (LEXDC,LEX2)=0
- FOR
- SET LEX2=$ORDER(^TMP("LEXQHL",$JOB,LEX1,LEX2))
- if +LEX2'>0
- QUIT
- Begin DoDot:2
- +7 IF LEX2=4!(LEX2=5)
- Begin DoDot:3
- +8 if +($GET(LEXRAN))'>0
- QUIT
- NEW LEXHD,LEXEC,LEXSTR,LEXCT
- SET LEXHD=$$HD(LEX2)
- SET (LEXCT,LEXEC)=0
- SET LEXSTR=""
- +9 SET LEX3=0
- FOR
- SET LEX3=$ORDER(^TMP("LEXQHL",$JOB,LEX1,LEX2,LEX3))
- if +LEX3'>0
- QUIT
- Begin DoDot:4
- +10 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=" "
- +11 IF $LENGTH($$TM^LEXQM(LEXD))
- SET LEXD=$GET(BOLD)_LEXD_$GET(NORM)
- SET LEXSPC=$GET(BOLD)_"- "_$GET(NORM)
- +12 SET LEXEC=LEXEC+1
- IF LEXEC=1
- Begin DoDot:5
- +13 SET LEXT=$SELECT(LEXD'=LEXP:LEXD,1:"")
- SET LEXT=LEXT_$JUSTIFY(" ",(11-$LENGTH(LEXT)))_LEXSPC_$GET(BOLD)_LEXHD_$GET(NORM)
- SET LEXT=" "_LEXT
- DO TL^LEXQHLM(LEXT)
- SET LEXCT=LEXCT+1
- End DoDot:5
- +14 if LEXD'=""
- SET LEXP=LEXD
- IF ($LENGTH(LEXSTR)+$LENGTH(LEXS)+3)'>63
- SET LEXSTR=$$TM^LEXQHLM(LEXSTR_" "_LEXS)
- +15 IF ($LENGTH(LEXSTR)+$LENGTH(LEXS)+3)>63
- SET LEXSTR=$$TM^LEXQHLM(LEXSTR)
- SET LEXT=$JUSTIFY(" ",11)_" "_LEXSTR
- SET LEXT=" "_LEXT
- DO TL^LEXQHLM(LEXT)
- SET LEXSTR=""
- SET LEXCT=LEXCT+1
- End DoDot:4
- +16 SET LEXSTR=$$TM^LEXQHLM(LEXSTR)
- IF $LENGTH(LEXSTR)
- Begin DoDot:4
- +17 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
- +18 NEW LEX3
- SET LEX3=0
- FOR
- SET LEX3=$ORDER(^TMP("LEXQHL",$JOB,LEX1,LEX2,LEX3))
- if +LEX3'>0
- QUIT
- Begin DoDot:3
- +19 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=" "
- +20 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)
- +21 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)
- +22 if LEXD'=""
- SET LEXP=LEXD
- End DoDot:3
- End DoDot:2
- End DoDot:1
- +23 DO KATTR^LEXQM
- +24 QUIT
- +25 ;
- +26 ; 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 ""