- 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 Feb 18, 2025@23:36:06 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