LEXQCM2 ;ISL/KER - Query - CPT Modifiers - Save ;05/23/2017
;;2.0;LEXICON UTILITY;**62,80,103**;Sep 23, 1996;Build 2
;
; Global Variables
; ^DIC(81.3, ICR 4492
; ^TMP("LEXQCM" SACC 2.3.2.5.1
; ^TMP("LEXQCMO" SACC 2.3.2.5.1
;
; External References
; $$DT^XLFDT ICR 10103
; $$UP^XLFSTR ICR 10104
;
; Variables NEWed or KILLed Elsewhere
; LEXIEN Modifier IEN
; LEXELDT External Last Date
; LEXLEN Offset Length
; LEXIIEN Include IENs flag
; LEXINC Include Modifier Ranges flag
; LEXINCI Include Inactive Modifier Ranges flag
; LEXINCF Include Future Modifier Ranges flag
; LEXGET Array of Non-Versioned Data
; LEXST CPT Status and Effective Dates
; LEXSD Versioned Short Description
; LEXLD Versioned Long Description
; LEXRAN Number of Ranges/Comment
; ^TMP("LEXQCM",$J,"RANGES",#) List of Ranges
;
EN ; Main Entry Point
K ^TMP("LEXQCMO",$J) Q:'$L($G(LEXELDT))
I +($G(LEXST))<0 D FUT D:$D(^TMP("LEXQCMO",$J)) DSP^LEXQO("LEXQCMO") Q
D FUL D:$D(^TMP("LEXQCMO",$J)) DSP^LEXQO("LEXQCMO")
Q
FUT ; Future Activation
N LEX1,LEX2,LEX3,LEXEFF,LEXI,LEXL,LEXNAM,LEXSO,LEXSTA S LEXI=+($G(LEXIEN)) Q:+LEXI'>0 Q:'$D(^DIC(81.3,+LEXI,0)) S LEXL=+($G(LEXLEN)) Q:+LEXL'>0
S:LEXL>62 LEXL=62 S LEXSO=$G(LEXGET(81.3,(+LEXI_","),.01,"E")) Q:'$L(LEXSO) S LEXNAM=$G(LEXGET(81.3,(+LEXI_","),"B")) Q:'$L(LEXNAM)
S LEXSTA=$G(LEXST),LEXEFF=$P(LEXSTA,"^",5),LEXSTA=$P(LEXSTA,"^",4) Q:'$L(LEXSTA) Q:'$L(LEXEFF) S (LEX1,LEX2,LEX3)=""
D BOD(LEXELDT),COD(LEXSO,LEXNAM,+($G(LEXL))),STA(.LEXST,+($G(LEXL)))
Q
BOD(X) ; Based on Date
N LEXBOD S LEXBOD=$G(X) Q:'$L(LEXBOD) Q:LEXBOD'["/" S X="Display based on date: "_LEXBOD D BL,TL(X)
Q
COD(X,Y,LEXLEN) ; Code Line
N LEXC,LEXN,LEXL,LEXT,LEXI,LEXTX,LEXTXT,LEXNAM,LEXIEN S LEXC=$G(X),LEXN=$G(Y),LEXIEN=+($P(LEXN," (IEN ",2)),LEXNAM=$P(LEXN," (IEN ",1)
S:$D(LEXIIEN)&(+LEXIEN>0)&($L(LEXNAM)) LEXNAM=LEXNAM_" (IEN "_LEXIEN_")" S LEXL=+($G(LEXLEN)) S:+LEXL'>0!(LEXL>61) LEXL=61
S LEXTX(1)=LEXNAM D PR^LEXU(.LEXTX,+($G(LEXL))) S LEXTXT=$G(LEXTX(1))
S LEXT="Code: "_LEXC,LEXT=LEXT_$J(" ",((79-+($G(LEXLEN)))-$L(LEXT)))_LEXTXT D BL,TL(LEXT)
S LEXI=1 F S LEXI=$O(LEXTX(LEXI)) Q:+LEXI'>0 D
. N LEXT,LEXTXT S LEXTXT=$G(LEXTX(LEXI)) Q:'$L(LEXTXT)
. S LEXT="",LEXT=LEXT_$J(" ",((79-+($G(LEXLEN)))-$L(LEXT)))_LEXTXT D TL(LEXT)
Q
STA(X,LEXLEN) ; Status Line
N LEX,LEXC,LEXI,LEXN,LEXX,LEXE,LEXS,LEXT,LEXW,LEXEFF,LEXSTA S LEXX=$G(X),LEXEFF=$P(LEXX,"^",5),LEXSTA=$P(LEXX,"^",4),LEXEFF=$TR(LEXEFF,"()","")
S LEXW=$P(LEXX,"^",6),LEXT=" Status: ",LEXT=LEXT_$J(" ",((79-+($G(LEXLEN)))-$L(LEXT))),LEXT=LEXT_LEXSTA
S LEXT=LEXT_$J(" ",(35-$L(LEXT))) S:LEXEFF'["future" LEXT=LEXT_"Effective: "
S LEXT=LEXT_$$UP^XLFSTR($E(LEXEFF,1))_$E(LEXEFF,2,$L(LEXEFF)) D BL,TL(LEXT)
I $L(LEXW) D
. N LEX,LEXT,LEXC,LEXI,LEXN S LEX(1)=LEXW D PR^LEXU(.LEX,(+($G(LEXLEN))-7)) Q:+($O(LEX(" "),-1))'>0
. S LEXT=$J(" ",((79-+($G(LEXLEN)))))
. S (LEXC,LEXI)=0 F S LEXI=$O(LEX(LEXI)) Q:+LEXI'>0 D
. . N LEXN S LEXN=$$TM^LEXQM($G(LEX(LEXI))) S:$L(LEXN) LEXC=LEXC+1 D:LEXC=1 BL D TL((LEXT_LEXN))
Q
;
FUL ; Full Display
N LEXFUL,LEX,LEXL S LEXL=+($G(LEXLEN)) S:LEXL>62 LEXL=62
S LEXFUL="" D FUT
D SD(.LEXSD,+($G(LEXL))),LD(.LEXLD,+($G(LEXL))),WN(.LEXWN,+($G(LEXL)))
D:+($G(LEXRAN))>0&($L($P($G(LEXRAN),"^",2)))&($O(^TMP("LEXQCM",$J,"RANGES",0))>0) RAN(.LEXRAN,+($G(LEXL)))
Q
SD(X,LEXLEN) ; Short Description
N LEXI,LEXH,LEXE,LEXL,LEXTX,LEXTXT,LEXN,LEXT Q:'$D(X(1)) S LEXN=$G(X(1)),LEXT=" Short Name: "
S LEXL=+($G(LEXLEN)) S:+LEXL'>0!(LEXL>63) LEXL=63 S LEXI=0 F S LEXI=$O(X(LEXI)) Q:+LEXI'>0 S LEXTX(LEXI)=$G(X(LEXI))
D PR^LEXU(.LEXTX,+($G(LEXL))) S LEXTXT=$G(LEXTX(1))
S LEXT=LEXT_$J(" ",((79-+($G(LEXLEN)))-$L(LEXT)))_LEXTXT D BL,TL(LEXT)
S LEXE=$G(X(0)),LEXT=" "_LEXE,LEXN=$G(LEXTX(2)),LEXT=LEXT_$J(" ",((79-+($G(LEXLEN)))-$L(LEXT)))_LEXN D TL(LEXT)
Q
LD(X,LEXLEN) ; Long Description
N LEXI,LEXH,LEXE,LEXN,LEXT Q:'$D(X(1)) S LEXN=$G(X(1)),LEXT=" Description: ",LEXT=LEXT_$J(" ",((79-+($G(LEXLEN)))-$L(LEXT)))_LEXN D BL,TL(LEXT)
S LEXE=$G(X(0)),LEXT=" "_LEXE,LEXN=$G(X(2)),LEXT=LEXT_$J(" ",((79-+($G(LEXLEN)))-$L(LEXT)))_LEXN D TL(LEXT)
S LEXT=$J(" ",((79-+($G(LEXLEN))))) S LEXI=2 F S LEXI=$O(X(LEXI)) Q:+LEXI'>0 S LEXN=LEXT_$G(X(LEXI)) D TL(LEXN)
Q
WN(X,LEXLEN) ; Warning
N LEXI,LEXH,LEXE,LEXN,LEXT,LEXC Q:'$D(X(1)) S LEXC=0,LEXN=$G(X(1)),LEXT="",LEXT=LEXT_$J(" ",((79-+($G(LEXLEN)))-$L(LEXT)))_LEXN D BL,TL(LEXT)
S LEXT=$J(" ",((79-+($G(LEXLEN))))),LEXI=1 F S LEXI=$O(X(LEXI)) Q:+LEXI'>0 S LEXN=LEXT_$G(X(LEXI)) D TL(LEXN)
Q
RAN(X,LEXLEN) ; Code Ranges
N LEXC,LEXH,LEXI,LEXN,LEXS,LEXT S LEXH=$G(X),LEXN=+LEXH,LEXH=$P(LEXH,"^",2) Q:+LEXN'>0 Q:'$L(LEXH)
S LEXT=" Code Ranges: ",LEXT=LEXT_$J(" ",((79-+($G(LEXLEN)))-$L(LEXT)))_LEXH,LEXN=$J(" ",((79-+($G(LEXLEN))))) D BL,TL(LEXT)
S (LEXC,LEXI)=0 F S LEXI=$O(^TMP("LEXQCM",$J,"RANGES",LEXI)) Q:+LEXI'>0 D
. S LEXC=LEXC+1 D:LEXC=1 BL S LEXT=$G(^TMP("LEXQCM",$J,"RANGES",LEXI)) Q:'$L(LEXT) D TL((LEXN_LEXT))
Q
CCR(X,LEXVDT,LEX,LEXLEN,LEXINCI,LEXINCF) ; CPT Code Ranges
;
; LEX=# of Ranges
; ^TMP("LEXQCM",$J,"RANGES",#)=Begin_End_Act_Inact
;
K ^TMP("LEXQCM",$J,"RAN"),^TMP("LEXQCM",$J,"RANGES")
N LEXC,LEXEVDT,LEXFD,LEXFN,LEXH1,LEXH2,LEXH3,LEXIEN,LEXL,LEXN,LEXP,LEXR0,LEXRA,LEXRA1,LEXRA2,LEXRB,LEXRDA,LEXRDI,LEXRE,LEXRI,LEXRI1,LEXRI2,LEXRN,LEXRT,LEXRX,LEXT
S LEXIEN=$G(X) Q:+LEXIEN'>0 Q:'$D(^DIC(81.3,+LEXIEN,0)) Q:$O(^DIC(81.3,+LEXIEN,10,0))'>0 S LEXVDT=+($G(LEXVDT)) S:LEXVDT'?7N LEXVDT=$$DT^XLFDT S LEXEVDT=$$SD^LEXQM(LEXVDT),LEXLEN=+($G(LEXLEN))
S:+LEXLEN'>0 LEXLEN=62 Q:'$L(LEXEVDT) S LEXINCI=+($G(LEXINCI)),LEXINCF=+($G(LEXINCF)) S (LEXFD,LEXRX)=0 F S LEXRX=$O(^DIC(81.3,+LEXIEN,10,LEXRX)) Q:+LEXRX'>0 D
. S LEXR0=$G(^DIC(81.3,+LEXIEN,10,LEXRX,0)),LEXRB=$P(LEXR0,"^",1) Q:$L(LEXRB)'=5 S LEXRE=$P(LEXR0,"^",2) S:$L(LEXRB)&('$L(LEXRE)) LEXRE=LEXRB Q:$L(LEXRE)'=5
. S LEXRA=$P(LEXR0,"^",3) Q:LEXRA'?7N S LEXRI=$P(LEXR0,"^",4) Q:+LEXRA>0&(LEXVDT<+($G(LEXRA)))&(+($G(LEXINCF))'>0) Q:+LEXRI>0&(LEXVDT>+($G(LEXRI)))&(+($G(LEXINCI))'>0)
. S LEXRN=$$NUM(LEXRB),LEXRT=LEXRB_"^"_LEXRE_"^"_LEXRA_"^"_LEXRI,LEXRA1=$S(LEXVDT<LEXRA:"<",1:" "),LEXRA2=$S(LEXVDT<LEXRA:">",1:" ")
. S LEXRI1=$S(LEXVDT<LEXRI:"<",1:" "),LEXRI2=$S(LEXVDT<LEXRI:">",1:" ") S:LEXRA1["<"!(LEXRA2[">")!(LEXRI1["<")!(LEXRI2[">") LEXFD=1
. S LEXRDA=$S($L(LEXRA):(LEXRA1_$$SD^LEXQM(LEXRA)_LEXRA2),1:""),LEXRDI=$S($L(LEXRI):(LEXRI1_$$SD^LEXQM(LEXRI)_LEXRI2),1:"")
. S ^TMP("LEXQCM",$J,"RAN",LEXRN,LEXRT)=LEXRB_" "_LEXRE_" "_LEXRDA_" "_LEXRDI
S LEXH1="CPT Code Range Effective Dates",LEXH2="Begin End Active Inactive",LEXH3="----- ----- ---------- ----------"
K LEX S (LEX,LEXL,LEXC,LEXRN)=0 S LEXFN="" S:+($G(LEXFD))>0 LEXFN=" Future dates indicated as '<mm/dd/yyyy>'"
S LEXC=0 F S LEXRN=$O(^TMP("LEXQCM",$J,"RAN",LEXRN)) Q:+LEXRN'>0 S LEXRT="" F S LEXRT=$O(^TMP("LEXQCM",$J,"RAN",LEXRN,LEXRT)) Q:'$L(LEXRT) D
. S LEXT=$G(^TMP("LEXQCM",$J,"RAN",LEXRN,LEXRT)) Q:'$L(LEXT) S LEXC=LEXC+1 I LEXC=1 D
. . S LEXN=$O(^TMP("LEXQCM",$J,"RANGES"," "),-1)+1,^TMP("LEXQCM",$J,"RANGES",LEXN)=LEXH1 S LEXN=$O(^TMP("LEXQCM",$J,"RANGES"," "),-1)+1,^TMP("LEXQCM",$J,"RANGES",LEXN)=LEXH2
. . S LEXN=$O(^TMP("LEXQCM",$J,"RANGES"," "),-1)+1,^TMP("LEXQCM",$J,"RANGES",LEXN)=LEXH3 S ^TMP("LEXQCM",$J,"RANGES",0)=LEXN
. S LEX=+($G(LEX))+1 S LEXN=$O(^TMP("LEXQCM",$J,"RANGES"," "),-1)+1,^TMP("LEXQCM",$J,"RANGES",LEXN)=LEXT,^TMP("LEXQCM",$J,"RANGES",0)=LEXN
I $L(LEXFN) D
. S LEXN=$O(^TMP("LEXQCM",$J,"RANGES"," "),-1)+1,^TMP("LEXQCM",$J,"RANGES",LEXN)=" ",^TMP("LEXQCM",$J,"RANGES",0)=LEXN
. S LEXN=$O(^TMP("LEXQCM",$J,"RANGES"," "),-1)+1,^TMP("LEXQCM",$J,"RANGES",LEXN)=LEXFN,^TMP("LEXQCM",$J,"RANGES",0)=LEXN
K ^TMP("LEXQCM",$J,"RAN") S LEXT="" I +LEX>0 D
. N LEXP,LEXT S LEXP=$S(+LEX>1:"s",1:""),LEXT="" S:+($G(LEXINCI))>0&(+($G(LEXINCF))>0) LEXT=+LEX_" Current and future Active or Inactive range"_LEXP_" found"
. S:+($G(LEXINCI))>0&(+($G(LEXINCF))'>0) LEXT=+LEX_" Currently Active or Inactive range"_LEXP_" found" S:+($G(LEXINCI))'>0&(+($G(LEXINCF))>0) LEXT=+LEX_" Current and future Active range"_LEXP_" found"
. S:+($G(LEXINCI))'>0&(+($G(LEXINCF))'>0) LEXT=+LEX_" Currently Active range"_LEXP_" found" S:$L(LEXT) LEX=LEX_"^"_LEXT
Q
;
; Miscellaneous
BL ; Blank Line
D TL(" ") Q
TL(X) ; Text Line
I $D(LEXTEST) W !,$G(X) Q
N LEXI S LEXI=+($O(^TMP("LEXQCMO",$J," "),-1))+1 S ^TMP("LEXQCMO",$J,LEXI)=$G(X),^TMP("LEXQCMO",$J,0)=LEXI
Q
NUM(X) ; Convert Code to Numeric
Q $S(X?1.N:+X,X?4N1A:$A($E(X,5))*10_$E(X,1,4),1:$A(X)_$E(X,2,5))
CLR ; Clear
N LEXELDT,LEXGET,LEXLD,LEXRAN,LEXSD,LEXST,LEXTEST,LEXWN
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLEXQCM2 9073 printed Apr 09, 2024@21:10:21 Page 2
LEXQCM2 ;ISL/KER - Query - CPT Modifiers - Save ;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("LEXQCM" SACC 2.3.2.5.1
+6 ; ^TMP("LEXQCMO" SACC 2.3.2.5.1
+7 ;
+8 ; External References
+9 ; $$DT^XLFDT ICR 10103
+10 ; $$UP^XLFSTR ICR 10104
+11 ;
+12 ; Variables NEWed or KILLed Elsewhere
+13 ; LEXIEN Modifier IEN
+14 ; LEXELDT External Last Date
+15 ; LEXLEN Offset Length
+16 ; LEXIIEN Include IENs flag
+17 ; LEXINC Include Modifier Ranges flag
+18 ; LEXINCI Include Inactive Modifier Ranges flag
+19 ; LEXINCF Include Future Modifier Ranges flag
+20 ; LEXGET Array of Non-Versioned Data
+21 ; LEXST CPT Status and Effective Dates
+22 ; LEXSD Versioned Short Description
+23 ; LEXLD Versioned Long Description
+24 ; LEXRAN Number of Ranges/Comment
+25 ; ^TMP("LEXQCM",$J,"RANGES",#) List of Ranges
+26 ;
EN ; Main Entry Point
+1 KILL ^TMP("LEXQCMO",$JOB)
if '$LENGTH($GET(LEXELDT))
QUIT
+2 IF +($GET(LEXST))<0
DO FUT
if $DATA(^TMP("LEXQCMO",$JOB))
DO DSP^LEXQO("LEXQCMO")
QUIT
+3 DO FUL
if $DATA(^TMP("LEXQCMO",$JOB))
DO DSP^LEXQO("LEXQCMO")
+4 QUIT
FUT ; Future Activation
+1 NEW LEX1,LEX2,LEX3,LEXEFF,LEXI,LEXL,LEXNAM,LEXSO,LEXSTA
SET LEXI=+($GET(LEXIEN))
if +LEXI'>0
QUIT
if '$DATA(^DIC(81.3,+LEXI,0))
QUIT
SET LEXL=+($GET(LEXLEN))
if +LEXL'>0
QUIT
+2 if LEXL>62
SET LEXL=62
SET LEXSO=$GET(LEXGET(81.3,(+LEXI_","),.01,"E"))
if '$LENGTH(LEXSO)
QUIT
SET LEXNAM=$GET(LEXGET(81.3,(+LEXI_","),"B"))
if '$LENGTH(LEXNAM)
QUIT
+3 SET LEXSTA=$GET(LEXST)
SET LEXEFF=$PIECE(LEXSTA,"^",5)
SET LEXSTA=$PIECE(LEXSTA,"^",4)
if '$LENGTH(LEXSTA)
QUIT
if '$LENGTH(LEXEFF)
QUIT
SET (LEX1,LEX2,LEX3)=""
+4 DO BOD(LEXELDT)
DO COD(LEXSO,LEXNAM,+($GET(LEXL)))
DO STA(.LEXST,+($GET(LEXL)))
+5 QUIT
BOD(X) ; Based on Date
+1 NEW LEXBOD
SET LEXBOD=$GET(X)
if '$LENGTH(LEXBOD)
QUIT
if LEXBOD'["/"
QUIT
SET X="Display based on date: "_LEXBOD
DO BL
DO TL(X)
+2 QUIT
COD(X,Y,LEXLEN) ; Code Line
+1 NEW LEXC,LEXN,LEXL,LEXT,LEXI,LEXTX,LEXTXT,LEXNAM,LEXIEN
SET LEXC=$GET(X)
SET LEXN=$GET(Y)
SET LEXIEN=+($PIECE(LEXN," (IEN ",2))
SET LEXNAM=$PIECE(LEXN," (IEN ",1)
+2 if $DATA(LEXIIEN)&(+LEXIEN>0)&($LENGTH(LEXNAM))
SET LEXNAM=LEXNAM_" (IEN "_LEXIEN_")"
SET LEXL=+($GET(LEXLEN))
if +LEXL'>0!(LEXL>61)
SET LEXL=61
+3 SET LEXTX(1)=LEXNAM
DO PR^LEXU(.LEXTX,+($GET(LEXL)))
SET LEXTXT=$GET(LEXTX(1))
+4 SET LEXT="Code: "_LEXC
SET LEXT=LEXT_$JUSTIFY(" ",((79-+($GET(LEXLEN)))-$LENGTH(LEXT)))_LEXTXT
DO BL
DO TL(LEXT)
+5 SET LEXI=1
FOR
SET LEXI=$ORDER(LEXTX(LEXI))
if +LEXI'>0
QUIT
Begin DoDot:1
+6 NEW LEXT,LEXTXT
SET LEXTXT=$GET(LEXTX(LEXI))
if '$LENGTH(LEXTXT)
QUIT
+7 SET LEXT=""
SET LEXT=LEXT_$JUSTIFY(" ",((79-+($GET(LEXLEN)))-$LENGTH(LEXT)))_LEXTXT
DO TL(LEXT)
End DoDot:1
+8 QUIT
STA(X,LEXLEN) ; Status Line
+1 NEW LEX,LEXC,LEXI,LEXN,LEXX,LEXE,LEXS,LEXT,LEXW,LEXEFF,LEXSTA
SET LEXX=$GET(X)
SET LEXEFF=$PIECE(LEXX,"^",5)
SET LEXSTA=$PIECE(LEXX,"^",4)
SET LEXEFF=$TRANSLATE(LEXEFF,"()","")
+2 SET LEXW=$PIECE(LEXX,"^",6)
SET LEXT=" Status: "
SET LEXT=LEXT_$JUSTIFY(" ",((79-+($GET(LEXLEN)))-$LENGTH(LEXT)))
SET LEXT=LEXT_LEXSTA
+3 SET LEXT=LEXT_$JUSTIFY(" ",(35-$LENGTH(LEXT)))
if LEXEFF'["future"
SET LEXT=LEXT_"Effective: "
+4 SET LEXT=LEXT_$$UP^XLFSTR($EXTRACT(LEXEFF,1))_$EXTRACT(LEXEFF,2,$LENGTH(LEXEFF))
DO BL
DO TL(LEXT)
+5 IF $LENGTH(LEXW)
Begin DoDot:1
+6 NEW LEX,LEXT,LEXC,LEXI,LEXN
SET LEX(1)=LEXW
DO PR^LEXU(.LEX,(+($GET(LEXLEN))-7))
if +($ORDER(LEX(" "),-1))'>0
QUIT
+7 SET LEXT=$JUSTIFY(" ",((79-+($GET(LEXLEN)))))
+8 SET (LEXC,LEXI)=0
FOR
SET LEXI=$ORDER(LEX(LEXI))
if +LEXI'>0
QUIT
Begin DoDot:2
+9 NEW LEXN
SET LEXN=$$TM^LEXQM($GET(LEX(LEXI)))
if $LENGTH(LEXN)
SET LEXC=LEXC+1
if LEXC=1
DO BL
DO TL((LEXT_LEXN))
End DoDot:2
End DoDot:1
+10 QUIT
+11 ;
FUL ; Full Display
+1 NEW LEXFUL,LEX,LEXL
SET LEXL=+($GET(LEXLEN))
if LEXL>62
SET LEXL=62
+2 SET LEXFUL=""
DO FUT
+3 DO SD(.LEXSD,+($GET(LEXL)))
DO LD(.LEXLD,+($GET(LEXL)))
DO WN(.LEXWN,+($GET(LEXL)))
+4 if +($GET(LEXRAN))>0&($LENGTH($PIECE($GET(LEXRAN),"^",2)))&($ORDER(^TMP("LEXQCM",$JOB,"RANGES",0))>0)
DO RAN(.LEXRAN,+($GET(LEXL)))
+5 QUIT
SD(X,LEXLEN) ; Short Description
+1 NEW LEXI,LEXH,LEXE,LEXL,LEXTX,LEXTXT,LEXN,LEXT
if '$DATA(X(1))
QUIT
SET LEXN=$GET(X(1))
SET LEXT=" Short Name: "
+2 SET LEXL=+($GET(LEXLEN))
if +LEXL'>0!(LEXL>63)
SET LEXL=63
SET LEXI=0
FOR
SET LEXI=$ORDER(X(LEXI))
if +LEXI'>0
QUIT
SET LEXTX(LEXI)=$GET(X(LEXI))
+3 DO PR^LEXU(.LEXTX,+($GET(LEXL)))
SET LEXTXT=$GET(LEXTX(1))
+4 SET LEXT=LEXT_$JUSTIFY(" ",((79-+($GET(LEXLEN)))-$LENGTH(LEXT)))_LEXTXT
DO BL
DO TL(LEXT)
+5 SET LEXE=$GET(X(0))
SET LEXT=" "_LEXE
SET LEXN=$GET(LEXTX(2))
SET LEXT=LEXT_$JUSTIFY(" ",((79-+($GET(LEXLEN)))-$LENGTH(LEXT)))_LEXN
DO TL(LEXT)
+6 QUIT
LD(X,LEXLEN) ; Long Description
+1 NEW LEXI,LEXH,LEXE,LEXN,LEXT
if '$DATA(X(1))
QUIT
SET LEXN=$GET(X(1))
SET LEXT=" Description: "
SET LEXT=LEXT_$JUSTIFY(" ",((79-+($GET(LEXLEN)))-$LENGTH(LEXT)))_LEXN
DO BL
DO TL(LEXT)
+2 SET LEXE=$GET(X(0))
SET LEXT=" "_LEXE
SET LEXN=$GET(X(2))
SET LEXT=LEXT_$JUSTIFY(" ",((79-+($GET(LEXLEN)))-$LENGTH(LEXT)))_LEXN
DO TL(LEXT)
+3 SET LEXT=$JUSTIFY(" ",((79-+($GET(LEXLEN)))))
SET LEXI=2
FOR
SET LEXI=$ORDER(X(LEXI))
if +LEXI'>0
QUIT
SET LEXN=LEXT_$GET(X(LEXI))
DO TL(LEXN)
+4 QUIT
WN(X,LEXLEN) ; Warning
+1 NEW LEXI,LEXH,LEXE,LEXN,LEXT,LEXC
if '$DATA(X(1))
QUIT
SET LEXC=0
SET LEXN=$GET(X(1))
SET LEXT=""
SET LEXT=LEXT_$JUSTIFY(" ",((79-+($GET(LEXLEN)))-$LENGTH(LEXT)))_LEXN
DO BL
DO TL(LEXT)
+2 SET LEXT=$JUSTIFY(" ",((79-+($GET(LEXLEN)))))
SET LEXI=1
FOR
SET LEXI=$ORDER(X(LEXI))
if +LEXI'>0
QUIT
SET LEXN=LEXT_$GET(X(LEXI))
DO TL(LEXN)
+3 QUIT
RAN(X,LEXLEN) ; Code Ranges
+1 NEW LEXC,LEXH,LEXI,LEXN,LEXS,LEXT
SET LEXH=$GET(X)
SET LEXN=+LEXH
SET LEXH=$PIECE(LEXH,"^",2)
if +LEXN'>0
QUIT
if '$LENGTH(LEXH)
QUIT
+2 SET LEXT=" Code Ranges: "
SET LEXT=LEXT_$JUSTIFY(" ",((79-+($GET(LEXLEN)))-$LENGTH(LEXT)))_LEXH
SET LEXN=$JUSTIFY(" ",((79-+($GET(LEXLEN)))))
DO BL
DO TL(LEXT)
+3 SET (LEXC,LEXI)=0
FOR
SET LEXI=$ORDER(^TMP("LEXQCM",$JOB,"RANGES",LEXI))
if +LEXI'>0
QUIT
Begin DoDot:1
+4 SET LEXC=LEXC+1
if LEXC=1
DO BL
SET LEXT=$GET(^TMP("LEXQCM",$JOB,"RANGES",LEXI))
if '$LENGTH(LEXT)
QUIT
DO TL((LEXN_LEXT))
End DoDot:1
+5 QUIT
CCR(X,LEXVDT,LEX,LEXLEN,LEXINCI,LEXINCF) ; CPT Code Ranges
+1 ;
+2 ; LEX=# of Ranges
+3 ; ^TMP("LEXQCM",$J,"RANGES",#)=Begin_End_Act_Inact
+4 ;
+5 KILL ^TMP("LEXQCM",$JOB,"RAN"),^TMP("LEXQCM",$JOB,"RANGES")
+6 NEW LEXC,LEXEVDT,LEXFD,LEXFN,LEXH1,LEXH2,LEXH3,LEXIEN,LEXL,LEXN,LEXP,LEXR0,LEXRA,LEXRA1,LEXRA2,LEXRB,LEXRDA,LEXRDI,LEXRE,LEXRI,LEXRI1,LEXRI2,LEXRN,LEXRT,LEXRX,LEXT
+7 SET LEXIEN=$GET(X)
if +LEXIEN'>0
QUIT
if '$DATA(^DIC(81.3,+LEXIEN,0))
QUIT
if $ORDER(^DIC(81.3,+LEXIEN,10,0))'>0
QUIT
SET LEXVDT=+($GET(LEXVDT))
if LEXVDT'?7N
SET LEXVDT=$$DT^XLFDT
SET LEXEVDT=$$SD^LEXQM(LEXVDT)
SET LEXLEN=+($GET(LEXLEN))
+8 if +LEXLEN'>0
SET LEXLEN=62
if '$LENGTH(LEXEVDT)
QUIT
SET LEXINCI=+($GET(LEXINCI))
SET LEXINCF=+($GET(LEXINCF))
SET (LEXFD,LEXRX)=0
FOR
SET LEXRX=$ORDER(^DIC(81.3,+LEXIEN,10,LEXRX))
if +LEXRX'>0
QUIT
Begin DoDot:1
+9 SET LEXR0=$GET(^DIC(81.3,+LEXIEN,10,LEXRX,0))
SET LEXRB=$PIECE(LEXR0,"^",1)
if $LENGTH(LEXRB)'=5
QUIT
SET LEXRE=$PIECE(LEXR0,"^",2)
if $LENGTH(LEXRB)&('$LENGTH(LEXRE))
SET LEXRE=LEXRB
if $LENGTH(LEXRE)'=5
QUIT
+10 SET LEXRA=$PIECE(LEXR0,"^",3)
if LEXRA'?7N
QUIT
SET LEXRI=$PIECE(LEXR0,"^",4)
if +LEXRA>0&(LEXVDT<+($GET(LEXRA)))&(+($GET(LEXINCF))'>0)
QUIT
if +LEXRI>0&(LEXVDT>+($GET(LEXRI)))&(+($GET(LEXINCI))'>0)
QUIT
+11 SET LEXRN=$$NUM(LEXRB)
SET LEXRT=LEXRB_"^"_LEXRE_"^"_LEXRA_"^"_LEXRI
SET LEXRA1=$SELECT(LEXVDT<LEXRA:"<",1:" ")
SET LEXRA2=$SELECT(LEXVDT<LEXRA:">",1:" ")
+12 SET LEXRI1=$SELECT(LEXVDT<LEXRI:"<",1:" ")
SET LEXRI2=$SELECT(LEXVDT<LEXRI:">",1:" ")
if LEXRA1["<"!(LEXRA2[">")!(LEXRI1["<")!(LEXRI2[">")
SET LEXFD=1
+13 SET LEXRDA=$SELECT($LENGTH(LEXRA):(LEXRA1_$$SD^LEXQM(LEXRA)_LEXRA2),1:"")
SET LEXRDI=$SELECT($LENGTH(LEXRI):(LEXRI1_$$SD^LEXQM(LEXRI)_LEXRI2),1:"")
+14 SET ^TMP("LEXQCM",$JOB,"RAN",LEXRN,LEXRT)=LEXRB_" "_LEXRE_" "_LEXRDA_" "_LEXRDI
End DoDot:1
+15 SET LEXH1="CPT Code Range Effective Dates"
SET LEXH2="Begin End Active Inactive"
SET LEXH3="----- ----- ---------- ----------"
+16 KILL LEX
SET (LEX,LEXL,LEXC,LEXRN)=0
SET LEXFN=""
if +($GET(LEXFD))>0
SET LEXFN=" Future dates indicated as '<mm/dd/yyyy>'"
+17 SET LEXC=0
FOR
SET LEXRN=$ORDER(^TMP("LEXQCM",$JOB,"RAN",LEXRN))
if +LEXRN'>0
QUIT
SET LEXRT=""
FOR
SET LEXRT=$ORDER(^TMP("LEXQCM",$JOB,"RAN",LEXRN,LEXRT))
if '$LENGTH(LEXRT)
QUIT
Begin DoDot:1
+18 SET LEXT=$GET(^TMP("LEXQCM",$JOB,"RAN",LEXRN,LEXRT))
if '$LENGTH(LEXT)
QUIT
SET LEXC=LEXC+1
IF LEXC=1
Begin DoDot:2
+19 SET LEXN=$ORDER(^TMP("LEXQCM",$JOB,"RANGES"," "),-1)+1
SET ^TMP("LEXQCM",$JOB,"RANGES",LEXN)=LEXH1
SET LEXN=$ORDER(^TMP("LEXQCM",$JOB,"RANGES"," "),-1)+1
SET ^TMP("LEXQCM",$JOB,"RANGES",LEXN)=LEXH2
+20 SET LEXN=$ORDER(^TMP("LEXQCM",$JOB,"RANGES"," "),-1)+1
SET ^TMP("LEXQCM",$JOB,"RANGES",LEXN)=LEXH3
SET ^TMP("LEXQCM",$JOB,"RANGES",0)=LEXN
End DoDot:2
+21 SET LEX=+($GET(LEX))+1
SET LEXN=$ORDER(^TMP("LEXQCM",$JOB,"RANGES"," "),-1)+1
SET ^TMP("LEXQCM",$JOB,"RANGES",LEXN)=LEXT
SET ^TMP("LEXQCM",$JOB,"RANGES",0)=LEXN
End DoDot:1
+22 IF $LENGTH(LEXFN)
Begin DoDot:1
+23 SET LEXN=$ORDER(^TMP("LEXQCM",$JOB,"RANGES"," "),-1)+1
SET ^TMP("LEXQCM",$JOB,"RANGES",LEXN)=" "
SET ^TMP("LEXQCM",$JOB,"RANGES",0)=LEXN
+24 SET LEXN=$ORDER(^TMP("LEXQCM",$JOB,"RANGES"," "),-1)+1
SET ^TMP("LEXQCM",$JOB,"RANGES",LEXN)=LEXFN
SET ^TMP("LEXQCM",$JOB,"RANGES",0)=LEXN
End DoDot:1
+25 KILL ^TMP("LEXQCM",$JOB,"RAN")
SET LEXT=""
IF +LEX>0
Begin DoDot:1
+26 NEW LEXP,LEXT
SET LEXP=$SELECT(+LEX>1:"s",1:"")
SET LEXT=""
if +($GET(LEXINCI))>0&(+($GET(LEXINCF))>0)
SET LEXT=+LEX_" Current and future Active or Inactive range"_LEXP_" found"
+27 if +($GET(LEXINCI))>0&(+($GET(LEXINCF))'>0)
SET LEXT=+LEX_" Currently Active or Inactive range"_LEXP_" found"
if +($GET(LEXINCI))'>0&(+($GET(LEXINCF))>0)
SET LEXT=+LEX_" Current and future Active range"_LEXP_" found"
+28 if +($GET(LEXINCI))'>0&(+($GET(LEXINCF))'>0)
SET LEXT=+LEX_" Currently Active range"_LEXP_" found"
if $LENGTH(LEXT)
SET LEX=LEX_"^"_LEXT
End DoDot:1
+29 QUIT
+30 ;
+31 ; Miscellaneous
BL ; Blank Line
+1 DO TL(" ")
QUIT
TL(X) ; Text Line
+1 IF $DATA(LEXTEST)
WRITE !,$GET(X)
QUIT
+2 NEW LEXI
SET LEXI=+($ORDER(^TMP("LEXQCMO",$JOB," "),-1))+1
SET ^TMP("LEXQCMO",$JOB,LEXI)=$GET(X)
SET ^TMP("LEXQCMO",$JOB,0)=LEXI
+3 QUIT
NUM(X) ; Convert Code to Numeric
+1 QUIT $SELECT(X?1.N:+X,X?4N1A:$ASCII($EXTRACT(X,5))*10_$EXTRACT(X,1,4),1:$ASCII(X)_$EXTRACT(X,2,5))
CLR ; Clear
+1 NEW LEXELDT,LEXGET,LEXLD,LEXRAN,LEXSD,LEXST,LEXTEST,LEXWN
+2 QUIT
