LEXQC6 ;ISL/KER - Query - Changes - Summary ;05/23/2017
;;2.0;LEXICON UTILITY;**103**;Sep 23, 1996;Build 2
;
; Global Variables
; ^TMP("LEXQC") SACC 2.3.2.5.1
; ^TMP("LEXQCO") SACC 2.3.2.5.1
;
; External References
; HOME^%ZIS ICR 10086
; ^%ZTLOAD ICR 10063
; $$GET1^DIQ ICR 2056
; ^DIR ICR 10026
; $$DT^XLFDT ICR 10103
; $$FMADD^XLFDT ICR 10103
; $$FMTE^XLFDT ICR 10103
; ^XMD ICR 10070
;
EN ; Change List Summary
N LEXENV S LEXENV=$$ENV Q:+LEXENV'>0
W !!," Summary (totals only)"
N %,I,LEXCDT,LEXBDT,LEXADT,LEXEDT,LEXRT,LEXSAB,LEXCONT,LEXIMP
S LEXCDT=$$CSD^LEXQM,LEXEDT=$P(LEXCDT,"^",1),LEXCDT=$P(LEXCDT,"^",2)
I '$L(LEXCDT)!(LEXCDT'?7N) W !!," Code Set Date invalid or not selected",! Q
I $$CDTOK(LEXCDT)'>0 W !!," No Code Set changes found for ",$$FMTE^XLFDT(LEXCDT),! Q
S LEXBDT=$$FMADD^XLFDT(LEXCDT,-1),LEXADT=$$FMADD^XLFDT(DT,+1)
Q:LEXBDT'?7N Q:LEXADT'?7N K ^TMP("LEXQC",$J)
D TASK K ^TMP("LEXQC",$J)
Q
MAIL ; Send Results by MailMan
N LEXTASK S LEXTASK=1 D EN
Q
TASK ; Task Search for CSV Changes
N X,Y,ZTSK,ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE,ZTQUEUED,ZTREQ
S LEXCDT=+($G(LEXCDT)) Q:LEXCDT'?7N S LEXEDT=$G(LEXEDT) Q:'$L(LEXEDT)
S ZTRTN="SUM^LEXQC6",ZTSAVE("LEXCDT")="",ZTIO="",ZTDTH=$H
S ZTDESC="Search for CSV Changes on "_LEXEDT
D:'$D(LEXTASK) @ZTRTN D:$D(LEXTASK) ^%ZTLOAD D HOME^%ZIS S X=+($G(ZTSK))
I +X>0 D
. W !!," A search for CSV changes on ",LEXEDT," has been queued"
. W !," (task ",+X,"). A summary report will be sent to you in"
. W !," a MailMan message.",!
K Y,ZTSK,ZTDESC,ZTDTH,ZTIO,ZTRTN,LEXQUIET,LEXTASK
Q
;
SUM ; Summary
D GET,DSP K ^TMP("LEXQC",$J)
Q
GET ; Get Data
N LEX1,LEX2,LEX3,LEXTX,LEXTT,LEXTV,LEXIIMP,LEXCIMP,LEXQLEN,LEXQSTR,LEXQTOT,LEXTOT,LEXCAT
S:$G(LEXCDT)'?7N LEXCDT=$$DT^XLFDT
S:$G(LEXBDT)'?7N LEXBDT=$$FMADD^XLFDT(LEXCDT,-1)
S:$G(LEXADT)'?7N LEXADT=$$FMADD^XLFDT(DT,+1)
S LEX1=3,LEX2=5,LEX3=26
S LEXIIMP=$$IMPDATE^LEXU("10D"),LEXCIMP=$$IMPDATE^LEXU("CPT"),LEXQTOT=0
I LEXCDT<LEXIIMP S LEXQTOT=LEXQTOT+($P($G(^LEX(757.03,1,0)),"^",6))+($P($G(^LEX(757.03,2,0)),"^",6))
I LEXCDT>(LEXIIMP-.0001) S LEXQTOT=LEXQTOT+($P($G(^LEX(757.03,30,0)),"^",6))+($P($G(^LEX(757.03,31,0)),"^",6))
I LEXCDT>(LEXCIMP-.0001) S LEXQTOT=LEXQTOT+($P($G(^LEX(757.03,3,0)),"^",6))+($P($G(^LEX(757.03,4,0)),"^",6))
S:+($G(LEXQTOT))'>0 LEXQTOT=193006
S LEXQLEN=68,LEXQSTR=+(LEXQTOT\LEXQLEN) S:LEXQSTR=0 LEXQSTR=1
W:'$D(ZTQUEUED) !!," Gathering data, please wait.",!," "
D:LEXCDT<LEXIIMP D09^LEXQC3,P09^LEXQC3
D:LEXCDT>(LEXIIMP-.0001) D10^LEXQC3,P10^LEXQC3
D:LEXCDT>(LEXCIMP-.0001) CPT^LEXQC4,MOD^LEXQC4
I $D(^TMP("LEXQC",$J)),$G(LEXCDT)?7N D
. N LEXTT,LEXQT,LEXFY,LEXQI,LEXQTR S LEXQT=""
. S:$E(LEXCDT,4,7)="0101" LEXQT=2 S:$E(LEXCDT,4,7)="0401" LEXQT=3 S:$E(LEXCDT,4,7)="0701" LEXQT=4 S:$E(LEXCDT,4,7)="1001" LEXQT=1
. S LEXFY=$E((+($E(LEXCDT,1,3))+1700),3,4) S:LEXQT=1 LEXFY=LEXFY+1 S LEXFY=$E(LEXFY,($L(LEXFY)-1),$L(LEXFY))
. S:$L(LEXFY)=1 LEXFY="0"_LEXFY S:$L(LEXFY)=1 LEXFY="0"_LEXFY S LEXQI=$S(LEXQT=1:"st",LEXQT=2:"nd",LEXQT=3:"rd",LEXQT=4:"th",1:"")
. S LEXQTR="" S:+LEXQT>0&(LEXQT<5)&($L(LEXFY)=2)&($L(LEXQI)) LEXQTR="FY"_LEXFY_" "_LEXQT_LEXQI_" Qtr"
. S LEXTT=" Change list summary for "_$$FMTE^XLFDT(LEXCDT,"5Z")_" "_$S($L(LEXQTR):" (",1:"")_LEXQTR_$S($L(LEXQTR):")",1:"")
. D BL,TL(LEXTT)
S (LEXTOT,LEXCAT)=0
S LEXSAB="ICD" I $D(^TMP("LEXQC",$J,LEXSAB)) D
. N LEXTX,LEXC S LEXC=+($P($$CGS(LEXSAB),"^",2)),LEXCAT=LEXCAT+1,LEXTOT=LEXTOT+LEXC
. S LEXTX=$$TTL("ICD-9-CM Diagnosis",LEXC)
. D BL,TL(LEXTX),BL,SAB
S LEXSAB="ICP" I $D(^TMP("LEXQC",$J,LEXSAB)) D
. N LEXTX,LEXC S LEXC=+($P($$CGS(LEXSAB),"^",2)),LEXCAT=LEXCAT+1,LEXTOT=LEXTOT+LEXC
. S LEXTX=$$TTL("ICD-9 Procedures",LEXC) D BL,TL(LEXTX),BL,SAB
S LEXSAB="10D" I $D(^TMP("LEXQC",$J,LEXSAB)) D
. N LEXTX,LEXC S LEXC=+($P($$CGS(LEXSAB),"^",2)),LEXCAT=LEXCAT+1,LEXTOT=LEXTOT+LEXC
. S LEXTX=$$TTL("ICD-10-CM Diagnosis",LEXC) D BL,TL(LEXTX),BL,SAB
S LEXSAB="10P" I $D(^TMP("LEXQC",$J,LEXSAB)) D
. N LEXTX,LEXC S LEXC=+($P($$CGS(LEXSAB),"^",2)),LEXCAT=LEXCAT+1,LEXTOT=LEXTOT+LEXC
. S LEXTX=$$TTL("ICD-10-PCS Procedures",LEXC) D BL,TL(LEXTX),BL,SAB
S LEXSAB="CPT" I $D(^TMP("LEXQC",$J,LEXSAB)) D
. N LEXTX,LEXC S LEXC=+($P($$CGS(LEXSAB),"^",2)),LEXCAT=LEXCAT+1,LEXTOT=LEXTOT+LEXC
. S LEXTX=$$TTL("CPT Procedures",LEXC) D BL,TL(LEXTX),BL,SAB
S LEXSAB="CPC" I $D(^TMP("LEXQC",$J,LEXSAB)) D
. N LEXTX,LEXC S LEXC=+($P($$CGS(LEXSAB),"^",2)),LEXCAT=LEXCAT+1,LEXTOT=LEXTOT+LEXC
. S LEXTX=$$TTL("HCPCS Procedures",LEXC) D BL,TL(LEXTX),BL,SAB
S LEXSAB="MOD" I $D(^TMP("LEXQC",$J,LEXSAB)) D
. N LEXTX,LEXC S LEXC=+($P($$CGS(LEXSAB),"^",2)),LEXCAT=LEXCAT+1,LEXTOT=LEXTOT+LEXC
. S LEXTX=$$TTL("CPT/HCPCS Modifiers",LEXC) D BL,TL(LEXTX),BL,SAB
I LEXCAT>1 D
. Q:+LEXTOT'>0 N LEXTX S LEXTX=$$TTL("Total Changes",LEXTOT) D BL,TL(LEXTX),BL
F LEXSAB="ICD","ICP","10D","10P","CPT","CPC","MOD" K ^TMP("LEXQC",$J,LEXSAB)
Q
SAB ; Get Data by Source Abbreviation (SAB)
Q:'$L($G(LEXSAB))
I $D(^TMP("LEXQC",$J,LEXSAB,"ACT",0)) D
. N LEXTX S LEXTX=$$FMT("","Added Codes",+$G(^TMP("LEXQC",$J,LEXSAB,"ACT",0))) D TL(LEXTX)
I $D(^TMP("LEXQC",$J,LEXSAB,"INA",0)) D
. N LEXTX S LEXTX=$$FMT("","Inactivated Codes",+$G(^TMP("LEXQC",$J,LEXSAB,"INA",0))) D TL(LEXTX)
I $D(^TMP("LEXQC",$J,LEXSAB,"REA",0)) D
. N LEXTX S LEXTX=$$FMT("","Re-Activated Codes",+$G(^TMP("LEXQC",$J,LEXSAB,"REA",0))) D TL(LEXTX)
I $D(^TMP("LEXQC",$J,LEXSAB,"REU",0)) D
. N LEXTX S LEXTX=$$FMT("","Re-Used Codes",+$G(^TMP("LEXQC",$J,LEXSAB,"REU",0))) D TL(LEXTX)
I $D(^TMP("LEXQC",$J,LEXSAB,"REV",0)) D
. N LEXTX S LEXTX=$$FMT("","Revised Codes",+$G(^TMP("LEXQC",$J,LEXSAB,"REV",0))) D TL(LEXTX)
Q
CGS(X) ; Changes for a Source Abbreviation (SAB)
N LEXSAB S LEXSAB=$G(X) Q:'$L($G(LEXSAB)) N LEXT,LEXC S (LEXT,LEXC)=0
I $D(^TMP("LEXQC",$J,LEXSAB,"ACT",0)) S LEXT=LEXT+1,LEXC=LEXC+$G(^TMP("LEXQC",$J,LEXSAB,"ACT",0))
I $D(^TMP("LEXQC",$J,LEXSAB,"INA",0)) S LEXT=LEXT+1,LEXC=LEXC+$G(^TMP("LEXQC",$J,LEXSAB,"INA",0))
I $D(^TMP("LEXQC",$J,LEXSAB,"REA",0)) S LEXT=LEXT+1,LEXC=LEXC+$G(^TMP("LEXQC",$J,LEXSAB,"REA",0))
I $D(^TMP("LEXQC",$J,LEXSAB,"REU",0)) S LEXT=LEXT+1,LEXC=LEXC+$G(^TMP("LEXQC",$J,LEXSAB,"REU",0))
I $D(^TMP("LEXQC",$J,LEXSAB,"REV",0)) S LEXT=LEXT+1,LEXC=LEXC+$G(^TMP("LEXQC",$J,LEXSAB,"REV",0))
S X=LEXT_"^"_LEXC
Q X
DSP ; Display Data
K ^TMP("LEXQCO",$J) M ^TMP("LEXQCO",$J)=^TMP("LEXQC",$J,"SUM")
D:'$D(ZTQUEUED)&($D(^TMP("LEXQCO",$J))) DSP^LEXQO("LEXQCO")
D:$D(ZTQUEUED)&($D(^TMP("LEXQCO",$J))) MM^LEXQC6
K ^TMP("LEXQCO",$J)
Q
;
; Miscellaneous
MM ; MailMan Message
G:'$D(^TMP("LEXQCO",$J)) MMQ N XCNP,XMSCR,XMDUZ,XMY,XMZ,XMSUB,XMTEXT,XMDUZ,LEXJ,LEXNM
S XMTEXT="^TMP(""LEXQCO"","_$J_",",XMSUB="CSV ICD/CPT Changes (Summary)",LEXNM=$$GET1^DIQ(200,+($G(DUZ)),.01) G:'$L(LEXNM) MMQ
S XMY(LEXNM)="",XMDUZ=.5 D ^XMD
MMQ ; MailMan Quit
K ^TMP("LEXQCO",$J),LEXNM,LEXSUB
Q
TTL(X,Y) ; Format Title Line
N LEXTX,LEXI1,LEXI2,LEXI3 S LEXI1=$S(+($G(LEX1))>0:+($G(LEX1)),1:3)
S LEXI2=$S(+($G(LEX2))>0:+($G(LEX2)),1:5) S LEXI3=$S(+($G(LEX3))>0:+($G(LEX3)),1:30)
S LEXTX="",LEXTX=LEXTX_$J(" ",(LEXI1-$L(LEXTX)))_$G(X) S Y=$S(+Y>0:+Y,1:"")
S LEXTX=LEXTX_$J(" ",(LEXI3-$L(LEXTX)))_$J($G(Y),6) S:+Y>0 LEXTX=LEXTX_" code"_$S(+($G(Y))>1:"s",1:"")
S X=LEXTX
Q X
FMT(X,Y,Z) ; Format Data Line
N LEXTX,LEXI1,LEXI2,LEXI3 S LEXI1=$S(+($G(LEX1))>0:+($G(LEX1)),1:3)
S LEXI2=$S(+($G(LEX2))>0:+($G(LEX2)),1:5) S LEXI3=$S(+($G(LEX3))>0:+($G(LEX3)),1:30)
S LEXTX="",LEXTX=LEXTX_$J(" ",(LEXI1-$L(LEXTX)))_$G(X)
S:$L($G(Y)) LEXTX=LEXTX_$J(" ",(LEXI2-$L(LEXTX)))_$G(Y)
S:$L($G(Z)) LEXTX=LEXTX_$J(" ",(LEXI3-$L(LEXTX)))_$J($G(Z),6) S X=LEXTX
Q X
CDTOK(X) ; Code Set Date is OK
N LEXCDT,LEXOK,LEXSAB,LEXI S LEXOK=0,LEXCDT=$G(X) Q:LEXCDT'?7N LEXOK
F LEXSAB="ICD","ICP","10D","10P","CPT","CPC" D Q:LEXOK>0
. S:$D(^LEX(757.02,"AUPD",LEXSAB,LEXCDT)) LEXOK=1
I LEXOK'>0 S LEXI=0 F S LEXI=$O(@("^DIC(81.3,"_LEXI_")")) Q:+LEXI'>0 D Q:LEXOK>0
. S:$D(@("^DIC(81.3,"_LEXI_",60,""B"","_LEXCDT_")")) LEXOK=1
. S:$D(@("^DIC(81.3,"_LEXI_",61,""B"","_LEXCDT_")")) LEXOK=1
. S:$D(@("^DIC(81.3,"_LEXI_",62,""B"","_LEXCDT_")")) LEXOK=1
S X=LEXOK
Q X
BL ; Blank Like
D TL(" ")
Q
TL(X) ; Text Line
N LEXI,LEXX S LEXX=$G(X) W:$D(LEXTEST) !,LEXX
S LEXI=$O(^TMP("LEXQC",$J,"SUM"," "),-1)+1,^TMP("LEXQC",$J,"SUM",+LEXI)=LEXX N LEXTEST
Q
CONT(X) ; Continue
Q:$G(LEXCONT)["^" "^" N DIR,DIROUT,DIRUT,DUOUT,DTOUT,Y S DIR(0)="FAO^1:30",DIR("A")=" Press <Enter> to continue or '^' to exit "
S DIR("PRE")="S:X[""^^"" X=""^^"" S:X'[""^^""&(X[""^"") X=""^"" S:X[""?"" X=""??"" S:X'[""^""&(X'[""?"") X="""""
S (DIR("?"),DIR("??"))="^D CONTH^"_$$LR D ^DIR Q:X["^^"!($D(DIROUT)) "^^" Q:$D(DUOUT) "^" Q:X["^" "^" Q ""
Q ""
CONTH ; Continue Help
W !," Press <Enter> to continue or '^' to exit"
Q
LR(X) ; Local Routine
S X=$T(+1),X=$P(X," ",1) Q X
ENV(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[HLEXQC6 9378 printed Mar 13, 2025@21:12:57 Page 2
LEXQC6 ;ISL/KER - Query - Changes - Summary ;05/23/2017
+1 ;;2.0;LEXICON UTILITY;**103**;Sep 23, 1996;Build 2
+2 ;
+3 ; Global Variables
+4 ; ^TMP("LEXQC") SACC 2.3.2.5.1
+5 ; ^TMP("LEXQCO") SACC 2.3.2.5.1
+6 ;
+7 ; External References
+8 ; HOME^%ZIS ICR 10086
+9 ; ^%ZTLOAD ICR 10063
+10 ; $$GET1^DIQ ICR 2056
+11 ; ^DIR ICR 10026
+12 ; $$DT^XLFDT ICR 10103
+13 ; $$FMADD^XLFDT ICR 10103
+14 ; $$FMTE^XLFDT ICR 10103
+15 ; ^XMD ICR 10070
+16 ;
EN ; Change List Summary
+1 NEW LEXENV
SET LEXENV=$$ENV
if +LEXENV'>0
QUIT
+2 WRITE !!," Summary (totals only)"
+3 NEW %,I,LEXCDT,LEXBDT,LEXADT,LEXEDT,LEXRT,LEXSAB,LEXCONT,LEXIMP
+4 SET LEXCDT=$$CSD^LEXQM
SET LEXEDT=$PIECE(LEXCDT,"^",1)
SET LEXCDT=$PIECE(LEXCDT,"^",2)
+5 IF '$LENGTH(LEXCDT)!(LEXCDT'?7N)
WRITE !!," Code Set Date invalid or not selected",!
QUIT
+6 IF $$CDTOK(LEXCDT)'>0
WRITE !!," No Code Set changes found for ",$$FMTE^XLFDT(LEXCDT),!
QUIT
+7 SET LEXBDT=$$FMADD^XLFDT(LEXCDT,-1)
SET LEXADT=$$FMADD^XLFDT(DT,+1)
+8 if LEXBDT'?7N
QUIT
if LEXADT'?7N
QUIT
KILL ^TMP("LEXQC",$JOB)
+9 DO TASK
KILL ^TMP("LEXQC",$JOB)
+10 QUIT
MAIL ; Send Results by MailMan
+1 NEW LEXTASK
SET LEXTASK=1
DO EN
+2 QUIT
TASK ; Task Search for CSV Changes
+1 NEW X,Y,ZTSK,ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE,ZTQUEUED,ZTREQ
+2 SET LEXCDT=+($GET(LEXCDT))
if LEXCDT'?7N
QUIT
SET LEXEDT=$GET(LEXEDT)
if '$LENGTH(LEXEDT)
QUIT
+3 SET ZTRTN="SUM^LEXQC6"
SET ZTSAVE("LEXCDT")=""
SET ZTIO=""
SET ZTDTH=$HOROLOG
+4 SET ZTDESC="Search for CSV Changes on "_LEXEDT
+5 if '$DATA(LEXTASK)
DO @ZTRTN
if $DATA(LEXTASK)
DO ^%ZTLOAD
DO HOME^%ZIS
SET X=+($GET(ZTSK))
+6 IF +X>0
Begin DoDot:1
+7 WRITE !!," A search for CSV changes on ",LEXEDT," has been queued"
+8 WRITE !," (task ",+X,"). A summary report will be sent to you in"
+9 WRITE !," a MailMan message.",!
End DoDot:1
+10 KILL Y,ZTSK,ZTDESC,ZTDTH,ZTIO,ZTRTN,LEXQUIET,LEXTASK
+11 QUIT
+12 ;
SUM ; Summary
+1 DO GET
DO DSP
KILL ^TMP("LEXQC",$JOB)
+2 QUIT
GET ; Get Data
+1 NEW LEX1,LEX2,LEX3,LEXTX,LEXTT,LEXTV,LEXIIMP,LEXCIMP,LEXQLEN,LEXQSTR,LEXQTOT,LEXTOT,LEXCAT
+2 if $GET(LEXCDT)'?7N
SET LEXCDT=$$DT^XLFDT
+3 if $GET(LEXBDT)'?7N
SET LEXBDT=$$FMADD^XLFDT(LEXCDT,-1)
+4 if $GET(LEXADT)'?7N
SET LEXADT=$$FMADD^XLFDT(DT,+1)
+5 SET LEX1=3
SET LEX2=5
SET LEX3=26
+6 SET LEXIIMP=$$IMPDATE^LEXU("10D")
SET LEXCIMP=$$IMPDATE^LEXU("CPT")
SET LEXQTOT=0
+7 IF LEXCDT<LEXIIMP
SET LEXQTOT=LEXQTOT+($PIECE($GET(^LEX(757.03,1,0)),"^",6))+($PIECE($GET(^LEX(757.03,2,0)),"^",6))
+8 IF LEXCDT>(LEXIIMP-.0001)
SET LEXQTOT=LEXQTOT+($PIECE($GET(^LEX(757.03,30,0)),"^",6))+($PIECE($GET(^LEX(757.03,31,0)),"^",6))
+9 IF LEXCDT>(LEXCIMP-.0001)
SET LEXQTOT=LEXQTOT+($PIECE($GET(^LEX(757.03,3,0)),"^",6))+($PIECE($GET(^LEX(757.03,4,0)),"^",6))
+10 if +($GET(LEXQTOT))'>0
SET LEXQTOT=193006
+11 SET LEXQLEN=68
SET LEXQSTR=+(LEXQTOT\LEXQLEN)
if LEXQSTR=0
SET LEXQSTR=1
+12 if '$DATA(ZTQUEUED)
WRITE !!," Gathering data, please wait.",!," "
+13 if LEXCDT<LEXIIMP
DO D09^LEXQC3
DO P09^LEXQC3
+14 if LEXCDT>(LEXIIMP-.0001)
DO D10^LEXQC3
DO P10^LEXQC3
+15 if LEXCDT>(LEXCIMP-.0001)
DO CPT^LEXQC4
DO MOD^LEXQC4
+16 IF $DATA(^TMP("LEXQC",$JOB))
IF $GET(LEXCDT)?7N
Begin DoDot:1
+17 NEW LEXTT,LEXQT,LEXFY,LEXQI,LEXQTR
SET LEXQT=""
+18 if $EXTRACT(LEXCDT,4,7)="0101"
SET LEXQT=2
if $EXTRACT(LEXCDT,4,7)="0401"
SET LEXQT=3
if $EXTRACT(LEXCDT,4,7)="0701"
SET LEXQT=4
if $EXTRACT(LEXCDT,4,7)="1001"
SET LEXQT=1
+19 SET LEXFY=$EXTRACT((+($EXTRACT(LEXCDT,1,3))+1700),3,4)
if LEXQT=1
SET LEXFY=LEXFY+1
SET LEXFY=$EXTRACT(LEXFY,($LENGTH(LEXFY)-1),$LENGTH(LEXFY))
+20 if $LENGTH(LEXFY)=1
SET LEXFY="0"_LEXFY
if $LENGTH(LEXFY)=1
SET LEXFY="0"_LEXFY
SET LEXQI=$SELECT(LEXQT=1:"st",LEXQT=2:"nd",LEXQT=3:"rd",LEXQT=4:"th",1:"")
+21 SET LEXQTR=""
if +LEXQT>0&(LEXQT<5)&($LENGTH(LEXFY)=2)&($LENGTH(LEXQI))
SET LEXQTR="FY"_LEXFY_" "_LEXQT_LEXQI_" Qtr"
+22 SET LEXTT=" Change list summary for "_$$FMTE^XLFDT(LEXCDT,"5Z")_" "_$SELECT($LENGTH(LEXQTR):" (",1:"")_LEXQTR_$SELECT($LENGTH(LEXQTR):")",1:"")
+23 DO BL
DO TL(LEXTT)
End DoDot:1
+24 SET (LEXTOT,LEXCAT)=0
+25 SET LEXSAB="ICD"
IF $DATA(^TMP("LEXQC",$JOB,LEXSAB))
Begin DoDot:1
+26 NEW LEXTX,LEXC
SET LEXC=+($PIECE($$CGS(LEXSAB),"^",2))
SET LEXCAT=LEXCAT+1
SET LEXTOT=LEXTOT+LEXC
+27 SET LEXTX=$$TTL("ICD-9-CM Diagnosis",LEXC)
+28 DO BL
DO TL(LEXTX)
DO BL
DO SAB
End DoDot:1
+29 SET LEXSAB="ICP"
IF $DATA(^TMP("LEXQC",$JOB,LEXSAB))
Begin DoDot:1
+30 NEW LEXTX,LEXC
SET LEXC=+($PIECE($$CGS(LEXSAB),"^",2))
SET LEXCAT=LEXCAT+1
SET LEXTOT=LEXTOT+LEXC
+31 SET LEXTX=$$TTL("ICD-9 Procedures",LEXC)
DO BL
DO TL(LEXTX)
DO BL
DO SAB
End DoDot:1
+32 SET LEXSAB="10D"
IF $DATA(^TMP("LEXQC",$JOB,LEXSAB))
Begin DoDot:1
+33 NEW LEXTX,LEXC
SET LEXC=+($PIECE($$CGS(LEXSAB),"^",2))
SET LEXCAT=LEXCAT+1
SET LEXTOT=LEXTOT+LEXC
+34 SET LEXTX=$$TTL("ICD-10-CM Diagnosis",LEXC)
DO BL
DO TL(LEXTX)
DO BL
DO SAB
End DoDot:1
+35 SET LEXSAB="10P"
IF $DATA(^TMP("LEXQC",$JOB,LEXSAB))
Begin DoDot:1
+36 NEW LEXTX,LEXC
SET LEXC=+($PIECE($$CGS(LEXSAB),"^",2))
SET LEXCAT=LEXCAT+1
SET LEXTOT=LEXTOT+LEXC
+37 SET LEXTX=$$TTL("ICD-10-PCS Procedures",LEXC)
DO BL
DO TL(LEXTX)
DO BL
DO SAB
End DoDot:1
+38 SET LEXSAB="CPT"
IF $DATA(^TMP("LEXQC",$JOB,LEXSAB))
Begin DoDot:1
+39 NEW LEXTX,LEXC
SET LEXC=+($PIECE($$CGS(LEXSAB),"^",2))
SET LEXCAT=LEXCAT+1
SET LEXTOT=LEXTOT+LEXC
+40 SET LEXTX=$$TTL("CPT Procedures",LEXC)
DO BL
DO TL(LEXTX)
DO BL
DO SAB
End DoDot:1
+41 SET LEXSAB="CPC"
IF $DATA(^TMP("LEXQC",$JOB,LEXSAB))
Begin DoDot:1
+42 NEW LEXTX,LEXC
SET LEXC=+($PIECE($$CGS(LEXSAB),"^",2))
SET LEXCAT=LEXCAT+1
SET LEXTOT=LEXTOT+LEXC
+43 SET LEXTX=$$TTL("HCPCS Procedures",LEXC)
DO BL
DO TL(LEXTX)
DO BL
DO SAB
End DoDot:1
+44 SET LEXSAB="MOD"
IF $DATA(^TMP("LEXQC",$JOB,LEXSAB))
Begin DoDot:1
+45 NEW LEXTX,LEXC
SET LEXC=+($PIECE($$CGS(LEXSAB),"^",2))
SET LEXCAT=LEXCAT+1
SET LEXTOT=LEXTOT+LEXC
+46 SET LEXTX=$$TTL("CPT/HCPCS Modifiers",LEXC)
DO BL
DO TL(LEXTX)
DO BL
DO SAB
End DoDot:1
+47 IF LEXCAT>1
Begin DoDot:1
+48 if +LEXTOT'>0
QUIT
NEW LEXTX
SET LEXTX=$$TTL("Total Changes",LEXTOT)
DO BL
DO TL(LEXTX)
DO BL
End DoDot:1
+49 FOR LEXSAB="ICD","ICP","10D","10P","CPT","CPC","MOD"
KILL ^TMP("LEXQC",$JOB,LEXSAB)
+50 QUIT
SAB ; Get Data by Source Abbreviation (SAB)
+1 if '$LENGTH($GET(LEXSAB))
QUIT
+2 IF $DATA(^TMP("LEXQC",$JOB,LEXSAB,"ACT",0))
Begin DoDot:1
+3 NEW LEXTX
SET LEXTX=$$FMT("","Added Codes",+$GET(^TMP("LEXQC",$JOB,LEXSAB,"ACT",0)))
DO TL(LEXTX)
End DoDot:1
+4 IF $DATA(^TMP("LEXQC",$JOB,LEXSAB,"INA",0))
Begin DoDot:1
+5 NEW LEXTX
SET LEXTX=$$FMT("","Inactivated Codes",+$GET(^TMP("LEXQC",$JOB,LEXSAB,"INA",0)))
DO TL(LEXTX)
End DoDot:1
+6 IF $DATA(^TMP("LEXQC",$JOB,LEXSAB,"REA",0))
Begin DoDot:1
+7 NEW LEXTX
SET LEXTX=$$FMT("","Re-Activated Codes",+$GET(^TMP("LEXQC",$JOB,LEXSAB,"REA",0)))
DO TL(LEXTX)
End DoDot:1
+8 IF $DATA(^TMP("LEXQC",$JOB,LEXSAB,"REU",0))
Begin DoDot:1
+9 NEW LEXTX
SET LEXTX=$$FMT("","Re-Used Codes",+$GET(^TMP("LEXQC",$JOB,LEXSAB,"REU",0)))
DO TL(LEXTX)
End DoDot:1
+10 IF $DATA(^TMP("LEXQC",$JOB,LEXSAB,"REV",0))
Begin DoDot:1
+11 NEW LEXTX
SET LEXTX=$$FMT("","Revised Codes",+$GET(^TMP("LEXQC",$JOB,LEXSAB,"REV",0)))
DO TL(LEXTX)
End DoDot:1
+12 QUIT
CGS(X) ; Changes for a Source Abbreviation (SAB)
+1 NEW LEXSAB
SET LEXSAB=$GET(X)
if '$LENGTH($GET(LEXSAB))
QUIT
NEW LEXT,LEXC
SET (LEXT,LEXC)=0
+2 IF $DATA(^TMP("LEXQC",$JOB,LEXSAB,"ACT",0))
SET LEXT=LEXT+1
SET LEXC=LEXC+$GET(^TMP("LEXQC",$JOB,LEXSAB,"ACT",0))
+3 IF $DATA(^TMP("LEXQC",$JOB,LEXSAB,"INA",0))
SET LEXT=LEXT+1
SET LEXC=LEXC+$GET(^TMP("LEXQC",$JOB,LEXSAB,"INA",0))
+4 IF $DATA(^TMP("LEXQC",$JOB,LEXSAB,"REA",0))
SET LEXT=LEXT+1
SET LEXC=LEXC+$GET(^TMP("LEXQC",$JOB,LEXSAB,"REA",0))
+5 IF $DATA(^TMP("LEXQC",$JOB,LEXSAB,"REU",0))
SET LEXT=LEXT+1
SET LEXC=LEXC+$GET(^TMP("LEXQC",$JOB,LEXSAB,"REU",0))
+6 IF $DATA(^TMP("LEXQC",$JOB,LEXSAB,"REV",0))
SET LEXT=LEXT+1
SET LEXC=LEXC+$GET(^TMP("LEXQC",$JOB,LEXSAB,"REV",0))
+7 SET X=LEXT_"^"_LEXC
+8 QUIT X
DSP ; Display Data
+1 KILL ^TMP("LEXQCO",$JOB)
MERGE ^TMP("LEXQCO",$JOB)=^TMP("LEXQC",$JOB,"SUM")
+2 if '$DATA(ZTQUEUED)&($DATA(^TMP("LEXQCO",$JOB)))
DO DSP^LEXQO("LEXQCO")
+3 if $DATA(ZTQUEUED)&($DATA(^TMP("LEXQCO",$JOB)))
DO MM^LEXQC6
+4 KILL ^TMP("LEXQCO",$JOB)
+5 QUIT
+6 ;
+7 ; Miscellaneous
MM ; MailMan Message
+1 if '$DATA(^TMP("LEXQCO",$JOB))
GOTO MMQ
NEW XCNP,XMSCR,XMDUZ,XMY,XMZ,XMSUB,XMTEXT,XMDUZ,LEXJ,LEXNM
+2 SET XMTEXT="^TMP(""LEXQCO"","_$JOB_","
SET XMSUB="CSV ICD/CPT Changes (Summary)"
SET LEXNM=$$GET1^DIQ(200,+($GET(DUZ)),.01)
if '$LENGTH(LEXNM)
GOTO MMQ
+3 SET XMY(LEXNM)=""
SET XMDUZ=.5
DO ^XMD
MMQ ; MailMan Quit
+1 KILL ^TMP("LEXQCO",$JOB),LEXNM,LEXSUB
+2 QUIT
TTL(X,Y) ; Format Title Line
+1 NEW LEXTX,LEXI1,LEXI2,LEXI3
SET LEXI1=$SELECT(+($GET(LEX1))>0:+($GET(LEX1)),1:3)
+2 SET LEXI2=$SELECT(+($GET(LEX2))>0:+($GET(LEX2)),1:5)
SET LEXI3=$SELECT(+($GET(LEX3))>0:+($GET(LEX3)),1:30)
+3 SET LEXTX=""
SET LEXTX=LEXTX_$JUSTIFY(" ",(LEXI1-$LENGTH(LEXTX)))_$GET(X)
SET Y=$SELECT(+Y>0:+Y,1:"")
+4 SET LEXTX=LEXTX_$JUSTIFY(" ",(LEXI3-$LENGTH(LEXTX)))_$JUSTIFY($GET(Y),6)
if +Y>0
SET LEXTX=LEXTX_" code"_$SELECT(+($GET(Y))>1:"s",1:"")
+5 SET X=LEXTX
+6 QUIT X
FMT(X,Y,Z) ; Format Data Line
+1 NEW LEXTX,LEXI1,LEXI2,LEXI3
SET LEXI1=$SELECT(+($GET(LEX1))>0:+($GET(LEX1)),1:3)
+2 SET LEXI2=$SELECT(+($GET(LEX2))>0:+($GET(LEX2)),1:5)
SET LEXI3=$SELECT(+($GET(LEX3))>0:+($GET(LEX3)),1:30)
+3 SET LEXTX=""
SET LEXTX=LEXTX_$JUSTIFY(" ",(LEXI1-$LENGTH(LEXTX)))_$GET(X)
+4 if $LENGTH($GET(Y))
SET LEXTX=LEXTX_$JUSTIFY(" ",(LEXI2-$LENGTH(LEXTX)))_$GET(Y)
+5 if $LENGTH($GET(Z))
SET LEXTX=LEXTX_$JUSTIFY(" ",(LEXI3-$LENGTH(LEXTX)))_$JUSTIFY($GET(Z),6)
SET X=LEXTX
+6 QUIT X
CDTOK(X) ; Code Set Date is OK
+1 NEW LEXCDT,LEXOK,LEXSAB,LEXI
SET LEXOK=0
SET LEXCDT=$GET(X)
if LEXCDT'?7N
QUIT LEXOK
+2 FOR LEXSAB="ICD","ICP","10D","10P","CPT","CPC"
Begin DoDot:1
+3 if $DATA(^LEX(757.02,"AUPD",LEXSAB,LEXCDT))
SET LEXOK=1
End DoDot:1
if LEXOK>0
QUIT
+4 IF LEXOK'>0
SET LEXI=0
FOR
SET LEXI=$ORDER(@("^DIC(81.3,"_LEXI_")"))
if +LEXI'>0
QUIT
Begin DoDot:1
+5 if $DATA(@("^DIC(81.3,"_LEXI_",60,""B"","_LEXCDT_")"))
SET LEXOK=1
+6 if $DATA(@("^DIC(81.3,"_LEXI_",61,""B"","_LEXCDT_")"))
SET LEXOK=1
+7 if $DATA(@("^DIC(81.3,"_LEXI_",62,""B"","_LEXCDT_")"))
SET LEXOK=1
End DoDot:1
if LEXOK>0
QUIT
+8 SET X=LEXOK
+9 QUIT X
BL ; Blank Like
+1 DO TL(" ")
+2 QUIT
TL(X) ; Text Line
+1 NEW LEXI,LEXX
SET LEXX=$GET(X)
if $DATA(LEXTEST)
WRITE !,LEXX
+2 SET LEXI=$ORDER(^TMP("LEXQC",$JOB,"SUM"," "),-1)+1
SET ^TMP("LEXQC",$JOB,"SUM",+LEXI)=LEXX
NEW LEXTEST
+3 QUIT
CONT(X) ; Continue
+1 if $GET(LEXCONT)["^"
QUIT "^"
NEW DIR,DIROUT,DIRUT,DUOUT,DTOUT,Y
SET DIR(0)="FAO^1:30"
SET DIR("A")=" Press <Enter> to continue or '^' to exit "
+2 SET DIR("PRE")="S:X[""^^"" X=""^^"" S:X'[""^^""&(X[""^"") X=""^"" S:X[""?"" X=""??"" S:X'[""^""&(X'[""?"") X="""""
+3 SET (DIR("?"),DIR("??"))="^D CONTH^"_$$LR
DO ^DIR
if X["^^"!($DATA(DIROUT))
QUIT "^^"
if $DATA(DUOUT)
QUIT "^"
if X["^"
QUIT "^"
QUIT ""
+4 QUIT ""
CONTH ; Continue Help
+1 WRITE !," Press <Enter> to continue or '^' to exit"
+2 QUIT
LR(X) ; Local Routine
+1 SET X=$TEXT(+1)
SET X=$PIECE(X," ",1)
QUIT X
ENV(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
