Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: LEXWUS

LEXWUS.m

Go to the documentation of this file.
  1. LEXWUS ;ISL/KER - Lexicon Keywords - Update (Set) ;05/23/2017
  1. ;;2.0;LEXICON UTILITY;**103**;Sep 23, 1996;Build 2
  1. ;
  1. ; Global Variables
  1. ; ^LEX(757.01, SACC 1.3
  1. ; ^LEX(757.071, SACC 1.3
  1. ; ^TMP("LEXWU",$J) SACC 2.3.2.5.1
  1. ;
  1. ; External References
  1. ; HOME^%ZIS ICR 10086
  1. ; ^%ZTLOAD ICR 10063
  1. ; $$GET1^DIQ ICR 2056
  1. ; $$DT^XLFDT ICR 10103
  1. ; $$FMDIFF^XLFDT ICR 10103
  1. ; $$FMTE^XLFDT ICR 10103
  1. ; $$NOW^XLFDT ICR 10103
  1. ; $$UP^XLFSTR ICR 10011
  1. ;
  1. ; Local Variables NEWed or KILLed Elsewhere
  1. ; Control Variables
  1. ; LEXTEST For testing only
  1. ; LEXAFT Set keywords active after date
  1. ; LEXCOM Commit Flag
  1. ; LEXQUIET Suppress Display
  1. ;
  1. ; Call STOP^LEXWUS to stop the task. It sets the following
  1. ; global node:
  1. ;
  1. ; ^TMP("LEXWU",$J,"STOP")
  1. ;
  1. Q
  1. EN ; Main Entry Point (tasked - includes ICD-9)
  1. N ZT,ZTKEY,ZTUCI,ZTSK,ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE,ZTQUEUED,ZTREQ,LEXRUN,LEXCOM,LEXCHK,LEXNAM,X,Y
  1. I '$D(LEXTEST) S LEXRUN=$$RUN2^LEXWUM I LEXRUN>0 W:$L($P(LEXRUN,"^",2)) !,?4,$P(LEXRUN,"^",2),! Q
  1. S ZTRTN="UPD^LEXWUS" S (LEXNAM,ZTDESC)="Keyword Update Utility (Set)",LEXCHK=""
  1. S LEXCOM=1,ZTSAVE("LEXCOM")="" K:$D(LEXTEST) LEXCOM,ZTSAVE("LEXCOM") S:$G(LEXAFT)?7N ZTSAVE("LEXAFT")=""
  1. K ^TMP("LEXWU",$J,"STOP") S ZTIO="",ZTDTH=$H D:'$D(LEXTEST) ^%ZTLOAD D:$D(LEXTEST) @ZTRTN
  1. I +($G(ZTSK))>0 W !!,?4,$G(LEXNAM)," tasked (#",+($G(ZTSK)),")",!
  1. D HOME^%ZIS K LEXTEST,LEXAFT
  1. Q
  1. EN2 ; Entry Point (tasked - Update Selected keyword - LEXKEY)
  1. ;
  1. ; Needs LEXKEY One Keyword
  1. ; <or>
  1. ; LEXKEY(LEXKEY1) Selected Keywords
  1. ; LEXKEY(LEXKEY2)
  1. ; LEXKEY(LEXKEYn)
  1. ;
  1. N ZT,ZTKEY,ZTUCI,ZTSK,ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE,ZTQUEUED,ZTREQ,LEXNAM,LEXRUN,LEXCOM,LEXCHK,X,Y
  1. I '$L($G(LEXKEY))&('$L($O(LEXKEY("")))) W !," LEXKEY keyword variable not defined",! Q
  1. I '$D(LEXTEST) S LEXRUN=$$RUN2^LEXWUM I LEXRUN>0 W:$L($P(LEXRUN,"^",2)) !,?4,$P(LEXRUN,"^",2),! Q
  1. S (LEXNAM,ZTDESC)="Keyword Update Utility (Set Selected Keyword)",ZTRTN="SEL^LEXWUS",LEXCHK=""
  1. S LEXCOM=1,ZTSAVE("LEXCOM")="" K:$D(LEXTEST) LEXCOM,ZTSAVE("LEXCOM")
  1. S:$L($G(LEXKEY)) ZTSAVE("LEXKEY")="" S:$L($O(LEXKEY(""))) ZTSAVE("LEXKEY(")=""
  1. S:$G(LEXAFT)?7N ZTSAVE("LEXAFT")="" K ^TMP("LEXWU",$J,"STOP")
  1. S ZTIO="",ZTDTH=$H D:'$D(LEXTEST) ^%ZTLOAD D:$D(LEXTEST) @ZTRTN
  1. I +($G(ZTSK))>0 W !!,?4,$G(LEXNAM)," tasked (#",+($G(ZTSK)),")",!
  1. D HOME^%ZIS K LEXTEST,LEXAFT
  1. Q
  1. ; Update
  1. UPD ; Update Keywords
  1. N LEXENV S LEXENV=$$ENV G:'LEXENV UPDQ K ^TMP("LEXWU",$J,"STOP") S:$D(ZTQUEUED) ZTREQ="@"
  1. N LEXBEG,LEXCHK,LEXCHKI,LEXCTR,LEXEFF,LEXELP,LEXEND,LEXENV,LEXEXC,LEXICDC,LEXICPC,LEXINA,LEXINC,LEXINP
  1. N LEXKEY,LEXKEYC,LEXKIEN,LEXTBEG,LEXTD,LEXTELP,LEXTEND,LEXTMP
  1. N LEXL01C,LEXL02C,LEXL03C,LEXL04C,LEXL17C,LEXL30C,LEXL31C,LEXL56C,LEXI01C,LEXI02C,LEXI30C,LEXI31C
  1. S (LEXL01C,LEXL02C,LEXL03C,LEXL04C,LEXL17C,LEXL30C,LEXL31C,LEXL56C,LEXI01C,LEXI02C,LEXI30C,LEXI31C)=0
  1. S (LEXCTR,LEXICDC,LEXICPC)=0,LEXCOM=1 K:$D(LEXTEST) LEXCOM
  1. S LEXTD=$$DT^XLFDT,LEXKEY="",LEXBEG=$$NOW^XLFDT S LEXAFT=$G(LEXAFT)
  1. F S LEXKEY=$O(^LEX(757.071,"B",LEXKEY)) Q:'$L(LEXKEY) Q:$$ABT D Q:$$ABT
  1. . N LEXKIEN,LEXTBEG,LEXTEND,LEXTELP,LEXTCHK S (LEXTCHK,LEXKIEN)=0
  1. . F S LEXKIEN=$O(^LEX(757.071,"B",LEXKEY,LEXKIEN)) Q:+LEXKIEN'>0 Q:$$ABT D KEY Q:$$ABT
  1. D UEND
  1. UPDQ ; Update Keywords Quit
  1. D NOSTOP
  1. Q
  1. SEL ; Update Selected Keyword
  1. S:$D(ZTQUEUED) ZTREQ="@" N LEXENV S LEXENV=$$ENV G:'LEXENV SELQ K ^TMP("LEXWU",$J,"STOP")
  1. I '$L($G(LEXKEY))&('$L($O(LEXKEY("")))) W !," LEXKEY keyword variable not defined",! G SELQ
  1. N LEXBEG,LEXCHK,LEXCHKI,LEXCTR,LEXEFF,LEXELP,LEXEND,LEXENV,LEXEXC,LEXICDC,LEXICPC,LEXINA,LEXINC,LEXINP
  1. N LEXKEYC,LEXKIEN,LEXTBEG,LEXTD,LEXTELP,LEXTEND,LEXTMP
  1. N LEXL01C,LEXL02C,LEXL03C,LEXL04C,LEXL17C,LEXL30C,LEXL31C,LEXL56C,LEXI01C,LEXI02C,LEXI30C,LEXI31C
  1. S (LEXL01C,LEXL02C,LEXL03C,LEXL04C,LEXL17C,LEXL30C,LEXL31C,LEXL56C,LEXI01C,LEXI02C,LEXI30C,LEXI31C)=0
  1. S (LEXCTR,LEXICDC,LEXICPC)=0,LEXCOM=1 K:$D(LEXTEST) LEXCOM
  1. S LEXTD=$$DT^XLFDT,LEXBEG=$$NOW^XLFDT S LEXAFT=$G(LEXAFT)
  1. I $L($G(LEXKEY)) D
  1. . N LEXKIEN S LEXKIEN=0 F S LEXKIEN=$O(^LEX(757.071,"B",LEXKEY,LEXKIEN)) Q:+LEXKIEN'>0 Q:$$ABT D KEY Q:$$ABT
  1. I $L($O(LEXKEY(""))) D
  1. . N LEXTKEY S LEXTKEY="" F S LEXTKEY=$O(LEXKEY(LEXTKEY)) Q:'$L(LEXTKEY) D
  1. . . N LEXKIEN,LEXKEY S LEXKEY=LEXTKEY,LEXKIEN=0
  1. . . F S LEXKIEN=$O(^LEX(757.071,"B",LEXKEY,LEXKIEN)) Q:+LEXKIEN'>0 Q:$$ABT D KEY Q:$$ABT
  1. D UEND
  1. SELQ ; Update Selected Keyword Quit
  1. D NOSTOP
  1. Q
  1. KEY ; Process Keyword ICD and Lexicon
  1. N LEXCHK,LEXCHK2,LEXCHKI,LEXEFF,LEXINA,LEXINC,LEXINCS,LEXEXC,LEXKEYC,LEXTBEG,LEXTEND,LEXTELP S (LEXKEYC(0),LEXKEYC(9))=0
  1. S LEXEFF=$P($G(^LEX(757.071,+LEXKIEN,0)),"^",2) Q:$G(LEXAFT)?7N&(LEXAFT>LEXEFF)
  1. S LEXINA=$P($G(^LEX(757.071,+LEXKIEN,0)),"^",3) Q:LEXINA>LEXEFF&(LEXINA'>LEXTD)
  1. S LEXINC=$P($G(^LEX(757.071,+LEXKIEN,0)),"^",4) Q:'$L(LEXINC) S LEXEXC=$P($G(^LEX(757.071,+LEXKIEN,0)),"^",5)
  1. S LEXCHK="" K LEXINP D INC(LEXINC) Q:'$L(LEXCHK)
  1. Q:$$ABT D IDP^LEXWUI,LEX^LEXWUL
  1. Q
  1. UEND ; Update End
  1. Q:$D(LEXQUIET) Q:$D(ZTQUEUED) H 2 S LEXEND=$$NOW^XLFDT,LEXELP=$$FMDIFF^XLFDT($G(LEXEND),$G(LEXBEG),3)
  1. S:$L($G(LEXEND))&($L($G(LEXBEG)))&('$L(LEXELP)) LEXELP="00:00:00" N LEXII,LEXTT S LEXII="",LEXTT=0
  1. N LEXLEXC,LEXSDOC,LEXICDC,LEXTTT S LEXLEXC=+($G(LEXL56C))+($G(LEXL17C))+($G(LEXL03C))+($G(LEXL04C))
  1. ; Lexicon
  1. S LEXLEXC=+($G(LEXL56C))+($G(LEXL17C))+($G(LEXL03C))+($G(LEXL04C))+($G(LEXL01C))+($G(LEXL02C))+($G(LEXL30C))+($G(LEXL31C))
  1. I +($G(LEXLEXC))>0 D
  1. . W !,?3,"Lexicon Changes ",?35,$J(LEXLEXC,8)
  1. . I +($G(LEXL01C))>0 W !,?5,"ICD-9 Diagnosis Changes ",?35,$J(LEXL01C,8)
  1. . I +($G(LEXL02C))>0 W !,?5,"ICD-9 Procedure Changes ",?35,$J(LEXL02C,8)
  1. . I +($G(LEXL30C))>0 W !,?5,"ICD-10 Diagnosis Changes ",?35,$J(LEXL30C,8)
  1. . I +($G(LEXL31C))>0 W !,?5,"ICD-10 Procedure Changes ",?35,$J(LEXL31C,8)
  1. . I +($G(LEXL56C))>0 W !,?5,"SNOMED CT Changes ",?35,$J(LEXL56C,8)
  1. . I +($G(LEXL17C))>0 W !,?5,"TITLE 38 Changes ",?35,$J(LEXL17C,8)
  1. . I +($G(LEXL03C))>0 W !,?5,"CPT-4 Procedure Changes ",?35,$J(LEXL03C,8)
  1. . I +($G(LEXL04C))>0 W !,?5,"HCPCS Procedure Changes ",?35,$J(LEXL04C,8)
  1. ; ICD files
  1. S LEXSDOC=+($G(LEXI01C))+($G(LEXI30C))+($G(LEXI02C))+($G(LEXI31C))
  1. S LEXICDC=+($G(LEXI01C))+($G(LEXI30C)),LEXICPC=+($G(LEXI02C))+($G(LEXI31C))
  1. I +($G(LEXSDOC))>0 D
  1. . N LEXTAB W:+($G(LEXLEXC))>0 ! W !,?3,"ICD* File Changes",?35,$J(LEXSDOC,8)
  1. . S LEXTAB="",LEXICDC=+($G(LEXI01C))+($G(LEXI30C))
  1. . I +($G(LEXI01C))>0&(+($G(LEXI30C))>0) W:LEXICDC>0 !,?5,"ICD Diagnosis File #80",?35,$J(LEXICDC,8) S LEXTAB=" "
  1. . I +($G(LEXI01C))>0 W !,?5,LEXTAB,"ICD-9 Diagnosis Changes ",?35,$J(LEXI01C,8)
  1. . I +($G(LEXI30C))>0 W !,?5,LEXTAB,"ICD-10 Diagnosis Changes ",?35,$J(LEXI30C,8)
  1. . S LEXTAB="",LEXICPC=+($G(LEXI02C))+($G(LEXI31C))
  1. . I +($G(LEXI02C))>0&(+($G(LEXI31C))>0) W:LEXICPC>0 !,?5,"ICD Procedures File #80.1",?35,$J(LEXICPC,8) S LEXTAB=" "
  1. . I +($G(LEXI02C))>0 W !,?5,LEXTAB,"ICD-9 Procedure Changes ",?35,$J(LEXI02C,8)
  1. . I +($G(LEXI31C))>0 W !,?5,LEXTAB,"ICD-10 Procedure Changes ",?35,$J(LEXI31C,8)
  1. S LEXTTT=+($G(LEXLEXC))+($G(LEXSDOC)) I LEXTTT>0 D
  1. . W:+($G(LEXLEXC))>0!(+($G(LEXSDOC))>0) !
  1. . I +($G(LEXLEXC))>0 W !,?3,"Total Changes ",?35,$J(LEXTTT,8)
  1. W ! I $L($G(LEXBEG)) W !,?3,"Start: ",?14,$TR($$FMTE^XLFDT(LEXBEG,"5Z"),"@"," ")
  1. I $L($G(LEXEND)) W !,?3,"Finish: ",?14,$TR($$FMTE^XLFDT(LEXEND,"5Z"),"@"," ")
  1. I $L($G(LEXELP)) W !,?3,"Elapsed: ",?14,$TR(LEXELP," ","0"),!
  1. Q
  1. ;
  1. ; Miscellaneous
  1. INC(X) ; Include Check
  1. K LEXINP S LEXCHKI=0,LEXCHK="" D PAR($G(X),.LEXINP)
  1. S LEXCHKI=$O(LEXINP(0)) S:+LEXCHKI>0 LEXCHK=$O(LEXINP(+LEXCHKI,""))
  1. K:LEXCHKI>0&($L(LEXCHK)) LEXINP(+LEXCHKI,LEXCHK),LEXINP("B",LEXCHK)
  1. S:'$L(LEXCHK) LEXCHK=$P(LEXINC," ",1)
  1. Q
  1. ABT(X) ; Abort
  1. Q:$D(^TMP("LEXWU",$J,"STOP")) 1
  1. Q 0
  1. DT ; Display ^TMP
  1. D DT^LEXWUM
  1. Q
  1. STOP ; Stop Task
  1. D STOP^LEXWUM
  1. Q
  1. NOSTOP ; Remove Stop
  1. N LEXI S LEXI=0 F S LEXI=$O(^TMP("LEXWU",LEXI)) Q:+LEXI'>0 K ^TMP("LEXWU",LEXI,"STOP")
  1. Q
  1. BK(X) ; Stop Task
  1. Q
  1. PAR(X,LEXARY) ; Key Word In Context, KWIC
  1. N LEXASRC,LEXBEG,LEXEND,LEXNUM,LEXTKN,LEXTXT S LEXTXT=$$UP^XLFSTR(X)
  1. K LEXARY S LEXBEG=1 F LEXEND=1:1:$L(LEXTXT)+1 D
  1. . S LEXASRC=$E(LEXTXT,LEXEND) I "~!@#$%&*()_+`-=[]{};'\:|,./?<> """[LEXASRC D
  1. . . S LEXTKN=$E(LEXTXT,LEXBEG,LEXEND-1),LEXBEG=LEXEND+1 I $L(LEXTKN)>0 D
  1. . . . N LEXNUM S LEXNUM=$O(^LEX(757.01,"ASL",LEXTKN,0))
  1. . . . S LEXARY(+($G(LEXNUM)),LEXTKN)=""
  1. . . . S LEXARY("B",LEXTKN)=""
  1. Q
  1. MON(X) ; Month
  1. 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))
  1. Q
  1. ENV(X) ; Environment
  1. D HOME^%ZIS S U="^",DT=$$DT^XLFDT,DTIME=300 K POP
  1. N LEXNM S LEXNM=$$GET1^DIQ(200,(DUZ_","),.01)
  1. I '$L(LEXNM) W !!,?5,"Invalid/Missing DUZ" Q 0
  1. Q 1