LEXWUP.m

LEXWUP ;ISL/KER - Lexicon Keywords - Update (Purge) ;05/23/2017

 ;;2.0;LEXICON UTILITY;**103**;Sep 23, 1996;Build 2

 ;               

 ; Global Variables

 ;    ^ICD0(              ICR   4486

 ;    ^ICD9(              ICR   4485

 ;    ^LEX(757,           SACC 1.3

 ;    ^LEX(757.01,        SACC 1.3

 ;    ^LEX(757.02,        SACC 1.3

 ;    ^LEX(757.03,        SACC 1.3

 ;    ^LEX(757.071,       SACC 1.3

 ;    ^TMP("LEXWU",$J)    SACC 2.3.2.5.1

 ;               

 ; External References

 ;    HOME^%ZIS           ICR  10086

 ;    ^%ZTLOAD            ICR  10063

 ;    ^DIK                ICR  10013

 ;    $$GET1^DIQ          ICR   2056

 ;    $$DT^XLFDT          ICR  10103

 ;    $$FMDIFF^XLFDT      ICR  10103

 ;    $$FMTE^XLFDT        ICR  10103

 ;    $$NOW^XLFDT         ICR  10103

 ;               

 ; Local Variables NEWed or KILLed Elsewhere

 ;   Control Variables

 ;     LEXTEST            For testing only

 ;     LEXAFT             Purge keywords inactive after date

 ;     LEXCOM             Commit Flag

 ;     LEXPUR             Purge some or all (LEXPUR="ALL")

 ;               

 ; Call STOP^LEXWUS to stop the task.  It sets the following

 ; global node:

 ; 

 ;     ^TMP("LEXWU",$J,"STOP")

 ;               

 Q

EN ; Main Entry Point (tasked)

 N ZT,ZTKEY,ZTUCI,ZTSK,ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE,ZTQUEUED,ZTREQ,LEXRUN,LEXCOM,LEXCHK,LEXNAM,I,X,Y

 S (LEXNAM,ZTDESC)="Keyword Update Utility (Purge Inactive)",LEXCHK=""

 I '$D(LEXTEST) S LEXRUN=$$RUN2^LEXWUM I LEXRUN>0 W:$L($P(LEXRUN,"^",2)) !,?4,$P(LEXRUN,"^",2),! Q

 S (LEXNAM,ZTDESC)="Keyword Update Utility (Purge Inactive)",LEXCHK=""

 S ZTRTN="PUR^LEXWUP" S LEXCHK="",LEXPUR="",ZTSAVE("LEXPUR")=""

 S:'$D(LEXCOM) LEXCOM=1,ZTSAVE("LEXCOM")=""

 I $D(LEXTEST) S ZTSAVE("LEXTEST")="" K LEXCOM,ZTSAVE("LEXCOM")

 S:$G(LEXAFT)?7N ZTSAVE("LEXAFT")="" K ^TMP("LEXWU",$J,"STOP") S ZTIO="",ZTDTH=$H

 D:'$D(LEXTEST) ^%ZTLOAD D:$D(LEXTEST) @ZTRTN

 I +($G(ZTSK))>0 W !!,?4,$G(LEXNAM)," tasked (#",+($G(ZTSK)),")",!

 D HOME^%ZIS K LEXTEST,LEXAFT,LEXCOM,LEXPUR

 Q

EN2 ; Entry Point (tasked - purge selected keyword - LEXKEY)

 ; 

 ;   Needs   LEXKEY             One Keyword 

 ;            <or>

 ;           LEXKEY(LEXKEY1)    Selected Keywords

 ;           LEXKEY(LEXKEY2)

 ;           LEXKEY(LEXKEYn)

 ;           

 N ZT,ZTKEY,ZTUCI,ZTSK,ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE,ZTQUEUED,ZTREQ,LEXRUN,LEXCOM,LEXCHK,LEXNAM,I,X,Y

 I '$L($G(LEXKEY))&('$L($O(LEXKEY("")))) W !," LEXKEY keyword variable not defined",! Q 

 I '$D(LEXTEST) S LEXRUN=$$RUN2^LEXWUM I LEXRUN>0 W:$L($P(LEXRUN,"^",2)) !,?4,$P(LEXRUN,"^",2),! Q

 S (LEXNAM,ZTDESC)="Keyword Update Utility (Purge Selected Keyword)",LEXCHK=""

 S ZTRTN="SEL^LEXWUP" S LEXPUR=$G(LEXPUR),ZTSAVE("LEXPUR")=""

 S:$L($G(LEXKEY)) ZTSAVE("LEXKEY")="" S:$L($O(LEXKEY(""))) ZTSAVE("LEXKEY(")=""

 S:'$D(LEXCOM) LEXCOM=1,ZTSAVE("LEXCOM")="" I $D(LEXTEST) S ZTSAVE("LEXTEST")="" K LEXCOM,ZTSAVE("LEXCOM")

 S:$G(LEXAFT)?7N ZTSAVE("LEXAFT")="" K ^TMP("LEXWU",$J,"STOP")

 S ZTIO="",ZTDTH=$H D:'$D(LEXTEST) ^%ZTLOAD D:$D(LEXTEST) @ZTRTN

 I +($G(ZTSK))>0 W !!,?4,$G(LEXNAM)," tasked (#",+($G(ZTSK)),")",!

 D HOME^%ZIS K LEXTEST,LEXAFT,LEXCOM,LEXPUR

 Q

PUR ; Purge Keywords

 S:$D(ZTQUEUED) ZTREQ="@"

 K ^TMP("LEXWU",$J) S LEXENV=$$ENV Q:'LEXENV

 N LEXBEG,LEXCTR,LEXEFF,LEXENV,LEXEXC,LEXICDC,LEXICPC,LEXINA,LEXINC,LEXKEY,LEXKIEN,LEXLEXC,LEXSF,LEXTD,DIC,DIK,I,X

 N LEXL01C,LEXL02C,LEXL03C,LEXL04C,LEXL17C,LEXL30C,LEXL31C,LEXL56C,LEXI01C,LEXI02C,LEXI30C,LEXI31C

 S (LEXL01C,LEXL02C,LEXL03C,LEXL04C,LEXL17C,LEXL30C,LEXL31C,LEXL56C,LEXI01C,LEXI02C,LEXI30C,LEXI31C)=0

 S (LEXCTR,LEXICDC,LEXICPC,LEXLEXC)=0

 K:$D(LEXTEST) LEXCOM S LEXTD=$$DT^XLFDT,LEXKEY="",LEXBEG=$$NOW^XLFDT S LEXAFT=$G(LEXAFT) K LEXSF

 F  S LEXKEY=$O(^LEX(757.071,"B",LEXKEY)) Q:'$L(LEXKEY)  Q:$$ABT  D  Q:$$ABT

 . N LEXKIEN S LEXKIEN=0

 . F  S LEXKIEN=$O(^LEX(757.071,"B",LEXKEY,LEXKIEN)) Q:+LEXKIEN'>0  Q:$$ABT  D  Q:$$ABT

 . . N LEXSTA,LEXEFF,LEXINA,LEXINC,LEXEXC S LEXSTA=$$INA(LEXKIEN) Q:($G(LEXPUR)'="ALL")&(LEXSTA'>0)

 . . S LEXEFF=$P($G(^LEX(757.071,+LEXKIEN,0)),"^",2),LEXINA=$P($G(^LEX(757.071,+LEXKIEN,0)),"^",3)

 . . S LEXINC=$P($G(^LEX(757.071,+LEXKIEN,0)),"^",4),LEXEXC=$P($G(^LEX(757.071,+LEXKIEN,0)),"^",5)

 . . D DINA,ICD,LEX

 D DEND K ^TMP("LEXWU",$J)

 Q

SEL ; Selected Keywords (For Post-Install)

 S:$D(ZTQUEUED) ZTREQ="@"

 D:'$L($G(LEXKEY))&('$L($O(LEXKEY("")))) CLR D:$D(^TMP("LEXWU",$J,"STOP")) CLR Q:'$L($G(LEXKEY))&('$L($O(LEXKEY(""))))

 N LEXBEG,LEXEND,LEXELP,LEXSF,LEXKIEN,LEXTD,DIC,DIK,I,X

 N LEXL01C,LEXL02C,LEXL03C,LEXL04C,LEXL17C,LEXL30C,LEXL31C,LEXL56C,LEXI01C,LEXI02C,LEXI30C,LEXI31C

 S (LEXL01C,LEXL02C,LEXL03C,LEXL04C,LEXL17C,LEXL30C,LEXL31C,LEXL56C,LEXI01C,LEXI02C,LEXI30C,LEXI31C)=0

 S (LEXCTR,LEXICDC,LEXICPC,LEXLEXC)=0

 K:$D(LEXTEST) LEXCOM S LEXTD=$$DT^XLFDT,LEXBEG=$$NOW^XLFDT S LEXAFT=$G(LEXAFT) K LEXSF

 I $L($G(LEXKEY)) D

 . S LEXKIEN=0 F  S LEXKIEN=$O(^LEX(757.071,"B",LEXKEY,LEXKIEN)) Q:+LEXKIEN'>0  Q:$$ABT  D  Q:$$ABT

 . . N LEXSTA,LEXEFF,LEXINA,LEXINC,LEXEXC S LEXSTA=$$INA(LEXKIEN)

 . . Q:($G(LEXPUR)'="ALL")&(LEXSTA'>0)

 . . S LEXEFF=$P($G(^LEX(757.071,+LEXKIEN,0)),"^",2),LEXINA=$P($G(^LEX(757.071,+LEXKIEN,0)),"^",3)

 . . S LEXINC=$P($G(^LEX(757.071,+LEXKIEN,0)),"^",4),LEXEXC=$P($G(^LEX(757.071,+LEXKIEN,0)),"^",5)

 . . D DINA D ICD,LEX

 I $L($O(LEXKEY(""))) D

 . N LEXTKEY S LEXTKEY="" F  S LEXTKEY=$O(LEXKEY(LEXTKEY)) Q:'$L(LEXTKEY)  D

 . . N LEXKIEN,LEXKEY S LEXKEY=LEXTKEY,LEXKIEN=0

 . . F  S LEXKIEN=$O(^LEX(757.071,"B",LEXKEY,LEXKIEN)) Q:+LEXKIEN'>0  Q:$$ABT  D  Q:$$ABT

 . . . N LEXSTA,LEXEFF,LEXINA,LEXINC,LEXEXC S LEXSTA=$$INA(LEXKIEN)

 . . . Q:($G(LEXPUR)'="ALL")&(LEXSTA'>0)

 . . . S LEXEFF=$P($G(^LEX(757.071,+LEXKIEN,0)),"^",2),LEXINA=$P($G(^LEX(757.071,+LEXKIEN,0)),"^",3)

 . . . S LEXINC=$P($G(^LEX(757.071,+LEXKIEN,0)),"^",4),LEXEXC=$P($G(^LEX(757.071,+LEXKIEN,0)),"^",5)

 . . . D DINA D ICD,LEX

 D DEND K ^TMP("LEXWU",$J) D CLR

 Q

 ;

ICD ; ICD Diagnosis/Procedures

 N DA,DIK,DICI,LEXCHK,LEXDIEN,LEXEFF,LEXEXP,LEXI,LEXIIEN,LEXND,LEXOK,LEXRT,LEXSIEN,LEXSRC,LEXSUP

 Q:$G(LEXTD)'?7N  Q:'$L($G(LEXKEY))  Q:'$L($G(LEXINC))

 N LEXRT,LEXIIEN F LEXRT="^ICD9(","^ICD0("  S LEXIIEN=0 D

 . F  S LEXIIEN=$O(@(LEXRT_"""D"","""_LEXKEY_""","_+LEXIIEN_")")) Q:+LEXIIEN'>0  D

 . . N LEXEFF,LEXSRC,LEXTYPE,LEXSYS S LEXSRC=$P($G(@(LEXRT_+LEXIIEN_",1)")),"^",1),LEXEFF=0

 . . S LEXSYS="" S:LEXSRC=1 LEXSYS="ICD-9-CM" S:LEXSRC=2 LEXSYS="ICD-9 Proc"

 . . S:LEXSRC=30 LEXSYS="ICD-10-CM" S:LEXSRC=31 LEXSYS="ICD-10-PCS"

 . . S:LEXSRC=1!(LEXSRC=30) LEXTYPE="ICD Grouper Diagnosis (80)" S:LEXSRC=2!(LEXSRC=31) LEXTYPE="ICD Grouper Procedure (80.1)"

 . . F  S LEXEFF=$O(@(LEXRT_"""D"","""_LEXKEY_""","_+LEXIIEN_","_+LEXEFF_")")) Q:+LEXEFF'>0  D

 . . . Q:LEXEFF'?7N  N LEXDIEN S LEXDIEN=0

 . . . F  S LEXDIEN=$O(@(LEXRT_"""D"","""_LEXKEY_""","_+LEXIIEN_","_+LEXEFF_","_+LEXDIEN_")")) Q:+LEXDIEN'>0  D

 . . . . N LEXSIEN S LEXSIEN=0

 . . . . F  S LEXSIEN=$O(@(LEXRT_"""D"","""_LEXKEY_""","_+LEXIIEN_","_+LEXEFF_","_+LEXDIEN_","_+LEXSIEN_")")) Q:+LEXSIEN'>0  D

 . . . . . N DA,DIK,LEXCHK,LEXEXP,LEXI,LEXND,LEXOK,LEXSUP,LEXOIEN

 . . . . . S LEXND=LEXRT_"""D"","""_LEXKEY_""","_+LEXIIEN_","_+LEXEFF_","_+LEXDIEN_","_+LEXSIEN_")"

 . . . . . S LEXND=LEXRT_+LEXIIEN_",68,"_+LEXDIEN_",1)",LEXEXP=@LEXND,LEXOK=1

 . . . . . F LEXI=1:1 S LEXCHK=$P($G(LEXINC),";",LEXI) Q:'$L(LEXCHK)  S:LEXEXP'[LEXCHK LEXOK=0

 . . . . . Q:'LEXOK  S LEXND=LEXRT_+LEXIIEN_",68,"_+LEXDIEN_",2,"_+LEXSIEN_",0)",LEXOIEN=LEXIIEN

 . . . . . S LEXSUP=@LEXND Q:'$L(LEXSUP)  Q:LEXSUP'=LEXKEY  Q:'$D(@(LEXRT_+LEXIIEN_",68,"_+LEXDIEN_",2,""B"","""_LEXSUP_""")"))

 . . . . . D DEXP I $D(LEXCOM) S DA=+LEXSIEN,DA(1)=+LEXDIEN,DA(2)=+LEXIIEN,DIK=LEXRT_DA(2)_",68,"_DA(1)_",2," D ^DIK

 . . . . . S LEXSDOC=+($G(LEXSDOC))+1 S:LEXSRC=1!(LEXSRC=30) LEXICDC=+($G(LEXICDC))+1

 . . . . . S:LEXSRC=2!(LEXSRC=31) LEXICPC=+($G(LEXICPC))+1 S:LEXSRC=1 LEXI01C=+($G(LEXI01C))+1 S:LEXSRC=2 LEXI02C=+($G(LEXI02C))+1

 . . . . . S:LEXSRC=30 LEXI30C=+($G(LEXI30C))+1 S:LEXSRC=31 LEXI31C=+($G(LEXI31C))+1

 Q

LEX ; Lexicon

 Q:$G(LEXTD)'?7N  Q:'$L($G(LEXKEY))  Q:'$L($G(LEXINC))

 N DA,DIK,DIC,I,LEXRT,LEXASRC,LEXSS,LEXMIEN S LEXRT="^LEX(757.01,",LEXASRC="^1^2^3^4^17^30^31^56^",LEXMIEN=0

 F  S LEXMIEN=$O(^LEX(757.01,"AWRD",LEXKEY,LEXMIEN)) Q:+LEXMIEN'>0  D

 . N LEXEIEN S LEXEIEN=0 F  S LEXEIEN=$O(^LEX(757.01,"AWRD",LEXKEY,LEXMIEN,LEXEIEN)) Q:'$L(LEXEIEN)  D

 . . N LEXSUP S LEXSUP=0 F  S LEXSUP=$O(^LEX(757.01,"AWRD",LEXKEY,LEXMIEN,LEXEIEN,LEXSUP)) Q:+LEXSUP'>0  D

 . . . K LEXSF N LEXTIEN,LEXIENA,LEXOK,LEXFND,LEXSYS S (LEXOK,LEXFND)=0,LEXSYS="" F LEXTIEN=LEXMIEN,LEXEIEN D

 . . . . N LEXSIEN S LEXSIEN=0 F  S LEXSIEN=$O(^LEX(757.02,"B",LEXTIEN,LEXSIEN)) Q:+LEXSIEN'>0  D

 . . . . . N LEXSRC S LEXSRC=$P($G(^LEX(757.02,+LEXSIEN,0)),"^",3)

 . . . . . Q:LEXASRC'[("^"_LEXSRC_"^")  S LEXOK=1,LEXFND=LEXFND+1

 . . . . . S:'$L(LEXSYS)&(LEXSRC=1) LEXSYS="ICD-9-CM" S:'$L(LEXSYS)&(LEXSRC=2) LEXSYS="ICD-9 Proc"

 . . . . . S:'$L(LEXSYS)&(LEXSRC=3) LEXSYS="CPT-4" S:'$L(LEXSYS)&(LEXSRC=4) LEXSYS="HCPCS"

 . . . . . S:'$L(LEXSYS)&(LEXSRC=30) LEXSYS="ICD-10-CM" S:'$L(LEXSYS)&(LEXSRC=31) LEXSYS="ICD-10-PCS"

 . . . . . S:'$L(LEXSYS)&(LEXSRC=56) LEXSYS="SNOMED CT" S:'$L(LEXSYS)&(LEXSRC=17) LEXSYS="Title 38"

 . . . . . S LEXTYPE="Lexicon Expression (757.01)"

 . . . . . S LEXSF(+LEXSRC)=+($G(LEXSF(+LEXSRC)))+1

 . . . K LEXIENA S LEXIENA(+($G(LEXMIEN)))="",LEXIENA(+($G(LEXEIEN)))=""

 . . . S LEXTIEN=0 F  S LEXTIEN=$O(LEXIENA(LEXTIEN)) Q:+LEXTIEN'>0  D

 . . . . N LEXKIEN S LEXKIEN=0 F  S LEXKIEN=$O(^LEX(757.01,+LEXTIEN,5,"B",LEXKEY,LEXKIEN)) Q:+LEXKIEN'>0  D

 . . . . . N DA,DIK,LEXEXP,LEXOIEN S LEXOIEN=LEXTIEN,LEXEXP=$G(^LEX(757.01,+LEXTIEN,0))

 . . . . . Q:'$D(^LEX(757.01,+LEXTIEN,5,"B",LEXKEY))  D DEXP I $O(LEXSF(0))>0 D

 . . . . . . N LEXS S LEXS=0 F  S LEXS=$O(LEXSF(LEXS)) Q:+LEXS'>0  D

 . . . . . . . S:LEXS=56 LEXL56C=+($G(LEXL56C))+1 S:LEXS=17 LEXL17C=+($G(LEXL17C))+1

 . . . . . . . S:LEXS=3 LEXL03C=+($G(LEXL03C))+1 S:LEXS=4 LEXL04C=+($G(LEXL04C))+1

 . . . . . . . S:LEXS=1 LEXL01C=+($G(LEXL01C))+1 S:LEXS=30 LEXL30C=+($G(LEXL30C))+1

 . . . . . . . S:LEXS=2 LEXL02C=+($G(LEXL02C))+1 S:LEXS=31 LEXL31C=+($G(LEXL31C))+1

 . . . . . I $D(LEXCOM) S DA(1)=LEXTIEN,DA=LEXKIEN,DIK="^LEX(757.01,"_DA(1)_",5," D ^DIK

 Q

 ;

 ; Displays

DEND ;   Display End Totals

 Q:$D(LEXQUIET)  Q:$D(ZTQUEUED)  H 2 S LEXEND=$$NOW^XLFDT,LEXELP=$$FMDIFF^XLFDT($G(LEXEND),$G(LEXBEG),3)

 S:$L($G(LEXEND))&($L($G(LEXBEG)))&('$L(LEXELP)) LEXELP="00:00:00" N LEXII,LEXTT S LEXII="",LEXTT=0

 N LEXLEXC,LEXSDOC,LEXICDC,LEXTTT

 ;     Lexicon

 S LEXLEXC=+($G(LEXL56C))+($G(LEXL17C))+($G(LEXL03C))+($G(LEXL04C))+($G(LEXL01C))+($G(LEXL02C))+($G(LEXL30C))+($G(LEXL31C))

 I +($G(LEXLEXC))>0 D

 . W !,?3,"Lexicon Changes ",?35,$J(LEXLEXC,8)

 . I +($G(LEXL01C))>0 W !,?5,"ICD-9 Diagnosis Changes ",?35,$J(LEXL01C,8)

 . I +($G(LEXL02C))>0 W !,?5,"ICD-9 Procedure Changes ",?35,$J(LEXL02C,8)

 . I +($G(LEXL30C))>0 W !,?5,"ICD-10 Diagnosis Changes ",?35,$J(LEXL30C,8)

 . I +($G(LEXL31C))>0 W !,?5,"ICD-10 Procedure Changes ",?35,$J(LEXL31C,8)

 . I +($G(LEXL56C))>0 W !,?5,"SNOMED CT Changes ",?35,$J(LEXL56C,8)

 . I +($G(LEXL17C))>0 W !,?5,"TITLE 38 Changes ",?35,$J(LEXL17C,8)

 . I +($G(LEXL03C))>0 W !,?5,"CPT-4 Procedure Changes ",?35,$J(LEXL03C,8)

 . I +($G(LEXL04C))>0 W !,?5,"HCPCS Procedure Changes ",?35,$J(LEXL04C,8)

 ;     ICD files

 S LEXSDOC=+($G(LEXI01C))+($G(LEXI30C))+($G(LEXI02C))+($G(LEXI31C))

 S LEXICDC=+($G(LEXI01C))+($G(LEXI30C)),LEXICPC=+($G(LEXI02C))+($G(LEXI31C))

 I +($G(LEXSDOC))>0 D

 . N LEXTAB W:+($G(LEXLEXC))>0 ! W !,?3,"ICD* File Changes",?35,$J(LEXSDOC,8)

 . S LEXTAB="",LEXICDC=+($G(LEXI01C))+($G(LEXI30C))

 . I +($G(LEXI01C))>0&(+($G(LEXI30C))>0) W:LEXICDC>0 !,?5,"ICD Diagnosis File #80",?35,$J(LEXICDC,8) S LEXTAB="  "

 . I +($G(LEXI01C))>0 W !,?5,LEXTAB,"ICD-9 Diagnosis Changes ",?35,$J(LEXI01C,8)

 . I +($G(LEXI30C))>0 W !,?5,LEXTAB,"ICD-10 Diagnosis Changes ",?35,$J(LEXI30C,8)

 . S LEXTAB="",LEXICPC=+($G(LEXI02C))+($G(LEXI31C))

 . I +($G(LEXI02C))>0&(+($G(LEXI31C))>0) W:LEXICPC>0 !,?5,"ICD Procedures File #80.1",?35,$J(LEXICPC,8) S LEXTAB="  "

 . I +($G(LEXI02C))>0 W !,?5,LEXTAB,"ICD-9 Procedure Changes ",?35,$J(LEXI02C,8)

 . I +($G(LEXI31C))>0 W !,?5,LEXTAB,"ICD-10 Procedure Changes ",?35,$J(LEXI31C,8)

 S LEXTTT=+($G(LEXLEXC))+($G(LEXSDOC)) I LEXTTT>0 D

 . W:+($G(LEXLEXC))>0!(+($G(LEXSDOC))>0) !

 . I +($G(LEXLEXC))>0 W !,?3,"Total Changes ",?35,$J(LEXTTT,8)

 W ! I $L($G(LEXBEG)) W !,?3,"Start:   ",?14,$TR($$FMTE^XLFDT(LEXBEG,"5Z"),"@"," ")

 I $L($G(LEXEND)) W !,?3,"Finish:  ",?14,$TR($$FMTE^XLFDT(LEXEND,"5Z"),"@"," ")

 I $L($G(LEXELP)) W !,?3,"Elapsed: ",?14,$TR(LEXELP," ","0"),!

 Q

DEXP ;   Display Expression

 Q:$D(LEXQUIET)  Q:$D(ZTQUEUED)  Q:'$L(LEXEXP)  Q:'$L(LEXINC)  Q:'$L(LEXKEY)

 W:$L($G(LEXTYPE)) !,"Type:            ",LEXTYPE W:$D(LEXSYS) !,"System:          ",LEXSYS

 W !,"Expression:      ",LEXEXP,!,"Include/Keyword: ",LEXINC,"/",LEXKEY

 I +($G(LEXOIEN))>0,$L($G(LEXRT)) W !,"IEN:             ",LEXRT,LEXOIEN,","

 W !

 Q

DINA ;   Display Inactive Keyword

 Q:$D(LEXQUIET)  Q:$D(ZTQUEUED)  Q:'$L($G(LEXKEY))  Q:$G(LEXEFF)'?7N  Q:$G(LEXINA)'?7N  Q

 W !,"Keyword:         ",LEXKEY,!,"Effective:       ",$$FMTE^XLFDT(LEXEFF,"5Z"),!,"Inactive:        ",$$FMTE^XLFDT(LEXINA,"5Z"),!

 Q

 ; 

 ; Miscellaneous

ABT(X) ;   Abort

 Q:$D(^TMP("LEXWU",$J,"STOP")) 1

 Q 0

INA(X) ;   Inactive before Today or after LEXAFT (optional)

 N LEXI,LEX1,LEX2,LEXA,LEXT,LEXO S LEXT=$$DT^XLFDT,LEXI=+($G(X)),LEX1=+($P($P($G(^LEX(757.071,+LEXI,0)),"^",2),".",1)) Q:LEX1'?7N "0^1"

 S LEX2=+($P($P($G(^LEX(757.071,+LEXI,0)),"^",3),".",1)) Q:LEX2'?7N "0^2"  S LEXA=$G(LEXAFT),LEXO=0

 ;     If Inactive after LEXAFT and not later Active        1

 Q:($G(LEXA)?7N)&((LEX2+.001)>LEXA)&((LEX2+.001)>LEX1) "1^3"

 ;     If Inactive after LEXAFT and later Active            0

 Q:($G(LEXA)?7N)&((LEX2+.001)>LEXA)&((LEX1+.001)>LEX2) "0^4"

 ;     If Inactive before LEXAFT and not later Active       0

 Q:($G(LEXA)?7N)&((LEXA+.001)>LEX2)&((LEX2+.001)>LEX1) "0^5"

 ;     If Inactive                                          1

 Q:(LEX2+.001)>LEX1 "1^6"

 ;     Else Active                                          0

 Q "0^7"

ACT(X) ;   Active before Today or after LEXAFT (optional)

 N LEXI,LEX1,LEX2,LEXA,LEXT,LEXO S LEXT=$$DT^XLFDT,LEXI=+($G(X)),LEX1=+($P($P($G(^LEX(757.071,+LEXI,0)),"^",2),".",1)) Q:LEX1'?7N "0^1"

 S LEX2=+($P($P($G(^LEX(757.071,+LEXI,0)),"^",3),".",1)),LEXA=$G(LEXAFT),LEXO=0

 ;     If Active after LEXAFT and not later Inctive         1

 Q:($G(LEXA)?7N)&((LEX1+.001)>LEXA)&((LEX1+.001)>LEX2) "1^2"

 ;     If Active after LEXAFT and later Inactive            0

 Q:($G(LEXA)?7N)&((LEX1+.001)>LEXA)&((LEX2+.001)>LEX1) "0^3"

 ;     If Active before LEXAFT and not later Inactive       0

 Q:($G(LEXA)?7N)&((LEXA+.001)>LEX1)&((LEX1+.001)>LEX2) "0^4"

 ;     If Active                                            1

 Q:(LEX1+.001)>LEX2 "1^5"

 ;     Else Inactive                                        0

 Q "0^6"

DT ;   Display ^TMP

 D DT^LEXWUM

 Q

STOP ;   Stop Task

 D STOP^LEXWUM

 Q

GO ;   Remove Stop

 K ^TMP("LEXWU",$J,"STOP")

 Q

CLR ;   Clear

 K ^TMP("LEXWU",$J,"STOP") K DA,DIC,DICI,DIK,I,LEX1,LEXL17C,LEX2,LEX3,LEXA,LEXAFT,LEXBEG,LEXC,LEXCAP,LEXCDT,LEXCHK,LEXCT

 K LEXCTR,LEXD,LEXDIEN,LEXEFF,LEXEIEN,LEXELP,LEXEND,LEXENV,LEXEXC,LEXEXP,LEXFND,LEXI,LEXI01C,LEXI02C,LEXI30C,LEXI31C,LEXICDC,LEXICPC

 K LEXIEN,LEXII,LEXIIEN,LEXINA,LEXINC,LEXKEY,LEXKIEN,LEXL01C,LEXL02C,LEXL03C,LEXL04C,LEXL17C,LEXL30C,LEXL31C,LEXL56C,LEXLEXC,LEXM

 K LEXMIEN,LEXNAM,LEXND,LEXNM,LEXO,LEXOIEN,LEXOK,LEXORD,LEXQUIET,LEXRT,LEXRUN,LEXS,LEXSDOC,LEXSF,LEXSIEN,LEXSRC,LEXSS,LEXSTA

 K LEXSUP,LEXSYS,LEXT,LEXTD,LEXTIEN,LEXTKEY,LEXTT,LEXTTT,LEXTYPE,LEXY,NEXKEY,POP,X,Y,ZT,ZTDESC,ZTDTH,ZTIO,ZTKEY,ZTQUEUED

 K ZTREQ,ZTRTN,ZTSAVE,ZTSK,ZTUCI

 Q

ENV(X) ;   Environment

 D HOME^%ZIS S U="^",DT=$$DT^XLFDT,DTIME=300 K POP

 N LEXNM S LEXNM=$$GET1^DIQ(200,(DUZ_","),.01)

 I '$L(LEXNM) W !!,?5,"Invalid/Missing DUZ" Q 0

 Q 1

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---LEXWUP   16065     printed  Mar 13, 2025@21:14:31                                                                                                                                                                                                     Page 2

LEXWUP    ;ISL/KER - Lexicon Keywords - Update (Purge) ;05/23/2017

 +1       ;;2.0;LEXICON UTILITY;**103**;Sep 23, 1996;Build 2

 +2       ;               

 +3       ; Global Variables

 +4       ;    ^ICD0(              ICR   4486

 +5       ;    ^ICD9(              ICR   4485

 +6       ;    ^LEX(757,           SACC 1.3

 +7       ;    ^LEX(757.01,        SACC 1.3

 +8       ;    ^LEX(757.02,        SACC 1.3

 +9       ;    ^LEX(757.03,        SACC 1.3

 +10      ;    ^LEX(757.071,       SACC 1.3

 +11      ;    ^TMP("LEXWU",$J)    SACC 2.3.2.5.1

 +12      ;               

 +13      ; External References

 +14      ;    HOME^%ZIS           ICR  10086

 +15      ;    ^%ZTLOAD            ICR  10063

 +16      ;    ^DIK                ICR  10013

 +17      ;    $$GET1^DIQ          ICR   2056

 +18      ;    $$DT^XLFDT          ICR  10103

 +19      ;    $$FMDIFF^XLFDT      ICR  10103

 +20      ;    $$FMTE^XLFDT        ICR  10103

 +21      ;    $$NOW^XLFDT         ICR  10103

 +22      ;               

 +23      ; Local Variables NEWed or KILLed Elsewhere

 +24      ;   Control Variables

 +25      ;     LEXTEST            For testing only

 +26      ;     LEXAFT             Purge keywords inactive after date

 +27      ;     LEXCOM             Commit Flag

 +28      ;     LEXPUR             Purge some or all (LEXPUR="ALL")

 +29      ;               

 +30      ; Call STOP^LEXWUS to stop the task.  It sets the following

 +31      ; global node:

 +32      ; 

 +33      ;     ^TMP("LEXWU",$J,"STOP")

 +34      ;               

 +35       QUIT 

EN        ; Main Entry Point (tasked)

 +1        NEW ZT,ZTKEY,ZTUCI,ZTSK,ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE,ZTQUEUED,ZTREQ,LEXRUN,LEXCOM,LEXCHK,LEXNAM,I,X,Y

 +2        SET (LEXNAM,ZTDESC)="Keyword Update Utility (Purge Inactive)"

           SET LEXCHK=""

 +3        IF '$DATA(LEXTEST)

               SET LEXRUN=$$RUN2^LEXWUM

               IF LEXRUN>0

                   if $LENGTH($PIECE(LEXRUN,"^",2))

                       WRITE !,?4,$PIECE(LEXRUN,"^",2),!

                   QUIT 

 +4        SET (LEXNAM,ZTDESC)="Keyword Update Utility (Purge Inactive)"

           SET LEXCHK=""

 +5        SET ZTRTN="PUR^LEXWUP"

           SET LEXCHK=""

           SET LEXPUR=""

           SET ZTSAVE("LEXPUR")=""

 +6        if '$DATA(LEXCOM)

               SET LEXCOM=1

               SET ZTSAVE("LEXCOM")=""

 +7        IF $DATA(LEXTEST)

               SET ZTSAVE("LEXTEST")=""

               KILL LEXCOM,ZTSAVE("LEXCOM")

 +8        if $GET(LEXAFT)?7N

               SET ZTSAVE("LEXAFT")=""

           KILL ^TMP("LEXWU",$JOB,"STOP")

           SET ZTIO=""

           SET ZTDTH=$HOROLOG

 +9        if '$DATA(LEXTEST)

               DO ^%ZTLOAD

           if $DATA(LEXTEST)

               DO @ZTRTN

 +10       IF +($GET(ZTSK))>0

               WRITE !!,?4,$GET(LEXNAM)," tasked (#",+($GET(ZTSK)),")",!

 +11       DO HOME^%ZIS

           KILL LEXTEST,LEXAFT,LEXCOM,LEXPUR

 +12       QUIT 

EN2       ; Entry Point (tasked - purge selected keyword - LEXKEY)

 +1       ; 

 +2       ;   Needs   LEXKEY             One Keyword 

 +3       ;            <or>

 +4       ;           LEXKEY(LEXKEY1)    Selected Keywords

 +5       ;           LEXKEY(LEXKEY2)

 +6       ;           LEXKEY(LEXKEYn)

 +7       ;           

 +8        NEW ZT,ZTKEY,ZTUCI,ZTSK,ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE,ZTQUEUED,ZTREQ,LEXRUN,LEXCOM,LEXCHK,LEXNAM,I,X,Y

 +9        IF '$LENGTH($GET(LEXKEY))&('$LENGTH($ORDER(LEXKEY(""))))

               WRITE !," LEXKEY keyword variable not defined",!

               QUIT 

 +10       IF '$DATA(LEXTEST)

               SET LEXRUN=$$RUN2^LEXWUM

               IF LEXRUN>0

                   if $LENGTH($PIECE(LEXRUN,"^",2))

                       WRITE !,?4,$PIECE(LEXRUN,"^",2),!

                   QUIT 

 +11       SET (LEXNAM,ZTDESC)="Keyword Update Utility (Purge Selected Keyword)"

           SET LEXCHK=""

 +12       SET ZTRTN="SEL^LEXWUP"

           SET LEXPUR=$GET(LEXPUR)

           SET ZTSAVE("LEXPUR")=""

 +13       if $LENGTH($GET(LEXKEY))

               SET ZTSAVE("LEXKEY")=""

           if $LENGTH($ORDER(LEXKEY("")))

               SET ZTSAVE("LEXKEY(")=""

 +14       if '$DATA(LEXCOM)

               SET LEXCOM=1

               SET ZTSAVE("LEXCOM")=""

           IF $DATA(LEXTEST)

               SET ZTSAVE("LEXTEST")=""

               KILL LEXCOM,ZTSAVE("LEXCOM")

 +15       if $GET(LEXAFT)?7N

               SET ZTSAVE("LEXAFT")=""

           KILL ^TMP("LEXWU",$JOB,"STOP")

 +16       SET ZTIO=""

           SET ZTDTH=$HOROLOG

           if '$DATA(LEXTEST)

               DO ^%ZTLOAD

           if $DATA(LEXTEST)

               DO @ZTRTN

 +17       IF +($GET(ZTSK))>0

               WRITE !!,?4,$GET(LEXNAM)," tasked (#",+($GET(ZTSK)),")",!

 +18       DO HOME^%ZIS

           KILL LEXTEST,LEXAFT,LEXCOM,LEXPUR

 +19       QUIT 

PUR       ; Purge Keywords

 +1        if $DATA(ZTQUEUED)

               SET ZTREQ="@"

 +2        KILL ^TMP("LEXWU",$JOB)

           SET LEXENV=$$ENV

           if 'LEXENV

               QUIT 

 +3        NEW LEXBEG,LEXCTR,LEXEFF,LEXENV,LEXEXC,LEXICDC,LEXICPC,LEXINA,LEXINC,LEXKEY,LEXKIEN,LEXLEXC,LEXSF,LEXTD,DIC,DIK,I,X

 +4        NEW LEXL01C,LEXL02C,LEXL03C,LEXL04C,LEXL17C,LEXL30C,LEXL31C,LEXL56C,LEXI01C,LEXI02C,LEXI30C,LEXI31C

 +5        SET (LEXL01C,LEXL02C,LEXL03C,LEXL04C,LEXL17C,LEXL30C,LEXL31C,LEXL56C,LEXI01C,LEXI02C,LEXI30C,LEXI31C)=0

 +6        SET (LEXCTR,LEXICDC,LEXICPC,LEXLEXC)=0

 +7        if $DATA(LEXTEST)

               KILL LEXCOM

           SET LEXTD=$$DT^XLFDT

           SET LEXKEY=""

           SET LEXBEG=$$NOW^XLFDT

           SET LEXAFT=$GET(LEXAFT)

           KILL LEXSF

 +8        FOR 

               SET LEXKEY=$ORDER(^LEX(757.071,"B",LEXKEY))

               if '$LENGTH(LEXKEY)

                   QUIT 

               if $$ABT

                   QUIT 

               Begin DoDot:1

 +9                NEW LEXKIEN

                   SET LEXKIEN=0

 +10               FOR 

                       SET LEXKIEN=$ORDER(^LEX(757.071,"B",LEXKEY,LEXKIEN))

                       if +LEXKIEN'>0

                           QUIT 

                       if $$ABT

                           QUIT 

                       Begin DoDot:2

 +11                       NEW LEXSTA,LEXEFF,LEXINA,LEXINC,LEXEXC

                           SET LEXSTA=$$INA(LEXKIEN)

                           if ($GET(LEXPUR)'="ALL")&(LEXSTA'>0)

                               QUIT 

 +12                       SET LEXEFF=$PIECE($GET(^LEX(757.071,+LEXKIEN,0)),"^",2)

                           SET LEXINA=$PIECE($GET(^LEX(757.071,+LEXKIEN,0)),"^",3)

 +13                       SET LEXINC=$PIECE($GET(^LEX(757.071,+LEXKIEN,0)),"^",4)

                           SET LEXEXC=$PIECE($GET(^LEX(757.071,+LEXKIEN,0)),"^",5)

 +14                       DO DINA

                           DO ICD

                           DO LEX

                       End DoDot:2

                       if $$ABT

                           QUIT 

               End DoDot:1

               if $$ABT

                   QUIT 

 +15       DO DEND

           KILL ^TMP("LEXWU",$JOB)

 +16       QUIT 

SEL       ; Selected Keywords (For Post-Install)

 +1        if $DATA(ZTQUEUED)

               SET ZTREQ="@"

 +2        if '$LENGTH($GET(LEXKEY))&('$LENGTH($ORDER(LEXKEY(""))))

               DO CLR

           if $DATA(^TMP("LEXWU",$JOB,"STOP"))

               DO CLR

           if '$LENGTH($GET(LEXKEY))&('$LENGTH($ORDER(LEXKEY(""))))

               QUIT 

 +3        NEW LEXBEG,LEXEND,LEXELP,LEXSF,LEXKIEN,LEXTD,DIC,DIK,I,X

 +4        NEW LEXL01C,LEXL02C,LEXL03C,LEXL04C,LEXL17C,LEXL30C,LEXL31C,LEXL56C,LEXI01C,LEXI02C,LEXI30C,LEXI31C

 +5        SET (LEXL01C,LEXL02C,LEXL03C,LEXL04C,LEXL17C,LEXL30C,LEXL31C,LEXL56C,LEXI01C,LEXI02C,LEXI30C,LEXI31C)=0

 +6        SET (LEXCTR,LEXICDC,LEXICPC,LEXLEXC)=0

 +7        if $DATA(LEXTEST)

               KILL LEXCOM

           SET LEXTD=$$DT^XLFDT

           SET LEXBEG=$$NOW^XLFDT

           SET LEXAFT=$GET(LEXAFT)

           KILL LEXSF

 +8        IF $LENGTH($GET(LEXKEY))