- 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 Mar 13, 2025@21:12:52 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
