- 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 Feb 18, 2025@23:34:31 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
