- 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
