LEXQCM ;ISL/KER - Query - CPT Modifiers - Extract ;05/23/2017
;;2.0;LEXICON UTILITY;**62,68,80,103**;Sep 23, 1996;Build 2
;
; Global Variables
; ^DIC(81.3) ICR 4492
;
; External References
; $$DT^XLFDT ICR 10103
; $$GET1^DIQ ICR 2056
; $$MODD^ICPTMOD ICR 1996
; $$MOD^ICPTMOD ICR 1996
; $$UP^XLFSTR ICR 10104
; GETS^DIQ ICR 2056
; HIST^ICPTAPIU ICR 1997
; HOME^%ZIS ICR 10086
; MODD^ICPTMOD ICR 1996
;
; Local Variables NEWed or KILLed Elsewhere
; LEXIIEN Include IENs flag
;
EN ; Main Entry Point
N LEXENV S LEXENV=$$EV Q:+LEXENV'>0
N LEX,LEXAD,LEXEDT,LEXFA,LEXCDT,LEXEXIT,LEXGET,LEXLD,LEXLEN,LEXLX,LEXMD,LEXSD,LEXST,LEXTEST,I,Z S LEXEXIT=0,LEXCDT=""
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 Modifier Lookup Loop
S LEXCDT=$G(LEXCDT),LEXEDT=$$ED^LEXQM(LEXCDT) I LEXCDT'?7N S LEXCDT="" Q
N LEXMOD,LEXMODC S LEXLEN=62
F S LEXMOD=$$MOD^LEXQCMA S:LEXMOD="^^" LEXEXIT=1 Q:LEXMOD="^"!(LEXMOD="^^") D Q:LEXMOD="^"!(LEXMOD="^^")
. K LEXGET,LEXST,LEXSD,LEXLD,LEXMD,LEXRAN,LEXLX,LEXWN,LEXFA N LEXIEN,LEXLDT,LEXELDT,LEXINC,LEXINCI,LEXINCF S (LEXINC,LEXINCI,LEXINCF)=0
. S LEXIEN=+($G(LEXMOD)),LEXLDT=+($G(LEXCDT)),LEXFA=$$FA(LEXIEN) Q:+LEXIEN'>0 Q:LEXLDT'?7N S LEXELDT=$$SD^LEXQM(LEXLDT) Q:'$L(LEXELDT)
. S (LEXINC,LEXINCI,LEXINCF)=0 I LEXFA?7N,LEXCDT?7N,LEXFA'>LEXCDT D
. . S LEXINC=$$INC^LEXQCMA Q:LEXINC["^" S:+LEXINC>0 LEXINCI=$$INCI^LEXQCMA S:+LEXINC>0 LEXINCF=$$INCF^LEXQCMA
. D CSV,EN^LEXQCM2
Q
CSV ; Code Set Versioning Display
; Needs LEXCDT Date
; LEXMOD CPT Modifier Internal Entry Number
N LEXEDT,LEXIEN,LEXIENS,LEXLTXT,LEXSO,LEXSTA
S LEXCDT=$G(LEXCDT),LEXEDT=$$ED^LEXQM(LEXCDT) I LEXCDT'?7N S (LEXMOD,LEXCDT)="" Q
S LEXINC=+($G(LEXINC)),LEXINCI=+($G(LEXINCI)),LEXIEN=+($G(LEXMOD)),LEXSO=$P($G(LEXMOD),"^",2),LEXLTXT=$P($G(LEXMOD),"^",3)
Q:+LEXIEN'>0 Q:'$L(LEXSO)
;
; Get the "Unversioned" Fields
; Modifier Field .01
S LEXIENS=LEXIEN_"," D GETS^DIQ(81.3,LEXIENS,".01","IE","LEXGET","LEXMSG")
; Get the "Versioned" Fields
; Effective Date and Status Sub-File 81.33 (60)
S LEXST=$$EF(+($G(LEXIEN)),+LEXCDT),LEXSTA=+($P(LEXST,"^",2))
; Modifier Name Sub-File 81.361 (61)
D SDS(+($G(LEXIEN)),+LEXCDT,.LEXSD,62,LEXSTA)
; Description Sub-File 81.362 (62)
D LDS(+($G(LEXIEN)),+LEXCDT,.LEXLD,62)
D WN(+LEXCDT,.LEXWN,62)
D:+($G(LEXINC))>0 CCR^LEXQCM2(+($G(LEXIEN)),+LEXCDT,.LEXRAN,62,+($G(LEXINCI)),+($G(LEXINCF)))
Q
;
EF(X,LEXCDT) ; Effective Dates
N LEX,LEXAD,LEXBRD,LEXBRW,LEXEE,LEXEF,LEXES,LEXFA,LEXH,LEXI,LEXID,LEXIEN,LEXLS,LEXPE,LEXPH,LEXPI,LEXP0,LEXPS,LEXSO,LEXST
S LEXIEN=+($G(X)),LEXCDT=+($G(LEXCDT)),LEXBRD=2890101,LEXBRW=""
Q:+LEXIEN'>0 "^^" Q:'$L($G(^DIC(81.3,+LEXIEN,0))) "^^" Q:LEXCDT'?7N "^^" S LEXSO=$P($G(^DIC(81.3,+LEXIEN,0)),"^",1)
S LEXFA=$$FA(+LEXIEN),LEXPI=$O(^DIC(81.3,+LEXIEN,60,"B",(LEXCDT+.999999)),-1),LEXPH=$O(^DIC(81.3,+LEXIEN,60,"B",+LEXPI," "),-1)
S LEXP0=$G(^DIC(81.3,+LEXIEN,60,+LEXPH,0)),LEXPS=$P(LEXP0,"^",2),LEXPE=$P(LEXP0,"^",1)
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:LEXFA?7N&('$L(LEXPE))&('$L(LEXPS))&(LEXFA=LEXBRD) LEXPE=LEXFA,LEXPS=1
I '$L(LEXPE),'$L(LEXPS) D Q X
. N LEXFA S LEXFA=$$FA(+LEXIEN)
. S LEXST="",LEXEF="",LEXES="Not Applicable",LEXLS=-1
. S:+LEXFA>0&(+LEXCDT>0)&(LEXFA>LEXCDT) LEXES="Pending",LEXLS=-1,LEXST=0,LEXBRW=""
. S LEXEE="" S:LEXFA?7N LEXEE="(future activation of "_$$SD^LEXQM(LEXFA)_")"
. S X=LEXLS_"^"_LEXST_"^"_LEXEF_"^"_LEXES_"^"_LEXEE S:$L(LEXBRW) $P(X,"^",6)=LEXBRW
S (LEXLS,LEXST)=LEXPS,LEXEF=LEXPE,LEXES=$S(+LEXST>0:"Active",1:"Inactive"),LEXEE=$$SD^LEXQM(LEXEF)
S X=LEXLS_"^"_LEXST_"^"_LEXEF_"^"_LEXES_"^"_LEXEE S:$L(LEXBRW) $P(X,"^",6)=LEXBRW
Q X
;
SDS(X,LEXVDT,LEX,LEXLEN,LEXSTA) ; Modifier Name (short description)
;
; LEX=# of Lines
; LEX(0)=External Date of Modifier Name
; LEX(#)=Modifier 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(^DIC(81.3,+LEXIEN,61)) S LEXVDT=+($G(LEXVDT))
S:LEXVDT'?7N LEXVDT=$$DT^XLFDT S LEXSTA=+($G(LEXSTA)),LEXSO=$P($G(^DIC(81.3,+LEXIEN,0)),"^",1)
S LEXLAST=$$MOD^ICPTMOD(+LEXIEN,"I",LEXVDT),LEXLSD=$P(LEXLAST,"^",3),LEXBRD=2890101
S:$D(LEXGET)&($L(LEXLSD)) LEXGET(81.3,(+LEXIEN_","),"B")=LEXLSD
S LEXLEN=+($G(LEXLEN)) S:+LEXLEN'>0 LEXLEN=62 S LEXFA=$$FA(+LEXIEN),LEXM=""
S LEXM="" S:+LEXVDT<LEXFA&(LEXFA'=LEXBRD) LEXM="CPT Modifier 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(^DIC(81.3,LEXIEN,61,"B",(LEXVDT+.001)),-1),LEXHIS=$O(^DIC(81.3,LEXIEN,61,"B",+LEXEFF," "),-1),LEXSDT=$P($G(^DIC(81.3,+LEXIEN,61,+LEXHIS,0)),"^",2)
S LEXLEF=$O(^DIC(81.3,LEXIEN,61,"B",(9999999+.001)),-1),LEXLHI=$O(^DIC(81.3,LEXIEN,61,"B",+LEXLEF," "),-1),LEXDDT=$P($G(^DIC(81.3,+LEXIEN,61,+LEXLHI,0)),"^",2)
S LEXAIEN="",LEXSIEN=LEXHIS S:LEXSIEN'>0&(LEXDDT?7N) LEXSIEN=$O(^DIC(81.3,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(LEXSDT)&(LEXEFF?7N)&($D(LEXIIEN)) LEXD=LEXD_" (IEN "_LEXAIEN_")"
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.3,(+LEXIEN_","),"B")=LEXD S LEXEE=$$SD^LEXQM(LEXE)
S:$D(LEXTEST)&(+($G(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,LEXDDT,LEXEVDT,LEXFA,LEXI,LEXIEN,LEXAIEN,LEXSIEN,LEXL,LEXLT,LEXLN,LEXM,LEXT,LEXSO,LEXTL,LEXTMP
S LEXIEN=$G(X) Q:+LEXIEN'>0 Q:'$D(^DIC(81.3,+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(^DIC(81.3,+LEXIEN,0)),"^",1) S LEXFA=$$FA(+LEXIEN),LEXM="" S LEXSTA=+($G(LEXSTA)),LEXBRD=2890101
S LEXM="" S:+LEXVDT<LEXFA&(LEXFA'=LEXBRD) LEXM=" Modifier 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 LEXLT=$$MODD^ICPTMOD(LEXIEN,"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(^DIC(81.3,+LEXIEN,62,"B",(LEXVDT+.999999)),-1) S:LEXDDT'?7N LEXDDT=$O(^DIC(81.3,+LEXIEN,62,"B",0)) S:LEXDDT?7N LEXEVDT=$$SD^LEXQM(LEXDDT)
S LEXSIEN="",LEXAIEN=LEXIEN S:LEXDDT?7N LEXSIEN=$O(^DIC(81.3,+LEXIEN,62,"B",LEXDDT,0)) S:+($G(LEXSIEN))>0 LEXAIEN=LEXAIEN_";"_+($G(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,63) K LEX F LEXI=1:1:+($G(LEXTMP)) 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)&(+($G(LEXSTA))'>0) LEXEVDT="--/--/----" S:$D(LEX(1)) LEX(0)=LEXEVDT S LEX=+($O(LEX(" "),-1))
Q
WN(X,LEX,LEXLEN) ; Warning
;
; LEX=# of Lines
; LEX(0)=External Date
; LEX(#)=Warning
;
N LEXVDT,LEXIA,LEXTMP K LEX S LEXVDT=$G(X) Q:LEXVDT'?7N S LEXIA=$$IA(LEXVDT) Q:+LEXIA'>0 S LEXLEN=+$G(LEXLEN) S:+LEXLEN>62 LEXLEN=62
S LEXTMP(1)="Warning: The 'Based on Date' provided precedes Code Set Versioning. The Modifier Name and Description 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
FA(X) ; First Activation
N LEXFA,LEXH,LEXI,LEXIEN,LEXSO S LEXIEN=+($G(X)) S X="",LEXSO=$P($G(^DIC(81.3,+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
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
EV(X) ; Check environment
N LEX S DT=$$DT^XLFDT D HOME^%ZIS S U="^" I +($G(DUZ))=0 W !!,?5,"DUZ not defined" Q 0
S LEX=$$GET1^DIQ(200,(DUZ_","),.01) I '$L(LEX) W !!,?5,"DUZ not valid" Q 0
Q 1
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLEXQCM 10099 printed Dec 13, 2024@02:08:27 Page 2
LEXQCM ;ISL/KER - Query - CPT Modifiers - Extract ;05/23/2017
+1 ;;2.0;LEXICON UTILITY;**62,68,80,103**;Sep 23, 1996;Build 2
+2 ;
+3 ; Global Variables
+4 ; ^DIC(81.3) ICR 4492
+5 ;
+6 ; External References
+7 ; $$DT^XLFDT ICR 10103
+8 ; $$GET1^DIQ ICR 2056
+9 ; $$MODD^ICPTMOD ICR 1996
+10 ; $$MOD^ICPTMOD ICR 1996
+11 ; $$UP^XLFSTR ICR 10104
+12 ; GETS^DIQ ICR 2056
+13 ; HIST^ICPTAPIU ICR 1997
+14 ; HOME^%ZIS ICR 10086
+15 ; MODD^ICPTMOD ICR 1996
+16 ;
+17 ; Local Variables NEWed or KILLed Elsewhere
+18 ; LEXIIEN Include IENs flag
+19 ;
EN ; Main Entry Point
+1 NEW LEXENV
SET LEXENV=$$EV
if +LEXENV'>0
QUIT
+2 NEW LEX,LEXAD,LEXEDT,LEXFA,LEXCDT,LEXEXIT,LEXGET,LEXLD,LEXLEN,LEXLX,LEXMD,LEXSD,LEXST,LEXTEST,I,Z
SET LEXEXIT=0
SET LEXCDT=""
+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
LOOK ; CPT Modifier Lookup Loop
+1 SET LEXCDT=$GET(LEXCDT)
SET LEXEDT=$$ED^LEXQM(LEXCDT)
IF LEXCDT'?7N
SET LEXCDT=""
QUIT
+2 NEW LEXMOD,LEXMODC
SET LEXLEN=62
+3 FOR
SET LEXMOD=$$MOD^LEXQCMA
if LEXMOD="^^"
SET LEXEXIT=1
if LEXMOD="^"!(LEXMOD="^^")
QUIT
Begin DoDot:1
+4 KILL LEXGET,LEXST,LEXSD,LEXLD,LEXMD,LEXRAN,LEXLX,LEXWN,LEXFA
NEW LEXIEN,LEXLDT,LEXELDT,LEXINC,LEXINCI,LEXINCF
SET (LEXINC,LEXINCI,LEXINCF)=0
+5 SET LEXIEN=+($GET(LEXMOD))
SET LEXLDT=+($GET(LEXCDT))
SET LEXFA=$$FA(LEXIEN)
if +LEXIEN'>0
QUIT
if LEXLDT'?7N
QUIT
SET LEXELDT=$$SD^LEXQM(LEXLDT)
if '$LENGTH(LEXELDT)
QUIT
+6 SET (LEXINC,LEXINCI,LEXINCF)=0
IF LEXFA?7N
IF LEXCDT?7N
IF LEXFA'>LEXCDT
Begin DoDot:2
+7 SET LEXINC=$$INC^LEXQCMA
if LEXINC["^"
QUIT
if +LEXINC>0
SET LEXINCI=$$INCI^LEXQCMA
if +LEXINC>0
SET LEXINCF=$$INCF^LEXQCMA
End DoDot:2
+8 DO CSV
DO EN^LEXQCM2
End DoDot:1
if LEXMOD="^"!(LEXMOD="^^")
QUIT
+9 QUIT
CSV ; Code Set Versioning Display
+1 ; Needs LEXCDT Date
+2 ; LEXMOD CPT Modifier Internal Entry Number
+3 NEW LEXEDT,LEXIEN,LEXIENS,LEXLTXT,LEXSO,LEXSTA
+4 SET LEXCDT=$GET(LEXCDT)
SET LEXEDT=$$ED^LEXQM(LEXCDT)
IF LEXCDT'?7N
SET (LEXMOD,LEXCDT)=""
QUIT
+5 SET LEXINC=+($GET(LEXINC))
SET LEXINCI=+($GET(LEXINCI))
SET LEXIEN=+($GET(LEXMOD))
SET LEXSO=$PIECE($GET(LEXMOD),"^",2)
SET LEXLTXT=$PIECE($GET(LEXMOD),"^",3)
+6 if +LEXIEN'>0
QUIT
if '$LENGTH(LEXSO)
QUIT
+7 ;
+8 ; Get the "Unversioned" Fields
+9 ; Modifier Field .01
+10 SET LEXIENS=LEXIEN_","
DO GETS^DIQ(81.3,LEXIENS,".01","IE","LEXGET","LEXMSG")
+11 ; Get the "Versioned" Fields
+12 ; Effective Date and Status Sub-File 81.33 (60)
+13 SET LEXST=$$EF(+($GET(LEXIEN)),+LEXCDT)
SET LEXSTA=+($PIECE(LEXST,"^",2))
+14 ; Modifier Name Sub-File 81.361 (61)
+15 DO SDS(+($GET(LEXIEN)),+LEXCDT,.LEXSD,62,LEXSTA)
+16 ; Description Sub-File 81.362 (62)
+17 DO LDS(+($GET(LEXIEN)),+LEXCDT,.LEXLD,62)
+18 DO WN(+LEXCDT,.LEXWN,62)
+19 if +($GET(LEXINC))>0
DO CCR^LEXQCM2(+($GET(LEXIEN)),+LEXCDT,.LEXRAN,62,+($GET(LEXINCI)),+($GET(LEXINCF)))
+20 QUIT
+21 ;
EF(X,LEXCDT) ; Effective Dates
+1 NEW LEX,LEXAD,LEXBRD,LEXBRW,LEXEE,LEXEF,LEXES,LEXFA,LEXH,LEXI,LEXID,LEXIEN,LEXLS,LEXPE,LEXPH,LEXPI,LEXP0,LEXPS,LEXSO,LEXST
+2 SET LEXIEN=+($GET(X))
SET LEXCDT=+($GET(LEXCDT))
SET LEXBRD=2890101
SET LEXBRW=""
+3 if +LEXIEN'>0
QUIT "^^"
if '$LENGTH($GET(^DIC(81.3,+LEXIEN,0)))
QUIT "^^"
if LEXCDT'?7N
QUIT "^^"
SET LEXSO=$PIECE($GET(^DIC(81.3,+LEXIEN,0)),"^",1)
+4 SET LEXFA=$$FA(+LEXIEN)
SET LEXPI=$ORDER(^DIC(81.3,+LEXIEN,60,"B",(LEXCDT+.999999)),-1)
SET LEXPH=$ORDER(^DIC(81.3,+LEXIEN,60,"B",+LEXPI," "),-1)
+5 SET LEXP0=$GET(^DIC(81.3,+LEXIEN,60,+LEXPH,0))
SET LEXPS=$PIECE(LEXP0,"^",2)
SET LEXPE=$PIECE(LEXP0,"^",1)
+6 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."
+7 if LEXFA?7N&('$LENGTH(LEXPE))&('$LENGTH(LEXPS))&(LEXFA=LEXBRD)
SET LEXPE=LEXFA
SET LEXPS=1
+8 IF '$LENGTH(LEXPE)
IF '$LENGTH(LEXPS)
Begin DoDot:1
+9 NEW LEXFA
SET LEXFA=$$FA(+LEXIEN)
+10 SET LEXST=""
SET LEXEF=""
SET LEXES="Not Applicable"
SET LEXLS=-1
+11 if +LEXFA>0&(+LEXCDT>0)&(LEXFA>LEXCDT)
SET LEXES="Pending"
SET LEXLS=-1
SET LEXST=0
SET LEXBRW=""
+12 SET LEXEE=""
if LEXFA?7N
SET LEXEE="(future activation of "_$$SD^LEXQM(LEXFA)_")"
+13 SET X=LEXLS_"^"_LEXST_"^"_LEXEF_"^"_LEXES_"^"_LEXEE
if $LENGTH(LEXBRW)
SET $PIECE(X,"^",6)=LEXBRW
End DoDot:1
QUIT X
+14 SET (LEXLS,LEXST)=LEXPS
SET LEXEF=LEXPE
SET LEXES=$SELECT(+LEXST>0:"Active",1:"Inactive")
SET LEXEE=$$SD^LEXQM(LEXEF)
+15 SET X=LEXLS_"^"_LEXST_"^"_LEXEF_"^"_LEXES_"^"_LEXEE
if $LENGTH(LEXBRW)
SET $PIECE(X,"^",6)=LEXBRW
+16 QUIT X
+17 ;
SDS(X,LEXVDT,LEX,LEXLEN,LEXSTA) ; Modifier Name (short description)
+1 ;
+2 ; LEX=# of Lines
+3 ; LEX(0)=External Date of Modifier Name
+4 ; LEX(#)=Modifier 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(^DIC(81.3,+LEXIEN,61))
QUIT
SET LEXVDT=+($GET(LEXVDT))
+8 if LEXVDT'?7N
SET LEXVDT=$$DT^XLFDT
SET LEXSTA=+($GET(LEXSTA))
SET LEXSO=$PIECE($GET(^DIC(81.3,+LEXIEN,0)),"^",1)
+9 SET LEXLAST=$$MOD^ICPTMOD(+LEXIEN,"I",LEXVDT)
SET LEXLSD=$PIECE(LEXLAST,"^",3)
SET LEXBRD=2890101
+10 if $DATA(LEXGET)&($LENGTH(LEXLSD))
SET LEXGET(81.3,(+LEXIEN_","),"B")=LEXLSD
+11 SET LEXLEN=+($GET(LEXLEN))
if +LEXLEN'>0
SET LEXLEN=62
SET LEXFA=$$FA(+LEXIEN)
SET LEXM=""
+12 SET LEXM=""
if +LEXVDT<LEXFA&(LEXFA'=LEXBRD)
SET LEXM="CPT Modifier 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(^DIC(81.3,LEXIEN,61,"B",(LEXVDT+.001)),-1)
SET LEXHIS=$ORDER(^DIC(81.3,LEXIEN,61,"B",+LEXEFF," "),-1)
SET LEXSDT=$PIECE($GET(^DIC(81.3,+LEXIEN,61,+LEXHIS,0)),"^",2)
+18 SET LEXLEF=$ORDER(^DIC(81.3,LEXIEN,61,"B",(9999999+.001)),-1)
SET LEXLHI=$ORDER(^DIC(81.3,LEXIEN,61,"B",+LEXLEF," "),-1)
SET LEXDDT=$PIECE($GET(^DIC(81.3,+LEXIEN,61,+LEXLHI,0)),"^",2)
+19 SET LEXAIEN=""
SET LEXSIEN=LEXHIS
if LEXSIEN'>0&(LEXDDT?7N)
SET LEXSIEN=$ORDER(^DIC(81.3,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(LEXSDT)&(LEXEFF?7N)&($DATA(LEXIIEN))
SET LEXD=LEXD_" (IEN "_LEXAIEN_")"
+23 if $LENGTH(LEXDDT)&(LEXLEF?7N)&('$LENGTH(LEXD))&('$LENGTH(LEXE))
SET LEXD=LEXDDT
SET LEXE=LEXLEF
SET LEXR="No Text Available for Date Provided"
+24 KILL LEX
SET LEX(1)=LEXD
if $LENGTH(LEXD)
SET LEXGET(81.3,(+LEXIEN_","),"B")=LEXD
SET LEXEE=$$SD^LEXQM(LEXE)
+25 if $DATA(LEXTEST)&(+($GET(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,LEXDDT,LEXEVDT,LEXFA,LEXI,LEXIEN,LEXAIEN,LEXSIEN,LEXL,LEXLT,LEXLN,LEXM,LEXT,LEXSO,LEXTL,LEXTMP
+8 SET LEXIEN=$GET(X)
if +LEXIEN'>0
QUIT
if '$DATA(^DIC(81.3,+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(^DIC(81.3,+LEXIEN,0)),"^",1)
SET LEXFA=$$FA(+LEXIEN)
SET LEXM=""
SET LEXSTA=+($GET(LEXSTA))
SET LEXBRD=2890101
+11 SET LEXM=""
if +LEXVDT<LEXFA&(LEXFA'=LEXBRD)
SET LEXM=" Modifier description is not available. The date provided precedes the initial activation of the code"
IF $LENGTH(LEXM)
Begin DoDot:1
+12 KILL LEX
NEW LEXT,LEXI
SET LEXT(1)=LEXM
DO PR^LEXU(.LEXT,(LEXLEN-7))
+13 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 LEXLT=$$MODD^ICPTMOD(LEXIEN,"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(^DIC(81.3,+LEXIEN,62,"B",(LEXVDT+.999999)),-1)
if LEXDDT'?7N
SET LEXDDT=$ORDER(^DIC(81.3,+LEXIEN,62,"B",0))
if LEXDDT?7N
SET LEXEVDT=$$SD^LEXQM(LEXDDT)
+19 SET LEXSIEN=""
SET LEXAIEN=LEXIEN
if LEXDDT?7N
SET LEXSIEN=$ORDER(^DIC(81.3,+LEXIEN,62,"B",LEXDDT,0))
if +($GET(LEXSIEN))>0
SET LEXAIEN=LEXAIEN_";"_+($GET(LEXSIEN))
+20 IF $DATA(LEXIIEN)
Begin DoDot:1
+21 NEW LEXI
SET LEXI=$ORDER(LEXTMP(" "),-1)
if +LEXI'>0
QUIT
if '$DATA(LEXTMP(LEXI))
QUIT
+22 SET LEXTMP(LEXI)=$GET(LEXTMP(LEXI))_" (IEN "_LEXAIEN_")"
End DoDot:1
+23 DO PR^LEXU(.LEXTMP,63)
KILL LEX
FOR LEXI=1:1:+($GET(LEXTMP))
Begin DoDot:1
+24 if '$DATA(LEXTMP(LEXI))
QUIT
SET LEXT=$$TM^LEXQM($GET(LEXTMP(LEXI)))
SET LEX(LEXI)=$$UP^XLFSTR(LEXT)
End DoDot:1
+25 IF $LENGTH(LEXM)
Begin DoDot:1
+26 NEW LEXT,LEXI,LEXL,LEXC
SET LEXL=+($ORDER(LEX(" "),-1))
SET LEXC=0
SET LEXT(1)=LEXM
DO PR^LEXU(.LEXT,(LEXLEN-7))
+27 SET LEXI=0
FOR
SET LEXI=$ORDER(LEXT(LEXI))
if +LEXI'>0
QUIT
Begin DoDot:2
+28 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
+29 if $DATA(LEXTEST)&(+($GET(LEXSTA))'>0)
SET LEXEVDT="--/--/----"
if $DATA(LEX(1))
SET LEX(0)=LEXEVDT
SET LEX=+($ORDER(LEX(" "),-1))
+30 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
KILL LEX
SET LEXVDT=$GET(X)
if LEXVDT'?7N
QUIT
SET LEXIA=$$IA(LEXVDT)
if +LEXIA'>0
QUIT
SET LEXLEN=+$GET(LEXLEN)
if +LEXLEN>62
SET LEXLEN=62
+7 SET LEXTMP(1)="Warning: The 'Based on Date' provided precedes Code Set Versioning. The Modifier Name and Description may be inaccurate for "_$$SD^LEXQM(LEXVDT)
+8 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))
+9 SET LEX=$ORDER(LEX(" "),-1)
SET LEX(0)=$$SD^LEXQM(LEXVDT)
+10 QUIT
+11 ; Miscellaneous
FA(X) ; First Activation
+1 NEW LEXFA,LEXH,LEXI,LEXIEN,LEXSO
SET LEXIEN=+($GET(X))
SET X=""
SET LEXSO=$PIECE($GET(^DIC(81.3,+LEXIEN,0)),"^",1)
DO HIST^ICPTAPIU(LEXSO,.LEXH)
SET LEXFA=""
SET LEXI=0
+2 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
+3 SET X=LEXFA
+4 QUIT X
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
EV(X) ; Check environment
+1 NEW LEX
SET DT=$$DT^XLFDT
DO HOME^%ZIS
SET U="^"
IF +($GET(DUZ))=0
WRITE !!,?5,"DUZ not defined"
QUIT 0
+2 SET LEX=$$GET1^DIQ(200,(DUZ_","),.01)
IF '$LENGTH(LEX)
WRITE !!,?5,"DUZ not valid"
QUIT 0
+3 QUIT 1
