LEXWUI ;ISL/KER - Lexicon Keywords - Update (ICD) ;05/23/2017
;;2.0;LEXICON UTILITY;**103**;Sep 23, 1996;Build 2
;
; Global Variables
; ^ICD0( ICR 4486
; ^ICD9( ICR 4485
; ^LEX(757.03, 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
; Control
; LEXCHK Word to check for
; LEXKEY Keyword to add if found
; LEXINC Text that must be included in term
; LEXEXC Text that must be excluded from the term
; LEXCOM Commit Flag
; LEXTD Today's Date
; ZTQUEUED TaskMan
; ZTREQ TaskMan
; LEXQUIET For testing only
; Counters
; LEXI01C ICD-9 Diagnosis Counter
; LEXI02C ICD-9 Procedure Counter
; LEXI30C ICD-10 Diagnosis Counter
; LEXI31C ICD-10 Procedure Counter
; LEXICDC ICD Diagnosis Counter
; LEXICPC ICD Procedure Counter
;
Q
IDP ; ICD Diagnosis/Procedures
S:$D(ZTQUEUED) ZTREQ="@" N LEXDIC F LEXDIC=80,80.1 D
. N LEXRT,LEXFI,LEXFID,LEXASRC I LEXDIC=80 S LEXRT="^ICD9(",LEXFI=LEXDIC,LEXFID="80.682",LEXASRC="^1^30^"
. I LEXDIC=80.1 S LEXRT="^ICD0(",LEXFI=LEXDIC,LEXFID="80.1682",LEXASRC="^2^31^"
. Q:+($G(LEXFI))'>0 Q:'$L($G(LEXRT)) Q:'$L($G(LEXFID)) Q:'$L($G(LEXASRC)) D IFI
Q
IFI ; ICD by File #
Q:$G(LEXTD)'?7N Q:'$L($G(LEXKEY)) Q:'$L($G(LEXCHK)) Q:'$L($G(LEXINC))
N LEXSI,LEXSRC,LEXTMP F LEXSI=2:1 S LEXSRC=$P(LEXASRC,"^",LEXSI) Q:'$L(LEXSRC) Q:$$ABT D ISR Q:$$ABT
Q
ISR ; ICD by Source
N LEXALT,LEXCTL,LEXPRI,LEXSAB,LEXSYS S LEXPRI=LEXCHK,LEXALT="" D SPC
S LEXSYS=$$SYS(LEXSRC) S LEXSAB=$E($G(^LEX(757.03,+LEXSRC,0)),1,3) Q:$L(LEXSAB)'=3
F LEXCTL=LEXPRI,LEXALT D:$L(LEXCTL) ISC
Q
ISC ; ICD by Check Word
N LEXIIEN S LEXIIEN=0 F S LEXIIEN=$O(@(LEXRT_"""AD"","_+LEXSRC_","""_LEXCTL_""","_LEXIIEN_")")) Q:+LEXIIEN'>0 Q:$$ABT D IIE Q:$$ABT
Q
IIE ; ICD by IEN
N LEXEFF,LEXHIEN,LEXEXP,LEXCT,LEXIN,LEXI,LEXTMP,LEXTYPE,LEXFIL
S LEXHIEN=0 F S LEXHIEN=$O(@(LEXRT_+LEXIIEN_",68,"_LEXHIEN_")")) Q:+LEXHIEN'>0 D IEX
Q
IEX ; ICD by Expression
S LEXEXP=$$UP^XLFSTR($G(@(LEXRT_+LEXIIEN_",68,"_+LEXHIEN_",1)"))) Q:'$L(LEXEXP)
Q:$D(@(LEXRT_+LEXIIEN_",68,"_+LEXHIEN_",2,""B"","""_LEXKEY_""")"))
; 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
S:LEXSRC=1 LEXI01C=+($G(LEXI01C))+1 S:LEXSRC=30 LEXI30C=+($G(LEXI30C))+1
S:LEXSRC=2 LEXI02C=+($G(LEXI02C))+1 S:LEXSRC=31 LEXI31C=+($G(LEXI31C))+1
S LEXICDC=+($G(LEXI01C))+($G(LEXI30C)) S LEXICPC=+($G(LEXI02C))+($G(LEXI31C))
D DEXP I $D(LEXCOM) D IIS
Q
IIS ; ICD Set
N DA,DIK,LEXKIEN,LEXP3,LEXP4 Q:+($G(LEXIIEN))'>0 Q:+($G(LEXHIEN))'>0 Q:'$L($G(LEXKEY))
S LEXDIC=$G(LEXDIC) Q:"^80^80.1^"'[("^"_LEXDIC_"^")
I LEXDIC=80 S:'$L(LEXRT) LEXRT="^ICD9(" S:'$L(LEXFID) LEXFID="80.682" S:'$L(LEXASRC) LEXASRC="^1^30^"
I LEXDIC=80.1 S:'$L(LEXRT) LEXRT="^ICD0(" S:'$L(LEXFID) LEXFID="80.1682" S:'$L(LEXASRC) LEXASRC="^2^31^"
Q:'$L($G(LEXRT)) Q:'$L($G(LEXSAB)) Q:'$L($G(LEXFID)) Q:'$L($G(LEXASRC)) Q:'$L(LEXKEY)
Q:$D(@(LEXRT_+LEXIIEN_",68,"_+LEXHIEN_",2,""B"","""_LEXKEY_""")"))
S LEXP3=$O(@(LEXRT_+LEXIIEN_",68,"_+LEXHIEN_",2,"" "")"),-1),(LEXKIEN,LEXP3)=LEXP3+1
S LEXP4=$P($G(@(LEXRT_+LEXIIEN_",68,"_+LEXHIEN_",2,0)")),"^",4),LEXP4=LEXP4+1
S @(LEXRT_+LEXIIEN_",68,"_+LEXHIEN_",2,"_+LEXKIEN_",0)")=LEXKEY
S @(LEXRT_+LEXIIEN_",68,"_+LEXHIEN_",2,0)")="^"_LEXFID_"^"_+LEXP3_"^"_+LEXP4
K DA,DIK S DA(2)=LEXIIEN,DA(1)=LEXHIEN,DA=LEXKIEN
S DIK=LEXRT_DA(2)_",68,"_DA(1)_",2," D IX1^DIK
Q
;
; Miscellaneous
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
DEXP ; Display Expression
Q:$D(LEXQUIET) Q:$D(ZTQUEUED) Q:'$L(LEXEXP) Q:'$L(LEXINC) Q:'$L(LEXKEY) Q:'$L($G(LEXRT))
N LEXS,LEXT S LEXS=$P($G(@(LEXRT_+LEXIIEN_","_+LEXIIEN_",1)")),"^",1)
S:LEXS=1!(LEXS=30) LEXT="ICD Grouper Diagnosis (80)" S:LEXS=2!(LEXS=31) LEXT="ICD Grouper Procedure (80.1)"
W:$L($G(LEXT)) !,"Type: ",LEXT W:$D(LEXSYS) !,"System: ",LEXSYS
W !,"Expression: ",LEXEXP,!,"Include/Keyword: ",LEXINC,"/",LEXKEY
I +($G(LEXIIEN))>0,$L($G(LEXRT)) W !,"IEN: ",LEXRT,LEXIIEN,","
W !
Q
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 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[HLEXWUI 5855 printed Dec 13, 2024@02:09:58 Page 2
LEXWUI ;ISL/KER - Lexicon Keywords - Update (ICD) ;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.03, 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
+17 ; Control
+18 ; LEXCHK Word to check for
+19 ; LEXKEY Keyword to add if found
+20 ; LEXINC Text that must be included in term
+21 ; LEXEXC Text that must be excluded from the term
+22 ; LEXCOM Commit Flag
+23 ; LEXTD Today's Date
+24 ; ZTQUEUED TaskMan
+25 ; ZTREQ TaskMan
+26 ; LEXQUIET For testing only
+27 ; Counters
+28 ; LEXI01C ICD-9 Diagnosis Counter
+29 ; LEXI02C ICD-9 Procedure Counter
+30 ; LEXI30C ICD-10 Diagnosis Counter
+31 ; LEXI31C ICD-10 Procedure Counter
+32 ; LEXICDC ICD Diagnosis Counter
+33 ; LEXICPC ICD Procedure Counter
+34 ;
+35 QUIT
IDP ; ICD Diagnosis/Procedures
+1 if $DATA(ZTQUEUED)
SET ZTREQ="@"
NEW LEXDIC
FOR LEXDIC=80,80.1
Begin DoDot:1
+2 NEW LEXRT,LEXFI,LEXFID,LEXASRC
IF LEXDIC=80
SET LEXRT="^ICD9("
SET LEXFI=LEXDIC
SET LEXFID="80.682"
SET LEXASRC="^1^30^"
+3 IF LEXDIC=80.1
SET LEXRT="^ICD0("
SET LEXFI=LEXDIC
SET LEXFID="80.1682"
SET LEXASRC="^2^31^"
+4 if +($GET(LEXFI))'>0
QUIT
if '$LENGTH($GET(LEXRT))
QUIT
if '$LENGTH($GET(LEXFID))
QUIT
if '$LENGTH($GET(LEXASRC))
QUIT
DO IFI
End DoDot:1
+5 QUIT
IFI ; ICD by File #
+1 if $GET(LEXTD)'?7N
QUIT
if '$LENGTH($GET(LEXKEY))
QUIT
if '$LENGTH($GET(LEXCHK))
QUIT
if '$LENGTH($GET(LEXINC))
QUIT
+2 NEW LEXSI,LEXSRC,LEXTMP
FOR LEXSI=2:1
SET LEXSRC=$PIECE(LEXASRC,"^",LEXSI)
if '$LENGTH(LEXSRC)
QUIT
if $$ABT
QUIT
DO ISR
if $$ABT
QUIT
+3 QUIT
ISR ; ICD by Source
+1 NEW LEXALT,LEXCTL,LEXPRI,LEXSAB,LEXSYS
SET LEXPRI=LEXCHK
SET LEXALT=""
DO SPC
+2 SET LEXSYS=$$SYS(LEXSRC)
SET LEXSAB=$EXTRACT($GET(^LEX(757.03,+LEXSRC,0)),1,3)
if $LENGTH(LEXSAB)'=3
QUIT
+3 FOR LEXCTL=LEXPRI,LEXALT
if $LENGTH(LEXCTL)
DO ISC
+4 QUIT
ISC ; ICD by Check Word
+1 NEW LEXIIEN
SET LEXIIEN=0
FOR
SET LEXIIEN=$ORDER(@(LEXRT_"""AD"","_+LEXSRC_","""_LEXCTL_""","_LEXIIEN_")"))
if +LEXIIEN'>0
QUIT
if $$ABT
QUIT
DO IIE
if $$ABT
QUIT
+2 QUIT
IIE ; ICD by IEN
+1 NEW LEXEFF,LEXHIEN,LEXEXP,LEXCT,LEXIN,LEXI,LEXTMP,LEXTYPE,LEXFIL
+2 SET LEXHIEN=0
FOR
SET LEXHIEN=$ORDER(@(LEXRT_+LEXIIEN_",68,"_LEXHIEN_")"))
if +LEXHIEN'>0
QUIT
DO IEX
+3 QUIT
IEX ; ICD by Expression
+1 SET LEXEXP=$$UP^XLFSTR($GET(@(LEXRT_+LEXIIEN_",68,"_+LEXHIEN_",1)")))
if '$LENGTH(LEXEXP)
QUIT
+2 if $DATA(@(LEXRT_+LEXIIEN_",68,"_+LEXHIEN_",2,""B"","""_LEXKEY_""")"))
QUIT
+3 ; Term contains ALL Includes
+4 SET (LEXCT,LEXIN)=0
Begin DoDot:1
+5 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
+6 ; Term contains Excludes
+7 IF $LENGTH($GET(LEXEXC))
SET LEXIN=0
Begin DoDot:1
+8 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
+9 if LEXSRC=1
SET LEXI01C=+($GET(LEXI01C))+1
if LEXSRC=30
SET LEXI30C=+($GET(LEXI30C))+1
+10 if LEXSRC=2
SET LEXI02C=+($GET(LEXI02C))+1
if LEXSRC=31
SET LEXI31C=+($GET(LEXI31C))+1
+11 SET LEXICDC=+($GET(LEXI01C))+($GET(LEXI30C))
SET LEXICPC=+($GET(LEXI02C))+($GET(LEXI31C))
+12 DO DEXP
IF $DATA(LEXCOM)
DO IIS
+13 QUIT
IIS ; ICD Set
+1 NEW DA,DIK,LEXKIEN,LEXP3,LEXP4
if +($GET(LEXIIEN))'>0
QUIT
if +($GET(LEXHIEN))'>0
QUIT
if '$LENGTH($GET(LEXKEY))
QUIT
+2 SET LEXDIC=$GET(LEXDIC)
if "^80^80.1^"'[("^"_LEXDIC_"^")
QUIT
+3 IF LEXDIC=80
if '$LENGTH(LEXRT)
SET LEXRT="^ICD9("
if '$LENGTH(LEXFID)
SET LEXFID="80.682"
if '$LENGTH(LEXASRC)
SET LEXASRC="^1^30^"
+4 IF LEXDIC=80.1
if '$LENGTH(LEXRT)
SET LEXRT="^ICD0("
if '$LENGTH(LEXFID)
SET LEXFID="80.1682"
if '$LENGTH(LEXASRC)
SET LEXASRC="^2^31^"
+5 if '$LENGTH($GET(LEXRT))
QUIT
if '$LENGTH($GET(LEXSAB))
QUIT
if '$LENGTH($GET(LEXFID))
QUIT
if '$LENGTH($GET(LEXASRC))
QUIT
if '$LENGTH(LEXKEY)
QUIT
+6 if $DATA(@(LEXRT_+LEXIIEN_",68,"_+LEXHIEN_",2,""B"","""_LEXKEY_""")"))
QUIT
+7 SET LEXP3=$ORDER(@(LEXRT_+LEXIIEN_",68,"_+LEXHIEN_",2,"" "")"),-1)
SET (LEXKIEN,LEXP3)=LEXP3+1
+8 SET LEXP4=$PIECE($GET(@(LEXRT_+LEXIIEN_",68,"_+LEXHIEN_",2,0)")),"^",4)
SET LEXP4=LEXP4+1
+9 SET @(LEXRT_+LEXIIEN_",68,"_+LEXHIEN_",2,"_+LEXKIEN_",0)")=LEXKEY
+10 SET @(LEXRT_+LEXIIEN_",68,"_+LEXHIEN_",2,0)")="^"_LEXFID_"^"_+LEXP3_"^"_+LEXP4
+11 KILL DA,DIK
SET DA(2)=LEXIIEN
SET DA(1)=LEXHIEN
SET DA=LEXKIEN
+12 SET DIK=LEXRT_DA(2)_",68,"_DA(1)_",2,"
DO IX1^DIK
+13 QUIT
+14 ;
+15 ; Miscellaneous
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
DEXP ; Display Expression
+1 if $DATA(LEXQUIET)
QUIT
if $DATA(ZTQUEUED)
QUIT
if '$LENGTH(LEXEXP)
QUIT
if '$LENGTH(LEXINC)
QUIT
if '$LENGTH(LEXKEY)
QUIT
if '$LENGTH($GET(LEXRT))
QUIT
+2 NEW LEXS,LEXT
SET LEXS=$PIECE($GET(@(LEXRT_+LEXIIEN_","_+LEXIIEN_",1)")),"^",1)
+3 if LEXS=1!(LEXS=30)
SET LEXT="ICD Grouper Diagnosis (80)"
if LEXS=2!(LEXS=31)
SET LEXT="ICD Grouper Procedure (80.1)"
+4 if $LENGTH($GET(LEXT))
WRITE !,"Type: ",LEXT
if $DATA(LEXSYS)
WRITE !,"System: ",LEXSYS
+5 WRITE !,"Expression: ",LEXEXP,!,"Include/Keyword: ",LEXINC,"/",LEXKEY
+6 IF +($GET(LEXIIEN))>0
IF $LENGTH($GET(LEXRT))
WRITE !,"IEN: ",LEXRT,LEXIIEN,","
+7 WRITE !
+8 QUIT
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
SET LEXNM=$$GET1^DIQ(200,(DUZ_","),.01)
+3 IF '$LENGTH(LEXNM)
WRITE !!,?5,"Invalid/Missing DUZ"
QUIT 0
+4 QUIT 1
