- 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 Feb 18, 2025@23:34:32 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
