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 ---[H[J[2J[HLEXWUP 16065 printed Sep 23, 2025@19:45:54 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))
Begin DoDot:1
+9 SET LEXKIEN=0
FOR
SET LEXKIEN=$ORDER(^LEX(757.071,"B",LEXKEY,LEXKIEN))
if +LEXKIEN'>0
QUIT
if $$ABT
QUIT
Begin DoDot:2
+10 NEW LEXSTA,LEXEFF,LEXINA,LEXINC,LEXEXC
SET LEXSTA=$$INA(LEXKIEN)
+11 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
+15 IF $LENGTH($ORDER(LEXKEY("")))
Begin DoDot:1
+16 NEW LEXTKEY
SET LEXTKEY=""
FOR
SET LEXTKEY=$ORDER(LEXKEY(LEXTKEY))
if '$LENGTH(LEXTKEY)
QUIT
Begin DoDot:2
+17 NEW LEXKIEN,LEXKEY
SET LEXKEY=LEXTKEY
SET LEXKIEN=0
+18 FOR
SET LEXKIEN=$ORDER(^LEX(757.071,"B",LEXKEY,LEXKIEN))
if +LEXKIEN'>0
QUIT
if $$ABT
QUIT
Begin DoDot:3
+19 NEW LEXSTA,LEXEFF,LEXINA,LEXINC,LEXEXC
SET LEXSTA=$$INA(LEXKIEN)
+20 if ($GET(LEXPUR)'="ALL")&(LEXSTA'>0)
QUIT
+21 SET LEXEFF=$PIECE($GET(^LEX(757.071,+LEXKIEN,0)),"^",2)
SET LEXINA=$PIECE($GET(^LEX(757.071,+LEXKIEN,0)),"^",3)
+22 SET LEXINC=$PIECE($GET(^LEX(757.071,+LEXKIEN,0)),"^",4)
SET LEXEXC=$PIECE($GET(^LEX(757.071,+LEXKIEN,0)),"^",5)
+23 DO DINA
DO ICD
DO LEX
End DoDot:3
if $$ABT
QUIT
End DoDot:2
End DoDot:1
+24 DO DEND
KILL ^TMP("LEXWU",$JOB)
DO CLR
+25 QUIT
+26 ;
ICD ; ICD Diagnosis/Procedures
+1 NEW DA,DIK,DICI,LEXCHK,LEXDIEN,LEXEFF,LEXEXP,LEXI,LEXIIEN,LEXND,LEXOK,LEXRT,LEXSIEN,LEXSRC,LEXSUP
+2 if $GET(LEXTD)'?7N
QUIT
if '$LENGTH($GET(LEXKEY))
QUIT
if '$LENGTH($GET(LEXINC))
QUIT
+3 NEW LEXRT,LEXIIEN
FOR LEXRT="^ICD9(","^ICD0("
SET LEXIIEN=0
Begin DoDot:1
+4 FOR
SET LEXIIEN=$ORDER(@(LEXRT_"""D"","""_LEXKEY_""","_+LEXIIEN_")"))
if +LEXIIEN'>0
QUIT
Begin DoDot:2
+5 NEW LEXEFF,LEXSRC,LEXTYPE,LEXSYS
SET LEXSRC=$PIECE($GET(@(LEXRT_+LEXIIEN_",1)")),"^",1)
SET LEXEFF=0
+6 SET LEXSYS=""
if LEXSRC=1
SET LEXSYS="ICD-9-CM"
if LEXSRC=2
SET LEXSYS="ICD-9 Proc"
+7 if LEXSRC=30
SET LEXSYS="ICD-10-CM"
if LEXSRC=31
SET LEXSYS="ICD-10-PCS"
+8 if LEXSRC=1!(LEXSRC=30)
SET LEXTYPE="ICD Grouper Diagnosis (80)"
if LEXSRC=2!(LEXSRC=31)
SET LEXTYPE="ICD Grouper Procedure (80.1)"
+9 FOR
SET LEXEFF=$ORDER(@(LEXRT_"""D"","""_LEXKEY_""","_+LEXIIEN_","_+LEXEFF_")"))
if +LEXEFF'>0
QUIT
Begin DoDot:3
+10 if LEXEFF'?7N
QUIT
NEW LEXDIEN
SET LEXDIEN=0
+11 FOR
SET LEXDIEN=$ORDER(@(LEXRT_"""D"","""_LEXKEY_""","_+LEXIIEN_","_+LEXEFF_","_+LEXDIEN_")"))
if +LEXDIEN'>0
QUIT
Begin DoDot:4
+12 NEW LEXSIEN
SET LEXSIEN=0
+13 FOR
SET LEXSIEN=$ORDER(@(LEXRT_"""D"","""_LEXKEY_""","_+LEXIIEN_","_+LEXEFF_","_+LEXDIEN_","_+LEXSIEN_")"))
if +LEXSIEN'>0
QUIT
Begin DoDot:5
+14 NEW DA,DIK,LEXCHK,LEXEXP,LEXI,LEXND,LEXOK,LEXSUP,LEXOIEN
+15 SET LEXND=LEXRT_"""D"","""_LEXKEY_""","_+LEXIIEN_","_+LEXEFF_","_+LEXDIEN_","_+LEXSIEN_")"
+16 SET LEXND=LEXRT_+LEXIIEN_",68,"_+LEXDIEN_",1)"
SET LEXEXP=@LEXND
SET LEXOK=1
+17 FOR LEXI=1:1
SET LEXCHK=$PIECE($GET(LEXINC),";",LEXI)
if '$LENGTH(LEXCHK)
QUIT
if LEXEXP'[LEXCHK
SET LEXOK=0
+18 if 'LEXOK
QUIT
SET LEXND=LEXRT_+LEXIIEN_",68,"_+LEXDIEN_",2,"_+LEXSIEN_",0)"
SET LEXOIEN=LEXIIEN
+19 SET LEXSUP=@LEXND
if '$LENGTH(LEXSUP)
QUIT
if LEXSUP'=LEXKEY
QUIT
if '$DATA(@(LEXRT_+LEXIIEN_",68,"_+LEXDIEN_",2,""B"","""_LEXSUP_""")"))
QUIT
+20 DO DEXP
IF $DATA(LEXCOM)
SET DA=+LEXSIEN
SET DA(1)=+LEXDIEN
SET DA(2)=+LEXIIEN
SET DIK=LEXRT_DA(2)_",68,"_DA(1)_",2,"
DO ^DIK
+21 SET LEXSDOC=+($GET(LEXSDOC))+1
if LEXSRC=1!(LEXSRC=30)
SET LEXICDC=+($GET(LEXICDC))+1
+22 if LEXSRC=2!(LEXSRC=31)
SET LEXICPC=+($GET(LEXICPC))+1
if LEXSRC=1
SET LEXI01C=+($GET(LEXI01C))+1
if LEXSRC=2
SET LEXI02C=+($GET(LEXI02C))+1
+23 if LEXSRC=30
SET LEXI30C=+($GET(LEXI30C))+1
if LEXSRC=31
SET LEXI31C=+($GET(LEXI31C))+1
End DoDot:5
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+24 QUIT
LEX ; Lexicon
+1 if $GET(LEXTD)'?7N
QUIT
if '$LENGTH($GET(LEXKEY))
QUIT
if '$LENGTH($GET(LEXINC))
QUIT
+2 NEW DA,DIK,DIC,I,LEXRT,LEXASRC,LEXSS,LEXMIEN
SET LEXRT="^LEX(757.01,"
SET LEXASRC="^1^2^3^4^17^30^31^56^"
SET LEXMIEN=0
+3 FOR
SET LEXMIEN=$ORDER(^LEX(757.01,"AWRD",LEXKEY,LEXMIEN))
if +LEXMIEN'>0
QUIT
Begin DoDot:1
+4 NEW LEXEIEN
SET LEXEIEN=0
FOR
SET LEXEIEN=$ORDER(^LEX(757.01,"AWRD",LEXKEY,LEXMIEN,LEXEIEN))
if '$LENGTH(LEXEIEN)
QUIT
Begin DoDot:2
+5 NEW LEXSUP
SET LEXSUP=0
FOR
SET LEXSUP=$ORDER(^LEX(757.01,"AWRD",LEXKEY,LEXMIEN,LEXEIEN,LEXSUP))
if +LEXSUP'>0
QUIT
Begin DoDot:3
+6 KILL LEXSF
NEW LEXTIEN,LEXIENA,LEXOK,LEXFND,LEXSYS
SET (LEXOK,LEXFND)=0
SET LEXSYS=""
FOR LEXTIEN=LEXMIEN,LEXEIEN
Begin DoDot:4
+7 NEW LEXSIEN
SET LEXSIEN=0
FOR
SET LEXSIEN=$ORDER(^LEX(757.02,"B",LEXTIEN,LEXSIEN))
if +LEXSIEN'>0
QUIT
Begin DoDot:5
+8 NEW LEXSRC
SET LEXSRC=$PIECE($GET(^LEX(757.02,+LEXSIEN,0)),"^",3)
+9 if LEXASRC'[("^"_LEXSRC_"^")
QUIT
SET LEXOK=1
SET LEXFND=LEXFND+1
+10 if '$LENGTH(LEXSYS)&(LEXSRC=1)
SET LEXSYS="ICD-9-CM"
if '$LENGTH(LEXSYS)&(LEXSRC=2)
SET LEXSYS="ICD-9 Proc"
+11 if '$LENGTH(LEXSYS)&(LEXSRC=3)
SET LEXSYS="CPT-4"
if '$LENGTH(LEXSYS)&(LEXSRC=4)
SET LEXSYS="HCPCS"
+12 if '$LENGTH(LEXSYS)&(LEXSRC=30)
SET LEXSYS="ICD-10-CM"
if '$LENGTH(LEXSYS)&(LEXSRC=31)
SET LEXSYS="ICD-10-PCS"
+13 if '$LENGTH(LEXSYS)&(LEXSRC=56)
SET LEXSYS="SNOMED CT"
if '$LENGTH(LEXSYS)&(LEXSRC=17)
SET LEXSYS="Title 38"
+14 SET LEXTYPE="Lexicon Expression (757.01)"
+15 SET LEXSF(+LEXSRC)=+($GET(LEXSF(+LEXSRC)))+1
End DoDot:5
End DoDot:4
+16 KILL LEXIENA
SET LEXIENA(+($GET(LEXMIEN)))=""
SET LEXIENA(+($GET(LEXEIEN)))=""
+17 SET LEXTIEN=0
FOR
SET LEXTIEN=$ORDER(LEXIENA(LEXTIEN))
if +LEXTIEN'>0
QUIT
Begin DoDot:4
+18 NEW LEXKIEN
SET LEXKIEN=0
FOR
SET LEXKIEN=$ORDER(^LEX(757.01,+LEXTIEN,5,"B",LEXKEY,LEXKIEN))
if +LEXKIEN'>0
QUIT
Begin DoDot:5
+19 NEW DA,DIK,LEXEXP,LEXOIEN
SET LEXOIEN=LEXTIEN
SET LEXEXP=$GET(^LEX(757.01,+LEXTIEN,0))
+20 if '$DATA(^LEX(757.01,+LEXTIEN,5,"B",LEXKEY))
QUIT
DO DEXP
IF $ORDER(LEXSF(0))>0
Begin DoDot:6
+21 NEW LEXS
SET LEXS=0
FOR
SET LEXS=$ORDER(LEXSF(LEXS))
if +LEXS'>0
QUIT
Begin DoDot:7
+22 if LEXS=56
SET LEXL56C=+($GET(LEXL56C))+1
if LEXS=17
SET LEXL17C=+($GET(LEXL17C))+1
+23 if LEXS=3
SET LEXL03C=+($GET(LEXL03C))+1
if LEXS=4
SET LEXL04C=+($GET(LEXL04C))+1
+24 if LEXS=1
SET LEXL01C=+($GET(LEXL01C))+1
if LEXS=30
SET LEXL30C=+($GET(LEXL30C))+1
+25 if LEXS=2
SET LEXL02C=+($GET(LEXL02C))+1
if LEXS=31
SET LEXL31C=+($GET(LEXL31C))+1
End DoDot:7
End DoDot:6
+26 IF $DATA(LEXCOM)
SET DA(1)=LEXTIEN
SET DA=LEXKIEN
SET DIK="^LEX(757.01,"_DA(1)_",5,"
DO ^DIK
End DoDot:5
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+27 QUIT
+28 ;
+29 ; Displays
DEND ; Display End Totals
+1 if $DATA(LEXQUIET)
QUIT
if $DATA(ZTQUEUED)
QUIT
HANG 2
SET LEXEND=$$NOW^XLFDT
SET LEXELP=$$FMDIFF^XLFDT($GET(LEXEND),$GET(LEXBEG),3)
+2 if $LENGTH($GET(LEXEND))&($LENGTH($GET(LEXBEG)))&('$LENGTH(LEXELP))
SET LEXELP="00:00:00"
NEW LEXII,LEXTT
SET LEXII=""
SET LEXTT=0
+3 NEW LEXLEXC,LEXSDOC,LEXICDC,LEXTTT
+4 ; Lexicon
+5 SET LEXLEXC=+($GET(LEXL56C))+($GET(LEXL17C))+($GET(LEXL03C))+($GET(LEXL04C))+($GET(LEXL01C))+($GET(LEXL02C))+($GET(LEXL30C))+($GET(LEXL31C))
+6 IF +($GET(LEXLEXC))>0
Begin DoDot:1
+7 WRITE !,?3,"Lexicon Changes ",?35,$JUSTIFY(LEXLEXC,8)
+8 IF +($GET(LEXL01C))>0
WRITE !,?5,"ICD-9 Diagnosis Changes ",?35,$JUSTIFY(LEXL01C,8)
+9 IF +($GET(LEXL02C))>0
WRITE !,?5,"ICD-9 Procedure Changes ",?35,$JUSTIFY(LEXL02C,8)
+10 IF +($GET(LEXL30C))>0
WRITE !,?5,"ICD-10 Diagnosis Changes ",?35,$JUSTIFY(LEXL30C,8)
+11 IF +($GET(LEXL31C))>0
WRITE !,?5,"ICD-10 Procedure Changes ",?35,$JUSTIFY(LEXL31C,8)
+12 IF +($GET(LEXL56C))>0
WRITE !,?5,"SNOMED CT Changes ",?35,$JUSTIFY(LEXL56C,8)
+13 IF +($GET(LEXL17C))>0
WRITE !,?5,"TITLE 38 Changes ",?35,$JUSTIFY(LEXL17C,8)
+14 IF +($GET(LEXL03C))>0
WRITE !,?5,"CPT-4 Procedure Changes ",?35,$JUSTIFY(LEXL03C,8)
+15 IF +($GET(LEXL04C))>0
WRITE !,?5,"HCPCS Procedure Changes ",?35,$JUSTIFY(LEXL04C,8)
End DoDot:1
+16 ; ICD files
+17 SET LEXSDOC=+($GET(LEXI01C))+($GET(LEXI30C))+($GET(LEXI02C))+($GET(LEXI31C))
+18 SET LEXICDC=+($GET(LEXI01C))+($GET(LEXI30C))
SET LEXICPC=+($GET(LEXI02C))+($GET(LEXI31C))
+19 IF +($GET(LEXSDOC))>0
Begin DoDot:1
+20 NEW LEXTAB
if +($GET(LEXLEXC))>0
WRITE !
WRITE !,?3,"ICD* File Changes",?35,$JUSTIFY(LEXSDOC,8)
+21 SET LEXTAB=""
SET LEXICDC=+($GET(LEXI01C))+($GET(LEXI30C))
+22 IF +($GET(LEXI01C))>0&(+($GET(LEXI30C))>0)
if LEXICDC>0
WRITE !,?5,"ICD Diagnosis File #80",?35,$JUSTIFY(LEXICDC,8)
SET LEXTAB=" "
+23 IF +($GET(LEXI01C))>0
WRITE !,?5,LEXTAB,"ICD-9 Diagnosis Changes ",?35,$JUSTIFY(LEXI01C,8)
+24 IF +($GET(LEXI30C))>0
WRITE !,?5,LEXTAB,"ICD-10 Diagnosis Changes ",?35,$JUSTIFY(LEXI30C,8)
+25 SET LEXTAB=""
SET LEXICPC=+($GET(LEXI02C))+($GET(LEXI31C))
+26 IF +($GET(LEXI02C))>0&(+($GET(LEXI31C))>0)
if LEXICPC>0
WRITE !,?5,"ICD Procedures File #80.1",?35,$JUSTIFY(LEXICPC,8)
SET LEXTAB=" "
+27 IF +($GET(LEXI02C))>0
WRITE !,?5,LEXTAB,"ICD-9 Procedure Changes ",?35,$JUSTIFY(LEXI02C,8)
+28 IF +($GET(LEXI31C))>0
WRITE !,?5,LEXTAB,"ICD-10 Procedure Changes ",?35,$JUSTIFY(LEXI31C,8)
End DoDot:1
+29 SET LEXTTT=+($GET(LEXLEXC))+($GET(LEXSDOC))
IF LEXTTT>0
Begin DoDot:1
+30 if +($GET(LEXLEXC))>0!(+($GET(LEXSDOC))>0)
WRITE !
+31 IF +($GET(LEXLEXC))>0
WRITE !,?3,"Total Changes ",?35,$JUSTIFY(LEXTTT,8)
End DoDot:1
+32 WRITE !
IF $LENGTH($GET(LEXBEG))
WRITE !,?3,"Start: ",?14,$TRANSLATE($$FMTE^XLFDT(LEXBEG,"5Z"),"@"," ")
+33 IF $LENGTH($GET(LEXEND))
WRITE !,?3,"Finish: ",?14,$TRANSLATE($$FMTE^XLFDT(LEXEND,"5Z"),"@"," ")
+34 IF $LENGTH($GET(LEXELP))
WRITE !,?3,"Elapsed: ",?14,$TRANSLATE(LEXELP," ","0"),!
+35 QUIT
DEXP ; Display Expression
+1 if $DATA(LEXQUIET)
QUIT
if $DATA(ZTQUEUED)
QUIT
if '$LENGTH(LEXEXP)
QUIT
if '$LENGTH(LEXINC)
QUIT
if '$LENGTH(LEXKEY)
QUIT
+2 if $LENGTH($GET(LEXTYPE))
WRITE !,"Type: ",LEXTYPE
if $DATA(LEXSYS)
WRITE !,"System: ",LEXSYS
+3 WRITE !,"Expression: ",LEXEXP,!,"Include/Keyword: ",LEXINC,"/",LEXKEY
+4 IF +($GET(LEXOIEN))>0
IF $LENGTH($GET(LEXRT))
WRITE !,"IEN: ",LEXRT,LEXOIEN,","
+5 WRITE !
+6 QUIT
DINA ; Display Inactive Keyword
+1 if $DATA(LEXQUIET)
QUIT
if $DATA(ZTQUEUED)
QUIT
if '$LENGTH($GET(LEXKEY))
QUIT
if $GET(LEXEFF)'?7N
QUIT
if $GET(LEXINA)'?7N
QUIT
QUIT
+2 WRITE !,"Keyword: ",LEXKEY,!,"Effective: ",$$FMTE^XLFDT(LEXEFF,"5Z"),!,"Inactive: ",$$FMTE^XLFDT(LEXINA,"5Z"),!
+3 QUIT
+4 ;
+5 ; Miscellaneous
ABT(X) ; Abort
+1 if $DATA(^TMP("LEXWU",$JOB,"STOP"))
QUIT 1
+2 QUIT 0
INA(X) ; Inactive before Today or after LEXAFT (optional)
+1 NEW LEXI,LEX1,LEX2,LEXA,LEXT,LEXO
SET LEXT=$$DT^XLFDT
SET LEXI=+($GET(X))
SET LEX1=+($PIECE($PIECE($GET(^LEX(757.071,+LEXI,0)),"^",2),".",1))
if LEX1'?7N
QUIT "0^1"
+2 SET LEX2=+($PIECE($PIECE($GET(^LEX(757.071,+LEXI,0)),"^",3),".",1))
if LEX2'?7N
QUIT "0^2"
SET LEXA=$GET(LEXAFT)
SET LEXO=0
+3 ; If Inactive after LEXAFT and not later Active 1
+4 if ($GET(LEXA)?7N)&((LEX2+.001)>LEXA)&((LEX2+.001)>LEX1)
QUIT "1^3"
+5 ; If Inactive after LEXAFT and later Active 0
+6 if ($GET(LEXA)?7N)&((LEX2+.001)>LEXA)&((LEX1+.001)>LEX2)
QUIT "0^4"
+7 ; If Inactive before LEXAFT and not later Active 0
+8 if ($GET(LEXA)?7N)&((LEXA+.001)>LEX2)&((LEX2+.001)>LEX1)
QUIT "0^5"
+9 ; If Inactive 1
+10 if (LEX2+.001)>LEX1
QUIT "1^6"
+11 ; Else Active 0
+12 QUIT "0^7"
ACT(X) ; Active before Today or after LEXAFT (optional)
+1 NEW LEXI,LEX1,LEX2,LEXA,LEXT,LEXO
SET LEXT=$$DT^XLFDT
SET LEXI=+($GET(X))
SET LEX1=+($PIECE($PIECE($GET(^LEX(757.071,+LEXI,0)),"^",2),".",1))
if LEX1'?7N
QUIT "0^1"
+2 SET LEX2=+($PIECE($PIECE($GET(^LEX(757.071,+LEXI,0)),"^",3),".",1))
SET LEXA=$GET(LEXAFT)
SET LEXO=0
+3 ; If Active after LEXAFT and not later Inctive 1
+4 if ($GET(LEXA)?7N)&((LEX1+.001)>LEXA)&((LEX1+.001)>LEX2)
QUIT "1^2"
+5 ; If Active after LEXAFT and later Inactive 0
+6 if ($GET(LEXA)?7N)&((LEX1+.001)>LEXA)&((LEX2+.001)>LEX1)
QUIT "0^3"
+7 ; If Active before LEXAFT and not later Inactive 0
+8 if ($GET(LEXA)?7N)&((LEXA+.001)>LEX1)&((LEX1+.001)>LEX2)
QUIT "0^4"
+9 ; If Active 1
+10 if (LEX1+.001)>LEX2
QUIT "1^5"
+11 ; Else Inactive 0
+12 QUIT "0^6"
DT ; Display ^TMP
+1 DO DT^LEXWUM
+2 QUIT
STOP ; Stop Task
+1 DO STOP^LEXWUM
+2 QUIT
GO ; Remove Stop
+1 KILL ^TMP("LEXWU",$JOB,"STOP")
+2 QUIT
CLR ; Clear
+1 KILL ^TMP("LEXWU",$JOB,"STOP")
KILL DA,DIC,DICI,DIK,I,LEX1,LEXL17C,LEX2,LEX3,LEXA,LEXAFT,LEXBEG,LEXC,LEXCAP,LEXCDT,LEXCHK,LEXCT
+2 KILL LEXCTR,LEXD,LEXDIEN,LEXEFF,LEXEIEN,LEXELP,LEXEND,LEXENV,LEXEXC,LEXEXP,LEXFND,LEXI,LEXI01C,LEXI02C,LEXI30C,LEXI31C,LEXICDC,LEXICPC
+3 KILL LEXIEN,LEXII,LEXIIEN,LEXINA,LEXINC,LEXKEY,LEXKIEN,LEXL01C,LEXL02C,LEXL03C,LEXL04C,LEXL17C,LEXL30C,LEXL31C,LEXL56C,LEXLEXC,LEXM
+4 KILL LEXMIEN,LEXNAM,LEXND,LEXNM,LEXO,LEXOIEN,LEXOK,LEXORD,LEXQUIET,LEXRT,LEXRUN,LEXS,LEXSDOC,LEXSF,LEXSIEN,LEXSRC,LEXSS,LEXSTA
+5 KILL LEXSUP,LEXSYS,LEXT,LEXTD,LEXTIEN,LEXTKEY,LEXTT,LEXTTT,LEXTYPE,LEXY,NEXKEY,POP,X,Y,ZT,ZTDESC,ZTDTH,ZTIO,ZTKEY,ZTQUEUED
+6 KILL ZTREQ,ZTRTN,ZTSAVE,ZTSK,ZTUCI
+7 QUIT
ENV(X) ; Environment
+1 DO HOME^%ZIS
SET U="^"
SET DT=$$DT^XLFDT
SET DTIME=300
KILL POP
+2 NEW LEXNM
SET LEXNM=$$GET1^DIQ(200,(DUZ_","),.01)
+3 IF '$LENGTH(LEXNM)
WRITE !!,?5,"Invalid/Missing DUZ"
QUIT 0
+4 QUIT 1
