LEXQCP ;ISL/KER - Query - CPT Procedures - Extract ;05/23/2017
;;2.0;LEXICON UTILITY;**62,80,103**;Sep 23, 1996;Build 2
;
; Global Variables
; ^ICPT( ICR 4489
;
; External References
; $$CPTD^ICPTCOD ICR 1995
; $$CPT^ICPTCOD ICR 1995
; $$DT^XLFDT ICR 10103
; $$GET1^DIQ ICR 2056
; $$UP^XLFSTR ICR 10104
; GETS^DIQ ICR 2056
;
; Local Variables NEWed or KILLed Elsewhere
; LEXIIEN Include IENs flag
;
EN ; Main Entry Point
N LEXENV S LEXENV=$$EV^LEXQM Q:+LEXENV'>0
N I,LEXAD,LEXEDT,LEXCDT,LEXEXIT,LEXGET,LEXLD,LEXLEN,LEXLX,LEXMD,LEXSD,LEXST,LEXTEST,Z S LEXEXIT=0,LEXCDT="" W !
F S LEXCDT=$$AD^LEXQM,LEXAD=LEXCDT Q:'$L(LEXCDT) S LEXEDT=$P(LEXCDT,"^",1),LEXCDT=$P(LEXCDT,"^",2) Q:LEXCDT'?7N D LOOK Q:LEXCDT'?7N Q:+LEXEXIT>0
Q
IEN ; Display with IENs
N LEXIIEN S LEXIIEN=1 D EN
Q
LOOK ; CPT Lookup Loop
S LEXCDT=$G(LEXCDT),LEXEDT=$$ED^LEXQM(LEXCDT) I LEXCDT'?7N S LEXCDT="" Q
N LEXCPT,LEXCPTC S LEXLEN=62
F S LEXCPT=$$CPT^LEXQCPA S:LEXCPT="^^" LEXEXIT=1 Q:LEXCPT="^"!(LEXCPT="^^") D Q:LEXCPT="^"!(LEXCPT="^^")
. K LEXGET,LEXST,LEXSD,LEXLD,LEXMD,LEXLX,LEXWN N LEXIEN,LEXLDT,LEXELDT,LEXINC,LEXFA
. S LEXIEN=+($G(LEXCPT)),LEXLDT=+($G(LEXCDT)),LEXFA=$$FA^LEXQCP2(+LEXIEN)
. Q:+LEXIEN'>0 Q:LEXLDT'?7N S LEXELDT=$$SD^LEXQM(LEXLDT) Q:'$L(LEXELDT)
. S LEXINC=0 I LEXFA?7N,LEXCDT?7N,LEXFA'>LEXCDT D
. . S LEXINC=$$INC^LEXQCPA Q:LEXINC["^"
. D CSV,EN^LEXQCP2
Q
CSV ; Code Set Versioning Display
N LEXEDT,LEXIEN,LEXIENS,LEXLTXT,LEXSO,LEXSTAT
S LEXCDT=$G(LEXCDT),LEXEDT=$$ED^LEXQM(LEXCDT) I LEXCDT'?7N S (LEXCPT,LEXCDT)="" Q
S LEXIEN=+($G(LEXCPT)),LEXSO=$P($G(LEXCPT),"^",2),LEXLTXT=$P($G(LEXCPT),"^",3) Q:+LEXIEN'>0 Q:'$L(LEXSO)
;
; Get the "Unversioned" Fields
;
; CPT Code Field .01
; CPT Major Category Field 3
; CPT Sub-Category Field 3
; Age Low Field 10.01
; Age High Field 10.02
; Sex Field 10.03
;
S LEXIENS=LEXIEN_"," D GETS^DIQ(81,LEXIENS,".01;3;10.01;10.02;10.03","IE","LEXGET","LEXMSG")
I $G(LEXGET(81,LEXIENS,3,"I"))>0,$L($G(LEXGET(81,LEXIENS,3,"I"))) D
. S LEXGET(81,LEXIENS,3,2)=$$GET1^DIQ(81.1,(+($G(LEXGET(81,LEXIENS,3,"I")))_","),.01)
. S LEXGET(81,LEXIENS,3,1)=$$GET1^DIQ(81.1,(+($G(LEXGET(81,LEXIENS,3,"I")))_","),3)
. I $L($G(LEXGET(81,LEXIENS,3,2))),'$L($G(LEXGET(81,LEXIENS,3,1))) S LEXGET(81,LEXIENS,3,1)=$G(LEXGET(81,LEXIENS,3,2)) K LEXGET(81,LEXIENS,3,2)
. I $G(LEXGET(81,LEXIENS,3,2))=$G(LEXGET(81,LEXIENS,3,1)) K LEXGET(81,LEXIENS,3,2)
. I '$L($G(LEXGET(81,LEXIENS,3,2))),'$L($G(LEXGET(81,LEXIENS,3,1))) K LEXGET(81,LEXIENS,3,1),LEXGET(81,LEXIENS,3,2)
; Get the "Versioned" Fields
;
; Effective Date and Status Sub-File 81.02 (60)
S LEXST=$$EF(+($G(LEXIEN)),+LEXCDT),LEXSTAT=+($P(LEXST,"^",2))
; Procedure Name Sub-File 81.061 (61)
D SDS(+($G(LEXIEN)),+LEXCDT,.LEXSD,62,LEXSTAT)
; Description Sub-File 81.062 (62)
D LDS(+($G(LEXIEN)),+LEXCDT,.LEXLD,62,LEXSTAT)
; Lexicon Expression
D LX(+($G(LEXIEN)),+LEXCDT,.LEXLX,62,LEXSTAT)
D WN^LEXQCP2(+LEXCDT,.LEXWN,62)
D MOD^LEXQCP2(+($G(LEXIEN)),+LEXCDT,.LEXMD,62,LEXSTAT)
Q
;
EF(X,LEXCDT) ; Effective Dates
N LEX,LEXBRD,LEXBRW,LEXAD,LEXEE,LEXEF,LEXES,LEXFA,LEXH,LEXI,LEXID,LEXIEN,LEXLS,LEXSO,LEXST S LEXIEN=+($G(X)),LEXCDT=+($G(LEXCDT))
Q:+LEXIEN'>0 "^^" Q:'$L(^ICPT(+LEXIEN,0)) "^^" Q:LEXCDT'?7N "^^" S LEXSO=$P($G(^ICPT(+LEXIEN,0)),"^",1),LEXBRD=2890101,LEXBRW=""
S LEX=$$CPT^ICPTCOD(LEXSO,LEXCDT) S LEXFA=$$FA^LEXQCP2(+LEXIEN) S (LEXLS,LEXST)=$P(LEX,"^",7),LEXID=$P(LEX,"^",8)
S:LEXCDT<LEXBRD&(+LEXFA=LEXBRD) LEXBRW="Warning: The 'Based on Date' provided precedes the initial Code Set Business Rule date of "_$$SD^LEXQM(LEXBRD)_", the Effective date may be inaccurate."
S LEXAD=$P(LEX,"^",9),LEXES=$S(+LEXST>0:"Active",1:"Inactive")
S:+LEXST'>0&(+LEXAD'>0) LEXES="Not Applicable",LEXLS=-1
S:+LEXFA>0&(+LEXCDT>0)&(LEXFA>LEXCDT) LEXES="Pending",LEXLS=-1,LEXST=0,LEXBRW=""
S:LEXST>0 LEXEF=LEXAD S:LEXST'>0 LEXEF=LEXID
S:LEXST'>0&(+LEXID'>0) LEXEF=LEXFA S LEXEE=$$SD^LEXQM(LEXEF)
I LEXST'>0,+LEXID'>0,$L(LEXEE),+LEXEF>LEXCDT S LEXEE="(future activation of "_LEXEE_")",LEXEF=""
S X=LEXLS_"^"_LEXST_"^"_LEXEF_"^"_LEXES_"^"_LEXEE S:$L(LEXBRW) $P(X,"^",6)=LEXBRW
Q X
;
SDS(X,LEXVDT,LEX,LEXLEN,LEXSTA) ; Procedure Name (short description)
;
; LEX=# of Lines
; LEX(0)=External Date of Procedure Name
; LEX(#)=Procedure Name
;
N LEXD,LEXBRD,LEXBRW,LEXDDT,LEXE,LEXEE,LEXEFF,LEXFA,LEXHIS,LEXI,LEXIA,LEXIEN,LEXAIEN,LEXSIEN,LEXL,LEXLAST,LEXLEF,LEXLHI
N LEXM,LEXR,LEXSDT,LEXSO,LEXLSD,LEXT S LEXIEN=$G(X) Q:+LEXIEN'>0 Q:'$D(^ICPT(+LEXIEN,61)) S LEXVDT=+($G(LEXVDT))
S:LEXVDT'?7N LEXVDT=$$DT^XLFDT S LEXSTA=+($G(LEXSTA)) S LEXSO=$P($G(^ICPT(+LEXIEN,0)),"^",1)
S LEXLAST=$$CPT^ICPTCOD(LEXSO),LEXLSD=$P(LEXLAST,"^",3),LEXBRD=2890101,LEXBRW=""
S:$D(LEXGET)&($L(LEXLSD)) LEXGET(81,(+LEXIEN_","),"B")=LEXLSD
S LEXLEN=+($G(LEXLEN)) S:+LEXLEN'>0 LEXLEN=62 S LEXFA=$$FA^LEXQCP2(+LEXIEN),LEXM=""
S LEXM="" S:+LEXVDT<LEXFA&(LEXFA'=LEXBRD) LEXM="Procedure Short Name is not available. The date provided precedes the initial activation of the code"
I $L(LEXM) D Q
. K LEX N LEXT,LEXI S LEXT(1)=LEXM D PR^LEXU(.LEXT,(LEXLEN-7))
. S LEXI=0 F S LEXI=$O(LEXT(LEXI)) Q:+LEXI'>0 S LEXT=$G(LEXT(LEXI)) S LEX(LEXI)=LEXT
. S:$D(LEX(1)) LEX(0)="--/--/----" S LEX=+($O(LEX(" "),-1))
S LEXM="" S LEXEFF=$O(^ICPT(LEXIEN,61,"B",(LEXVDT+.001)),-1),LEXHIS=$O(^ICPT(LEXIEN,61,"B",+LEXEFF," "),-1),LEXSDT=$P($G(^ICPT(+LEXIEN,61,+LEXHIS,0)),"^",2)
S LEXLEF=$O(^ICPT(LEXIEN,61,"B",(9999999+.001)),-1),LEXLHI=$O(^ICPT(LEXIEN,61,"B",+LEXLEF," "),-1),LEXDDT=$P($G(^ICPT(+LEXIEN,61,+LEXLHI,0)),"^",2)
S (LEXAIEN,LEXSIEN)="" S LEXSIEN=LEXHIS S:$G(LEXDDT)?7N LEXSIEN=$O(^ICPT(+LEXIEN,61,"B",LEXDDT,0))
S LEXAIEN=LEXIEN S:+LEXSIEN>0 LEXAIEN=LEXAIEN_";"_LEXSIEN
S (LEXD,LEXE,LEXR)="" S:$L(LEXSDT)&(LEXEFF?7N) LEXD=LEXSDT,LEXE=LEXEFF
S:$L(LEXDDT)&(LEXLEF?7N)&('$L(LEXD))&('$L(LEXE)) LEXD=LEXDDT,LEXE=LEXLEF,LEXR="No Text Available for Date Provided"
S:$D(LEXIIEN) LEXD=LEXD_" (IEN "_LEXAIEN_")"
K LEX S LEX(1)=LEXD S:$L(LEXD) LEXGET(81,(+LEXIEN_","),"B")=LEXD
S LEXEE=$$SD^LEXQM(LEXE) S:$D(LEXTEST)&(+LEXSTA'>0) LEXEE="--/--/----" S:$L(LEX(1)) LEX(0)=LEXEE
S LEX=+($O(LEX(" "),-1))
Q
LDS(X,LEXVDT,LEX,LEXLEN,LEXSTA) ; Long Description
;
; LEX=# of Lines
; LEX(0)=External Date of Description
; LEX(#)=Description
; LEX(#)=Description continued
;
N LEXC,LEXBRD,LEXBRW,LEXDDT,LEXEVDT,LEXFA,LEXI,LEXIEN,LEXAIEN,LEXSIEN,LEXL,LEXLN,LEXM,LEXT,LEXSO,LEXTL,LEXTMP
S LEXIEN=$G(X) Q:+LEXIEN'>0 Q:'$D(^ICPT(+LEXIEN,62))
S LEXVDT=+($G(LEXVDT)) S:LEXVDT'?7N LEXVDT=$$DT^XLFDT S LEXEVDT=$$SD^LEXQM(LEXVDT),LEXLEN=+($G(LEXLEN)) S:+LEXLEN'>0 LEXLEN=62
S LEXSO=$P($G(^ICPT(+LEXIEN,0)),"^",1) S LEXFA=$$FA^LEXQCP2(+LEXIEN),LEXM="" S LEXSTA=+($G(LEXSTA)),LEXBRD=2890101,LEXBRW=""
S LEXM="" S:+LEXVDT<LEXFA&(LEXFA'=LEXBRD) LEXM="Description is not available. The date provided precedes the initial activation of the code"
I $L(LEXM) D Q
. K LEX N LEXT,LEXI S LEXT(1)=LEXM D PR^LEXU(.LEXT,(LEXLEN-7)) S LEXI=0 F S LEXI=$O(LEXT(LEXI)) Q:+LEXI'>0 S LEXT=$G(LEXT(LEXI)) S LEX(LEXI)=LEXT
. S:$D(LEX(1)) LEX(0)="--/--/----" S LEX=+($O(LEX(" "),-1))
K LEXTMP S LEXTL=$$CPTD^ICPTCOD(LEXSO,"LEXTMP",,LEXVDT) S LEXL=+($O(LEXTMP(" "),-1)),LEXLN=$G(LEXTMP(+LEXL))
S LEXM="" K:LEXL>0&(LEXLN["CODE TEXT MAY BE INACCURATE") LEXTMP(+LEXL)
F LEXI=1:1:2 S LEXL=+($O(LEXTMP(" "),-1)),LEXLN=$$TM^LEXQM($G(LEXTMP(+LEXL))) K:LEXL>0&('$L(LEXLN)) LEXTMP(+LEXL)
S LEXDDT=$O(^ICPT(+LEXIEN,62,"B",(LEXVDT+.999999)),-1) S:LEXDDT'?7N LEXDDT=$O(^ICPT(+LEXIEN,62,"B",0)) S:LEXDDT?7N LEXEVDT=$$SD^LEXQM(LEXDDT)
S (LEXAIEN,LEXSIEN)="" S:$G(LEXDDT)?7N LEXSIEN=$O(^ICPT(+LEXIEN,62,"B",LEXDDT,0))
S LEXAIEN=LEXIEN S:+LEXSIEN>0 LEXAIEN=LEXAIEN_";"_LEXSIEN
I $D(LEXIIEN) D
. N LEXI S LEXI=$O(LEXTMP(" "),-1) Q:LEXI'>0 Q:'$D(LEXTMP(LEXI))
. S LEXTMP(LEXI)=$G(LEXTMP(LEXI))_" (IEN "_LEXAIEN_")"
D PR^LEXU(.LEXTMP,LEXLEN) K LEX S LEXI=0 F S LEXI=$O(LEXTMP(LEXI)) Q:+LEXI'>0 D
. Q:'$D(LEXTMP(LEXI)) S LEXT=$$TM^LEXQM($G(LEXTMP(LEXI))),LEX(LEXI)=$$UP^XLFSTR(LEXT)
I $L(LEXM) D
. N LEXT,LEXI,LEXL,LEXC S LEXL=+($O(LEX(" "),-1)),LEXC=0 S LEXT(1)=LEXM D PR^LEXU(.LEXT,(LEXLEN-7))
. S LEXI=0 F S LEXI=$O(LEXT(LEXI)) Q:+LEXI'>0 D
. . S LEXT=$G(LEXT(LEXI)) S:$L(LEXT) LEXC=LEXC+1 S LEXL=LEXL+1,LEX(LEXL)=LEXT
S:$D(LEXTEST)&(+LEXSTA'>0) LEXEVDT="--/--/----" S:$D(LEX(1)) LEX(0)=LEXEVDT S LEX=+($O(LEX(" "),-1))
Q
LX(X,LEXVDT,LEX,LEXLEN,LEXSTA) ; Lexicon Expression
;
; LEX=# of Lines
; LEX(0)=External Date of Expression
; LEX(#)=Expression
; LEX(#)=Expression continued
;
N LEXEF,LEXEVDT,LEXLEX,LEXEE,LEXFA,LEXI,LEXIA,LEXIEN,LEXLEF,LEXLHS,LEXLST,LEXM,LEXN0,LEXPF,LEXSAB,LEXSIEN,LEXSO
N LEXTSRC,LEXT,LEXTE,LEXTEXP,LEXTEF,LEXTEFE,LEXTS,LEXTSTA,LEXVTMP
S LEXIEN=$G(X) Q:+LEXIEN'>0 Q:'$D(^ICPT(+LEXIEN,0)) S LEXVDT=+($G(LEXVDT)) S:LEXVDT'?7N LEXVDT=$$DT^XLFDT S LEXSTA=+($G(LEXSTA))
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^LEXQCP2(+LEXIEN),LEXM="",LEXIA=$$IA(LEXVDT)
S LEXTSRC=$P($G(^ICPT(+LEXIEN,0)),"^",6) S LEXTSRC=$S(LEXTSRC="H":"CPC",LEXTSRC="C":"CPT",1:"")
S LEXTSTA=$$STATCHK^LEXSRC2(LEXSO,LEXVDT,,LEXTSRC)
S LEXTS=$P($G(LEXTSTA),"^",2),LEXTE=+($G(^LEX(757.02,+LEXTS,0))),LEXTEXP=$G(^LEX(757.01,+LEXTE,0))
S (LEXTEF,LEXTEFE)="",LEXEF="" F S LEXEF=$O(^LEX(757.02,+LEXTS,4,"B",LEXEF)) Q:+LEXEF'>0 D
. N LEXH S LEXH=0 F S LEXH=$O(^LEX(757.02,+LEXTS,4,"B",LEXEF,LEXH)) Q:+LEXH'>0 D
. . S:$P($G(^LEX(757.02,+LEXTS,4,+LEXH,0)),"^",2)>0&(LEXEF?7N) LEXTEF=LEXEF
. . S:LEXTEF?7N LEXTEFE=$$SD^LEXQM(LEXTEF)
I LEXSTA'>0,$L($G(LEXTEXP)),$G(LEXTEF)?7N,$L($G(LEXTEFE)) D Q
. K LEX N LEXT,LEXM,LEXI S LEXT(1)=LEXTEXP S:$D(LEXIIEN) LEXT(1)=$G(LEXT(1))_" (IEN "_LEXTE_")"
. D PR^LEXU(.LEXT,(LEXLEN-7))
. S LEXI=0 F S LEXI=$O(LEXT(LEXI)) Q:+LEXI'>0 S:$L($G(LEXT(LEXI))) LEX(+LEXI)=$G(LEXT(LEXI))
. S LEX=+($O(LEX(" "),-1)) S LEX(0)=LEXTEFE
S LEXSIEN=0 F S LEXSIEN=$O(^LEX(757.02,"CODE",(LEXSO_" "),LEXSIEN)) Q:+LEXSIEN'>0 D
. N LEXN0 S LEXN0=$G(^LEX(757.02,+LEXSIEN,0)),LEXSAB=$P(LEXN0,"^",3)
. Q:"^3^4^"'[("^"_LEXSAB_"^") S LEXPF=+($P(LEXN0,"^",5)) S LEXLEF=$O(^LEX(757.02,+LEXSIEN,4,"B",(LEXVDT+.99999)),-1) I LEXLEF?7N D
. . S LEXLHS=$O(^LEX(757.02,+LEXSIEN,4,"B",+LEXLEF," "),-1) I +LEXLHS>0 D
. . . S LEXLST=$G(^LEX(757.02,+LEXSIEN,4,+LEXLHS,0)),LEXLST=$P(LEXLST,"^",2)
. . . S:LEXLST>0 LEXVTMP(+LEXPF,LEXSIEN)=+LEXN0_"^"_LEXLEF
S (LEXLEX,LEXEF)="",LEXSIEN=$O(LEXVTMP(1,0)),LEXLEX=+($G(LEXVTMP(1,+LEXSIEN))),LEXEF=$P($G(LEXVTMP(1,+LEXSIEN)),"^",2)
S:+LEXSIEN'>0!(+LEXLEX'>0) LEXSIEN=$O(LEXVTMP(0,0)),LEXLEX=+($G(LEXVTMP(0,+LEXSIEN))),LEXEF=$P($G(LEXVTMP(0,+LEXSIEN)),"^",2)
K LEX I +LEXLEX>0,$L($G(^LEX(757.01,+LEXLEX,0))),$L(LEXEF),LEXEF?7N D Q
. K LEX N LEXT,LEXM,LEXI S LEXT(1)=$G(^LEX(757.01,+LEXLEX,0)) S:$D(LEXIIEN) LEXT(1)=$G(LEXT(1))_" (IEN "_LEXLEX_")"
. D PR^LEXU(.LEXT,(LEXLEN-7)) S LEXI=0 F S LEXI=$O(LEXT(LEXI)) Q:+LEXI'>0 S:$L($G(LEXT(LEXI))) LEX(+LEXI)=$G(LEXT(LEXI))
. S LEX=+($O(LEX(" "),-1)) S LEXEE=$$SD^LEXQM(LEXEF) S:$D(LEXTEST)&(+LEXSTA'>0) LEXEE="--/--/----" S LEX(0)=LEXEE
Q
; Miscellaneous
IA(X) ; Inaccurate
N LEXBRD,LEXVDT,LEXSYS S LEXVDT=+($G(X)),LEXSYS=1,LEXVDT=$S($G(LEXVDT)="":$$DT^XLFDT,1:$$DBR(LEXVDT)),LEXBRD=3021001,X=$S(LEXVDT<LEXBRD:1,1:0)
Q X
DBR(X) ; Date Business Rules
N LEXVDT S LEXVDT=$G(X) Q:'$G(LEXVDT)!($P(LEXVDT,".")'?7N) $$DT^XLFDT
S:LEXVDT#10000=0 LEXVDT=LEXVDT+101 S:LEXVDT#100=0 LEXVDT=LEXVDT+1 S X=$S(LEXVDT<2890101:2890101,1:LEXVDT)
Q X
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLEXQCP 12096 printed Apr 09, 2024@21:12:47 Page 2
LEXQCP ;ISL/KER - Query - CPT Procedures - Extract ;05/23/2017
+1 ;;2.0;LEXICON UTILITY;**62,80,103**;Sep 23, 1996;Build 2
+2 ;
+3 ; Global Variables
+4 ; ^ICPT( ICR 4489
+5 ;
+6 ; External References
+7 ; $$CPTD^ICPTCOD ICR 1995
+8 ; $$CPT^ICPTCOD ICR 1995
+9 ; $$DT^XLFDT ICR 10103
+10 ; $$GET1^DIQ ICR 2056
+11 ; $$UP^XLFSTR ICR 10104
+12 ; GETS^DIQ ICR 2056
+13 ;
+14 ; Local Variables NEWed or KILLed Elsewhere
+15 ; LEXIIEN Include IENs flag
+16 ;
EN ; Main Entry Point
+1 NEW LEXENV
SET LEXENV=$$EV^LEXQM
if +LEXENV'>0
QUIT
+2 NEW I,LEXAD,LEXEDT,LEXCDT,LEXEXIT,LEXGET,LEXLD,LEXLEN,LEXLX,LEXMD,LEXSD,LEXST,LEXTEST,Z
SET LEXEXIT=0
SET LEXCDT=""
WRITE !
+3 FOR
SET LEXCDT=$$AD^LEXQM
SET LEXAD=LEXCDT
if '$LENGTH(LEXCDT)
QUIT
SET LEXEDT=$PIECE(LEXCDT,"^",1)
SET LEXCDT=$PIECE(LEXCDT,"^",2)
if LEXCDT'?7N
QUIT
DO LOOK
if LEXCDT'?7N
QUIT
if +LEXEXIT>0
QUIT
+4 QUIT
IEN ; Display with IENs
+1 NEW LEXIIEN
SET LEXIIEN=1
DO EN
+2 QUIT
LOOK ; CPT Lookup Loop
+1 SET LEXCDT=$GET(LEXCDT)
SET LEXEDT=$$ED^LEXQM(LEXCDT)
IF LEXCDT'?7N
SET LEXCDT=""
QUIT
+2 NEW LEXCPT,LEXCPTC
SET LEXLEN=62
+3 FOR
SET LEXCPT=$$CPT^LEXQCPA
if LEXCPT="^^"
SET LEXEXIT=1
if LEXCPT="^"!(LEXCPT="^^")
QUIT
Begin DoDot:1
+4 KILL LEXGET,LEXST,LEXSD,LEXLD,LEXMD,LEXLX,LEXWN
NEW LEXIEN,LEXLDT,LEXELDT,LEXINC,LEXFA
+5 SET LEXIEN=+($GET(LEXCPT))
SET LEXLDT=+($GET(LEXCDT))
SET LEXFA=$$FA^LEXQCP2(+LEXIEN)
+6 if +LEXIEN'>0
QUIT
if LEXLDT'?7N
QUIT
SET LEXELDT=$$SD^LEXQM(LEXLDT)
if '$LENGTH(LEXELDT)
QUIT
+7 SET LEXINC=0
IF LEXFA?7N
IF LEXCDT?7N
IF LEXFA'>LEXCDT
Begin DoDot:2
+8 SET LEXINC=$$INC^LEXQCPA
if LEXINC["^"
QUIT
End DoDot:2
+9 DO CSV
DO EN^LEXQCP2
End DoDot:1
if LEXCPT="^"!(LEXCPT="^^")
QUIT
+10 QUIT
CSV ; Code Set Versioning Display
+1 NEW LEXEDT,LEXIEN,LEXIENS,LEXLTXT,LEXSO,LEXSTAT
+2 SET LEXCDT=$GET(LEXCDT)
SET LEXEDT=$$ED^LEXQM(LEXCDT)
IF LEXCDT'?7N
SET (LEXCPT,LEXCDT)=""
QUIT
+3 SET LEXIEN=+($GET(LEXCPT))
SET LEXSO=$PIECE($GET(LEXCPT),"^",2)
SET LEXLTXT=$PIECE($GET(LEXCPT),"^",3)
if +LEXIEN'>0
QUIT
if '$LENGTH(LEXSO)
QUIT
+4 ;
+5 ; Get the "Unversioned" Fields
+6 ;
+7 ; CPT Code Field .01
+8 ; CPT Major Category Field 3
+9 ; CPT Sub-Category Field 3
+10 ; Age Low Field 10.01
+11 ; Age High Field 10.02
+12 ; Sex Field 10.03
+13 ;
+14 SET LEXIENS=LEXIEN_","
DO GETS^DIQ(81,LEXIENS,".01;3;10.01;10.02;10.03","IE","LEXGET","LEXMSG")
+15 IF $GET(LEXGET(81,LEXIENS,3,"I"))>0
IF $LENGTH($GET(LEXGET(81,LEXIENS,3,"I")))
Begin DoDot:1
+16 SET LEXGET(81,LEXIENS,3,2)=$$GET1^DIQ(81.1,(+($GET(LEXGET(81,LEXIENS,3,"I")))_","),.01)
+17 SET LEXGET(81,LEXIENS,3,1)=$$GET1^DIQ(81.1,(+($GET(LEXGET(81,LEXIENS,3,"I")))_","),3)
+18 IF $LENGTH($GET(LEXGET(81,LEXIENS,3,2)))
IF '$LENGTH($GET(LEXGET(81,LEXIENS,3,1)))
SET LEXGET(81,LEXIENS,3,1)=$GET(LEXGET(81,LEXIENS,3,2))
KILL LEXGET(81,LEXIENS,3,2)
+19 IF $GET(LEXGET(81,LEXIENS,3,2))=$GET(LEXGET(81,LEXIENS,3,1))
KILL LEXGET(81,LEXIENS,3,2)
+20 IF '$LENGTH($GET(LEXGET(81,LEXIENS,3,2)))
IF '$LENGTH($GET(LEXGET(81,LEXIENS,3,1)))
KILL LEXGET(81,LEXIENS,3,1),LEXGET(81,LEXIENS,3,2)
End DoDot:1
+21 ; Get the "Versioned" Fields
+22 ;
+23 ; Effective Date and Status Sub-File 81.02 (60)
+24 SET LEXST=$$EF(+($GET(LEXIEN)),+LEXCDT)
SET LEXSTAT=+($PIECE(LEXST,"^",2))
+25 ; Procedure Name Sub-File 81.061 (61)
+26 DO SDS(+($GET(LEXIEN)),+LEXCDT,.LEXSD,62,LEXSTAT)
+27 ; Description Sub-File 81.062 (62)
+28 DO LDS(+($GET(LEXIEN)),+LEXCDT,.LEXLD,62,LEXSTAT)
+29 ; Lexicon Expression
+30 DO LX(+($GET(LEXIEN)),+LEXCDT,.LEXLX,62,LEXSTAT)
+31 DO WN^LEXQCP2(+LEXCDT,.LEXWN,62)
+32 DO MOD^LEXQCP2(+($GET(LEXIEN)),+LEXCDT,.LEXMD,62,LEXSTAT)
+33 QUIT
+34 ;
EF(X,LEXCDT) ; Effective Dates
+1 NEW LEX,LEXBRD,LEXBRW,LEXAD,LEXEE,LEXEF,LEXES,LEXFA,LEXH,LEXI,LEXID,LEXIEN,LEXLS,LEXSO,LEXST
SET LEXIEN=+($GET(X))
SET LEXCDT=+($GET(LEXCDT))
+2 if +LEXIEN'>0
QUIT "^^"
if '$LENGTH(^ICPT(+LEXIEN,0))
QUIT "^^"
if LEXCDT'?7N
QUIT "^^"
SET LEXSO=$PIECE($GET(^ICPT(+LEXIEN,0)),"^",1)
SET LEXBRD=2890101
SET LEXBRW=""
+3 SET LEX=$$CPT^ICPTCOD(LEXSO,LEXCDT)
SET LEXFA=$$FA^LEXQCP2(+LEXIEN)
SET (LEXLS,LEXST)=$PIECE(LEX,"^",7)
SET LEXID=$PIECE(LEX,"^",8)
+4 if LEXCDT<LEXBRD&(+LEXFA=LEXBRD)
SET LEXBRW="Warning: The 'Based on Date' provided precedes the initial Code Set Business Rule date of "_$$SD^LEXQM(LEXBRD)_", the Effective date may be inaccurate."
+5 SET LEXAD=$PIECE(LEX,"^",9)
SET LEXES=$SELECT(+LEXST>0:"Active",1:"Inactive")
+6 if +LEXST'>0&(+LEXAD'>0)
SET LEXES="Not Applicable"
SET LEXLS=-1
+7 if +LEXFA>0&(+LEXCDT>0)&(LEXFA>LEXCDT)
SET LEXES="Pending"
SET LEXLS=-1
SET LEXST=0
SET LEXBRW=""
+8 if LEXST>0
SET LEXEF=LEXAD
if LEXST'>0
SET LEXEF=LEXID
+9 if LEXST'>0&(+LEXID'>0)
SET LEXEF=LEXFA
SET LEXEE=$$SD^LEXQM(LEXEF)
+10 IF LEXST'>0
IF +LEXID'>0
IF $LENGTH(LEXEE)
IF +LEXEF>LEXCDT
SET LEXEE="(future activation of "_LEXEE_")"
SET LEXEF=""
+11 SET X=LEXLS_"^"_LEXST_"^"_LEXEF_"^"_LEXES_"^"_LEXEE
if $LENGTH(LEXBRW)
SET $PIECE(X,"^",6)=LEXBRW
+12 QUIT X
+13 ;
SDS(X,LEXVDT,LEX,LEXLEN,LEXSTA) ; Procedure Name (short description)
+1 ;
+2 ; LEX=# of Lines
+3 ; LEX(0)=External Date of Procedure Name
+4 ; LEX(#)=Procedure Name
+5 ;
+6 NEW LEXD,LEXBRD,LEXBRW,LEXDDT,LEXE,LEXEE,LEXEFF,LEXFA,LEXHIS,LEXI,LEXIA,LEXIEN,LEXAIEN,LEXSIEN,LEXL,LEXLAST,LEXLEF,LEXLHI
+7 NEW LEXM,LEXR,LEXSDT,LEXSO,LEXLSD,LEXT
SET LEXIEN=$GET(X)
if +LEXIEN'>0
QUIT
if '$DATA(^ICPT(+LEXIEN,61))
QUIT
SET LEXVDT=+($GET(LEXVDT))
+8 if LEXVDT'?7N
SET LEXVDT=$$DT^XLFDT
SET LEXSTA=+($GET(LEXSTA))
SET LEXSO=$PIECE($GET(^ICPT(+LEXIEN,0)),"^",1)
+9 SET LEXLAST=$$CPT^ICPTCOD(LEXSO)
SET LEXLSD=$PIECE(LEXLAST,"^",3)
SET LEXBRD=2890101
SET LEXBRW=""
+10 if $DATA(LEXGET)&($LENGTH(LEXLSD))
SET LEXGET(81,(+LEXIEN_","),"B")=LEXLSD
+11 SET LEXLEN=+($GET(LEXLEN))
if +LEXLEN'>0
SET LEXLEN=62
SET LEXFA=$$FA^LEXQCP2(+LEXIEN)
SET LEXM=""
+12 SET LEXM=""
if +LEXVDT<LEXFA&(LEXFA'=LEXBRD)
SET LEXM="Procedure Short Name is not available. The date provided precedes the initial activation of the code"
+13 IF $LENGTH(LEXM)
Begin DoDot:1
+14 KILL LEX
NEW LEXT,LEXI
SET LEXT(1)=LEXM
DO PR^LEXU(.LEXT,(LEXLEN-7))
+15 SET LEXI=0
FOR
SET LEXI=$ORDER(LEXT(LEXI))
if +LEXI'>0
QUIT
SET LEXT=$GET(LEXT(LEXI))
SET LEX(LEXI)=LEXT
+16 if $DATA(LEX(1))
SET LEX(0)="--/--/----"
SET LEX=+($ORDER(LEX(" "),-1))
End DoDot:1
QUIT
+17 SET LEXM=""
SET LEXEFF=$ORDER(^ICPT(LEXIEN,61,"B",(LEXVDT+.001)),-1)
SET LEXHIS=$ORDER(^ICPT(LEXIEN,61,"B",+LEXEFF," "),-1)
SET LEXSDT=$PIECE($GET(^ICPT(+LEXIEN,61,+LEXHIS,0)),"^",2)
+18 SET LEXLEF=$ORDER(^ICPT(LEXIEN,61,"B",(9999999+.001)),-1)
SET LEXLHI=$ORDER(^ICPT(LEXIEN,61,"B",+LEXLEF," "),-1)
SET LEXDDT=$PIECE($GET(^ICPT(+LEXIEN,61,+LEXLHI,0)),"^",2)
+19 SET (LEXAIEN,LEXSIEN)=""
SET LEXSIEN=LEXHIS
if $GET(LEXDDT)?7N
SET LEXSIEN=$ORDER(^ICPT(+LEXIEN,61,"B",LEXDDT,0))
+20 SET LEXAIEN=LEXIEN
if +LEXSIEN>0
SET LEXAIEN=LEXAIEN_";"_LEXSIEN
+21 SET (LEXD,LEXE,LEXR)=""
if $LENGTH(LEXSDT)&(LEXEFF?7N)
SET LEXD=LEXSDT
SET LEXE=LEXEFF
+22 if $LENGTH(LEXDDT)&(LEXLEF?7N)&('$LENGTH(LEXD))&('$LENGTH(LEXE))
SET LEXD=LEXDDT
SET LEXE=LEXLEF
SET LEXR="No Text Available for Date Provided"
+23 if $DATA(LEXIIEN)
SET LEXD=LEXD_" (IEN "_LEXAIEN_")"
+24 KILL LEX
SET LEX(1)=LEXD
if $LENGTH(LEXD)
SET LEXGET(81,(+LEXIEN_","),"B")=LEXD
+25 SET LEXEE=$$SD^LEXQM(LEXE)
if $DATA(LEXTEST)&(+LEXSTA'>0)
SET LEXEE="--/--/----"
if $LENGTH(LEX(1))
SET LEX(0)=LEXEE
+26 SET LEX=+($ORDER(LEX(" "),-1))
+27 QUIT
LDS(X,LEXVDT,LEX,LEXLEN,LEXSTA) ; Long Description
+1 ;
+2 ; LEX=# of Lines
+3 ; LEX(0)=External Date of Description
+4 ; LEX(#)=Description
+5 ; LEX(#)=Description continued
+6 ;
+7 NEW LEXC,LEXBRD,LEXBRW,LEXDDT,LEXEVDT,LEXFA,LEXI,LEXIEN,LEXAIEN,LEXSIEN,LEXL,LEXLN,LEXM,LEXT,LEXSO,LEXTL,LEXTMP
+8 SET LEXIEN=$GET(X)
if +LEXIEN'>0
QUIT
if '$DATA(^ICPT(+LEXIEN,62))
QUIT
+9 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
+10 SET LEXSO=$PIECE($GET(^ICPT(+LEXIEN,0)),"^",1)
SET LEXFA=$$FA^LEXQCP2(+LEXIEN)
SET LEXM=""
SET LEXSTA=+($GET(LEXSTA))
SET LEXBRD=2890101
SET LEXBRW=""
+11 SET LEXM=""
if +LEXVDT<LEXFA&(LEXFA'=LEXBRD)
SET LEXM="Description is not available. The date provided precedes the initial activation of the code"
+12 IF $LENGTH(LEXM)
Begin DoDot:1
+13 KILL LEX
NEW LEXT,LEXI
SET LEXT(1)=LEXM
DO PR^LEXU(.LEXT,(LEXLEN-7))
SET LEXI=0
FOR
SET LEXI=$ORDER(LEXT(LEXI))
if +LEXI'>0
QUIT
SET LEXT=$GET(LEXT(LEXI))
SET LEX(LEXI)=LEXT
+14 if $DATA(LEX(1))
SET LEX(0)="--/--/----"
SET LEX=+($ORDER(LEX(" "),-1))
End DoDot:1
QUIT
+15 KILL LEXTMP
SET LEXTL=$$CPTD^ICPTCOD(LEXSO,"LEXTMP",,LEXVDT)
SET LEXL=+($ORDER(LEXTMP(" "),-1))
SET LEXLN=$GET(LEXTMP(+LEXL))
+16 SET LEXM=""
if LEXL>0&(LEXLN["CODE TEXT MAY BE INACCURATE")
KILL LEXTMP(+LEXL)
+17 FOR LEXI=1:1:2
SET LEXL=+($ORDER(LEXTMP(" "),-1))
SET LEXLN=$$TM^LEXQM($GET(LEXTMP(+LEXL)))
if LEXL>0&('$LENGTH(LEXLN))
KILL LEXTMP(+LEXL)
+18 SET LEXDDT=$ORDER(^ICPT(+LEXIEN,62,"B",(LEXVDT+.999999)),-1)
if LEXDDT'?7N
SET LEXDDT=$ORDER(^ICPT(+LEXIEN,62,"B",0))
if LEXDDT?7N
SET LEXEVDT=$$SD^LEXQM(LEXDDT)
+19 SET (LEXAIEN,LEXSIEN)=""
if $GET(LEXDDT)?7N
SET LEXSIEN=$ORDER(^ICPT(+LEXIEN,62,"B",LEXDDT,0))
+20 SET LEXAIEN=LEXIEN
if +LEXSIEN>0
SET LEXAIEN=LEXAIEN_";"_LEXSIEN
+21 IF $DATA(LEXIIEN)
Begin DoDot:1
+22 NEW LEXI
SET LEXI=$ORDER(LEXTMP(" "),-1)
if LEXI'>0
QUIT
if '$DATA(LEXTMP(LEXI))
QUIT
+23 SET LEXTMP(LEXI)=$GET(LEXTMP(LEXI))_" (IEN "_LEXAIEN_")"
End DoDot:1
+24 DO PR^LEXU(.LEXTMP,LEXLEN)
KILL LEX
SET LEXI=0
FOR
SET LEXI=$ORDER(LEXTMP(LEXI))
if +LEXI'>0
QUIT
Begin DoDot:1
+25 if '$DATA(LEXTMP(LEXI))
QUIT
SET LEXT=$$TM^LEXQM($GET(LEXTMP(LEXI)))
SET LEX(LEXI)=$$UP^XLFSTR(LEXT)
End DoDot:1
+26 IF $LENGTH(LEXM)
Begin DoDot:1
+27 NEW LEXT,LEXI,LEXL,LEXC
SET LEXL=+($ORDER(LEX(" "),-1))
SET LEXC=0
SET LEXT(1)=LEXM
DO PR^LEXU(.LEXT,(LEXLEN-7))
+28 SET LEXI=0
FOR
SET LEXI=$ORDER(LEXT(LEXI))
if +LEXI'>0
QUIT
Begin DoDot:2
+29 SET LEXT=$GET(LEXT(LEXI))
if $LENGTH(LEXT)
SET LEXC=LEXC+1
SET LEXL=LEXL+1
SET LEX(LEXL)=LEXT
End DoDot:2
End DoDot:1
+30 if $DATA(LEXTEST)&(+LEXSTA'>0)
SET LEXEVDT="--/--/----"
if $DATA(LEX(1))
SET LEX(0)=LEXEVDT
SET LEX=+($ORDER(LEX(" "),-1))
+31 QUIT
LX(X,LEXVDT,LEX,LEXLEN,LEXSTA) ; Lexicon Expression
+1 ;
+2 ; LEX=# of Lines
+3 ; LEX(0)=External Date of Expression
+4 ; LEX(#)=Expression
+5 ; LEX(#)=Expression continued
+6 ;
+7 NEW LEXEF,LEXEVDT,LEXLEX,LEXEE,LEXFA,LEXI,LEXIA,LEXIEN,LEXLEF,LEXLHS,LEXLST,LEXM,LEXN0,LEXPF,LEXSAB,LEXSIEN,LEXSO
+8 NEW LEXTSRC,LEXT,LEXTE,LEXTEXP,LEXTEF,LEXTEFE,LEXTS,LEXTSTA,LEXVTMP
+9 SET LEXIEN=$GET(X)
if +LEXIEN'>0
QUIT
if '$DATA(^ICPT(+LEXIEN,0))
QUIT
SET LEXVDT=+($GET(LEXVDT))
if LEXVDT'?7N
SET LEXVDT=$$DT^XLFDT
SET LEXSTA=+($GET(LEXSTA))
+10 SET LEXEVDT=$$SD^LEXQM(LEXVDT)
SET LEXLEN=+($GET(LEXLEN))
if +LEXLEN'>0
SET LEXLEN=62
if '$LENGTH(LEXEVDT)
QUIT
+11 SET LEXSO=$PIECE($GET(^ICPT(+LEXIEN,0)),"^",1)
if '$LENGTH(LEXSO)
QUIT
SET LEXFA=$$FA^LEXQCP2(+LEXIEN)
SET LEXM=""
SET LEXIA=$$IA(LEXVDT)
+12 SET LEXTSRC=$PIECE($GET(^ICPT(+LEXIEN,0)),"^",6)
SET LEXTSRC=$SELECT(LEXTSRC="H":"CPC",LEXTSRC="C":"CPT",1:"")
+13 SET LEXTSTA=$$STATCHK^LEXSRC2(LEXSO,LEXVDT,,LEXTSRC)
+14 SET LEXTS=$PIECE($GET(LEXTSTA),"^",2)
SET LEXTE=+($GET(^LEX(757.02,+LEXTS,0)))
SET LEXTEXP=$GET(^LEX(757.01,+LEXTE,0))
+15 SET (LEXTEF,LEXTEFE)=""
SET LEXEF=""
FOR
SET LEXEF=$ORDER(^LEX(757.02,+LEXTS,4,"B",LEXEF))
if +LEXEF'>0
QUIT
Begin DoDot:1
+16 NEW LEXH
SET LEXH=0
FOR
SET LEXH=$ORDER(^LEX(757.02,+LEXTS,4,"B",LEXEF,LEXH))
if +LEXH'>0
QUIT
Begin DoDot:2
+17 if $PIECE($GET(^LEX(757.02,+LEXTS,4,+LEXH,0)),"^",2)>0&(LEXEF?7N)
SET LEXTEF=LEXEF
+18 if LEXTEF?7N
SET LEXTEFE=$$SD^LEXQM(LEXTEF)
End DoDot:2
End DoDot:1
+19 IF LEXSTA'>0
IF $LENGTH($GET(LEXTEXP))
IF $GET(LEXTEF)?7N
IF $LENGTH($GET(LEXTEFE))
Begin DoDot:1
+20 KILL LEX
NEW LEXT,LEXM,LEXI
SET LEXT(1)=LEXTEXP
if $DATA(LEXIIEN)
SET LEXT(1)=$GET(LEXT(1))_" (IEN "_LEXTE_")"
+21 DO PR^LEXU(.LEXT,(LEXLEN-7))
+22 SET LEXI=0
FOR
SET LEXI=$ORDER(LEXT(LEXI))
if +LEXI'>0
QUIT
if $LENGTH($GET(LEXT(LEXI)))
SET LEX(+LEXI)=$GET(LEXT(LEXI))
+23 SET LEX=+($ORDER(LEX(" "),-1))
SET LEX(0)=LEXTEFE
End DoDot:1
QUIT
+24 SET LEXSIEN=0
FOR
SET LEXSIEN=$ORDER(^LEX(757.02,"CODE",(LEXSO_" "),LEXSIEN))
if +LEXSIEN'>0
QUIT
Begin DoDot:1
+25 NEW LEXN0
SET LEXN0=$GET(^LEX(757.02,+LEXSIEN,0))
SET LEXSAB=$PIECE(LEXN0,"^",3)
+26 if "^3^4^"'[("^"_LEXSAB_"^")
QUIT
SET LEXPF=+($PIECE(LEXN0,"^",5))
SET LEXLEF=$ORDER(^LEX(757.02,+LEXSIEN,4,"B",(LEXVDT+.99999)),-1)
IF LEXLEF?7N
Begin DoDot:2
+27 SET LEXLHS=$ORDER(^LEX(757.02,+LEXSIEN,4,"B",+LEXLEF," "),-1)
IF +LEXLHS>0
Begin DoDot:3
+28 SET LEXLST=$GET(^LEX(757.02,+LEXSIEN,4,+LEXLHS,0))
SET LEXLST=$PIECE(LEXLST,"^",2)
+29 if LEXLST>0
SET LEXVTMP(+LEXPF,LEXSIEN)=+LEXN0_"^"_LEXLEF
End DoDot:3
End DoDot:2
End DoDot:1
+30 SET (LEXLEX,LEXEF)=""
SET LEXSIEN=$ORDER(LEXVTMP(1,0))
SET LEXLEX=+($GET(LEXVTMP(1,+LEXSIEN)))
SET LEXEF=$PIECE($GET(LEXVTMP(1,+LEXSIEN)),"^",2)
+31 if +LEXSIEN'>0!(+LEXLEX'>0)
SET LEXSIEN=$ORDER(LEXVTMP(0,0))
SET LEXLEX=+($GET(LEXVTMP(0,+LEXSIEN)))
SET LEXEF=$PIECE($GET(LEXVTMP(0,+LEXSIEN)),"^",2)
+32 KILL LEX
IF +LEXLEX>0
IF $LENGTH($GET(^LEX(757.01,+LEXLEX,0)))
IF $LENGTH(LEXEF)
IF LEXEF?7N
Begin DoDot:1
+33 KILL LEX
NEW LEXT,LEXM,LEXI
SET LEXT(1)=$GET(^LEX(757.01,+LEXLEX,0))
if $DATA(LEXIIEN)
SET LEXT(1)=$GET(LEXT(1))_" (IEN "_LEXLEX_")"
+34 DO PR^LEXU(.LEXT,(LEXLEN-7))
SET LEXI=0
FOR
SET LEXI=$ORDER(LEXT(LEXI))
if +LEXI'>0
QUIT
if $LENGTH($GET(LEXT(LEXI)))
SET LEX(+LEXI)=$GET(LEXT(LEXI))
+35 SET LEX=+($ORDER(LEX(" "),-1))
SET LEXEE=$$SD^LEXQM(LEXEF)
if $DATA(LEXTEST)&(+LEXSTA'>0)
SET LEXEE="--/--/----"
SET LEX(0)=LEXEE
End DoDot:1
QUIT
+36 QUIT
+37 ; Miscellaneous
IA(X) ; Inaccurate
+1 NEW LEXBRD,LEXVDT,LEXSYS
SET LEXVDT=+($GET(X))
SET LEXSYS=1
SET LEXVDT=$SELECT($GET(LEXVDT)="":$$DT^XLFDT,1:$$DBR(LEXVDT))
SET LEXBRD=3021001
SET X=$SELECT(LEXVDT<LEXBRD:1,1:0)
+2 QUIT X
DBR(X) ; Date Business Rules
+1 NEW LEXVDT
SET LEXVDT=$GET(X)
if '$GET(LEXVDT)!($PIECE(LEXVDT,".")'?7N)
QUIT $$DT^XLFDT
+2 if LEXVDT#10000=0
SET LEXVDT=LEXVDT+101
if LEXVDT#100=0
SET LEXVDT=LEXVDT+1
SET X=$SELECT(LEXVDT<2890101:2890101,1:LEXVDT)
+3 QUIT X
