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

LEXWUI.m

Go to the documentation of this file.
  1. LEXWUI ;ISL/KER - Lexicon Keywords - Update (ICD) ;05/23/2017
  1. ;;2.0;LEXICON UTILITY;**103**;Sep 23, 1996;Build 2
  1. ;
  1. ; Global Variables
  1. ; ^ICD0( ICR 4486
  1. ; ^ICD9( ICR 4485
  1. ; ^LEX(757.03, SACC 1.3
  1. ; ^TMP("LEXWU",$J) SACC 2.3.2.5.1
  1. ;
  1. ; External References
  1. ; HOME^%ZIS ICR 10086
  1. ; IX1^DIK ICR 10013
  1. ; $$GET1^DIQ ICR 2056
  1. ; $$DT^XLFDT ICR 10103
  1. ; $$UP^XLFSTR ICR 10011
  1. ;
  1. ; Local Variables NEWed or KILLed Elsewhere
  1. ; Control
  1. ; LEXCHK Word to check for
  1. ; LEXKEY Keyword to add if found
  1. ; LEXINC Text that must be included in term
  1. ; LEXEXC Text that must be excluded from the term
  1. ; LEXCOM Commit Flag
  1. ; LEXTD Today's Date
  1. ; ZTQUEUED TaskMan
  1. ; ZTREQ TaskMan
  1. ; LEXQUIET For testing only
  1. ; Counters
  1. ; LEXI01C ICD-9 Diagnosis Counter
  1. ; LEXI02C ICD-9 Procedure Counter
  1. ; LEXI30C ICD-10 Diagnosis Counter
  1. ; LEXI31C ICD-10 Procedure Counter
  1. ; LEXICDC ICD Diagnosis Counter
  1. ; LEXICPC ICD Procedure Counter
  1. ;
  1. Q
  1. IDP ; ICD Diagnosis/Procedures
  1. S:$D(ZTQUEUED) ZTREQ="@" N LEXDIC F LEXDIC=80,80.1 D
  1. . N LEXRT,LEXFI,LEXFID,LEXASRC I LEXDIC=80 S LEXRT="^ICD9(",LEXFI=LEXDIC,LEXFID="80.682",LEXASRC="^1^30^"
  1. . I LEXDIC=80.1 S LEXRT="^ICD0(",LEXFI=LEXDIC,LEXFID="80.1682",LEXASRC="^2^31^"
  1. . Q:+($G(LEXFI))'>0 Q:'$L($G(LEXRT)) Q:'$L($G(LEXFID)) Q:'$L($G(LEXASRC)) D IFI
  1. Q
  1. IFI ; ICD by File #
  1. Q:$G(LEXTD)'?7N Q:'$L($G(LEXKEY)) Q:'$L($G(LEXCHK)) Q:'$L($G(LEXINC))
  1. N LEXSI,LEXSRC,LEXTMP F LEXSI=2:1 S LEXSRC=$P(LEXASRC,"^",LEXSI) Q:'$L(LEXSRC) Q:$$ABT D ISR Q:$$ABT
  1. Q
  1. ISR ; ICD by Source
  1. N LEXALT,LEXCTL,LEXPRI,LEXSAB,LEXSYS S LEXPRI=LEXCHK,LEXALT="" D SPC
  1. S LEXSYS=$$SYS(LEXSRC) S LEXSAB=$E($G(^LEX(757.03,+LEXSRC,0)),1,3) Q:$L(LEXSAB)'=3
  1. F LEXCTL=LEXPRI,LEXALT D:$L(LEXCTL) ISC
  1. Q
  1. ISC ; ICD by Check Word
  1. N LEXIIEN S LEXIIEN=0 F S LEXIIEN=$O(@(LEXRT_"""AD"","_+LEXSRC_","""_LEXCTL_""","_LEXIIEN_")")) Q:+LEXIIEN'>0 Q:$$ABT D IIE Q:$$ABT
  1. Q
  1. IIE ; ICD by IEN
  1. N LEXEFF,LEXHIEN,LEXEXP,LEXCT,LEXIN,LEXI,LEXTMP,LEXTYPE,LEXFIL
  1. S LEXHIEN=0 F S LEXHIEN=$O(@(LEXRT_+LEXIIEN_",68,"_LEXHIEN_")")) Q:+LEXHIEN'>0 D IEX
  1. Q
  1. IEX ; ICD by Expression
  1. S LEXEXP=$$UP^XLFSTR($G(@(LEXRT_+LEXIIEN_",68,"_+LEXHIEN_",1)"))) Q:'$L(LEXEXP)
  1. Q:$D(@(LEXRT_+LEXIIEN_",68,"_+LEXHIEN_",2,""B"","""_LEXKEY_""")"))
  1. ; Term contains ALL Includes
  1. S (LEXCT,LEXIN)=0 D Q:LEXIN'>0 Q:LEXCT'=LEXIN
  1. . 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
  1. ; Term contains Excludes
  1. I $L($G(LEXEXC)) S LEXIN=0 D Q:LEXIN>0
  1. . S LEXIN=0 I $L($G(LEXEXC)) F LEXI=1:1 S LEXTMP=$P(LEXEXC,";",LEXI) Q:'$L(LEXTMP) S:LEXEXP[LEXTMP LEXIN=1
  1. S:LEXSRC=1 LEXI01C=+($G(LEXI01C))+1 S:LEXSRC=30 LEXI30C=+($G(LEXI30C))+1
  1. S:LEXSRC=2 LEXI02C=+($G(LEXI02C))+1 S:LEXSRC=31 LEXI31C=+($G(LEXI31C))+1
  1. S LEXICDC=+($G(LEXI01C))+($G(LEXI30C)) S LEXICPC=+($G(LEXI02C))+($G(LEXI31C))
  1. D DEXP I $D(LEXCOM) D IIS
  1. Q
  1. IIS ; ICD Set
  1. N DA,DIK,LEXKIEN,LEXP3,LEXP4 Q:+($G(LEXIIEN))'>0 Q:+($G(LEXHIEN))'>0 Q:'$L($G(LEXKEY))
  1. S LEXDIC=$G(LEXDIC) Q:"^80^80.1^"'[("^"_LEXDIC_"^")
  1. I LEXDIC=80 S:'$L(LEXRT) LEXRT="^ICD9(" S:'$L(LEXFID) LEXFID="80.682" S:'$L(LEXASRC) LEXASRC="^1^30^"
  1. I LEXDIC=80.1 S:'$L(LEXRT) LEXRT="^ICD0(" S:'$L(LEXFID) LEXFID="80.1682" S:'$L(LEXASRC) LEXASRC="^2^31^"
  1. Q:'$L($G(LEXRT)) Q:'$L($G(LEXSAB)) Q:'$L($G(LEXFID)) Q:'$L($G(LEXASRC)) Q:'$L(LEXKEY)
  1. Q:$D(@(LEXRT_+LEXIIEN_",68,"_+LEXHIEN_",2,""B"","""_LEXKEY_""")"))
  1. S LEXP3=$O(@(LEXRT_+LEXIIEN_",68,"_+LEXHIEN_",2,"" "")"),-1),(LEXKIEN,LEXP3)=LEXP3+1
  1. S LEXP4=$P($G(@(LEXRT_+LEXIIEN_",68,"_+LEXHIEN_",2,0)")),"^",4),LEXP4=LEXP4+1
  1. S @(LEXRT_+LEXIIEN_",68,"_+LEXHIEN_",2,"_+LEXKIEN_",0)")=LEXKEY
  1. S @(LEXRT_+LEXIIEN_",68,"_+LEXHIEN_",2,0)")="^"_LEXFID_"^"_+LEXP3_"^"_+LEXP4
  1. K DA,DIK S DA(2)=LEXIIEN,DA(1)=LEXHIEN,DA=LEXKIEN
  1. S DIK=LEXRT_DA(2)_",68,"_DA(1)_",2," D IX1^DIK
  1. Q
  1. ;
  1. ; Miscellaneous
  1. IN(X,Y) ; Is X in Y
  1. N LEXC,LEXE,LEXP,LEXO S LEXO=0 S LEXC=$G(X),LEXE=$G(Y) Q:$E(LEXE,1,$L(LEXC))=LEXC 1
  1. F LEXP=" ","-","[","(","&","+","/","," S:LEXE[(LEXP_LEXC) LEXO=1
  1. S X=LEXO
  1. Q X
  1. DEXP ; Display Expression
  1. Q:$D(LEXQUIET) Q:$D(ZTQUEUED) Q:'$L(LEXEXP) Q:'$L(LEXINC) Q:'$L(LEXKEY) Q:'$L($G(LEXRT))
  1. N LEXS,LEXT S LEXS=$P($G(@(LEXRT_+LEXIIEN_","_+LEXIIEN_",1)")),"^",1)
  1. S:LEXS=1!(LEXS=30) LEXT="ICD Grouper Diagnosis (80)" S:LEXS=2!(LEXS=31) LEXT="ICD Grouper Procedure (80.1)"
  1. W:$L($G(LEXT)) !,"Type: ",LEXT W:$D(LEXSYS) !,"System: ",LEXSYS
  1. W !,"Expression: ",LEXEXP,!,"Include/Keyword: ",LEXINC,"/",LEXKEY
  1. I +($G(LEXIIEN))>0,$L($G(LEXRT)) W !,"IEN: ",LEXRT,LEXIIEN,","
  1. W !
  1. Q
  1. SPC ; Special Cases
  1. S LEXALT="" S:LEXKEY="XRAY" LEXALT=LEXKEY S:LEXKEY="ECOLI" LEXALT=LEXKEY
  1. Q
  1. SYS(X) ; System
  1. N LEXSRC S LEXSRC=$G(X) S X="" S:LEXSRC=1 X="ICD-9-CM" S:LEXSRC=2 X="ICD-9 Proc"
  1. S:LEXSRC=30 X="ICD-10-CM" S:LEXSRC=31 X="ICD-10-PCS"
  1. S:LEXSRC=3 X="CPT-4" S:LEXSRC=4 X="HCPCS"
  1. S:LEXSRC=17 X="Title 38" S:LEXSRC=56 X="SNOMED CT"
  1. Q X
  1. TM(X,Y) ; Trim Character Y - Default " "
  1. S X=$G(X) Q:X="" X S Y=$G(Y) S:'$L(Y) Y=" "
  1. F Q:$E(X,1)'=Y S X=$E(X,2,$L(X))
  1. F Q:$E(X,$L(X))'=Y S X=$E(X,1,($L(X)-1))
  1. Q X
  1. ABT(X) ; Abort
  1. Q:$D(^TMP("LEXWU",$J,"STOP")) 1
  1. Q 0
  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