LEXQCP ;ISL/KER - Query - CPT Procedures - Extract ;04/21/2014
;;2.0;LEXICON UTILITY;**62,80**;Sep 23, 1996;Build 10
;
; 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
;
EN ; Main Entry Point
N LEXENV S LEXENV=$$EV^LEXQM Q:+LEXENV'>0
N LEXAD,LEXEDT,LEXCDT,LEXEXIT,LEXTEST 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
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,LEXL,LEXLAST,LEXLEF,LEXLHI,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),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^LEXQM(.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 (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"
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,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^LEXQM(.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)
D PR^LEXQM(.LEXTMP,LEXLEN) K LEX F LEXI=1:1:13 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^LEXQM(.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,LEXT,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 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)) D PR^LEXQM(.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
LEXQCP ;ISL/KER - Query - CPT Procedures - Extract ;04/21/2014
+1 ;;2.0;LEXICON UTILITY;**62,80**;Sep 23, 1996;Build 10
+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 ;
EN ; Main Entry Point
+1 NEW LEXENV
SET LEXENV=$$EV^LEXQM
IF +LEXENV'>0
QUIT
+2 NEW LEXAD,LEXEDT,LEXCDT,LEXEXIT,LEXTEST
SET LEXEXIT=0
SET LEXCDT=""
+3 WRITE !
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
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,LEXL,LEXLAST,LEXLEF,LEXLHI,LEXM,LEXR,LEXSDT,LEXSO,LEXLSD,LEXT
+7 SET LEXIEN=$GET(X)
IF +LEXIEN'>0
QUIT
IF '$DATA(^ICPT(+LEXIEN,61))
QUIT
SET LEXVDT=+($GET(LEXVDT))
IF LEXVDT'?7N
SET LEXVDT=$$DT^XLFDT
SET LEXSTA=+($GET(LEXSTA))
+8 SET LEXSO=$PIECE($GET(^ICPT(+LEXIEN,0)),"^",1)
SET LEXLAST=$$CPT^ICPTCOD(LEXSO)
SET LEXLSD=$PIECE(LEXLAST,"^",3)
SET LEXBRD=2890101
SET LEXBRW=""
+9 IF $DATA(LEXGET)&($LENGTH(LEXLSD))
SET LEXGET(81,(+LEXIEN_","),"B")=LEXLSD
+10 SET LEXLEN=+($GET(LEXLEN))
IF +LEXLEN'>0
SET LEXLEN=62
SET LEXFA=$$FA^LEXQCP2(+LEXIEN)
SET LEXM=""
+11 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"
+12 IF $LENGTH(LEXM)
Begin DoDot:1
+13 KILL LEX
NEW LEXT,LEXI
SET LEXT(1)=LEXM
DO PR^LEXQM(.LEXT,(LEXLEN-7))
+14 SET LEXI=0
FOR
SET LEXI=$ORDER(LEXT(LEXI))
IF +LEXI'>0
QUIT
SET LEXT=$GET(LEXT(LEXI))
SET LEX(LEXI)=LEXT
+15 IF $DATA(LEX(1))
SET LEX(0)="--/--/----"
SET LEX=+($ORDER(LEX(" "),-1))
End DoDot:1
QUIT
+16 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)
+17 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)
+18 SET (LEXD,LEXE,LEXR)=""
IF $LENGTH(LEXSDT)&(LEXEFF?7N)
SET LEXD=LEXSDT
SET LEXE=LEXEFF
+19 IF $LENGTH(LEXDDT)&(LEXLEF?7N)&('$LENGTH(LEXD))&('$LENGTH(LEXE))
SET LEXD=LEXDDT
SET LEXE=LEXLEF
SET LEXR="No Text Available for Date Provided"
+20 KILL LEX
SET LEX(1)=LEXD
IF $LENGTH(LEXD)
SET LEXGET(81,(+LEXIEN_","),"B")=LEXD
+21 SET LEXEE=$$SD^LEXQM(LEXE)
IF $DATA(LEXTEST)&(+LEXSTA'>0)
SET LEXEE="--/--/----"
IF $LENGTH(LEX(1))
SET LEX(0)=LEXEE
+22 SET LEX=+($ORDER(LEX(" "),-1))
+23 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,LEXL,LEXLN,LEXM,LEXT,LEXSO,LEXTL,LEXTMP
SET LEXIEN=$GET(X)
IF +LEXIEN'>0
QUIT
IF '$DATA(^ICPT(+LEXIEN,62))
QUIT
+8 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
+9 SET LEXSO=$PIECE($GET(^ICPT(+LEXIEN,0)),"^",1)
SET LEXFA=$$FA^LEXQCP2(+LEXIEN)
SET LEXM=""
SET LEXSTA=+($GET(LEXSTA))
SET LEXBRD=2890101
SET LEXBRW=""
+10 SET LEXM=""
IF +LEXVDT<LEXFA&(LEXFA'=LEXBRD)
SET LEXM="Description is not available. The date provided precedes the initial activation of the code"
+11 IF $LENGTH(LEXM)
Begin DoDot:1
+12 KILL LEX
NEW LEXT,LEXI
SET LEXT(1)=LEXM
DO PR^LEXQM(.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
+13 IF $DATA(LEX(1))
SET LEX(0)="--/--/----"
SET LEX=+($ORDER(LEX(" "),-1))
End DoDot:1
QUIT
+14 KILL LEXTMP
SET LEXTL=$$CPTD^ICPTCOD(LEXSO,"LEXTMP",,LEXVDT)
SET LEXL=+($ORDER(LEXTMP(" "),-1))
SET LEXLN=$GET(LEXTMP(+LEXL))
+15 SET LEXM=""
IF LEXL>0&(LEXLN["CODE TEXT MAY BE INACCURATE")
KILL LEXTMP(+LEXL)
+16 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)
+17 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)
+18 DO PR^LEXQM(.LEXTMP,LEXLEN)
KILL LEX
FOR LEXI=1:1:13
Begin DoDot:1
+19 IF '$DATA(LEXTMP(LEXI))
QUIT
SET LEXT=$$TM^LEXQM($GET(LEXTMP(LEXI)))
SET LEX(LEXI)=$$UP^XLFSTR(LEXT)
End DoDot:1
+20 IF $LENGTH(LEXM)
Begin DoDot:1
+21 NEW LEXT,LEXI,LEXL,LEXC
SET LEXL=+($ORDER(LEX(" "),-1))
SET LEXC=0
SET LEXT(1)=LEXM
DO PR^LEXQM(.LEXT,(LEXLEN-7))
+22 SET LEXI=0
FOR
SET LEXI=$ORDER(LEXT(LEXI))
IF +LEXI'>0
QUIT
Begin DoDot:2
+23 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
+24 IF $DATA(LEXTEST)&(+LEXSTA'>0)
SET LEXEVDT="--/--/----"
IF $DATA(LEX(1))
SET LEX(0)=LEXEVDT
SET LEX=+($ORDER(LEX(" "),-1))
+25 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,LEXT,LEXVTMP
+8 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))
+9 SET LEXEVDT=$$SD^LEXQM(LEXVDT)
SET LEXLEN=+($GET(LEXLEN))
IF +LEXLEN'>0
SET LEXLEN=62
IF '$LENGTH(LEXEVDT)
QUIT
+10 SET LEXSO=$PIECE($GET(^ICPT(+LEXIEN,0)),"^",1)
IF '$LENGTH(LEXSO)
QUIT
SET LEXFA=$$FA^LEXQCP2(+LEXIEN)
SET LEXM=""
SET LEXIA=$$IA(LEXVDT)
+11 SET LEXSIEN=0
FOR
SET LEXSIEN=$ORDER(^LEX(757.02,"CODE",(LEXSO_" "),LEXSIEN))
IF +LEXSIEN'>0
QUIT
Begin DoDot:1
+12 NEW LEXN0
SET LEXN0=$GET(^LEX(757.02,+LEXSIEN,0))
SET LEXSAB=$PIECE(LEXN0,"^",3)
+13 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
+14 SET LEXLHS=$ORDER(^LEX(757.02,+LEXSIEN,4,"B",+LEXLEF," "),-1)
IF +LEXLHS>0
Begin DoDot:3
+15 SET LEXLST=$GET(^LEX(757.02,+LEXSIEN,4,+LEXLHS,0))
SET LEXLST=$PIECE(LEXLST,"^",2)
+16 IF LEXLST>0
SET LEXVTMP(+LEXPF,LEXSIEN)=+LEXN0_"^"_LEXLEF
End DoDot:3
End DoDot:2
End DoDot:1
+17 SET (LEXLEX,LEXEF)=""
SET LEXSIEN=$ORDER(LEXVTMP(1,0))
SET LEXLEX=+($GET(LEXVTMP(1,+LEXSIEN)))
SET LEXEF=$PIECE($GET(LEXVTMP(1,+LEXSIEN)),"^",2)
+18 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)
+19 KILL LEX
IF +LEXLEX>0
IF $LENGTH($GET(^LEX(757.01,+LEXLEX,0)))
IF $LENGTH(LEXEF)
IF LEXEF?7N
Begin DoDot:1
+20 KILL LEX
NEW LEXT,LEXM,LEXI
SET LEXT(1)=$GET(^LEX(757.01,+LEXLEX,0))
DO PR^LEXQM(.LEXT,(LEXLEN-7))
+21 SET LEXI=0
FOR
SET LEXI=$ORDER(LEXT(LEXI))
IF +LEXI'>0
QUIT
IF $LENGTH($GET(LEXT(LEXI)))
SET LEX(+LEXI)=$GET(LEXT(LEXI))
+22 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
+23 QUIT
+24 ; 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
