LEXQC ;ISL/KER - Query - Changes - Extract ;05/23/2017
;;2.0;LEXICON UTILITY;**62,80,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
; $$FMADD^XLFDT ICR 10103
; $$FMTE^XLFDT ICR 10103
; ^XMD ICR 10070
;
EN ; Main Entry Point
N LEXENV S LEXENV=$$EV^LEXQM Q:+LEXENV'>0
W:$L($G(IOF)) @IOF W !," ICD/CPT Change List",!," ==================="
K ^TMP("LEXQCO",$J),^TMP("LEXQC",$J) N LEXEXIT,LEXDSP,LEXOUT
S LEXDSP=$$DT I "^D^B^"'[("^"_LEXDSP_"^") W !!," Display type not selected",! Q
S LEXOUT=$$OUT I "^0^1^"'[("^"_LEXOUT_"^") W !!," Output not selected",! Q
I LEXDSP="B" D Q
. N LEXTASK S:LEXOUT=1 LEXTASK=1 K:LEXOUT'=1 LEXTASK D EN^LEXQC6
I LEXDSP="D" D Q
. N LEXTASK S:LEXOUT=1 LEXTASK=1 K:LEXOUT'=1 LEXTASK D TASK
Q
SUM ; Summary List (totals only)
N LEXOUT S LEXOUT=$$OUT D:LEXOUT="0" EN^LEXQC6 D:LEXOUT="1" MAIL^LEXQC6
Q
TASK ; Task Search for CSV Changes
W !!," Detailed Display (includes codes)"
N X,Y,ZTSK,ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE,ZTQUEUED,ZTREQ,LEXCDT,LEXEDT,LEXEXIT
S LEXCDT=$$CSD^LEXQM
I +($G(LEXEXIT))>0 W !!," Code Set Change List aborted",! Q
S 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 LEXCDT=+($G(LEXCDT)) Q:LEXCDT'?7N S LEXEDT=$G(LEXEDT) Q:'$L(LEXEDT)
S ZTRTN="SEARCH^LEXQC",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,"). Results will be sent to you in a MailMan"
. W !," message.",!
K Y,ZTSK,ZTDESC,ZTDTH,ZTIO,ZTRTN,LEXQUIET,LEXTASK
Q
SEARCH ; Search for CSV changes
S:$D(ZTQUEUED) ZTREQ="@" S LEXCDT=$G(LEXCDT) Q:LEXCDT'?7N
N LEXBDT,LEXADT,LEXRT,LEXQTOT,LEXQLEN,LEXQSTR,LEXIIMP,LEXCIMP
S LEXBDT=$$FMADD^XLFDT(LEXCDT,-1),LEXADT=$$FMADD^XLFDT(DT,+1)
Q:LEXBDT'?7N Q:LEXADT'?7N K ^TMP("LEXQC",$J)
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 D EN^LEXQC2
D:'$D(ZTQUEUED)&($D(^TMP("LEXQCO",$J))) DSP^LEXQO("LEXQCO")
D:$D(ZTQUEUED)&($D(^TMP("LEXQCO",$J))) MM
Q
;
; Miscellaneous
DT(X) ; Display Type
Q:+($G(LEXEXIT))>0 "^^" N DIR,DIRUT,DIROUT,DTOUT,DUOUT,Y,DIRB S DIRB=$$RET^LEXQD("LEXQC","DT",+($G(DUZ)),"Display Type")
S:'$L(DIRB) DIRB="Detailed"
S DIR(0)="SAO^D:Detailed Listing;B:Brief Listing",DIR("A")=" Detailed or Brief Listing? (D/B) "
S:"^DETAILED^BRIEF^Detailed^Brief^"[("^"_DIRB_"^") DIR("B")=DIRB
S DIR("PRE")="S:X[""?"" X=""??""" S (DIR("?"),DIR("??"))="^D DTH^LEXQC"
W ! D ^DIR S:X["^^"!($D(DTOUT)) LEXEXIT=1 Q:X["^^"!(+($G(LEXEXIT))>0) "^^" Q:$D(DIRUT)!($D(DIROUT))!($D(DTOUT))!($D(DUOUT)) "^"
S DIRB=$S(Y="D":"Detailed",Y="B":"Brief",X["^":"",1:"")
D:$L(DIRB) SAV^LEXQD("LEXQC","DT",+($G(DUZ)),"Display Type",$G(DIRB))
S X=$S("^D^B^"[("^"_Y_"^"):Y,1:"^")
Q X
DTH ; Display Type Help
W !,?3,"Listing of Code Set changes for a specified date",!
W !,?3," Enter For To"
W !,?3," D Detailed Listing Includes codes"
W !,?3," B Brief Listing Include totals only"
Q
OUT(X) ; Output
Q:+($G(LEXEXIT))>0 "^^" N DIR,DIRUT,DIROUT,DTOUT,DUOUT,Y,DIRB S DIRB=$$RET^LEXQD("LEXQC","OUT",+($G(DUZ)),"Output")
S:'$L(DIRB) DIRB="No"
S DIR(0)="YAO",DIR("A")=" Save Listing in a MailMan Message? (Y/N) "
S:"^YES^NO^Yes^No^"[("^"_DIRB_"^") DIR("B")=DIRB
S DIR("PRE")="S:X[""?"" X=""??""" S (DIR("?"),DIR("??"))="^D OUTH^LEXQC"
W ! D ^DIR S:X["^^"!($D(DTOUT)) LEXEXIT=1 Q:X["^^"!(+($G(LEXEXIT))>0) "^^" Q:$D(DIRUT)!($D(DIROUT))!($D(DTOUT))!($D(DUOUT)) "^"
S DIRB=$S(Y="1":"Yes",Y="0":"No",1:"^")
D:$L(DIRB) SAV^LEXQD("LEXQC","OUT",+($G(DUZ)),"Output",$G(DIRB))
S X=$S("^0^1^"[("^"_Y_"^"):Y,1:"^")
Q X
OUTH ; Output
W !,?3,"Enter 'Yes' to send the output listing in a MailMan message."
W !,?3,"Enter 'No' to display the output listing to the screen."
Q
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",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
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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLEXQC 5911 printed Sep 23, 2025@19:44:14 Page 2
LEXQC ;ISL/KER - Query - Changes - Extract ;05/23/2017
+1 ;;2.0;LEXICON UTILITY;**62,80,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 ; $$FMADD^XLFDT ICR 10103
+13 ; $$FMTE^XLFDT ICR 10103
+14 ; ^XMD ICR 10070
+15 ;
EN ; Main Entry Point
+1 NEW LEXENV
SET LEXENV=$$EV^LEXQM
if +LEXENV'>0
QUIT
+2 if $LENGTH($GET(IOF))
WRITE @IOF
WRITE !," ICD/CPT Change List",!," ==================="
+3 KILL ^TMP("LEXQCO",$JOB),^TMP("LEXQC",$JOB)
NEW LEXEXIT,LEXDSP,LEXOUT
+4 SET LEXDSP=$$DT
IF "^D^B^"'[("^"_LEXDSP_"^")
WRITE !!," Display type not selected",!
QUIT
+5 SET LEXOUT=$$OUT
IF "^0^1^"'[("^"_LEXOUT_"^")
WRITE !!," Output not selected",!
QUIT
+6 IF LEXDSP="B"
Begin DoDot:1
+7 NEW LEXTASK
if LEXOUT=1
SET LEXTASK=1
if LEXOUT'=1
KILL LEXTASK
DO EN^LEXQC6
End DoDot:1
QUIT
+8 IF LEXDSP="D"
Begin DoDot:1
+9 NEW LEXTASK
if LEXOUT=1
SET LEXTASK=1
if LEXOUT'=1
KILL LEXTASK
DO TASK
End DoDot:1
QUIT
+10 QUIT
SUM ; Summary List (totals only)
+1 NEW LEXOUT
SET LEXOUT=$$OUT
if LEXOUT="0"
DO EN^LEXQC6
if LEXOUT="1"
DO MAIL^LEXQC6
+2 QUIT
TASK ; Task Search for CSV Changes
+1 WRITE !!," Detailed Display (includes codes)"
+2 NEW X,Y,ZTSK,ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE,ZTQUEUED,ZTREQ,LEXCDT,LEXEDT,LEXEXIT
+3 SET LEXCDT=$$CSD^LEXQM
+4 IF +($GET(LEXEXIT))>0
WRITE !!," Code Set Change List aborted",!
QUIT
+5 SET LEXEDT=$PIECE(LEXCDT,"^",1)
SET LEXCDT=$PIECE(LEXCDT,"^",2)
+6 IF '$LENGTH(LEXCDT)!(LEXCDT'?7N)
WRITE !!," Code Set Date invalid or not selected",!
QUIT
+7 IF $$CDTOK(LEXCDT)'>0
WRITE !!," No Code Set changes found for ",$$FMTE^XLFDT(LEXCDT),!
QUIT
+8 SET LEXCDT=+($GET(LEXCDT))
if LEXCDT'?7N
QUIT
SET LEXEDT=$GET(LEXEDT)
if '$LENGTH(LEXEDT)
QUIT
+9 SET ZTRTN="SEARCH^LEXQC"
SET ZTSAVE("LEXCDT")=""
SET ZTIO=""
SET ZTDTH=$HOROLOG
+10 SET ZTDESC="Search for CSV Changes on "_LEXEDT
+11 if '$DATA(LEXTASK)
DO @ZTRTN
if $DATA(LEXTASK)
DO ^%ZTLOAD
DO HOME^%ZIS
SET X=+($GET(ZTSK))
+12 IF +X>0
Begin DoDot:1
+13 WRITE !!," A search for CSV changes on ",LEXEDT," has been queued"
+14 WRITE !," (task ",+X,"). Results will be sent to you in a MailMan"
+15 WRITE !," message.",!
End DoDot:1
+16 KILL Y,ZTSK,ZTDESC,ZTDTH,ZTIO,ZTRTN,LEXQUIET,LEXTASK
+17 QUIT
SEARCH ; Search for CSV changes
+1 if $DATA(ZTQUEUED)
SET ZTREQ="@"
SET LEXCDT=$GET(LEXCDT)
if LEXCDT'?7N
QUIT
+2 NEW LEXBDT,LEXADT,LEXRT,LEXQTOT,LEXQLEN,LEXQSTR,LEXIIMP,LEXCIMP
+3 SET LEXBDT=$$FMADD^XLFDT(LEXCDT,-1)
SET LEXADT=$$FMADD^XLFDT(DT,+1)
+4 if LEXBDT'?7N
QUIT
if LEXADT'?7N
QUIT
KILL ^TMP("LEXQC",$JOB)
+5 SET LEXIIMP=$$IMPDATE^LEXU("10D")
SET LEXCIMP=$$IMPDATE^LEXU("CPT")
SET LEXQTOT=0
+6 IF LEXCDT<LEXIIMP
SET LEXQTOT=LEXQTOT+($PIECE($GET(^LEX(757.03,1,0)),"^",6))+($PIECE($GET(^LEX(757.03,2,0)),"^",6))
+7 IF LEXCDT>(LEXIIMP-.0001)
SET LEXQTOT=LEXQTOT+($PIECE($GET(^LEX(757.03,30,0)),"^",6))+($PIECE($GET(^LEX(757.03,31,0)),"^",6))
+8 IF LEXCDT>(LEXCIMP-.0001)
SET LEXQTOT=LEXQTOT+($PIECE($GET(^LEX(757.03,3,0)),"^",6))+($PIECE($GET(^LEX(757.03,4,0)),"^",6))
+9 if +($GET(LEXQTOT))'>0
SET LEXQTOT=193006
+10 SET LEXQLEN=68
SET LEXQSTR=+(LEXQTOT\LEXQLEN)
if LEXQSTR=0
SET LEXQSTR=1
+11 if '$DATA(ZTQUEUED)
WRITE !!," Gathering data, please wait.",!," "
+12 if LEXCDT<LEXIIMP
DO D09^LEXQC3
DO P09^LEXQC3
+13 if LEXCDT>(LEXIIMP-.0001)
DO D10^LEXQC3
DO P10^LEXQC3
+14 if LEXCDT>(LEXCIMP-.0001)
DO CPT^LEXQC4
DO MOD^LEXQC4
DO EN^LEXQC2
+15 if '$DATA(ZTQUEUED)&($DATA(^TMP("LEXQCO",$JOB)))
DO DSP^LEXQO("LEXQCO")
+16 if $DATA(ZTQUEUED)&($DATA(^TMP("LEXQCO",$JOB)))
DO MM
+17 QUIT
+18 ;
+19 ; Miscellaneous
DT(X) ; Display Type
+1 if +($GET(LEXEXIT))>0
QUIT "^^"
NEW DIR,DIRUT,DIROUT,DTOUT,DUOUT,Y,DIRB
SET DIRB=$$RET^LEXQD("LEXQC","DT",+($GET(DUZ)),"Display Type")
+2 if '$LENGTH(DIRB)
SET DIRB="Detailed"
+3 SET DIR(0)="SAO^D:Detailed Listing;B:Brief Listing"
SET DIR("A")=" Detailed or Brief Listing? (D/B) "
+4 if "^DETAILED^BRIEF^Detailed^Brief^"[("^"_DIRB_"^")
SET DIR("B")=DIRB
+5 SET DIR("PRE")="S:X[""?"" X=""??"""
SET (DIR("?"),DIR("??"))="^D DTH^LEXQC"
+6 WRITE !
DO ^DIR
if X["^^"!($DATA(DTOUT))
SET LEXEXIT=1
if X["^^"!(+($GET(LEXEXIT))>0)
QUIT "^^"
if $DATA(DIRUT)!($DATA(DIROUT))!($DATA(DTOUT))!($DATA(DUOUT))
QUIT "^"
+7 SET DIRB=$SELECT(Y="D":"Detailed",Y="B":"Brief",X["^":"",1:"")
+8 if $LENGTH(DIRB)
DO SAV^LEXQD("LEXQC","DT",+($GET(DUZ)),"Display Type",$GET(DIRB))
+9 SET X=$SELECT("^D^B^"[("^"_Y_"^"):Y,1:"^")
+10 QUIT X
DTH ; Display Type Help
+1 WRITE !,?3,"Listing of Code Set changes for a specified date",!
+2 WRITE !,?3," Enter For To"
+3 WRITE !,?3," D Detailed Listing Includes codes"
+4 WRITE !,?3," B Brief Listing Include totals only"
+5 QUIT
OUT(X) ; Output
+1 if +($GET(LEXEXIT))>0
QUIT "^^"
NEW DIR,DIRUT,DIROUT,DTOUT,DUOUT,Y,DIRB
SET DIRB=$$RET^LEXQD("LEXQC","OUT",+($GET(DUZ)),"Output")
+2 if '$LENGTH(DIRB)
SET DIRB="No"
+3 SET DIR(0)="YAO"
SET DIR("A")=" Save Listing in a MailMan Message? (Y/N) "
+4 if "^YES^NO^Yes^No^"[("^"_DIRB_"^")
SET DIR("B")=DIRB
+5 SET DIR("PRE")="S:X[""?"" X=""??"""
SET (DIR("?"),DIR("??"))="^D OUTH^LEXQC"
+6 WRITE !
DO ^DIR
if X["^^"!($DATA(DTOUT))
SET LEXEXIT=1
if X["^^"!(+($GET(LEXEXIT))>0)
QUIT "^^"
if $DATA(DIRUT)!($DATA(DIROUT))!($DATA(DTOUT))!($DATA(DUOUT))
QUIT "^"
+7 SET DIRB=$SELECT(Y="1":"Yes",Y="0":"No",1:"^")
+8 if $LENGTH(DIRB)
DO SAV^LEXQD("LEXQC","OUT",+($GET(DUZ)),"Output",$GET(DIRB))
+9 SET X=$SELECT("^0^1^"[("^"_Y_"^"):Y,1:"^")
+10 QUIT X
OUTH ; Output
+1 WRITE !,?3,"Enter 'Yes' to send the output listing in a MailMan message."
+2 WRITE !,?3,"Enter 'No' to display the output listing to the screen."
+3 QUIT
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"
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
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
