- 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
