LEXWUL ;ISL/KER - Lexicon Keywords - Update (Lexicon) ;05/23/2017
;;2.0;LEXICON UTILITY;**103**;Sep 23, 1996;Build 2
;
; Global Variables
; ^LEX(757 SACC 1.3
; ^LEX(757.01 SACC 1.3
; ^LEX(757.02 SACC 1.3
; ^TMP("LEXWU",$J) SACC 2.3.2.5.1
;
; External References
; HOME^%ZIS ICR 10086
; IX1^DIK ICR 10013
; $$GET1^DIQ ICR 2056
; $$DT^XLFDT ICR 10103
; $$UP^XLFSTR ICR 10011
;
; Local Variables NEWed or KILLed Elsewhere (LEXWUS)
; Control
; LEXEXC Exclude String
; LEXINC Include String
; LEXCHK Index node being checked
; LEXKEY Keyword being processed
; LEXQUIET Suppress Display
; LEXTEST Test Flag
; LEXCOM Commit Flag
; Counters
; LEXL01C ICD-9 Diagnosis Counter
; LEXL02C ICD-9 Procedure Counter
; LEXL03C CPT-4 Procedure Counter
; LEXL04C HCPCS Procedure Counter
; LEXL17C Title 38 Counter
; LEXL30C ICD-10 Diagnosis Counter
; LEXL31C ICD-10 Procedure Counter
; LEXL56C SNOMED CT Counter
;
Q
LEX ; Lexicon Expressions
Q:'$L($G(LEXKEY)) Q:'$L($G(LEXCHK)) Q:'$L($G(LEXINC)) Q:'$L(LEXKEY) K ^LEX("LEXWU",$J,"IEN"),^LEX("LEXWU",$J,"OUT")
N LEXSRC,LEXSAB,LEXPRI,LEXALT S LEXPRI=$G(LEXCHK),LEXALT="" D SPC K:$D(LEXTEST) LEXCOM I $L(LEXPRI) D
. N LEXCHK F LEXCHK=LEXPRI,LEXALT D:$L($G(LEXCHK)) LCHK
Q
LCHK ; Lexicon Check
Q:'$L(LEXCHK) N LEXCIEN,LEXEIEN,LEXCCTR,LEXICTR,LEXSRCA,LEXIENA S (LEXCCTR,LEXICTR,LEXCIEN)=0 K LEXIENA
F S LEXCIEN=$O(^LEX(757.01,"AWRD",LEXCHK,LEXCIEN)) Q:+LEXCIEN'>0 D
. S LEXIENA(+LEXCIEN)="" N LEXIIEN S LEXIIEN=0
. F S LEXIIEN=$O(^LEX(757.01,"AWRD",LEXCHK,LEXCIEN,LEXIIEN)) Q:+LEXIIEN'>0 S LEXIENA(+LEXIIEN)=""
S LEXEIEN=0 F S LEXEIEN=$O(LEXIENA(LEXEIEN)) Q:+LEXEIEN'>0 D LEXP
Q
LEXP ; Lexicon Expression
Q:+($G(LEXEIEN))'>0 N LEXCIEN,LEXCT,LEXEXP,LEXI,LEXIN,LEXND,LEXS,LEXSIEN,LEXSRC,LEXSRCA,LEXTMP,LEXTIEN K LEXSRCA
S LEXCIEN=LEXEIEN Q:'$D(^LEX(757.01,+LEXCIEN,0)) Q:$P($G(^LEX(757.01,+LEXCIEN,1)),"^",5)>0
Q:$D(^LEX(757.01,+LEXCIEN,5,"B",LEXKEY)) Q:$D(^LEX("LEXWU",$J,"IEN",+LEXCIEN)) S ^LEX("LEXWU",$J,"IEN",+LEXCIEN)=""
S LEXSIEN=0 F S LEXSIEN=$O(^LEX(757.02,"B",+LEXCIEN,LEXSIEN)) Q:+LEXSIEN'>0 D
. N LEXS,LEXND,LEXSRC S LEXND=$G(^LEX(757.02,+LEXSIEN,0)) Q:$P(LEXND,"^",5)'>0
. F LEXSRC=1,2,3,4,17,30,31,56 S:$P(LEXND,"^",3)=LEXSRC LEXSRCA(LEXSRC)=""
Q:'$D(LEXSRCA) Q:$O(LEXSRCA(0))'>0 S LEXEIEN=LEXCIEN,LEXEXP=$$UP^XLFSTR($G(^LEX(757.01,+LEXEIEN,0))) Q:'$L(LEXEXP)
; Term contains ALL Includes
S (LEXCT,LEXIN)=0 D Q:LEXIN'>0 Q:LEXCT'=LEXIN
. F LEXI=1:1 S LEXTMP=$$TM($P(LEXINC,";",LEXI)) Q:'$L(LEXTMP) S LEXCT=LEXCT+1 S:$$IN(LEXTMP,LEXEXP)>0 LEXIN=LEXIN+1
; Term contains Excludes
I $L($G(LEXEXC)) S LEXIN=0 D Q:LEXIN>0
. S LEXIN=0 I $L($G(LEXEXC)) F LEXI=1:1 S LEXTMP=$P(LEXEXC,";",LEXI) Q:'$L(LEXTMP) S:LEXEXP[LEXTMP LEXIN=1
D LSET
Q
LSET ; Lexicon Set Keyword
Q:+($G(LEXEIEN))'>0 Q:'$D(^LEX(757.01,+($G(LEXEIEN)),0)) Q:'$L(LEXEXP) Q:'$L(LEXKEY) Q:'$D(LEXSRCA)
N DA,DIK,LEXCT,LEXI,LEXIEN,LEXIN,LEXP3,LEXP4,LEXSYS
S:$D(LEXSRCA(1)) LEXL01C=+($G(LEXL01C))+1,LEXSYS=$$SYS(1) S:$D(LEXSRCA(2)) LEXL02C=+($G(LEXL02C))+1,LEXSYS=$$SYS(2)
S:$D(LEXSRCA(3)) LEXL03C=+($G(LEXL03C))+1,LEXSYS=$$SYS(3) S:$D(LEXSRCA(4)) LEXL04C=+($G(LEXL04C))+1,LEXSYS=$$SYS(4)
S:$D(LEXSRCA(17)) LEXL17C=+($G(LEXL17C))+1,LEXSYS=$$SYS(17) S:$D(LEXSRCA(30)) LEXL30C=+($G(LEXL30C))+1,LEXSYS=$$SYS(30)
S:$D(LEXSRCA(31)) LEXL31C=+($G(LEXL31C))+1,LEXSYS=$$SYS(31) S:$D(LEXSRCA(56)) LEXL56C=+($G(LEXL56C))+1,LEXSYS=$$SYS(56)
D DEXP I $D(LEXCOM) D
. N DA,DIK,LEXIEN,LEXP3,LEXP4 S LEXIEN=$O(^LEX(757.01,+LEXEIEN,5," "),-1)+1,^LEX(757.01,+LEXEIEN,5,LEXIEN,0)=LEXKEY
. S DA=LEXIEN,DA(1)=LEXEIEN,DIK="^LEX(757.01,"_DA(1)_",5," D IX1^DIK
. S LEXP3="",(LEXP4,LEXI)=0 F S LEXI=$O(^LEX(757.01,LEXEIEN,5,LEXI)) Q:+LEXI'>0 D
. . S LEXP3=LEXI,LEXP4=LEXP4+1 N DA,DIK S DA(1)=LEXEIEN,DA=LEXI,DIK="^LEX(757.01,"_DA(1)_",5," D IX1^DIK
. S:+LEXP3'>0 LEXP3="" S ^LEX(757.01,+LEXEIEN,5,0)="^757.18^"_+LEXP3_"^"_+LEXP4
Q
;
; Miscellaneous
DEXP ; Display Expression
Q:$D(LEXQUIET) Q:$D(ZTQUEUED) Q:'$L(LEXEXP) Q:'$L(LEXINC) Q:'$L(LEXKEY)
W !,"Type: Lexicon Expression (757.01)" W:$D(LEXSYS) !,"System: ",$G(LEXSYS)
W !,"Expression: ",$G(LEXEXP),!,"Include/Keyword: ",$G(LEXINC),"/",$G(LEXKEY)
I +($G(LEXEIEN))>0 W !,"IEN: ^LEX(757.01,",+($G(LEXEIEN)),","
W !
Q
CIEN(X) ; Concept IEN
N LEXEIEN,LEXMIEN,LEXCIEN
S LEXEIEN=+($G(X)),LEXMIEN=+($G(^LEX(757.01,+LEXEIEN,1))),LEXCIEN=+($G(^LEX(757,+LEXMIEN,0))) S X=LEXCIEN
Q X
IN(X,Y) ; Is X in Y
N LEXC,LEXE,LEXP,LEXO S LEXO=0 S LEXC=$G(X),LEXE=$G(Y) Q:$E(LEXE,1,$L(LEXC))=LEXC 1
F LEXP=" ","-","[","(","&","+","/","," S:LEXE[(LEXP_LEXC) LEXO=1
S X=LEXO
Q X
SPC ; Special Cases
S LEXALT="" S:LEXKEY="XRAY" LEXALT=LEXKEY S:LEXKEY="ECOLI" LEXALT=LEXKEY
Q
SYS(X) ; System
N LEXSRC S LEXSRC=$G(X) S X="" S:LEXSRC=1 X="ICD-9-CM" S:LEXSRC=2 X="ICD-9 Proc"
S:LEXSRC=30 X="ICD-10-CM" S:LEXSRC=31 X="ICD-10-PCS"
S:LEXSRC=3 X="CPT-4" S:LEXSRC=4 X="HCPCS"
S:LEXSRC=17 X="Title 38" S:LEXSRC=56 X="SNOMED CT"
Q X
TM(X,Y) ; Trim Character Y - Default " "
S X=$G(X) Q:X="" X S Y=$G(Y) S:'$L(Y) Y=" "
F Q:$E(X,1)'=Y S X=$E(X,2,$L(X))
F Q:$E(X,$L(X))'=Y S X=$E(X,1,($L(X)-1))
Q X
ABT(X) ; Abort
Q:$D(^TMP("LEXWU",$J,"STOP")) 1
Q 0
ENV(X) ; Environment
D HOME^%ZIS S U="^",DT=$$DT^XLFDT,DTIME=300 K POP
N LEXNM,ZTQUEUED,ZTREQ 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[HLEXWUL 5949 printed Apr 09, 2024@21:08:19 Page 2
LEXWUL ;ISL/KER - Lexicon Keywords - Update (Lexicon) ;05/23/2017
+1 ;;2.0;LEXICON UTILITY;**103**;Sep 23, 1996;Build 2
+2 ;
+3 ; Global Variables
+4 ; ^LEX(757 SACC 1.3
+5 ; ^LEX(757.01 SACC 1.3
+6 ; ^LEX(757.02 SACC 1.3
+7 ; ^TMP("LEXWU",$J) SACC 2.3.2.5.1
+8 ;
+9 ; External References
+10 ; HOME^%ZIS ICR 10086
+11 ; IX1^DIK ICR 10013
+12 ; $$GET1^DIQ ICR 2056
+13 ; $$DT^XLFDT ICR 10103
+14 ; $$UP^XLFSTR ICR 10011
+15 ;
+16 ; Local Variables NEWed or KILLed Elsewhere (LEXWUS)
+17 ; Control
+18 ; LEXEXC Exclude String
+19 ; LEXINC Include String
+20 ; LEXCHK Index node being checked
+21 ; LEXKEY Keyword being processed
+22 ; LEXQUIET Suppress Display
+23 ; LEXTEST Test Flag
+24 ; LEXCOM Commit Flag
+25 ; Counters
+26 ; LEXL01C ICD-9 Diagnosis Counter
+27 ; LEXL02C ICD-9 Procedure Counter
+28 ; LEXL03C CPT-4 Procedure Counter
+29 ; LEXL04C HCPCS Procedure Counter
+30 ; LEXL17C Title 38 Counter
+31 ; LEXL30C ICD-10 Diagnosis Counter
+32 ; LEXL31C ICD-10 Procedure Counter
+33 ; LEXL56C SNOMED CT Counter
+34 ;
+35 QUIT
LEX ; Lexicon Expressions
+1 if '$LENGTH($GET(LEXKEY))
QUIT
if '$LENGTH($GET(LEXCHK))
QUIT
if '$LENGTH($GET(LEXINC))
QUIT
if '$LENGTH(LEXKEY)
QUIT
KILL ^LEX("LEXWU",$JOB,"IEN"),^LEX("LEXWU",$JOB,"OUT")
+2 NEW LEXSRC,LEXSAB,LEXPRI,LEXALT
SET LEXPRI=$GET(LEXCHK)
SET LEXALT=""
DO SPC
if $DATA(LEXTEST)
KILL LEXCOM
IF $LENGTH(LEXPRI)
Begin DoDot:1
+3 NEW LEXCHK
FOR LEXCHK=LEXPRI,LEXALT
if $LENGTH($GET(LEXCHK))
DO LCHK
End DoDot:1
+4 QUIT
LCHK ; Lexicon Check
+1 if '$LENGTH(LEXCHK)
QUIT
NEW LEXCIEN,LEXEIEN,LEXCCTR,LEXICTR,LEXSRCA,LEXIENA
SET (LEXCCTR,LEXICTR,LEXCIEN)=0
KILL LEXIENA
+2 FOR
SET LEXCIEN=$ORDER(^LEX(757.01,"AWRD",LEXCHK,LEXCIEN))
if +LEXCIEN'>0
QUIT
Begin DoDot:1
+3 SET LEXIENA(+LEXCIEN)=""
NEW LEXIIEN
SET LEXIIEN=0
+4 FOR
SET LEXIIEN=$ORDER(^LEX(757.01,"AWRD",LEXCHK,LEXCIEN,LEXIIEN))
if +LEXIIEN'>0
QUIT
SET LEXIENA(+LEXIIEN)=""
End DoDot:1
+5 SET LEXEIEN=0
FOR
SET LEXEIEN=$ORDER(LEXIENA(LEXEIEN))
if +LEXEIEN'>0
QUIT
DO LEXP
+6 QUIT
LEXP ; Lexicon Expression
+1 if +($GET(LEXEIEN))'>0
QUIT
NEW LEXCIEN,LEXCT,LEXEXP,LEXI,LEXIN,LEXND,LEXS,LEXSIEN,LEXSRC,LEXSRCA,LEXTMP,LEXTIEN
KILL LEXSRCA
+2 SET LEXCIEN=LEXEIEN
if '$DATA(^LEX(757.01,+LEXCIEN,0))
QUIT
if $PIECE($GET(^LEX(757.01,+LEXCIEN,1)),"^",5)>0
QUIT
+3 if $DATA(^LEX(757.01,+LEXCIEN,5,"B",LEXKEY))
QUIT
if $DATA(^LEX("LEXWU",$JOB,"IEN",+LEXCIEN))
QUIT
SET ^LEX("LEXWU",$JOB,"IEN",+LEXCIEN)=""
+4 SET LEXSIEN=0
FOR
SET LEXSIEN=$ORDER(^LEX(757.02,"B",+LEXCIEN,LEXSIEN))
if +LEXSIEN'>0
QUIT
Begin DoDot:1
+5 NEW LEXS,LEXND,LEXSRC
SET LEXND=$GET(^LEX(757.02,+LEXSIEN,0))
if $PIECE(LEXND,"^",5)'>0
QUIT
+6 FOR LEXSRC=1,2,3,4,17,30,31,56
if $PIECE(LEXND,"^",3)=LEXSRC
SET LEXSRCA(LEXSRC)=""
End DoDot:1
+7 if '$DATA(LEXSRCA)
QUIT
if $ORDER(LEXSRCA(0))'>0
QUIT
SET LEXEIEN=LEXCIEN
SET LEXEXP=$$UP^XLFSTR($GET(^LEX(757.01,+LEXEIEN,0)))
if '$LENGTH(LEXEXP)
QUIT
+8 ; Term contains ALL Includes
+9 SET (LEXCT,LEXIN)=0
Begin DoDot:1
+10 FOR LEXI=1:1
SET LEXTMP=$$TM($PIECE(LEXINC,";",LEXI))
if '$LENGTH(LEXTMP)
QUIT
SET LEXCT=LEXCT+1
if $$IN(LEXTMP,LEXEXP)>0
SET LEXIN=LEXIN+1
End DoDot:1
if LEXIN'>0
QUIT
if LEXCT'=LEXIN
QUIT
+11 ; Term contains Excludes
+12 IF $LENGTH($GET(LEXEXC))
SET LEXIN=0
Begin DoDot:1
+13 SET LEXIN=0
IF $LENGTH($GET(LEXEXC))
FOR LEXI=1:1
SET LEXTMP=$PIECE(LEXEXC,";",LEXI)
if '$LENGTH(LEXTMP)
QUIT
if LEXEXP[LEXTMP
SET LEXIN=1
End DoDot:1
if LEXIN>0
QUIT
+14 DO LSET
+15 QUIT
LSET ; Lexicon Set Keyword
+1 if +($GET(LEXEIEN))'>0
QUIT
if '$DATA(^LEX(757.01,+($GET(LEXEIEN)),0))
QUIT
if '$LENGTH(LEXEXP)
QUIT
if '$LENGTH(LEXKEY)
QUIT
if '$DATA(LEXSRCA)
QUIT
+2 NEW DA,DIK,LEXCT,LEXI,LEXIEN,LEXIN,LEXP3,LEXP4,LEXSYS
+3 if $DATA(LEXSRCA(1))
SET LEXL01C=+($GET(LEXL01C))+1
SET LEXSYS=$$SYS(1)
if $DATA(LEXSRCA(2))
SET LEXL02C=+($GET(LEXL02C))+1
SET LEXSYS=$$SYS(2)
+4 if $DATA(LEXSRCA(3))
SET LEXL03C=+($GET(LEXL03C))+1
SET LEXSYS=$$SYS(3)
if $DATA(LEXSRCA(4))
SET LEXL04C=+($GET(LEXL04C))+1
SET LEXSYS=$$SYS(4)
+5 if $DATA(LEXSRCA(17))
SET LEXL17C=+($GET(LEXL17C))+1
SET LEXSYS=$$SYS(17)
if $DATA(LEXSRCA(30))
SET LEXL30C=+($GET(LEXL30C))+1
SET LEXSYS=$$SYS(30)
+6 if $DATA(LEXSRCA(31))
SET LEXL31C=+($GET(LEXL31C))+1
SET LEXSYS=$$SYS(31)
if $DATA(LEXSRCA(56))
SET LEXL56C=+($GET(LEXL56C))+1
SET LEXSYS=$$SYS(56)
+7 DO DEXP
IF $DATA(LEXCOM)
Begin DoDot:1
+8 NEW DA,DIK,LEXIEN,LEXP3,LEXP4
SET LEXIEN=$ORDER(^LEX(757.01,+LEXEIEN,5," "),-1)+1
SET ^LEX(757.01,+LEXEIEN,5,LEXIEN,0)=LEXKEY
+9 SET DA=LEXIEN
SET DA(1)=LEXEIEN
SET DIK="^LEX(757.01,"_DA(1)_",5,"
DO IX1^DIK
+10 SET LEXP3=""
SET (LEXP4,LEXI)=0
FOR
SET LEXI=$ORDER(^LEX(757.01,LEXEIEN,5,LEXI))
if +LEXI'>0
QUIT
Begin DoDot:2
+11 SET LEXP3=LEXI
SET LEXP4=LEXP4+1
NEW DA,DIK
SET DA(1)=LEXEIEN
SET DA=LEXI
SET DIK="^LEX(757.01,"_DA(1)_",5,"
DO IX1^DIK
End DoDot:2
+12 if +LEXP3'>0
SET LEXP3=""
SET ^LEX(757.01,+LEXEIEN,5,0)="^757.18^"_+LEXP3_"^"_+LEXP4
End DoDot:1
+13 QUIT
+14 ;
+15 ; Miscellaneous
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 WRITE !,"Type: Lexicon Expression (757.01)"
if $DATA(LEXSYS)
WRITE !,"System: ",$GET(LEXSYS)
+3 WRITE !,"Expression: ",$GET(LEXEXP),!,"Include/Keyword: ",$GET(LEXINC),"/",$GET(LEXKEY)
+4 IF +($GET(LEXEIEN))>0
WRITE !,"IEN: ^LEX(757.01,",+($GET(LEXEIEN)),","
+5 WRITE !
+6 QUIT
CIEN(X) ; Concept IEN
+1 NEW LEXEIEN,LEXMIEN,LEXCIEN
+2 SET LEXEIEN=+($GET(X))
SET LEXMIEN=+($GET(^LEX(757.01,+LEXEIEN,1)))
SET LEXCIEN=+($GET(^LEX(757,+LEXMIEN,0)))
SET X=LEXCIEN
+3 QUIT X
IN(X,Y) ; Is X in Y
+1 NEW LEXC,LEXE,LEXP,LEXO
SET LEXO=0
SET LEXC=$GET(X)
SET LEXE=$GET(Y)
if $EXTRACT(LEXE,1,$LENGTH(LEXC))=LEXC
QUIT 1
+2 FOR LEXP=" ","-","[","(","&","+","/",","
if LEXE[(LEXP_LEXC)
SET LEXO=1
+3 SET X=LEXO
+4 QUIT X
SPC ; Special Cases
+1 SET LEXALT=""
if LEXKEY="XRAY"
SET LEXALT=LEXKEY
if LEXKEY="ECOLI"
SET LEXALT=LEXKEY
+2 QUIT
SYS(X) ; System
+1 NEW LEXSRC
SET LEXSRC=$GET(X)
SET X=""
if LEXSRC=1
SET X="ICD-9-CM"
if LEXSRC=2
SET X="ICD-9 Proc"
+2 if LEXSRC=30
SET X="ICD-10-CM"
if LEXSRC=31
SET X="ICD-10-PCS"
+3 if LEXSRC=3
SET X="CPT-4"
if LEXSRC=4
SET X="HCPCS"
+4 if LEXSRC=17
SET X="Title 38"
if LEXSRC=56
SET X="SNOMED CT"
+5 QUIT X
TM(X,Y) ; Trim Character Y - Default " "
+1 SET X=$GET(X)
if X=""
QUIT X
SET Y=$GET(Y)
if '$LENGTH(Y)
SET Y=" "
+2 FOR
if $EXTRACT(X,1)'=Y
QUIT
SET X=$EXTRACT(X,2,$LENGTH(X))
+3 FOR
if $EXTRACT(X,$LENGTH(X))'=Y
QUIT
SET X=$EXTRACT(X,1,($LENGTH(X)-1))
+4 QUIT X
ABT(X) ; Abort
+1 if $DATA(^TMP("LEXWU",$JOB,"STOP"))
QUIT 1
+2 QUIT 0
ENV(X) ; Environment
+1 DO HOME^%ZIS
SET U="^"
SET DT=$$DT^XLFDT
SET DTIME=300
KILL POP
+2 NEW LEXNM,ZTQUEUED,ZTREQ
SET LEXNM=$$GET1^DIQ(200,(DUZ_","),.01)
+3 IF '$LENGTH(LEXNM)
WRITE !!,?5,"Invalid/Missing DUZ"
QUIT 0
+4 QUIT 1
