LEXQCP2 ;ISL/KER - Query - CPT Procedures - Save ;04/21/2014
;;2.0;LEXICON UTILITY;**62,80**;Sep 23, 1996;Build 10
;
; 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
; 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(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,LEXLEN) ; Code Line
N LEXC,LEXN,LEXT S LEXC=$G(X),LEXN=$G(Y),LEXT="Code: "_LEXC,LEXT=LEXT_$J(" ",((79-+($G(LEXLEN)))-$L(LEXT)))_LEXN 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^LEXQM(.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 LEXI,LEX1,LEX2,LEXT,LEXH1,LEXH2,LEXV1,LEXV2,LEXT,LEXTC S LEXI=+($G(X)),LEX1=$G(LEXGET(81,(+LEXI_","),3,1)),LEX2=$G(LEXGET(81,(+LEXI_","),3,2)) Q:'$L((LEX1_LEX2))
S LEXT=" Categories: " S:$L(LEX1)&('$L(LEX2)) LEXT=" Category: " S:'$L(LEX1)&($L(LEX2)) LEXT=" Category: " S LEXT=LEXT_$J(" ",((79-+($G(LEXLEN)))-$L(LEXT)))
S:$L(LEX1)&($L(LEX2)) LEXH1="Major Category: "_LEX1,LEXH2="Sub-Category: "_LEX2 S LEXH2=$J(" ",(79-+($G(LEXLEN))))_$G(LEXH2) S:$L(LEX1)&('$L(LEX2)) LEXH1=LEX1,LEXH2=""
S:'$L(LEX1)&('$L(LEX2)) LEXH1="",LEXH2="" S LEX=LEXT_LEXH1_"^"_LEXH2
D:$L($P(LEX,"^",1))!($L($P(LEX,"^",2))) BL D:$L($P(LEX,"^",1)) TL($P(LEX,"^",1)) D:$L($P(LEX,"^",2)) TL($P(LEX,"^",2))
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(X,LEXLEN) ; CPT Modifiers
N LEXI,LEXH,LEXE,LEXN,LEXT Q:'$D(X(1)) S LEXE=$G(X(0)),LEXN=$G(X(1)),LEXT=" Modifiers:",LEXT=LEXT_$J(" ",((79-+($G(LEXLEN)))-$L(LEXT)))_LEXN D BL,TL(LEXT)
S 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 D
. S LEXN=LEXT_$G(X(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 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)) 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(LEXS) S LEXI=$O(LEX(" "),-1)+1,LEX(LEXI)=$$TM^LEXQM(LEXS)
S LEX=$O(LEX(" "),-1) S:$D(LEXTEST)&(+LEXSTA'>0) LEXEVDT="--/--/----" S LEX(0)=LEXEVDT
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^LEXQM(.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
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
LEXQCP2 ;ISL/KER - Query - CPT Procedures - Save ;04/21/2014
+1 ;;2.0;LEXICON UTILITY;**62,80**;Sep 23, 1996;Build 10
+2 ;
+3 ; Global Variables
+4 ; ^DIC(81.3, ICR 4492
+5 ; ^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 ; LEXLEN Offset Length
+17 ; LEXGET Array of Non-Versioned Data
+18 ; LEXST CPT Status and Effective Dates
+19 ; LEXSD Versioned Short Description
+20 ; LEXLD Versioned Long Description
+21 ; LEXMD Versioned Modifiers
+22 ; LEXLX Versioned Lexicon Term
+23 ; LEXWN Warning
+24 ; LEXINC Flag to Display Modifiers
+25 ; LEXELDT External Last Date
+26 ;
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(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,LEXLEN) ; Code Line
+1 NEW LEXC,LEXN,LEXT
SET LEXC=$GET(X)
SET LEXN=$GET(Y)
SET LEXT="Code: "_LEXC
SET LEXT=LEXT_$JUSTIFY(" ",((79-+($GET(LEXLEN)))-$LENGTH(LEXT)))_LEXN
DO BL
DO TL(LEXT)
+2 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^LEXQM(.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 LEXI,LEX1,LEX2,LEXT,LEXH1,LEXH2,LEXV1,LEXV2,LEXT,LEXTC
SET LEXI=+($GET(X))
SET LEX1=$GET(LEXGET(81,(+LEXI_","),3,1))
SET LEX2=$GET(LEXGET(81,(+LEXI_","),3,2))
IF '$LENGTH((LEX1_LEX2))
QUIT
+2 SET LEXT=" Categories: "
IF $LENGTH(LEX1)&('$LENGTH(LEX2))
SET LEXT=" Category: "
IF '$LENGTH(LEX1)&($LENGTH(LEX2))
SET LEXT=" Category: "
SET LEXT=LEXT_$JUSTIFY(" ",((79-+($GET(LEXLEN)))-$LENGTH(LEXT)))
+3 IF $LENGTH(LEX1)&($LENGTH(LEX2))
SET LEXH1="Major Category: "_LEX1
SET LEXH2="Sub-Category: "_LEX2
SET LEXH2=$JUSTIFY(" ",(79-+($GET(LEXLEN))))_$GET(LEXH2)
IF $LENGTH(LEX1)&('$LENGTH(LEX2))
SET LEXH1=LEX1
SET LEXH2=""
+4 IF '$LENGTH(LEX1)&('$LENGTH(LEX2))
SET LEXH1=""
SET LEXH2=""
SET LEX=LEXT_LEXH1_"^"_LEXH2
+5 IF $LENGTH($PIECE(LEX,"^",1))!($LENGTH($PIECE(LEX,"^",2)))
DO BL
IF $LENGTH($PIECE(LEX,"^",1))
DO TL($PIECE(LEX,"^",1))
IF $LENGTH($PIECE(LEX,"^",2))
DO TL($PIECE(LEX,"^",2))
+6 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
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 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(X,LEXLEN) ; CPT Modifiers
+1 NEW LEXI,LEXH,LEXE,LEXN,LEXT
IF '$DATA(X(1))
QUIT
SET LEXE=$GET(X(0))
SET LEXN=$GET(X(1))
SET LEXT=" Modifiers:"
SET LEXT=LEXT_$JUSTIFY(" ",((79-+($GET(LEXLEN)))-$LENGTH(LEXT)))_LEXN
DO BL
DO TL(LEXT)
+2 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
Begin DoDot:1
+4 SET LEXN=LEXT_$GET(X(LEXI))
DO TL(LEXN)
End DoDot:1
+5 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
DO MODA^ICPTMOD(LEXSO,LEXVDT,.LEXA)
SET (LEXS,LEXM)=""
FOR
SET LEXM=$ORDER(LEXA("A",LEXM))
IF '$LENGTH(LEXM)
QUIT
Begin DoDot:1
+10 IF '$DATA(^DIC(81.3,"B",LEXM))
QUIT
IF ($LENGTH(LEXS)+$LENGTH(LEXM)+3)'>62
SET LEXS=LEXS_LEXM_" "
QUIT
+11 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
+12 IF $LENGTH(LEXS)
SET LEXI=$ORDER(LEX(" "),-1)+1
SET LEX(LEXI)=$$TM^LEXQM(LEXS)
+13 SET LEX=$ORDER(LEX(" "),-1)
IF $DATA(LEXTEST)&(+LEXSTA'>0)
SET LEXEVDT="--/--/----"
SET LEX(0)=LEXEVDT
+14 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^LEXQM(.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
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
