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

LEX10TAX.m

Go to the documentation of this file.
  1. LEX10TAX ;ISL/KER - Post ICD-10 Taxonomy Look-up ;05/23/2017
  1. ;;2.0;LEXICON UTILITY;**80,86,103**;Sep 23, 1996;Build 2
  1. ;
  1. ; Global Variables
  1. ; ^LEX(757.01 N/A
  1. ; ^LEX(757.02 N/A
  1. ; ^LEX(757.03 N/A
  1. ; ^TMP("LEXFND" SACC 2.3.2.5.1
  1. ; ^TMP("LEXHIT" SACC 2.3.2.5.1
  1. ; ^TMP("LEXSCH" SACC 2.3.2.5.1
  1. ; ^TMP(LEX10 SACC 2.3.2.5.1
  1. ;
  1. ; External References
  1. ; LOOK^LEXA ICR 2950
  1. ; CONFIG^LEXSET ICR 1609
  1. ; $$STATCHK^LEXSRC2 ICR 4083
  1. ; $$DT^XLFDT ICR 10103
  1. ; $$FMTE^XLFDT ICR 10103
  1. ;
  1. Q
  1. TAX(X,LEXSRC,LEXDT,LEXSUB,LEXVER) ; Get Taxonomy Information
  1. ;
  1. ; Input:
  1. ;
  1. ; X Search String
  1. ;
  1. ; LEXSRC String of Sources
  1. ; Delimited by an "^" Up-Arrow
  1. ;
  1. ; Using source abbreviations
  1. ; "ICD^ICP^10D^10P"
  1. ;
  1. ; Using source pointers to file 757.03
  1. ; "1^2^30^31"
  1. ;
  1. ; Using Nomenclature
  1. ; "ICD-9-CM^ICD-9 Proc^ICD-10-CM^ICD-10 Proc
  1. ;
  1. ; LEXDT Date to use to evaluate status
  1. ;
  1. ; LEXSUB Name of a subscript to use in the ^TMP
  1. ; global (optional)
  1. ;
  1. ; ^TMP(LEXSUB,$J,
  1. ; ^TMP("LEXTAX",$J, Default
  1. ;
  1. ; LEXVER Versioning Flag (optional, default = 0)
  1. ;
  1. ; 0 Return active and inactive codes
  1. ; 1 Version, return active codes only
  1. ;
  1. ; Output:
  1. ;
  1. ; $$TAX The number of codes found or -1 ^ error message
  1. ;
  1. ; ^TMP(LEXSUB,$J,SRC,(CODE_" "),#)
  1. ;
  1. ; 5 piece "^" delimited string
  1. ;
  1. ; 1 Activation Date (can be a future date)
  1. ; 2 Inactivation Date (can be a future date)
  1. ; 3 Lexicon IEN to Expression File 757.01
  1. ; 4 Variable Pointer to a National file
  1. ; 5 Short Name from a National file
  1. ;
  1. ; ^TMP(LEXSUB,$J,SRC,(CODE_" "),#,0)
  1. ;
  1. ; 2 piece "^" delimited string
  1. ;
  1. ; 1 Code (no spaces)
  1. ; 2 Lexicon Expression
  1. ;
  1. ; Subscript SRC is a pointer to the CODING SYSTEM FILE 757.03
  1. ;
  1. N LEX,LEXX,LEXIS,LEXVDT,LEX10SUB S LEXX=$$UP^XLFSTR($G(X)) Q:$L(LEXX)'>1 "-1^Search Text Missing"
  1. S LEXVDT="" S:$P($G(LEXDT),".",1)'?7N LEXDT=$$DT^XLFDT
  1. S:$P($G(LEXDT),".",1)?7N LEXVDT=$P($G(LEXDT),".",1)
  1. S LEXSRC=$$SRC($G(LEXSRC))
  1. S LEX10SUB=$G(LEXSUB) S:'$L(LEX10SUB) LEX10SUB="LEXTAX"
  1. S LEXIS=$$IS(LEXX),LEXVER=+($G(LEXVER)) D:LEXIS LBC D:'LEXIS LBT
  1. S X=+($G(^TMP(LEX10SUB,$J,0))) S:X'>0 X="-1^No Entries Found"
  1. Q X
  1. LBC ; Lookup by Code
  1. N LEXCTL,LEXORD S LEXCTL=LEXX,LEXORD=$E(LEXX,1,($L(LEXX)-1))_$C($A($E(LEXX,$L(LEXX)))-1)_"~ "
  1. F S LEXORD=$O(^LEX(757.02,"CODE",LEXORD)) Q:'$L(LEXORD)!($E(LEXORD,1,$L(LEXCTL))'=LEXCTL) D
  1. . N LEXSIEN S LEXSIEN=0
  1. . F S LEXSIEN=$O(^LEX(757.02,"CODE",LEXORD,LEXSIEN)) Q:+LEXSIEN'>0 D
  1. . . N LEXND,LEXIEN,LEXCD,LEXPF,LEXTY,LEXSR S LEXND=$G(^LEX(757.02,+LEXSIEN,0)),LEXIEN=+LEXND
  1. . . S LEXCD=$P(LEXND,"^",2),LEXPF=$P(LEXND,"^",5),LEXSR=$P(LEXND,"^",3)
  1. . . Q:("^"_LEXSRC_"^")'[("^"_LEXSR_"^")
  1. . . S LEXTY=$P($G(^LEX(757.01,+LEXIEN,1)),"^",2)
  1. . . Q:LEXTY'=1 Q:LEXPF'>0 Q:$E(LEXCD,1,$L(LEXCTL))'=LEXCTL D ES(LEXIEN,$G(LEXVDT))
  1. D REO D:+($G(^TMP(LEX10SUB,$J,0)))'>0 LBT
  1. Q
  1. LBT ; Looup by Text
  1. K ^TMP("LEXSCH",$J),^TMP("LEXFND",$J),^TMP("LEXHIT",$J),LEX
  1. N LEXTMP,LEXFQ,LEXIEN,DIC,LEXSAB S DIC="^LEX(757.01,",LEXTMP=$G(LEXVDT)
  1. D CONFIG^LEXSET("PXRM","CR1")
  1. S ^TMP("LEXSCH",$J,"ADF",0)=1 S ^TMP("LEXSCH",$J,"FIL",0)="I 1"
  1. S ^TMP("LEXSCH",$J,"FIL",1)="ALL" S ^TMP("LEXSCH",$J,"LEN",0)=1
  1. K LEXVDT D LOOK^LEXA(LEXX,"PXRM",1,"CR1") S:LEXTMP?7N LEXVDT=LEXTMP
  1. S LEXIEN=+$G(LEX("LIST",1)) D:LEXIEN>0 ES(LEXIEN,$G(LEXTMP))
  1. S LEXFQ="" F S LEXFQ=$O(^TMP("LEXFND",$J,LEXFQ)) Q:'$L(LEXFQ) D
  1. . S LEXIEN=0 F S LEXIEN=$O(^TMP("LEXFND",$J,LEXFQ,LEXIEN)) Q:+LEXIEN'>0 D
  1. . . K LEXCTL D ES(LEXIEN)
  1. K ^TMP("LEXSCH",$J),^TMP("LEXFND",$J),^TMP("LEXHIT",$J),LEX D REO
  1. Q
  1. ES(X,Y) ; Expression to Code
  1. N LEXIEN,LEXSIEN,LEXDT S LEXIEN=+($G(X)) Q:+LEXIEN'>0 S LEXDT=$P($G(Y),".",1) S:LEXDT'?7N LEXDT=$$DT^XLFDT
  1. S LEXSIEN=0 F S LEXSIEN=$O(^LEX(757.02,"B",LEXIEN,LEXSIEN)) Q:+LEXSIEN'>0 D
  1. . N LEXND,LEXV,LEXEF,LEXHI,LEXST,LEXCO,LEXSR,LEXSB,LEXNM,X,LEX,LEXCT,LEXCD,LEXFIL
  1. . S LEXV=1,LEXND=$G(^LEX(757.02,+LEXSIEN,0)),LEXCD=$P(LEXND,"^",2),LEXSR=$P(LEXND,"^",3)
  1. . Q:("^"_LEXSRC_"^")'[("^"_LEXSR_"^")
  1. . I 0 I LEXSR=56 S LEXFIL=$$SCT(LEXIEN,LEXDT) Q:LEXFIL'>0
  1. . Q:'$L(LEXCD) Q:+LEXSR'>0 Q:'$D(^LEX(757.03,+LEXSR,0))
  1. . I +($G(LEXVER))>0,$G(LEXVDT)?7N D Q:LEXV'>0
  1. . . N LEXST S LEXST=$$STATCHK^LEXSRC2(LEXCD,LEXVDT,,LEXSR) S:+LEXST'>0 LEXV=0
  1. . Q:$D(^TMP(LEX10SUB,$J,+LEXSR,(LEXCD_" "))) S X=$$PERIOD^LEXU(LEXCD,+LEXSR,.LEX)
  1. . S LEXCT=0,LEXEF=0 F S LEXEF=$O(LEX(LEXEF)) Q:+LEXEF'>0 D
  1. . . Q:LEXEF'?7N N LEXND,LEXDD S LEXND=$G(LEX(LEXEF)),LEXDD=$G(LEX(LEXEF,0))
  1. . . Q:$P(LEXND,"^",2)'>0 Q:'$L(LEXDD) S LEXCT=LEXCT+1
  1. . . I '$D(^TMP(LEX10SUB,$J,+LEXSR,(LEXCD_" "))) D
  1. . . . S ^TMP(LEX10SUB,$J,0)=$G(^TMP(LEX10SUB,$J,0))+1
  1. . . S ^TMP(LEX10SUB,$J,+LEXSR,(LEXCD_" "),LEXCT)=LEXEF_"^"_LEXND
  1. . . S ^TMP(LEX10SUB,$J,+LEXSR,(LEXCD_" "),LEXCT,0)=LEXCD_"^"_LEXDD
  1. Q
  1. REO ; Reorder Array
  1. N LEXKEY S LEXKEY="" F S LEXKEY=$O(^TMP(LEX10SUB,$J,"IN",LEXKEY)) Q:'$L(LEXKEY) D
  1. . N LEXCD S LEXCD="" F S LEXCD=$O(^TMP(LEX10SUB,$J,"IN",LEXKEY,LEXCD)) Q:'$L(LEXCD) D
  1. . . N LEXND,LEXSB,LEXI S LEXND=$G(^TMP(LEX10SUB,$J,"IN",LEXKEY,LEXCD))
  1. . . S LEXSB=$P(LEXND,"^",7) Q:'$L(LEXSB) S LEXSR=$P(LEXND,"^",6) Q:+LEXSR'>0
  1. . . S LEXI=$O(^TMP(LEX10SUB,$J,LEXSR," "),-1)+1 S ^TMP(LEX10SUB,$J,LEXSR,LEXI)=LEXND
  1. K ^TMP(LEX10SUB,$J,"IN")
  1. Q
  1. IS(X) ; Is a Code
  1. S X=$G(X) Q:'$L(X) 0
  1. Q:$D(^LEX(757.02,"CODE",(X_" "))) 1
  1. Q:$O(^LEX(757.02,"CODE",(X_" ")))[X 1
  1. Q 0
  1. SRC(X) ; Re-Create Source String
  1. N LEXX,LEXN,LEXI S LEXN="" S LEXX=$G(X) Q:'$L(LEXX) "ALL"
  1. F LEXI=1:1 Q:'$L($P(LEXX,"^",LEXI)) D
  1. . N LEXSB,LEXSR S LEXSB=$P(LEXX,"^",LEXI)
  1. . S LEXSR=$$CS(LEXSB) S:+LEXSR>0 LEXN=LEXN_"^"_+LEXSR
  1. S X=$$TM(LEXN,"^")
  1. Q X
  1. CS(X) ; Coding System
  1. N LEXIN S LEXIN=$G(X) Q:'$L(LEXIN) ""
  1. Q:LEXIN?1N.N&($D(^LEX(757.03,+LEXIN,0))) +LEXIN
  1. Q:$D(^LEX(757.03,"ASAB",LEXIN))&($O(^LEX(757.03,"ASAB",LEXIN,0))>0) $O(^LEX(757.03,"ASAB",LEXIN,0))
  1. Q:$D(^LEX(757.03,"B",LEXIN))&($O(^LEX(757.03,"B",LEXIN,0))>0) $O(^LEX(757.03,"B",LEXIN,0))
  1. Q:$D(^LEX(757.03,"C",LEXIN))&($O(^LEX(757.03,"C",LEXIN,0))>0) $O(^LEX(757.03,"C",LEXIN,0))
  1. Q ""
  1. ;
  1. ; Miscellaneous
  1. SCT(LEX,LEXVDT) ; Filter by SNOMED CT (SCT) (Human only)
  1. ;
  1. ; Input
  1. ;
  1. ; LEX IEN of file 757.01
  1. ; LEXVDT Date to use for screening by codes
  1. ;
  1. ; Output
  1. ;
  1. ; $$SCT Human SNOMED Code or Null
  1. ; Excludes Veterinary SNOMED codes
  1. ;
  1. N LEXEX,LEXMC,LEXD,LEXC,LEXI,LEXO,LEXPL,LEXVT S LEXEX=+($G(LEX)),LEXD=$G(LEXVDT) Q:LEXEX'>0 0
  1. S LEXC=$S(LEXD?7N:$$ONE^LEXU(+LEXEX,LEXD,"SCT"),1:$$ONE^LEXU(+LEXEX,,"SCT"))
  1. Q:'$L(LEXC) 0 S LEXMC=+($G(^LEX(757.01,+LEXEX,1))) Q:LEXMC'>0 0 Q:'$D(^LEX(757.1,"B",LEXMC)) 0
  1. S LEXVT=0,LEXI=0 F S LEXI=$O(^LEX(757.1,"B",LEXMC,LEXI)) Q:+LEXI'>0 D Q:LEXVT>0
  1. . N LEXT,LEXN S LEXT=$P($G(^LEX(757.1,LEXI,0)),"^",3),LEXN=$$UP^XLFSTR($P($G(^LEX(757.12,+LEXT,0)),"^",2)) S:LEXN["VETERINARY" LEXVT=1
  1. S LEXPL=0,LEXI=0 F S LEXI=$O(^LEX(757.21,"B",LEXEX,LEXI)) Q:+LEXI'>0 D Q:LEXPL>0
  1. . N LEXT,LEXN S LEXT=$P($G(^LEX(757.21,LEXI,0)),"^",2),LEXN=$P($G(^LEXT(757.2,+LEXT,0)),"^",2) S:LEXN="PLS" LEXPL=1
  1. S LEXO=1 S:LEXVT=1 LEXO=0 S:LEXPL'>0 LEXO=0
  1. S X=LEXO
  1. Q X
  1. SHO ; Show ^TMP global
  1. N LEXNN,LEXNC,LEXS S LEXS=$G(LEXSUB) S:'$L(LEXS) LEXS="LEXTAX"
  1. S LEXNN="^TMP("""_LEXS_""","_$J_")",LEXNC="^TMP("""_LEXS_""","_$J_","
  1. F S LEXNN=$Q(@LEXNN) Q:'$L(LEXNN)!(LEXNN'[LEXNC) D
  1. . N LEXND S LEXND=@LEXNN W !,LEXNN,"=",LEXND
  1. Q
  1. EXP ; Show ^TMP global (expanded display)
  1. N LEXN1,LEXN2,LEXN3,LEXNN,LEXNC,LEXS,LEXTD S LEXS=$G(LEXSUB) S:'$L(LEXS) LEXS="LEXTAX"
  1. S LEXTD=$$DT^XLFDT,LEXN1=0 F S LEXN1=$O(^TMP(LEXS,$J,LEXN1)) Q:+LEXN1'>0 D
  1. . N LEXSNM Q:'$D(^LEX(757.03,LEXN1,0))
  1. . S LEXSNM=$P($G(^LEX(757.03,LEXN1,0)),"^",2) Q:'$L(LEXSNM)
  1. . S LEXN2="" F S LEXN2=$O(^TMP(LEXS,$J,LEXN1,LEXN2)) Q:'$L(LEXN2) D
  1. . . W !,?3,LEXSNM," Code: ",LEXN2
  1. . . S LEXN3=0 F S LEXN3=$O(^TMP(LEXS,$J,LEXN1,LEXN2,LEXN3)) Q:+LEXN3'>0 D
  1. . . . N LEXN,LEX0,LEXAC,LEXIN,LEXIE,LEXVP,LEXSN,LEXCD,LEXNM,LEXA,LEXI
  1. . . . S LEXN=$G(^TMP(LEXS,$J,LEXN1,LEXN2,LEXN3))
  1. . . . S LEX0=$G(^TMP(LEXS,$J,LEXN1,LEXN2,LEXN3,0))
  1. . . . S LEXAC=$P(LEXN,"^",1),LEXIN=$P(LEXN,"^",2)
  1. . . . S LEXIE=$P(LEXN,"^",3),LEXVP=$P(LEXN,"^",4)
  1. . . . S LEXSN=$P(LEXN,"^",5)
  1. . . . W !,?5,"Active: ",$$ED(LEXAC) W:LEXAC>LEXTD " (Pending)"
  1. . . . W ?36,"Inactive: ",$$ED(LEXIN) W:LEXIN>LEXTD " (Pending)"
  1. . . . S LEX0=$G(^TMP(LEXS,$J,LEXN1,LEXN2,LEXN3,0))
  1. . . . S LEXCD=$P(LEX0,"^",1)
  1. . . . S LEXNM=$P(LEX0,"^",2) S LEXA(1)=LEXNM D PR^LEXU(.LEXA,(79-36))
  1. . . . W !,?5," IEN: ",LEXIE W:$L($G(LEXA(1))) ?36,$G(LEXA(1))
  1. . . . S LEXI=1 F S LEXI=$O(LEXA(LEXI)) Q:+LEXI'>0 W:$L($G(LEXA(LEXI))) !,?36,$G(LEXA(LEXI))
  1. Q
  1. ED(X) ; Exernal Date
  1. S X=$G(X) Q:X'?7N "--/--/----"
  1. S X=$$FMTE^XLFDT(X,"5Z")
  1. Q X
  1. VET(X) ; Veterinary Term - 1 = Yes
  1. N LEXEX,LEXMC,LEXD,LEXC,LEXI,LEXO S LEXEX=+($G(X)) Q:LEXEX'>0 -1
  1. S LEXMC=+($G(^LEX(757.01,+LEXEX,1))) Q:LEXMC'>0 -1 Q:'$D(^LEX(757.1,"B",LEXMC)) -3
  1. S LEXO=0,LEXI=0 F S LEXI=$O(^LEX(757.1,"B",LEXMC,LEXI)) Q:+LEXI'>0 D
  1. . N LEXT,LEXN S LEXT=$P($G(^LEX(757.1,LEXI,0)),"^",3)
  1. . S LEXN=$$UP^XLFSTR($P($G(^LEX(757.12,+LEXT,0)),"^",2))
  1. . S:LEXN["VETERINARY" LEXO=1
  1. S X=LEXO
  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