LEXWUS ;ISL/KER - Lexicon Keywords - Update (Set) ;05/23/2017
;;2.0;LEXICON UTILITY;**103**;Sep 23, 1996;Build 2
;
; Global Variables
; ^LEX(757.01, 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
; $$GET1^DIQ ICR 2056
; $$DT^XLFDT ICR 10103
; $$FMDIFF^XLFDT ICR 10103
; $$FMTE^XLFDT ICR 10103
; $$NOW^XLFDT ICR 10103
; $$UP^XLFSTR ICR 10011
;
; Local Variables NEWed or KILLed Elsewhere
; Control Variables
; LEXTEST For testing only
; LEXAFT Set keywords active after date
; LEXCOM Commit Flag
; LEXQUIET Suppress Display
;
; Call STOP^LEXWUS to stop the task. It sets the following
; global node:
;
; ^TMP("LEXWU",$J,"STOP")
;
Q
EN ; Main Entry Point (tasked - includes ICD-9)
N ZT,ZTKEY,ZTUCI,ZTSK,ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE,ZTQUEUED,ZTREQ,LEXRUN,LEXCOM,LEXCHK,LEXNAM,X,Y
I '$D(LEXTEST) S LEXRUN=$$RUN2^LEXWUM I LEXRUN>0 W:$L($P(LEXRUN,"^",2)) !,?4,$P(LEXRUN,"^",2),! Q
S ZTRTN="UPD^LEXWUS" S (LEXNAM,ZTDESC)="Keyword Update Utility (Set)",LEXCHK=""
S LEXCOM=1,ZTSAVE("LEXCOM")="" K:$D(LEXTEST) 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
Q
EN2 ; Entry Point (tasked - Update 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,LEXNAM,LEXRUN,LEXCOM,LEXCHK,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 (Set Selected Keyword)",ZTRTN="SEL^LEXWUS",LEXCHK=""
S LEXCOM=1,ZTSAVE("LEXCOM")="" K:$D(LEXTEST) LEXCOM,ZTSAVE("LEXCOM")
S:$L($G(LEXKEY)) ZTSAVE("LEXKEY")="" S:$L($O(LEXKEY(""))) ZTSAVE("LEXKEY(")=""
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
Q
; Update
UPD ; Update Keywords
N LEXENV S LEXENV=$$ENV G:'LEXENV UPDQ K ^TMP("LEXWU",$J,"STOP") S:$D(ZTQUEUED) ZTREQ="@"
N LEXBEG,LEXCHK,LEXCHKI,LEXCTR,LEXEFF,LEXELP,LEXEND,LEXENV,LEXEXC,LEXICDC,LEXICPC,LEXINA,LEXINC,LEXINP
N LEXKEY,LEXKEYC,LEXKIEN,LEXTBEG,LEXTD,LEXTELP,LEXTEND,LEXTMP
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)=0,LEXCOM=1 K:$D(LEXTEST) LEXCOM
S LEXTD=$$DT^XLFDT,LEXKEY="",LEXBEG=$$NOW^XLFDT S LEXAFT=$G(LEXAFT)
F S LEXKEY=$O(^LEX(757.071,"B",LEXKEY)) Q:'$L(LEXKEY) Q:$$ABT D Q:$$ABT
. N LEXKIEN,LEXTBEG,LEXTEND,LEXTELP,LEXTCHK S (LEXTCHK,LEXKIEN)=0
. F S LEXKIEN=$O(^LEX(757.071,"B",LEXKEY,LEXKIEN)) Q:+LEXKIEN'>0 Q:$$ABT D KEY Q:$$ABT
D UEND
UPDQ ; Update Keywords Quit
D NOSTOP
Q
SEL ; Update Selected Keyword
S:$D(ZTQUEUED) ZTREQ="@" N LEXENV S LEXENV=$$ENV G:'LEXENV SELQ K ^TMP("LEXWU",$J,"STOP")
I '$L($G(LEXKEY))&('$L($O(LEXKEY("")))) W !," LEXKEY keyword variable not defined",! G SELQ
N LEXBEG,LEXCHK,LEXCHKI,LEXCTR,LEXEFF,LEXELP,LEXEND,LEXENV,LEXEXC,LEXICDC,LEXICPC,LEXINA,LEXINC,LEXINP
N LEXKEYC,LEXKIEN,LEXTBEG,LEXTD,LEXTELP,LEXTEND,LEXTMP
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)=0,LEXCOM=1 K:$D(LEXTEST) LEXCOM
S LEXTD=$$DT^XLFDT,LEXBEG=$$NOW^XLFDT S LEXAFT=$G(LEXAFT)
I $L($G(LEXKEY)) D
. N LEXKIEN S LEXKIEN=0 F S LEXKIEN=$O(^LEX(757.071,"B",LEXKEY,LEXKIEN)) Q:+LEXKIEN'>0 Q:$$ABT D KEY Q:$$ABT
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 KEY Q:$$ABT
D UEND
SELQ ; Update Selected Keyword Quit
D NOSTOP
Q
KEY ; Process Keyword ICD and Lexicon
N LEXCHK,LEXCHK2,LEXCHKI,LEXEFF,LEXINA,LEXINC,LEXINCS,LEXEXC,LEXKEYC,LEXTBEG,LEXTEND,LEXTELP S (LEXKEYC(0),LEXKEYC(9))=0
S LEXEFF=$P($G(^LEX(757.071,+LEXKIEN,0)),"^",2) Q:$G(LEXAFT)?7N&(LEXAFT>LEXEFF)
S LEXINA=$P($G(^LEX(757.071,+LEXKIEN,0)),"^",3) Q:LEXINA>LEXEFF&(LEXINA'>LEXTD)
S LEXINC=$P($G(^LEX(757.071,+LEXKIEN,0)),"^",4) Q:'$L(LEXINC) S LEXEXC=$P($G(^LEX(757.071,+LEXKIEN,0)),"^",5)
S LEXCHK="" K LEXINP D INC(LEXINC) Q:'$L(LEXCHK)
Q:$$ABT D IDP^LEXWUI,LEX^LEXWUL
Q
UEND ; Update End
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 S LEXLEXC=+($G(LEXL56C))+($G(LEXL17C))+($G(LEXL03C))+($G(LEXL04C))
; 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
;
; Miscellaneous
INC(X) ; Include Check
K LEXINP S LEXCHKI=0,LEXCHK="" D PAR($G(X),.LEXINP)
S LEXCHKI=$O(LEXINP(0)) S:+LEXCHKI>0 LEXCHK=$O(LEXINP(+LEXCHKI,""))
K:LEXCHKI>0&($L(LEXCHK)) LEXINP(+LEXCHKI,LEXCHK),LEXINP("B",LEXCHK)
S:'$L(LEXCHK) LEXCHK=$P(LEXINC," ",1)
Q
ABT(X) ; Abort
Q:$D(^TMP("LEXWU",$J,"STOP")) 1
Q 0
DT ; Display ^TMP
D DT^LEXWUM
Q
STOP ; Stop Task
D STOP^LEXWUM
Q
NOSTOP ; Remove Stop
N LEXI S LEXI=0 F S LEXI=$O(^TMP("LEXWU",LEXI)) Q:+LEXI'>0 K ^TMP("LEXWU",LEXI,"STOP")
Q
BK(X) ; Stop Task
Q
PAR(X,LEXARY) ; Key Word In Context, KWIC
N LEXASRC,LEXBEG,LEXEND,LEXNUM,LEXTKN,LEXTXT S LEXTXT=$$UP^XLFSTR(X)
K LEXARY S LEXBEG=1 F LEXEND=1:1:$L(LEXTXT)+1 D
. S LEXASRC=$E(LEXTXT,LEXEND) I "~!@#$%&*()_+`-=[]{};'\:|,./?<> """[LEXASRC D
. . S LEXTKN=$E(LEXTXT,LEXBEG,LEXEND-1),LEXBEG=LEXEND+1 I $L(LEXTKN)>0 D
. . . N LEXNUM S LEXNUM=$O(^LEX(757.01,"ASL",LEXTKN,0))
. . . S LEXARY(+($G(LEXNUM)),LEXTKN)=""
. . . S LEXARY("B",LEXTKN)=""
Q
MON(X) ; Month
Q $S($G(X)=1:"JAN",$G(X)=2:"FEB",$G(X)=3:"MAR",$G(X)=4:"APR",$G(X)=5:"MAY",$G(X)=6:"JUN",$G(X)=7:"JUL",$G(X)=8:"AUG",$G(X)=9:"SEP",$G(X)=10:"OCT",$G(X)=11:"NOV",$G(X)=12:"DEC",1:$G(X))
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[HLEXWUS 9208 printed Apr 09, 2024@21:07:56 Page 2
LEXWUS ;ISL/KER - Lexicon Keywords - Update (Set) ;05/23/2017
+1 ;;2.0;LEXICON UTILITY;**103**;Sep 23, 1996;Build 2
+2 ;
+3 ; Global Variables
+4 ; ^LEX(757.01, SACC 1.3
+5 ; ^LEX(757.071, SACC 1.3
+6 ; ^TMP("LEXWU",$J) SACC 2.3.2.5.1
+7 ;
+8 ; External References
+9 ; HOME^%ZIS ICR 10086
+10 ; ^%ZTLOAD ICR 10063
+11 ; $$GET1^DIQ ICR 2056
+12 ; $$DT^XLFDT ICR 10103
+13 ; $$FMDIFF^XLFDT ICR 10103
+14 ; $$FMTE^XLFDT ICR 10103
+15 ; $$NOW^XLFDT ICR 10103
+16 ; $$UP^XLFSTR ICR 10011
+17 ;
+18 ; Local Variables NEWed or KILLed Elsewhere
+19 ; Control Variables
+20 ; LEXTEST For testing only
+21 ; LEXAFT Set keywords active after date
+22 ; LEXCOM Commit Flag
+23 ; LEXQUIET Suppress Display
+24 ;
+25 ; Call STOP^LEXWUS to stop the task. It sets the following
+26 ; global node:
+27 ;
+28 ; ^TMP("LEXWU",$J,"STOP")
+29 ;
+30 QUIT
EN ; Main Entry Point (tasked - includes ICD-9)
+1 NEW ZT,ZTKEY,ZTUCI,ZTSK,ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE,ZTQUEUED,ZTREQ,LEXRUN,LEXCOM,LEXCHK,LEXNAM,X,Y
+2 IF '$DATA(LEXTEST)
SET LEXRUN=$$RUN2^LEXWUM
IF LEXRUN>0
if $LENGTH($PIECE(LEXRUN,"^",2))
WRITE !,?4,$PIECE(LEXRUN,"^",2),!
QUIT
+3 SET ZTRTN="UPD^LEXWUS"
SET (LEXNAM,ZTDESC)="Keyword Update Utility (Set)"
SET LEXCHK=""
+4 SET LEXCOM=1
SET ZTSAVE("LEXCOM")=""
if $DATA(LEXTEST)
KILL LEXCOM,ZTSAVE("LEXCOM")
if $GET(LEXAFT)?7N
SET ZTSAVE("LEXAFT")=""
+5 KILL ^TMP("LEXWU",$JOB,"STOP")
SET ZTIO=""
SET ZTDTH=$HOROLOG
if '$DATA(LEXTEST)
DO ^%ZTLOAD
if $DATA(LEXTEST)
DO @ZTRTN
+6 IF +($GET(ZTSK))>0
WRITE !!,?4,$GET(LEXNAM)," tasked (#",+($GET(ZTSK)),")",!
+7 DO HOME^%ZIS
KILL LEXTEST,LEXAFT
+8 QUIT
EN2 ; Entry Point (tasked - Update 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,LEXNAM,LEXRUN,LEXCOM,LEXCHK,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 (Set Selected Keyword)"
SET ZTRTN="SEL^LEXWUS"
SET LEXCHK=""
+12 SET LEXCOM=1
SET ZTSAVE("LEXCOM")=""
if $DATA(LEXTEST)
KILL LEXCOM,ZTSAVE("LEXCOM")
+13 if $LENGTH($GET(LEXKEY))
SET ZTSAVE("LEXKEY")=""
if $LENGTH($ORDER(LEXKEY("")))
SET ZTSAVE("LEXKEY(")=""
+14 if $GET(LEXAFT)?7N
SET ZTSAVE("LEXAFT")=""
KILL ^TMP("LEXWU",$JOB,"STOP")
+15 SET ZTIO=""
SET ZTDTH=$HOROLOG
if '$DATA(LEXTEST)
DO ^%ZTLOAD
if $DATA(LEXTEST)
DO @ZTRTN
+16 IF +($GET(ZTSK))>0
WRITE !!,?4,$GET(LEXNAM)," tasked (#",+($GET(ZTSK)),")",!
+17 DO HOME^%ZIS
KILL LEXTEST,LEXAFT
+18 QUIT
+19 ; Update
UPD ; Update Keywords
+1 NEW LEXENV
SET LEXENV=$$ENV
if 'LEXENV
GOTO UPDQ
KILL ^TMP("LEXWU",$JOB,"STOP")
if $DATA(ZTQUEUED)
SET ZTREQ="@"
+2 NEW LEXBEG,LEXCHK,LEXCHKI,LEXCTR,LEXEFF,LEXELP,LEXEND,LEXENV,LEXEXC,LEXICDC,LEXICPC,LEXINA,LEXINC,LEXINP
+3 NEW LEXKEY,LEXKEYC,LEXKIEN,LEXTBEG,LEXTD,LEXTELP,LEXTEND,LEXTMP
+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)=0
SET LEXCOM=1
if $DATA(LEXTEST)
KILL LEXCOM
+7 SET LEXTD=$$DT^XLFDT
SET LEXKEY=""
SET LEXBEG=$$NOW^XLFDT
SET LEXAFT=$GET(LEXAFT)
+8 FOR
SET LEXKEY=$ORDER(^LEX(757.071,"B",LEXKEY))
if '$LENGTH(LEXKEY)
QUIT
if $$ABT
QUIT
Begin DoDot:1
+9 NEW LEXKIEN,LEXTBEG,LEXTEND,LEXTELP,LEXTCHK
SET (LEXTCHK,LEXKIEN)=0
+10 FOR
SET LEXKIEN=$ORDER(^LEX(757.071,"B",LEXKEY,LEXKIEN))
if +LEXKIEN'>0
QUIT
if $$ABT
QUIT
DO KEY
if $$ABT
QUIT
End DoDot:1
if $$ABT
QUIT
+11 DO UEND
UPDQ ; Update Keywords Quit
+1 DO NOSTOP
+2 QUIT
SEL ; Update Selected Keyword
+1 if $DATA(ZTQUEUED)
SET ZTREQ="@"
NEW LEXENV
SET LEXENV=$$ENV
if 'LEXENV
GOTO SELQ
KILL ^TMP("LEXWU",$JOB,"STOP")
+2 IF '$LENGTH($GET(LEXKEY))&('$LENGTH($ORDER(LEXKEY(""))))
WRITE !," LEXKEY keyword variable not defined",!
GOTO SELQ
+3 NEW LEXBEG,LEXCHK,LEXCHKI,LEXCTR,LEXEFF,LEXELP,LEXEND,LEXENV,LEXEXC,LEXICDC,LEXICPC,LEXINA,LEXINC,LEXINP
+4 NEW LEXKEYC,LEXKIEN,LEXTBEG,LEXTD,LEXTELP,LEXTEND,LEXTMP
+5 NEW LEXL01C,LEXL02C,LEXL03C,LEXL04C,LEXL17C,LEXL30C,LEXL31C,LEXL56C,LEXI01C,LEXI02C,LEXI30C,LEXI31C
+6 SET (LEXL01C,LEXL02C,LEXL03C,LEXL04C,LEXL17C,LEXL30C,LEXL31C,LEXL56C,LEXI01C,LEXI02C,LEXI30C,LEXI31C)=0
+7 SET (LEXCTR,LEXICDC,LEXICPC)=0
SET LEXCOM=1
if $DATA(LEXTEST)
KILL LEXCOM
+8 SET LEXTD=$$DT^XLFDT
SET LEXBEG=$$NOW^XLFDT
SET LEXAFT=$GET(LEXAFT)
+9 IF $LENGTH($GET(LEXKEY))
Begin DoDot:1
+10 NEW LEXKIEN
SET LEXKIEN=0
FOR
SET LEXKIEN=$ORDER(^LEX(757.071,"B",LEXKEY,LEXKIEN))
if +LEXKIEN'>0
QUIT
if $$ABT
QUIT
DO KEY
if $$ABT
QUIT
End DoDot:1
+11 IF $LENGTH($ORDER(LEXKEY("")))
Begin DoDot:1
+12 NEW LEXTKEY
SET LEXTKEY=""
FOR
SET LEXTKEY=$ORDER(LEXKEY(LEXTKEY))
if '$LENGTH(LEXTKEY)
QUIT
Begin DoDot:2
+13 NEW LEXKIEN,LEXKEY
SET LEXKEY=LEXTKEY
SET LEXKIEN=0
+14 FOR
SET LEXKIEN=$ORDER(^LEX(757.071,"B",LEXKEY,LEXKIEN))
if +LEXKIEN'>0
QUIT
if $$ABT
QUIT
DO KEY
if $$ABT
QUIT
End DoDot:2
End DoDot:1
+15 DO UEND
SELQ ; Update Selected Keyword Quit
+1 DO NOSTOP
+2 QUIT
KEY ; Process Keyword ICD and Lexicon
+1 NEW LEXCHK,LEXCHK2,LEXCHKI,LEXEFF,LEXINA,LEXINC,LEXINCS,LEXEXC,LEXKEYC,LEXTBEG,LEXTEND,LEXTELP
SET (LEXKEYC(0),LEXKEYC(9))=0
+2 SET LEXEFF=$PIECE($GET(^LEX(757.071,+LEXKIEN,0)),"^",2)
if $GET(LEXAFT)?7N&(LEXAFT>LEXEFF)
QUIT
+3 SET LEXINA=$PIECE($GET(^LEX(757.071,+LEXKIEN,0)),"^",3)
if LEXINA>LEXEFF&(LEXINA'>LEXTD)
QUIT
+4 SET LEXINC=$PIECE($GET(^LEX(757.071,+LEXKIEN,0)),"^",4)
if '$LENGTH(LEXINC)
QUIT
SET LEXEXC=$PIECE($GET(^LEX(757.071,+LEXKIEN,0)),"^",5)
+5 SET LEXCHK=""
KILL LEXINP
DO INC(LEXINC)
if '$LENGTH(LEXCHK)
QUIT
+6 if $$ABT
QUIT
DO IDP^LEXWUI
DO LEX^LEXWUL
+7 QUIT
UEND ; Update End
+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
SET LEXLEXC=+($GET(LEXL56C))+($GET(LEXL17C))+($GET(LEXL03C))+($GET(LEXL04C))
+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
+36 ;
+37 ; Miscellaneous
INC(X) ; Include Check
+1 KILL LEXINP
SET LEXCHKI=0
SET LEXCHK=""
DO PAR($GET(X),.LEXINP)
+2 SET LEXCHKI=$ORDER(LEXINP(0))
if +LEXCHKI>0
SET LEXCHK=$ORDER(LEXINP(+LEXCHKI,""))
+3 if LEXCHKI>0&($LENGTH(LEXCHK))
KILL LEXINP(+LEXCHKI,LEXCHK),LEXINP("B",LEXCHK)
+4 if '$LENGTH(LEXCHK)
SET LEXCHK=$PIECE(LEXINC," ",1)
+5 QUIT
ABT(X) ; Abort
+1 if $DATA(^TMP("LEXWU",$JOB,"STOP"))
QUIT 1
+2 QUIT 0
DT ; Display ^TMP
+1 DO DT^LEXWUM
+2 QUIT
STOP ; Stop Task
+1 DO STOP^LEXWUM
+2 QUIT
NOSTOP ; Remove Stop
+1 NEW LEXI
SET LEXI=0
FOR
SET LEXI=$ORDER(^TMP("LEXWU",LEXI))
if +LEXI'>0
QUIT
KILL ^TMP("LEXWU",LEXI,"STOP")
+2 QUIT
BK(X) ; Stop Task
+1 QUIT
PAR(X,LEXARY) ; Key Word In Context, KWIC
+1 NEW LEXASRC,LEXBEG,LEXEND,LEXNUM,LEXTKN,LEXTXT
SET LEXTXT=$$UP^XLFSTR(X)
+2 KILL LEXARY
SET LEXBEG=1
FOR LEXEND=1:1:$LENGTH(LEXTXT)+1
Begin DoDot:1
+3 SET LEXASRC=$EXTRACT(LEXTXT,LEXEND)
IF "~!@#$%&*()_+`-=[]{};'\:|,./?<> """[LEXASRC
Begin DoDot:2
+4 SET LEXTKN=$EXTRACT(LEXTXT,LEXBEG,LEXEND-1)
SET LEXBEG=LEXEND+1
IF $LENGTH(LEXTKN)>0
Begin DoDot:3
+5 NEW LEXNUM
SET LEXNUM=$ORDER(^LEX(757.01,"ASL",LEXTKN,0))
+6 SET LEXARY(+($GET(LEXNUM)),LEXTKN)=""
+7 SET LEXARY("B",LEXTKN)=""
End DoDot:3
End DoDot:2
End DoDot:1
+8 QUIT
MON(X) ; Month
+1 QUIT $SELECT($GET(X)=1:"JAN",$GET(X)=2:"FEB",$GET(X)=3:"MAR",$GET(X)=4:"APR",$GET(X)=5:"MAY",$GET(X)=6:"JUN",$GET(X)=7:"JUL",$GET(X)=8:"AUG",$GET(X)=9:"SEP",$GET(X)=10:"OCT",$GET(X)=11:"NOV",$GET(X)=12:"DEC",1:$GET(X))
+2 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
