LEXQCP2 ;ISL/KER - Query - CPT Procedures - Save ;05/23/2017
;;2.0;LEXICON UTILITY;**62,80,103**;Sep 23, 1996;Build 2
;
; Global Variables
; ^DIC(81.3, ICR 4492
; ^ICPT( ICR 4489
; ^TMP("LEXQCPO") SACC 2.3.2.5.1
;
; External References
; HIST^ICPTAPIU ICR 1997
; $$MODA^ICPTMOD ICR 1996
; $$DT^XLFDT ICR 10103
; $$UP^XLFSTR ICR 10104
;
; Local Variables NEWed or KILLed Elsewhere
; LEXIEN CPT Internal Entry Number
; LEXIIEN Include IENs flag
; LEXLEN Offset Length
; LEXGET Array of Non-Versioned Data
; LEXST CPT Status and Effective Dates
; LEXSD Versioned Short Description
; LEXLD Versioned Long Description
; LEXMD Versioned Modifiers
; LEXLX Versioned Lexicon Term
; LEXWN Warning
; LEXINC Flag to Display Modifiers
; LEXELDT External Last Date
;
EN ; Main Entry Point
K ^TMP("LEXQCPO",$J) Q:'$L($G(LEXELDT)) I +($G(LEXST))<0 D FUT D:$D(^TMP("LEXQCPO",$J)) DSP^LEXQO("LEXQCPO") Q
D FUL D:$D(^TMP("LEXQCPO",$J)) DSP^LEXQO("LEXQCPO")
Q
FUT ; Future Activation
N LEX1,LEX2,LEX3,LEXEFF,LEXI,LEXL,LEXNAM,LEXSO,LEXSTA S LEXI=+($G(LEXIEN)) Q:+LEXI'>0 Q:'$D(^ICPT(+LEXI,0)) S LEXL=+($G(LEXLEN)) Q:+LEXL'>0
S:LEXL>62 LEXL=62 S LEXSO=$G(LEXGET(81,(+LEXI_","),.01,"E")) Q:'$L(LEXSO) S LEXNAM=$G(LEXGET(81,(+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(LEXCDT),+($G(LEXL))),STA(.LEXST,+($G(LEXL)))
Q
BOD(X) ; Based on Date
N LEXBOD,LEXT S LEXBOD=$G(X),LEXT="Display based on date: "_LEXBOD D BL,TL(LEXT)
Q
COD(X,Y,LEXD,LEXLEN) ; Code Line
N LEXC,LEXN,LEXT,LEXIEN,LEXNAM S LEXC=$G(X),LEXN=$G(Y),LEXD=$G(LEXD),LEXIEN=$$CI(LEXC,LEXD)
S LEXNAM=$P(LEXN," (IEN ",1) S:$D(LEXIIEN)&($L(LEXIEN)) LEXNAM=LEXIEN
S LEXT="Code: "_LEXC,LEXT=LEXT_$J(" ",((79-+($G(LEXLEN)))-$L(LEXT)))_LEXNAM D BL,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,CAT(+($G(LEXIEN)),+($G(LEXL))),LIM(+($G(LEXIEN)),+($G(LEXL)))
D SD(.LEXSD,+($G(LEXL))),LD(.LEXLD,+($G(LEXL))),LX(.LEXLX,+($G(LEXL))),WR(.LEXWN,+($G(LEXL)))
D:+($G(LEXINC))>0 MD(.LEXMD,+($G(LEXL)))
Q
CAT(X,LEXLEN) ; CPT Categories
N LEXA,LEXC,LEXI,LEX1,LEX2,LEX1I,LEX2I,LEXT,LEXH1,LEXH2,LEXI,LEXV1,LEXV2,LEXT,LEXTC,LEXO S (LEX1,LEX2,LEX1I,LEX2I,LEXH1,LEXH2)=""
S LEXI=+($G(X)) S LEX1=$G(LEXGET(81,(+LEXI_","),3,1)) S:$L(LEX1) LEX1I=$O(^DIC(81.1,"B",LEX1,0)) S:LEX1I'>0 LEX1I=""
S LEX2=$G(LEXGET(81,(+LEXI_","),3,2)) S:$L(LEX2) LEX2I=$O(^DIC(81.1,"B",LEX2,0)) S:LEX2I'>0 LEX2I="" Q:'$L((LEX1_LEX2))
S:$D(LEXIIEN)&($L(LEX1))&($L($G(LEX1I)))&($G(LEX1I)>0) LEX1=LEX1_" (IEN "_LEX1I_")"
S:$D(LEXIIEN)&($L(LEX2))&($L($G(LEX2I)))&($G(LEX2I)>0) LEX2=LEX2_" (IEN "_LEX2I_")"
I $L(LEX1)&('$L(LEX2))!('$L(LEX1)&($L(LEX2))) D
. N LEXA,LEXI,LEXC S LEXT=" Category: ",LEXT=LEXT_$J(" ",((79-+($G(LEXLEN)))-$L(LEXT)))
. S:$L(LEX1) LEXA(1)=LEX1 S:$L(LEX2) LEXA(1)=LEX2 D PR^LEXU(.LEXA,LEXLEN)
. S LEXT=LEXT_LEXA(1) S LEXC=$O(LEXO(" "),-1)+1,LEXO(LEXC)=LEXT
. S LEXI=1 F S LEXI=$O(LEXA(LEXI)) Q:+LEXI'>0 D
. . N LEXT S LEXT="" S LEXT=LEXT_$J(" ",((79-+($G(LEXLEN)))-$L(LEXT)))
. . S LEXT=LEXT_$G(LEXA(LEXI)),LEXC=$O(LEXO(" "),-1)+1,LEXO(LEXC)=LEXT
I $L(LEX1)&($L(LEX2)) D
. N LEXH1,LEXH2,LEXT,LEXA S LEXH1=" Major Cat:",LEXH2=" Sub-Category:"
. S LEXT=LEXH1,LEXT=LEXT_$J(" ",((79-+($G(LEXLEN)))-$L(LEXT)))
. K LEXA S LEXA(1)=LEX1 D PR^LEXU(.LEXA,LEXLEN)
. S LEXT=LEXT_LEXA(1) S LEXC=$O(LEXO(" "),-1)+1,LEXO(LEXC)=LEXT
. S LEXI=1 F S LEXI=$O(LEXA(LEXI)) Q:+LEXI'>0 D
. . N LEXT S LEXT="" S LEXT=LEXT_$J(" ",((79-+($G(LEXLEN)))-$L(LEXT)))
. . S LEXT=LEXT_$G(LEXA(LEXI)) S LEXC=$O(LEXO(" "),-1)+1,LEXO(LEXC)=LEXT
. S LEXT=LEXH2,LEXT=LEXT_$J(" ",((79-+($G(LEXLEN)))-$L(LEXT)))
. K LEXA S LEXA(1)=LEX2 D PR^LEXU(.LEXA,LEXLEN)
. S LEXT=LEXT_LEXA(1) S LEXC=$O(LEXO(" "),-1)+1,LEXO(LEXC)=LEXT
. S LEXI=1 F S LEXI=$O(LEXA(LEXI)) Q:+LEXI'>0 D
. . N LEXT S LEXT="" S LEXT=LEXT_$J(" ",((79-+($G(LEXLEN)))-$L(LEXT)))
. . S LEXT=LEXT_$G(LEXA(LEXI)) S LEXC=$O(LEXO(" "),-1)+1,LEXO(LEXC)=LEXT
D:$O(LEXO(0))>0 BL S LEXI=0 F S LEXI=$O(LEXO(LEXI)) Q:+LEXI'>0 D
. N LEXT S LEXT=$G(LEXO(LEXI)) D:$L(LEXT) TL(LEXT)
Q
LIM(X,LEXLEN) ; Limitations
N LEXI,LEXH,LEXL,LEXS,LEXT S LEXI=+($G(X)),LEXL=$G(LEXGET(81,(+LEXI_","),10.01,"E")) S:'$L(LEXL) LEXL="N/A"
S LEXH=$G(LEXGET(81,(+LEXI_","),10.02,"E")) S:'$L(LEXH) LEXH="N/A" S LEXS=$G(LEXGET(81,(+LEXI_","),10.03,"E")) S:'$L(LEXS) LEXS="N/A"
Q:(LEXH_LEXL_LEXS)="N/AN/AN/A" S LEXT=" Limitations: ",LEXT=LEXT_$J(" ",((79-+($G(LEXLEN)))-$L(LEXT)))_"Age Low: "_LEXL
S LEXT=LEXT_$J(" ",(35-$L(LEXT)))_"Age High: "_LEXH,LEXT=LEXT_$J(" ",(56-$L(LEXT)))_"Sex: "_LEXS D BL,TL(LEXT)
Q
SD(X,LEXLEN) ; Short Description
N LEXI,LEXH,LEXE,LEXN,LEXT Q:'$D(X(1)) S LEXN=$G(X(1)),LEXT=" Short Name: ",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)
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
LX(X,LEXLEN) ; Lexicon Expression
N LEXI,LEXH,LEXE,LEXN,LEXT Q:'$D(X(1)) S LEXN=$G(X(1)),LEXT=" Lexicon Term:",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))))),LEXI=2 F S LEXI=$O(X(LEXI)) Q:+LEXI'>0 S LEXN=LEXT_$G(X(LEXI)) D TL(LEXN)
Q
WR(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
MD(LEXM,LEXLEN) ; CPT Modifiers
N LEXI,LEXC,LEXH,LEXE,LEXH1,LEXH2,LEXN,LEXT,LEXA Q:'$D(LEXM(1)) S LEXLEN=+($G(LEXLEN)) S:+LEXLEN'>0 LEXLEN=62 S LEXE=$G(LEXM(0))
S LEXH1=" Modifiers:" S LEXH1=LEXH1_$J(" ",((79-+($G(LEXLEN)))-$L(LEXH1)))
S LEXH2=" "_LEXE S LEXH2=LEXH2_$J(" ",((79-+($G(LEXLEN)))-$L(LEXH2)))
I $D(LEXIIEN) D Q
. N LEXA S LEXA(1)=$G(LEXM(1)) D PR^LEXU(.LEXA,LEXLEN)
. S LEXT=LEXH1_$G(LEXA(1)) D BL,TL(LEXT) I $D(LEXA(2)) D
. . S LEXT=LEXH2_$G(LEXA(2)) D TL(LEXT)
. . S LEXH2=" ",LEXH2=LEXH2_$J(" ",((79-+($G(LEXLEN)))-$L(LEXH2)))
. S LEXC=1 F S LEXC=$O(LEXM(LEXC)) Q:+LEXC'>0 D
. . N LEXS,LEXA,LEXI
. . S LEXA(1)=$G(LEXM(LEXC)) D PR^LEXU(.LEXA,LEXLEN)
. . S LEXI=0 F S LEXI=$O(LEXA(LEXI)) Q:+LEXI'>0 D
. . . N LEXS S LEXS=$G(LEXA(LEXI)) Q:'$L(LEXS)
. . . S LEXS=LEXH2_LEXS D:LEXI=1 TL(LEXS) D:LEXI>1 TL((" "_LEXS))
. . . I LEXI=1 S LEXH2=" ",LEXH2=LEXH2_$J(" ",((79-+($G(LEXLEN)))-$L(LEXH2)))
S LEXN=$G(LEXM(1)),LEXT=LEXH1_LEXN D BL,TL(LEXT)
S LEXN=$G(LEXM(2)),LEXT=LEXH2_LEXN D TL(LEXT)
S LEXT=$J(" ",((79-+($G(LEXLEN))))),LEXI=2 F S LEXI=$O(LEXM(LEXI)) Q:+LEXI'>0 D
. S LEXN=LEXT_$G(LEXM(LEXI)) D TL(LEXN)
Q
MOD(X,LEXVDT,LEX,LEXLEN,LEXSTA) ; CPT Modifiers
;
; LEX=# of Lines
; LEX(0)=External Date
; LEX(#)=Modifier List
;
N LEXA,LEXEVDT,LEXFA,LEXI,LEXIEN,LEXM,LEXS,LEXSO S LEXIEN=$G(X) Q:+LEXIEN'>0 Q:'$D(^ICPT(+LEXIEN,0)) S LEXSTA=+($G(LEXSTA))
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 LEXSO=$P($G(^ICPT(+LEXIEN,0)),"^",1) Q:'$L(LEXSO) S LEXFA=$$FA(+LEXIEN) Q:LEXVDT<LEXFA
K LEX S:+LEXSTA'>0 LEXEVDT="" S LEX(0)=LEXEVDT D MODA^ICPTMOD(LEXSO,LEXVDT,.LEXA)
S (LEXS,LEXM)="" F S LEXM=$O(LEXA("A",LEXM)) Q:'$L(LEXM) D
. Q:'$D(^DIC(81.3,"B",LEXM)) N LEXTF,LEXTT,LEXTI,LEXTD
. S LEXTF="",LEXTT=$G(LEXA("A",LEXM)),LEXTI=+LEXTT,LEXTD=$P(LEXTT,"^",2)
. S:LEXTI>0&($L(LEXTD)) LEXTF=LEXM_" "_LEXTD_" (IEN "_LEXTI_")"
. I $D(LEXIIEN) S LEXS="",LEXI=$O(LEX(" "),-1)+1 S:$L($G(LEXTF)) LEX(LEXI)=$$TM^LEXQM(LEXTF) Q
. I ($L(LEXS)+$L(LEXM)+3)'>62 S LEXS=LEXS_LEXM_" " Q
. I ($L(LEXS)+$L(LEXM)+3)>62 S LEXI=$O(LEX(" "),-1)+1,LEX(LEXI)=$$TM^LEXQM(LEXS),LEXS=LEXM_" " Q
I $L($G(LEXS)) S LEXI=$O(LEX(" "),-1)+1,LEX(LEXI)=$$TM^LEXQM(LEXS)
S LEX=$O(LEX(" "),-1)
Q
WN(X,LEX,LEXLEN) ; Warning
;
; LEX=# of Lines
; LEX(0)=External Date
; LEX(#)=Warning
;
N LEXVDT,LEXIA,LEXTMP,LEXREF K LEX S LEXVDT=$G(X) Q:LEXVDT'?7N S LEXIA=$$IA^LEXQCP(LEXVDT) Q:+LEXIA'>0
S LEXLEN=+$G(LEXLEN) S:+LEXLEN>62 LEXLEN=62 S LEXREF="Short Name and Description" S:$D(LEXLX) LEXREF="Short Name, Description and Lexicon Term"
S LEXTMP(1)="Warning: The 'Based on Date' provided precedes Code Set Versioning. The "_LEXREF_" may be inaccurate for "_$$SD^LEXQM(LEXVDT)
D PR^LEXU(.LEXTMP,LEXLEN) K LEX S LEXI=0 F S LEXI=$O(LEXTMP(LEXI)) Q:+LEXI'>0 S LEX(LEXI)=$G(LEXTMP(LEXI))
S LEX=$O(LEX(" "),-1),LEX(0)=$$SD^LEXQM(LEXVDT)
Q
;
; Miscellaneous
CI(X,LEXD) ; Code IENs
N LEXSO,LEXSDO,LEXLEX,LEXSAB S LEXSO=$G(X) Q:'$L(LEXSO) S LEXD=$G(LEXD) I LEXD'?7N D
. N LEXEF,LEXTD S LEXTD="",LEXEF=9999999 F S LEXEF=$O(^LEX(757.02,"ACT",(LEXSO_" "),3,LEXEF),-1) Q:+LEXEF'>0 D
. . N LEXIE S LEXIE=$O(^LEX(757.02," "),-1) F S LEXIE=$O(^LEX(757.02,"ACT",(LEXSO_" "),3,+LEXEF,LEXIE),-1) Q:+LEXIE'>0 D
. . . N LEXSR S LEXSR=$P($G(^LEX(757.02,+LEXIE,0)),"^",3) S:"^3^4^"[("^"_LEXSR_"^") LEXTD=LEXEF
. S:LEXTD?7N LEXD=LEXTD
S:LEXD'?7N LEXD=$$DT^XLFDT S LEXSDO=$O(^ICPT("BA",(LEXSO_" "),0)),LEXSAB=$S($E(LEXSO,1)?1U:"CPC",1:"CPT")
S LEXLEX=$$STATCHK^LEXSRC2(LEXSO,LEXD,,LEXSAB),LEXLEX=$P(LEXLEX,"^",2)
S LEXSDO=$S(+LEXSDO>0:("CPT IEN "_+LEXSDO),1:"") S LEXLEX=$S(+LEXLEX>0:("Lexicon IEN "_+LEXLEX),1:"")
S X="" S:$L(LEXSDO)&('$L(LEXLEX)) X=LEXSDO S:'$L(LEXSDO)&($L(LEXLEX)) X=LEXLEX S:$L(LEXSDO)&($L(LEXLEX)) X=(LEXSDO_"/"_LEXLEX)
Q X
FA(X) ; First Activation
N LEXFA,LEXH,LEXI,LEXIEN,LEXSO
S LEXIEN=+($G(X)) S X="",LEXSO=$P($G(^ICPT(+LEXIEN,0)),"^",1) D HIST^ICPTAPIU(LEXSO,.LEXH) S LEXFA="",LEXI=0
F S LEXI=$O(LEXH(LEXI)) Q:+LEXI'>0!($L(LEXFA)) S:+($G(LEXH(LEXI)))>0&(LEXI?7N) LEXFA=LEXI Q:$L(LEXFA)
S X=LEXFA
Q X
BL ; Blank Line
D TL(" ") Q
TL(X) ; Text Line
I $D(LEXTEST) W !,$G(X) Q
N LEXI S LEXI=+($O(^TMP("LEXQCPO",$J," "),-1))+1 S ^TMP("LEXQCPO",$J,LEXI)=$G(X),^TMP("LEXQCPO",$J,0)=LEXI
Q
CLR ; Clear
N LEXIEN,LEXLEN,LEXGET,LEXSD,LEXLD,LEXMD,LEXLX,LEXINC,LEXELDT,LEXST,LEXTEST,LEXWN
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLEXQCP2 11926 printed Dec 13, 2024@02:08:31 Page 2
LEXQCP2 ;ISL/KER - Query - CPT Procedures - 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 ; ^ICPT( ICR 4489
+6 ; ^TMP("LEXQCPO") SACC 2.3.2.5.1
+7 ;
+8 ; External References
+9 ; HIST^ICPTAPIU ICR 1997
+10 ; $$MODA^ICPTMOD ICR 1996
+11 ; $$DT^XLFDT ICR 10103
+12 ; $$UP^XLFSTR ICR 10104
+13 ;
+14 ; Local Variables NEWed or KILLed Elsewhere
+15 ; LEXIEN CPT Internal Entry Number
+16 ; LEXIIEN Include IENs flag
+17 ; LEXLEN Offset Length
+18 ; LEXGET Array of Non-Versioned Data
+19 ; LEXST CPT Status and Effective Dates
+20 ; LEXSD Versioned Short Description
+21 ; LEXLD Versioned Long Description
+22 ; LEXMD Versioned Modifiers
+23 ; LEXLX Versioned Lexicon Term
+24 ; LEXWN Warning
+25 ; LEXINC Flag to Display Modifiers
+26 ; LEXELDT External Last Date
+27 ;
EN ; Main Entry Point
+1 KILL ^TMP("LEXQCPO",$JOB)
if '$LENGTH($GET(LEXELDT))
QUIT
IF +($GET(LEXST))<0
DO FUT
if $DATA(^TMP("LEXQCPO",$JOB))
DO DSP^LEXQO("LEXQCPO")
QUIT
+2 DO FUL
if $DATA(^TMP("LEXQCPO",$JOB))
DO DSP^LEXQO("LEXQCPO")
+3 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(^ICPT(+LEXI,0))
QUIT
SET LEXL=+($GET(LEXLEN))
if +LEXL'>0
QUIT
+2 if LEXL>62
SET LEXL=62
SET LEXSO=$GET(LEXGET(81,(+LEXI_","),.01,"E"))
if '$LENGTH(LEXSO)
QUIT
SET LEXNAM=$GET(LEXGET(81,(+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(LEXCDT),+($GET(LEXL)))
DO STA(.LEXST,+($GET(LEXL)))
+5 QUIT
BOD(X) ; Based on Date
+1 NEW LEXBOD,LEXT
SET LEXBOD=$GET(X)
SET LEXT="Display based on date: "_LEXBOD
DO BL
DO TL(LEXT)
+2 QUIT
COD(X,Y,LEXD,LEXLEN) ; Code Line
+1 NEW LEXC,LEXN,LEXT,LEXIEN,LEXNAM
SET LEXC=$GET(X)
SET LEXN=$GET(Y)
SET LEXD=$GET(LEXD)
SET LEXIEN=$$CI(LEXC,LEXD)
+2 SET LEXNAM=$PIECE(LEXN," (IEN ",1)
if $DATA(LEXIIEN)&($LENGTH(LEXIEN))
SET LEXNAM=LEXIEN
+3 SET LEXT="Code: "_LEXC
SET LEXT=LEXT_$JUSTIFY(" ",((79-+($GET(LEXLEN)))-$LENGTH(LEXT)))_LEXNAM
DO BL
DO TL(LEXT)
+4 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)))
+4 if LEXEFF'["future"
SET LEXT=LEXT_"Effective: "
+5 SET LEXT=LEXT_$$UP^XLFSTR($EXTRACT(LEXEFF,1))_$EXTRACT(LEXEFF,2,$LENGTH(LEXEFF))
DO BL
DO TL(LEXT)
+6 IF $LENGTH(LEXW)
Begin DoDot:1
+7 NEW LEX,LEXT,LEXC,LEXI,LEXN
SET LEX(1)=LEXW
DO PR^LEXU(.LEX,(+($GET(LEXLEN))-7))
if +($ORDER(LEX(" "),-1))'>0
QUIT
+8 SET LEXT=$JUSTIFY(" ",((79-+($GET(LEXLEN)))))
+9 SET (LEXC,LEXI)=0
FOR
SET LEXI=$ORDER(LEX(LEXI))
if +LEXI'>0
QUIT
Begin DoDot:2
+10 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
+11 QUIT
FUL ; Full Display
+1 NEW LEXFUL,LEX,LEXL
SET LEXL=+($GET(LEXLEN))
if LEXL>62
SET LEXL=62
+2 SET LEXFUL=""
DO FUT
DO CAT(+($GET(LEXIEN)),+($GET(LEXL)))
DO LIM(+($GET(LEXIEN)),+($GET(LEXL)))
+3 DO SD(.LEXSD,+($GET(LEXL)))
DO LD(.LEXLD,+($GET(LEXL)))
DO LX(.LEXLX,+($GET(LEXL)))
DO WR(.LEXWN,+($GET(LEXL)))
+4 if +($GET(LEXINC))>0
DO MD(.LEXMD,+($GET(LEXL)))
+5 QUIT
CAT(X,LEXLEN) ; CPT Categories
+1 NEW LEXA,LEXC,LEXI,LEX1,LEX2,LEX1I,LEX2I,LEXT,LEXH1,LEXH2,LEXI,LEXV1,LEXV2,LEXT,LEXTC,LEXO
SET (LEX1,LEX2,LEX1I,LEX2I,LEXH1,LEXH2)=""
+2 SET LEXI=+($GET(X))
SET LEX1=$GET(LEXGET(81,(+LEXI_","),3,1))
if $LENGTH(LEX1)
SET LEX1I=$ORDER(^DIC(81.1,"B",LEX1,0))
if LEX1I'>0
SET LEX1I=""
+3 SET LEX2=$GET(LEXGET(81,(+LEXI_","),3,2))
if $LENGTH(LEX2)
SET LEX2I=$ORDER(^DIC(81.1,"B",LEX2,0))
if LEX2I'>0
SET LEX2I=""
if '$LENGTH((LEX1_LEX2))
QUIT
+4 if $DATA(LEXIIEN)&($LENGTH(LEX1))&($LENGTH($GET(LEX1I)))&($GET(LEX1I)>0)
SET LEX1=LEX1_" (IEN "_LEX1I_")"
+5 if $DATA(LEXIIEN)&($LENGTH(LEX2))&($LENGTH($GET(LEX2I)))&($GET(LEX2I)>0)
SET LEX2=LEX2_" (IEN "_LEX2I_")"
+6 IF $LENGTH(LEX1)&('$LENGTH(LEX2))!('$LENGTH(LEX1)&($LENGTH(LEX2)))
Begin DoDot:1
+7 NEW LEXA,LEXI,LEXC
SET LEXT=" Category: "
SET LEXT=LEXT_$JUSTIFY(" ",((79-+($GET(LEXLEN)))-$LENGTH(LEXT)))
+8 if $LENGTH(LEX1)
SET LEXA(1)=LEX1
if $LENGTH(LEX2)
SET LEXA(1)=LEX2
DO PR^LEXU(.LEXA,LEXLEN)
+9 SET LEXT=LEXT_LEXA(1)
SET LEXC=$ORDER(LEXO(" "),-1)+1
SET LEXO(LEXC)=LEXT
+10 SET LEXI=1
FOR
SET LEXI=$ORDER(LEXA(LEXI))
if +LEXI'>0
QUIT
Begin DoDot:2
+11 NEW LEXT
SET LEXT=""
SET LEXT=LEXT_$JUSTIFY(" ",((79-+($GET(LEXLEN)))-$LENGTH(LEXT)))
+12 SET LEXT=LEXT_$GET(LEXA(LEXI))
SET LEXC=$ORDER(LEXO(" "),-1)+1
SET LEXO(LEXC)=LEXT
End DoDot:2
End DoDot:1
+13 IF $LENGTH(LEX1)&($LENGTH(LEX2))
Begin DoDot:1
+14 NEW LEXH1,LEXH2,LEXT,LEXA
SET LEXH1=" Major Cat:"
SET LEXH2=" Sub-Category:"
+15 SET LEXT=LEXH1
SET LEXT=LEXT_$JUSTIFY(" ",((79-+($GET(LEXLEN)))-$LENGTH(LEXT)))
+16 KILL LEXA
SET LEXA(1)=LEX1
DO PR^LEXU(.LEXA,LEXLEN)
+17 SET LEXT=LEXT_LEXA(1)
SET LEXC=$ORDER(LEXO(" "),-1)+1
SET LEXO(LEXC)=LEXT
+18 SET LEXI=1
FOR
SET LEXI=$ORDER(LEXA(LEXI))
if +LEXI'>0
QUIT
Begin DoDot:2
+19 NEW LEXT
SET LEXT=""
SET LEXT=LEXT_$JUSTIFY(" ",((79-+($GET(LEXLEN)))-$LENGTH(LEXT)))
+20 SET LEXT=LEXT_$GET(LEXA(LEXI))
SET LEXC=$ORDER(LEXO(" "),-1)+1
SET LEXO(LEXC)=LEXT
End DoDot:2
+21 SET LEXT=LEXH2
SET LEXT=LEXT_$JUSTIFY(" ",((79-+($GET(LEXLEN)))-$LENGTH(LEXT)))
+22 KILL LEXA
SET LEXA(1)=LEX2
DO PR^LEXU(.LEXA,LEXLEN)
+23 SET LEXT=LEXT_LEXA(1)
SET LEXC=$ORDER(LEXO(" "),-1)+1
SET LEXO(LEXC)=LEXT
+24 SET LEXI=1
FOR
SET LEXI=$ORDER(LEXA(LEXI))
if +LEXI'>0
QUIT
Begin DoDot:2
+25 NEW LEXT
SET LEXT=""
SET LEXT=LEXT_$JUSTIFY(" ",((79-+($GET(LEXLEN)))-$LENGTH(LEXT)))
+26 SET LEXT=LEXT_$GET(LEXA(LEXI))
SET LEXC=$ORDER(LEXO(" "),-1)+1
SET LEXO(LEXC)=LEXT
End DoDot:2
End DoDot:1
+27 if $ORDER(LEXO(0))>0
DO BL
SET LEXI=0
FOR
SET LEXI=$ORDER(LEXO(LEXI))
if +LEXI'>0
QUIT
Begin DoDot:1
+28 NEW LEXT
SET LEXT=$GET(LEXO(LEXI))
if $LENGTH(LEXT)
DO TL(LEXT)
End DoDot:1
+29 QUIT
LIM(X,LEXLEN) ; Limitations
+1 NEW LEXI,LEXH,LEXL,LEXS,LEXT
SET LEXI=+($GET(X))
SET LEXL=$GET(LEXGET(81,(+LEXI_","),10.01,"E"))
if '$LENGTH(LEXL)
SET LEXL="N/A"
+2 SET LEXH=$GET(LEXGET(81,(+LEXI_","),10.02,"E"))
if '$LENGTH(LEXH)
SET LEXH="N/A"
SET LEXS=$GET(LEXGET(81,(+LEXI_","),10.03,"E"))
if '$LENGTH(LEXS)
SET LEXS="N/A"
+3 if (LEXH_LEXL_LEXS)="N/AN/AN/A"
QUIT
SET LEXT=" Limitations: "
SET LEXT=LEXT_$JUSTIFY(" ",((79-+($GET(LEXLEN)))-$LENGTH(LEXT)))_"Age Low: "_LEXL
+4 SET LEXT=LEXT_$JUSTIFY(" ",(35-$LENGTH(LEXT)))_"Age High: "_LEXH
SET LEXT=LEXT_$JUSTIFY(" ",(56-$LENGTH(LEXT)))_"Sex: "_LEXS
DO BL
DO TL(LEXT)
+5 QUIT
SD(X,LEXLEN) ; Short Description
+1 NEW LEXI,LEXH,LEXE,LEXN,LEXT
if '$DATA(X(1))
QUIT
SET LEXN=$GET(X(1))
SET LEXT=" Short Name: "
SET LEXT=LEXT_$JUSTIFY(" ",((79-+($GET(LEXLEN)))-$LENGTH(LEXT)))_LEXN
+2 DO BL
DO TL(LEXT)
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 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
LX(X,LEXLEN) ; Lexicon Expression
+1 NEW LEXI,LEXH,LEXE,LEXN,LEXT
if '$DATA(X(1))
QUIT
SET LEXN=$GET(X(1))
SET LEXT=" Lexicon Term:"
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
WR(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
MD(LEXM,LEXLEN) ; CPT Modifiers
+1 NEW LEXI,LEXC,LEXH,LEXE,LEXH1,LEXH2,LEXN,LEXT,LEXA
if '$DATA(LEXM(1))
QUIT
SET LEXLEN=+($GET(LEXLEN))
if +LEXLEN'>0
SET LEXLEN=62
SET LEXE=$GET(LEXM(0))
+2 SET LEXH1=" Modifiers:"
SET LEXH1=LEXH1_$JUSTIFY(" ",((79-+($GET(LEXLEN)))-$LENGTH(LEXH1)))
+3 SET LEXH2=" "_LEXE
SET LEXH2=LEXH2_$JUSTIFY(" ",((79-+($GET(LEXLEN)))-$LENGTH(LEXH2)))
+4 IF $DATA(LEXIIEN)
Begin DoDot:1
+5 NEW LEXA
SET LEXA(1)=$GET(LEXM(1))
DO PR^LEXU(.LEXA,LEXLEN)
+6 SET LEXT=LEXH1_$GET(LEXA(1))
DO BL
DO TL(LEXT)
IF $DATA(LEXA(2))
Begin DoDot:2
+7 SET LEXT=LEXH2_$GET(LEXA(2))
DO TL(LEXT)
+8 SET LEXH2=" "
SET LEXH2=LEXH2_$JUSTIFY(" ",((79-+($GET(LEXLEN)))-$LENGTH(LEXH2)))
End DoDot:2
+9 SET LEXC=1
FOR
SET LEXC=$ORDER(LEXM(LEXC))
if +LEXC'>0
QUIT
Begin DoDot:2
+10 NEW LEXS,LEXA,LEXI
+11 SET LEXA(1)=$GET(LEXM(LEXC))
DO PR^LEXU(.LEXA,LEXLEN)
+12 SET LEXI=0
FOR
SET LEXI=$ORDER(LEXA(LEXI))
if +LEXI'>0
QUIT
Begin DoDot:3
+13 NEW LEXS
SET LEXS=$GET(LEXA(LEXI))
if '$LENGTH(LEXS)
QUIT
+14 SET LEXS=LEXH2_LEXS
if LEXI=1
DO TL(LEXS)
if LEXI>1
DO TL((" "_LEXS))
+15 IF LEXI=1
SET LEXH2=" "
SET LEXH2=LEXH2_$JUSTIFY(" ",((79-+($GET(LEXLEN)))-$LENGTH(LEXH2)))
End DoDot:3
End DoDot:2
End DoDot:1
QUIT
+16 SET LEXN=$GET(LEXM(1))
SET LEXT=LEXH1_LEXN
DO BL
DO TL(LEXT)
+17 SET LEXN=$GET(LEXM(2))
SET LEXT=LEXH2_LEXN
DO TL(LEXT)
+18 SET LEXT=$JUSTIFY(" ",((79-+($GET(LEXLEN)))))
SET LEXI=2
FOR
SET LEXI=$ORDER(LEXM(LEXI))
if +LEXI'>0
QUIT
Begin DoDot:1
+19 SET LEXN=LEXT_$GET(LEXM(LEXI))
DO TL(LEXN)
End DoDot:1
+20 QUIT
MOD(X,LEXVDT,LEX,LEXLEN,LEXSTA) ; CPT Modifiers
+1 ;
+2 ; LEX=# of Lines
+3 ; LEX(0)=External Date
+4 ; LEX(#)=Modifier List
+5 ;
+6 NEW LEXA,LEXEVDT,LEXFA,LEXI,LEXIEN,LEXM,LEXS,LEXSO
SET LEXIEN=$GET(X)
if +LEXIEN'>0
QUIT
if '$DATA(^ICPT(+LEXIEN,0))
QUIT
SET LEXSTA=+($GET(LEXSTA))
+7 SET LEXVDT=+($GET(LEXVDT))
if LEXVDT'?7N
SET LEXVDT=$$DT^XLFDT
SET LEXEVDT=$$SD^LEXQM(LEXVDT)
SET LEXLEN=+($GET(LEXLEN))
if +LEXLEN'>0
SET LEXLEN=62
if '$LENGTH(LEXEVDT)
QUIT
+8 SET LEXSO=$PIECE($GET(^ICPT(+LEXIEN,0)),"^",1)
if '$LENGTH(LEXSO)
QUIT
SET LEXFA=$$FA(+LEXIEN)
if LEXVDT<LEXFA
QUIT
+9 KILL LEX
if +LEXSTA'>0
SET LEXEVDT=""
SET LEX(0)=LEXEVDT
DO MODA^ICPTMOD(LEXSO,LEXVDT,.LEXA)
+10 SET (LEXS,LEXM)=""
FOR
SET LEXM=$ORDER(LEXA("A",LEXM))
if '$LENGTH(LEXM)
QUIT
Begin DoDot:1
+11 if '$DATA(^DIC(81.3,"B",LEXM))
QUIT
NEW LEXTF,LEXTT,LEXTI,LEXTD
+12 SET LEXTF=""
SET LEXTT=$GET(LEXA("A",LEXM))
SET LEXTI=+LEXTT
SET LEXTD=$PIECE(LEXTT,"^",2)
+13 if LEXTI>0&($LENGTH(LEXTD))
SET LEXTF=LEXM_" "_LEXTD_" (IEN "_LEXTI_")"
+14 IF $DATA(LEXIIEN)
SET LEXS=""
SET LEXI=$ORDER(LEX(" "),-1)+1
if $LENGTH($GET(LEXTF))
SET LEX(LEXI)=$$TM^LEXQM(LEXTF)
QUIT
+15 IF ($LENGTH(LEXS)+$LENGTH(LEXM)+3)'>62
SET LEXS=LEXS_LEXM_" "
QUIT
+16 IF ($LENGTH(LEXS)+$LENGTH(LEXM)+3)>62
SET LEXI=$ORDER(LEX(" "),-1)+1
SET LEX(LEXI)=$$TM^LEXQM(LEXS)
SET LEXS=LEXM_" "
QUIT
End DoDot:1
+17 IF $LENGTH($GET(LEXS))
SET LEXI=$ORDER(LEX(" "),-1)+1
SET LEX(LEXI)=$$TM^LEXQM(LEXS)
+18 SET LEX=$ORDER(LEX(" "),-1)
+19 QUIT
WN(X,LEX,LEXLEN) ; Warning
+1 ;
+2 ; LEX=# of Lines
+3 ; LEX(0)=External Date
+4 ; LEX(#)=Warning
+5 ;
+6 NEW LEXVDT,LEXIA,LEXTMP,LEXREF
KILL LEX
SET LEXVDT=$GET(X)
if LEXVDT'?7N
QUIT
SET LEXIA=$$IA^LEXQCP(LEXVDT)
if +LEXIA'>0
QUIT
+7 SET LEXLEN=+$GET(LEXLEN)
if +LEXLEN>62
SET LEXLEN=62
SET LEXREF="Short Name and Description"
if $DATA(LEXLX)
SET LEXREF="Short Name, Description and Lexicon Term"
+8 SET LEXTMP(1)="Warning: The 'Based on Date' provided precedes Code Set Versioning. The "_LEXREF_" may be inaccurate for "_$$SD^LEXQM(LEXVDT)
+9 DO PR^LEXU(.LEXTMP,LEXLEN)
KILL LEX
SET LEXI=0
FOR
SET LEXI=$ORDER(LEXTMP(LEXI))
if +LEXI'>0
QUIT
SET LEX(LEXI)=$GET(LEXTMP(LEXI))
+10 SET LEX=$ORDER(LEX(" "),-1)
SET LEX(0)=$$SD^LEXQM(LEXVDT)
+11 QUIT
+12 ;
+13 ; Miscellaneous
CI(X,LEXD) ; Code IENs
+1 NEW LEXSO,LEXSDO,LEXLEX,LEXSAB
SET LEXSO=$GET(X)
if '$LENGTH(LEXSO)
QUIT
SET LEXD=$GET(LEXD)
IF LEXD'?7N
Begin DoDot:1
+2 NEW LEXEF,LEXTD
SET LEXTD=""
SET LEXEF=9999999
FOR
SET LEXEF=$ORDER(^LEX(757.02,"ACT",(LEXSO_" "),3,LEXEF),-1)
if +LEXEF'>0
QUIT
Begin DoDot:2
+3 NEW LEXIE
SET LEXIE=$ORDER(^LEX(757.02," "),-1)
FOR
SET LEXIE=$ORDER(^LEX(757.02,"ACT",(LEXSO_" "),3,+LEXEF,LEXIE),-1)
if +LEXIE'>0
QUIT
Begin DoDot:3
+4 NEW LEXSR
SET LEXSR=$PIECE($GET(^LEX(757.02,+LEXIE,0)),"^",3)
if "^3^4^"[("^"_LEXSR_"^")
SET LEXTD=LEXEF
End DoDot:3
End DoDot:2
+5 if LEXTD?7N
SET LEXD=LEXTD
End DoDot:1
+6 if LEXD'?7N
SET LEXD=$$DT^XLFDT
SET LEXSDO=$ORDER(^ICPT("BA",(LEXSO_" "),0))
SET LEXSAB=$SELECT($EXTRACT(LEXSO,1)?1U:"CPC",1:"CPT")
+7 SET LEXLEX=$$STATCHK^LEXSRC2(LEXSO,LEXD,,LEXSAB)
SET LEXLEX=$PIECE(LEXLEX,"^",2)
+8 SET LEXSDO=$SELECT(+LEXSDO>0:("CPT IEN "_+LEXSDO),1:"")
SET LEXLEX=$SELECT(+LEXLEX>0:("Lexicon IEN "_+LEXLEX),1:"")
+9 SET X=""
if $LENGTH(LEXSDO)&('$LENGTH(LEXLEX))
SET X=LEXSDO
if '$LENGTH(LEXSDO)&($LENGTH(LEXLEX))
SET X=LEXLEX
if $LENGTH(LEXSDO)&($LENGTH(LEXLEX))
SET X=(LEXSDO_"/"_LEXLEX)
+10 QUIT X
FA(X) ; First Activation
+1 NEW LEXFA,LEXH,LEXI,LEXIEN,LEXSO
+2 SET LEXIEN=+($GET(X))
SET X=""
SET LEXSO=$PIECE($GET(^ICPT(+LEXIEN,0)),"^",1)
DO HIST^ICPTAPIU(LEXSO,.LEXH)
SET LEXFA=""
SET LEXI=0
+3 FOR
SET LEXI=$ORDER(LEXH(LEXI))
if +LEXI'>0!($LENGTH(LEXFA))
QUIT
if +($GET(LEXH(LEXI)))>0&(LEXI?7N)
SET LEXFA=LEXI
if $LENGTH(LEXFA)
QUIT
+4 SET X=LEXFA
+5 QUIT X
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("LEXQCPO",$JOB," "),-1))+1
SET ^TMP("LEXQCPO",$JOB,LEXI)=$GET(X)
SET ^TMP("LEXQCPO",$JOB,0)=LEXI
+3 QUIT
CLR ; Clear
+1 NEW LEXIEN,LEXLEN,LEXGET,LEXSD,LEXLD,LEXMD,LEXLX,LEXINC,LEXELDT,LEXST,LEXTEST,LEXWN
+2 QUIT
