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