- LEX10TAX ;ISL/KER - Post ICD-10 Taxonomy Look-up ;05/23/2017
- ;;2.0;LEXICON UTILITY;**80,86,103**;Sep 23, 1996;Build 2
- ;
- ; Global Variables
- ; ^LEX(757.01 N/A
- ; ^LEX(757.02 N/A
- ; ^LEX(757.03 N/A
- ; ^TMP("LEXFND" SACC 2.3.2.5.1
- ; ^TMP("LEXHIT" SACC 2.3.2.5.1
- ; ^TMP("LEXSCH" SACC 2.3.2.5.1
- ; ^TMP(LEX10 SACC 2.3.2.5.1
- ;
- ; External References
- ; LOOK^LEXA ICR 2950
- ; CONFIG^LEXSET ICR 1609
- ; $$STATCHK^LEXSRC2 ICR 4083
- ; $$DT^XLFDT ICR 10103
- ; $$FMTE^XLFDT ICR 10103
- ;
- Q
- TAX(X,LEXSRC,LEXDT,LEXSUB,LEXVER) ; Get Taxonomy Information
- ;
- ; Input:
- ;
- ; X Search String
- ;
- ; LEXSRC String of Sources
- ; Delimited by an "^" Up-Arrow
- ;
- ; Using source abbreviations
- ; "ICD^ICP^10D^10P"
- ;
- ; Using source pointers to file 757.03
- ; "1^2^30^31"
- ;
- ; Using Nomenclature
- ; "ICD-9-CM^ICD-9 Proc^ICD-10-CM^ICD-10 Proc
- ;
- ; LEXDT Date to use to evaluate status
- ;
- ; LEXSUB Name of a subscript to use in the ^TMP
- ; global (optional)
- ;
- ; ^TMP(LEXSUB,$J,
- ; ^TMP("LEXTAX",$J, Default
- ;
- ; LEXVER Versioning Flag (optional, default = 0)
- ;
- ; 0 Return active and inactive codes
- ; 1 Version, return active codes only
- ;
- ; Output:
- ;
- ; $$TAX The number of codes found or -1 ^ error message
- ;
- ; ^TMP(LEXSUB,$J,SRC,(CODE_" "),#)
- ;
- ; 5 piece "^" delimited string
- ;
- ; 1 Activation Date (can be a future date)
- ; 2 Inactivation Date (can be a future date)
- ; 3 Lexicon IEN to Expression File 757.01
- ; 4 Variable Pointer to a National file
- ; 5 Short Name from a National file
- ;
- ; ^TMP(LEXSUB,$J,SRC,(CODE_" "),#,0)
- ;
- ; 2 piece "^" delimited string
- ;
- ; 1 Code (no spaces)
- ; 2 Lexicon Expression
- ;
- ; Subscript SRC is a pointer to the CODING SYSTEM FILE 757.03
- ;
- N LEX,LEXX,LEXIS,LEXVDT,LEX10SUB S LEXX=$$UP^XLFSTR($G(X)) Q:$L(LEXX)'>1 "-1^Search Text Missing"
- S LEXVDT="" S:$P($G(LEXDT),".",1)'?7N LEXDT=$$DT^XLFDT
- S:$P($G(LEXDT),".",1)?7N LEXVDT=$P($G(LEXDT),".",1)
- S LEXSRC=$$SRC($G(LEXSRC))
- S LEX10SUB=$G(LEXSUB) S:'$L(LEX10SUB) LEX10SUB="LEXTAX"
- S LEXIS=$$IS(LEXX),LEXVER=+($G(LEXVER)) D:LEXIS LBC D:'LEXIS LBT
- S X=+($G(^TMP(LEX10SUB,$J,0))) S:X'>0 X="-1^No Entries Found"
- Q X
- LBC ; Lookup by Code
- N LEXCTL,LEXORD S LEXCTL=LEXX,LEXORD=$E(LEXX,1,($L(LEXX)-1))_$C($A($E(LEXX,$L(LEXX)))-1)_"~ "
- F S LEXORD=$O(^LEX(757.02,"CODE",LEXORD)) Q:'$L(LEXORD)!($E(LEXORD,1,$L(LEXCTL))'=LEXCTL) D
- . N LEXSIEN S LEXSIEN=0
- . F S LEXSIEN=$O(^LEX(757.02,"CODE",LEXORD,LEXSIEN)) Q:+LEXSIEN'>0 D
- . . N LEXND,LEXIEN,LEXCD,LEXPF,LEXTY,LEXSR S LEXND=$G(^LEX(757.02,+LEXSIEN,0)),LEXIEN=+LEXND
- . . S LEXCD=$P(LEXND,"^",2),LEXPF=$P(LEXND,"^",5),LEXSR=$P(LEXND,"^",3)
- . . Q:("^"_LEXSRC_"^")'[("^"_LEXSR_"^")
- . . S LEXTY=$P($G(^LEX(757.01,+LEXIEN,1)),"^",2)
- . . Q:LEXTY'=1 Q:LEXPF'>0 Q:$E(LEXCD,1,$L(LEXCTL))'=LEXCTL D ES(LEXIEN,$G(LEXVDT))
- D REO D:+($G(^TMP(LEX10SUB,$J,0)))'>0 LBT
- Q
- LBT ; Looup by Text
- K ^TMP("LEXSCH",$J),^TMP("LEXFND",$J),^TMP("LEXHIT",$J),LEX
- N LEXTMP,LEXFQ,LEXIEN,DIC,LEXSAB S DIC="^LEX(757.01,",LEXTMP=$G(LEXVDT)
- D CONFIG^LEXSET("PXRM","CR1")
- S ^TMP("LEXSCH",$J,"ADF",0)=1 S ^TMP("LEXSCH",$J,"FIL",0)="I 1"
- S ^TMP("LEXSCH",$J,"FIL",1)="ALL" S ^TMP("LEXSCH",$J,"LEN",0)=1
- K LEXVDT D LOOK^LEXA(LEXX,"PXRM",1,"CR1") S:LEXTMP?7N LEXVDT=LEXTMP
- S LEXIEN=+$G(LEX("LIST",1)) D:LEXIEN>0 ES(LEXIEN,$G(LEXTMP))
- S LEXFQ="" F S LEXFQ=$O(^TMP("LEXFND",$J,LEXFQ)) Q:'$L(LEXFQ) D
- . S LEXIEN=0 F S LEXIEN=$O(^TMP("LEXFND",$J,LEXFQ,LEXIEN)) Q:+LEXIEN'>0 D
- . . K LEXCTL D ES(LEXIEN)
- K ^TMP("LEXSCH",$J),^TMP("LEXFND",$J),^TMP("LEXHIT",$J),LEX D REO
- Q
- ES(X,Y) ; Expression to Code
- N LEXIEN,LEXSIEN,LEXDT S LEXIEN=+($G(X)) Q:+LEXIEN'>0 S LEXDT=$P($G(Y),".",1) S:LEXDT'?7N LEXDT=$$DT^XLFDT
- S LEXSIEN=0 F S LEXSIEN=$O(^LEX(757.02,"B",LEXIEN,LEXSIEN)) Q:+LEXSIEN'>0 D
- . N LEXND,LEXV,LEXEF,LEXHI,LEXST,LEXCO,LEXSR,LEXSB,LEXNM,X,LEX,LEXCT,LEXCD,LEXFIL
- . S LEXV=1,LEXND=$G(^LEX(757.02,+LEXSIEN,0)),LEXCD=$P(LEXND,"^",2),LEXSR=$P(LEXND,"^",3)
- . Q:("^"_LEXSRC_"^")'[("^"_LEXSR_"^")
- . I 0 I LEXSR=56 S LEXFIL=$$SCT(LEXIEN,LEXDT) Q:LEXFIL'>0
- . Q:'$L(LEXCD) Q:+LEXSR'>0 Q:'$D(^LEX(757.03,+LEXSR,0))
- . I +($G(LEXVER))>0,$G(LEXVDT)?7N D Q:LEXV'>0
- . . N LEXST S LEXST=$$STATCHK^LEXSRC2(LEXCD,LEXVDT,,LEXSR) S:+LEXST'>0 LEXV=0
- . Q:$D(^TMP(LEX10SUB,$J,+LEXSR,(LEXCD_" "))) S X=$$PERIOD^LEXU(LEXCD,+LEXSR,.LEX)
- . S LEXCT=0,LEXEF=0 F S LEXEF=$O(LEX(LEXEF)) Q:+LEXEF'>0 D
- . . Q:LEXEF'?7N N LEXND,LEXDD S LEXND=$G(LEX(LEXEF)),LEXDD=$G(LEX(LEXEF,0))
- . . Q:$P(LEXND,"^",2)'>0 Q:'$L(LEXDD) S LEXCT=LEXCT+1
- . . I '$D(^TMP(LEX10SUB,$J,+LEXSR,(LEXCD_" "))) D
- . . . S ^TMP(LEX10SUB,$J,0)=$G(^TMP(LEX10SUB,$J,0))+1
- . . S ^TMP(LEX10SUB,$J,+LEXSR,(LEXCD_" "),LEXCT)=LEXEF_"^"_LEXND
- . . S ^TMP(LEX10SUB,$J,+LEXSR,(LEXCD_" "),LEXCT,0)=LEXCD_"^"_LEXDD
- Q
- REO ; Reorder Array
- N LEXKEY S LEXKEY="" F S LEXKEY=$O(^TMP(LEX10SUB,$J,"IN",LEXKEY)) Q:'$L(LEXKEY) D
- . N LEXCD S LEXCD="" F S LEXCD=$O(^TMP(LEX10SUB,$J,"IN",LEXKEY,LEXCD)) Q:'$L(LEXCD) D
- . . N LEXND,LEXSB,LEXI S LEXND=$G(^TMP(LEX10SUB,$J,"IN",LEXKEY,LEXCD))
- . . S LEXSB=$P(LEXND,"^",7) Q:'$L(LEXSB) S LEXSR=$P(LEXND,"^",6) Q:+LEXSR'>0
- . . S LEXI=$O(^TMP(LEX10SUB,$J,LEXSR," "),-1)+1 S ^TMP(LEX10SUB,$J,LEXSR,LEXI)=LEXND
- K ^TMP(LEX10SUB,$J,"IN")
- Q
- IS(X) ; Is a Code
- S X=$G(X) Q:'$L(X) 0
- Q:$D(^LEX(757.02,"CODE",(X_" "))) 1
- Q:$O(^LEX(757.02,"CODE",(X_" ")))[X 1
- Q 0
- SRC(X) ; Re-Create Source String
- N LEXX,LEXN,LEXI S LEXN="" S LEXX=$G(X) Q:'$L(LEXX) "ALL"
- F LEXI=1:1 Q:'$L($P(LEXX,"^",LEXI)) D
- . N LEXSB,LEXSR S LEXSB=$P(LEXX,"^",LEXI)
- . S LEXSR=$$CS(LEXSB) S:+LEXSR>0 LEXN=LEXN_"^"_+LEXSR
- S X=$$TM(LEXN,"^")
- Q X
- CS(X) ; Coding System
- N LEXIN S LEXIN=$G(X) Q:'$L(LEXIN) ""
- Q:LEXIN?1N.N&($D(^LEX(757.03,+LEXIN,0))) +LEXIN
- Q:$D(^LEX(757.03,"ASAB",LEXIN))&($O(^LEX(757.03,"ASAB",LEXIN,0))>0) $O(^LEX(757.03,"ASAB",LEXIN,0))
- Q:$D(^LEX(757.03,"B",LEXIN))&($O(^LEX(757.03,"B",LEXIN,0))>0) $O(^LEX(757.03,"B",LEXIN,0))
- Q:$D(^LEX(757.03,"C",LEXIN))&($O(^LEX(757.03,"C",LEXIN,0))>0) $O(^LEX(757.03,"C",LEXIN,0))
- Q ""
- ;
- ; Miscellaneous
- SCT(LEX,LEXVDT) ; Filter by SNOMED CT (SCT) (Human only)
- ;
- ; Input
- ;
- ; LEX IEN of file 757.01
- ; LEXVDT Date to use for screening by codes
- ;
- ; Output
- ;
- ; $$SCT Human SNOMED Code or Null
- ; Excludes Veterinary SNOMED codes
- ;
- N LEXEX,LEXMC,LEXD,LEXC,LEXI,LEXO,LEXPL,LEXVT S LEXEX=+($G(LEX)),LEXD=$G(LEXVDT) Q:LEXEX'>0 0
- S LEXC=$S(LEXD?7N:$$ONE^LEXU(+LEXEX,LEXD,"SCT"),1:$$ONE^LEXU(+LEXEX,,"SCT"))
- Q:'$L(LEXC) 0 S LEXMC=+($G(^LEX(757.01,+LEXEX,1))) Q:LEXMC'>0 0 Q:'$D(^LEX(757.1,"B",LEXMC)) 0
- S LEXVT=0,LEXI=0 F S LEXI=$O(^LEX(757.1,"B",LEXMC,LEXI)) Q:+LEXI'>0 D Q:LEXVT>0
- . 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
- S LEXPL=0,LEXI=0 F S LEXI=$O(^LEX(757.21,"B",LEXEX,LEXI)) Q:+LEXI'>0 D Q:LEXPL>0
- . 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
- S LEXO=1 S:LEXVT=1 LEXO=0 S:LEXPL'>0 LEXO=0
- S X=LEXO
- Q X
- SHO ; Show ^TMP global
- N LEXNN,LEXNC,LEXS S LEXS=$G(LEXSUB) S:'$L(LEXS) LEXS="LEXTAX"
- S LEXNN="^TMP("""_LEXS_""","_$J_")",LEXNC="^TMP("""_LEXS_""","_$J_","
- F S LEXNN=$Q(@LEXNN) Q:'$L(LEXNN)!(LEXNN'[LEXNC) D
- . N LEXND S LEXND=@LEXNN W !,LEXNN,"=",LEXND
- Q
- EXP ; Show ^TMP global (expanded display)
- N LEXN1,LEXN2,LEXN3,LEXNN,LEXNC,LEXS,LEXTD S LEXS=$G(LEXSUB) S:'$L(LEXS) LEXS="LEXTAX"
- S LEXTD=$$DT^XLFDT,LEXN1=0 F S LEXN1=$O(^TMP(LEXS,$J,LEXN1)) Q:+LEXN1'>0 D
- . N LEXSNM Q:'$D(^LEX(757.03,LEXN1,0))
- . S LEXSNM=$P($G(^LEX(757.03,LEXN1,0)),"^",2) Q:'$L(LEXSNM)
- . S LEXN2="" F S LEXN2=$O(^TMP(LEXS,$J,LEXN1,LEXN2)) Q:'$L(LEXN2) D
- . . W !,?3,LEXSNM," Code: ",LEXN2
- . . S LEXN3=0 F S LEXN3=$O(^TMP(LEXS,$J,LEXN1,LEXN2,LEXN3)) Q:+LEXN3'>0 D
- . . . N LEXN,LEX0,LEXAC,LEXIN,LEXIE,LEXVP,LEXSN,LEXCD,LEXNM,LEXA,LEXI
- . . . S LEXN=$G(^TMP(LEXS,$J,LEXN1,LEXN2,LEXN3))
- . . . S LEX0=$G(^TMP(LEXS,$J,LEXN1,LEXN2,LEXN3,0))
- . . . S LEXAC=$P(LEXN,"^",1),LEXIN=$P(LEXN,"^",2)
- . . . S LEXIE=$P(LEXN,"^",3),LEXVP=$P(LEXN,"^",4)
- . . . S LEXSN=$P(LEXN,"^",5)
- . . . W !,?5,"Active: ",$$ED(LEXAC) W:LEXAC>LEXTD " (Pending)"
- . . . W ?36,"Inactive: ",$$ED(LEXIN) W:LEXIN>LEXTD " (Pending)"
- . . . S LEX0=$G(^TMP(LEXS,$J,LEXN1,LEXN2,LEXN3,0))
- . . . S LEXCD=$P(LEX0,"^",1)
- . . . S LEXNM=$P(LEX0,"^",2) S LEXA(1)=LEXNM D PR^LEXU(.LEXA,(79-36))
- . . . W !,?5," IEN: ",LEXIE W:$L($G(LEXA(1))) ?36,$G(LEXA(1))
- . . . S LEXI=1 F S LEXI=$O(LEXA(LEXI)) Q:+LEXI'>0 W:$L($G(LEXA(LEXI))) !,?36,$G(LEXA(LEXI))
- Q
- ED(X) ; Exernal Date
- S X=$G(X) Q:X'?7N "--/--/----"
- S X=$$FMTE^XLFDT(X,"5Z")
- Q X
- VET(X) ; Veterinary Term - 1 = Yes
- N LEXEX,LEXMC,LEXD,LEXC,LEXI,LEXO S LEXEX=+($G(X)) Q:LEXEX'>0 -1
- S LEXMC=+($G(^LEX(757.01,+LEXEX,1))) Q:LEXMC'>0 -1 Q:'$D(^LEX(757.1,"B",LEXMC)) -3
- S LEXO=0,LEXI=0 F S LEXI=$O(^LEX(757.1,"B",LEXMC,LEXI)) Q:+LEXI'>0 D
- . N LEXT,LEXN S LEXT=$P($G(^LEX(757.1,LEXI,0)),"^",3)
- . S LEXN=$$UP^XLFSTR($P($G(^LEX(757.12,+LEXT,0)),"^",2))
- . S:LEXN["VETERINARY" LEXO=1
- S X=LEXO
- 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
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLEX10TAX 10004 printed Feb 18, 2025@23:29:41 Page 2
- 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
- +2 ;
- +3 ; Global Variables
- +4 ; ^LEX(757.01 N/A
- +5 ; ^LEX(757.02 N/A
- +6 ; ^LEX(757.03 N/A
- +7 ; ^TMP("LEXFND" SACC 2.3.2.5.1
- +8 ; ^TMP("LEXHIT" SACC 2.3.2.5.1
- +9 ; ^TMP("LEXSCH" SACC 2.3.2.5.1
- +10 ; ^TMP(LEX10 SACC 2.3.2.5.1
- +11 ;
- +12 ; External References
- +13 ; LOOK^LEXA ICR 2950
- +14 ; CONFIG^LEXSET ICR 1609
- +15 ; $$STATCHK^LEXSRC2 ICR 4083
- +16 ; $$DT^XLFDT ICR 10103
- +17 ; $$FMTE^XLFDT ICR 10103
- +18 ;
- +19 QUIT
- TAX(X,LEXSRC,LEXDT,LEXSUB,LEXVER) ; Get Taxonomy Information
- +1 ;
- +2 ; Input:
- +3 ;
- +4 ; X Search String
- +5 ;
- +6 ; LEXSRC String of Sources
- +7 ; Delimited by an "^" Up-Arrow
- +8 ;
- +9 ; Using source abbreviations
- +10 ; "ICD^ICP^10D^10P"
- +11 ;
- +12 ; Using source pointers to file 757.03
- +13 ; "1^2^30^31"
- +14 ;
- +15 ; Using Nomenclature
- +16 ; "ICD-9-CM^ICD-9 Proc^ICD-10-CM^ICD-10 Proc
- +17 ;
- +18 ; LEXDT Date to use to evaluate status
- +19 ;
- +20 ; LEXSUB Name of a subscript to use in the ^TMP
- +21 ; global (optional)
- +22 ;
- +23 ; ^TMP(LEXSUB,$J,
- +24 ; ^TMP("LEXTAX",$J, Default
- +25 ;
- +26 ; LEXVER Versioning Flag (optional, default = 0)
- +27 ;
- +28 ; 0 Return active and inactive codes
- +29 ; 1 Version, return active codes only
- +30 ;
- +31 ; Output:
- +32 ;
- +33 ; $$TAX The number of codes found or -1 ^ error message
- +34 ;
- +35 ; ^TMP(LEXSUB,$J,SRC,(CODE_" "),#)
- +36 ;
- +37 ; 5 piece "^" delimited string
- +38 ;
- +39 ; 1 Activation Date (can be a future date)
- +40 ; 2 Inactivation Date (can be a future date)
- +41 ; 3 Lexicon IEN to Expression File 757.01
- +42 ; 4 Variable Pointer to a National file
- +43 ; 5 Short Name from a National file
- +44 ;
- +45 ; ^TMP(LEXSUB,$J,SRC,(CODE_" "),#,0)
- +46 ;
- +47 ; 2 piece "^" delimited string
- +48 ;
- +49 ; 1 Code (no spaces)
- +50 ; 2 Lexicon Expression
- +51 ;
- +52 ; Subscript SRC is a pointer to the CODING SYSTEM FILE 757.03
- +53 ;
- +54 NEW LEX,LEXX,LEXIS,LEXVDT,LEX10SUB
- SET LEXX=$$UP^XLFSTR($GET(X))
- if $LENGTH(LEXX)'>1
- QUIT "-1^Search Text Missing"
- +55 SET LEXVDT=""
- if $PIECE($GET(LEXDT),".",1)'?7N
- SET LEXDT=$$DT^XLFDT
- +56 if $PIECE($GET(LEXDT),".",1)?7N
- SET LEXVDT=$PIECE($GET(LEXDT),".",1)
- +57 SET LEXSRC=$$SRC($GET(LEXSRC))
- +58 SET LEX10SUB=$GET(LEXSUB)
- if '$LENGTH(LEX10SUB)
- SET LEX10SUB="LEXTAX"
- +59 SET LEXIS=$$IS(LEXX)
- SET LEXVER=+($GET(LEXVER))
- if LEXIS
- DO LBC
- if 'LEXIS
- DO LBT
- +60 SET X=+($GET(^TMP(LEX10SUB,$JOB,0)))
- if X'>0
- SET X="-1^No Entries Found"
- +61 QUIT X
- LBC ; Lookup by Code
- +1 NEW LEXCTL,LEXORD
- SET LEXCTL=LEXX
- SET LEXORD=$EXTRACT(LEXX,1,($LENGTH(LEXX)-1))_$CHAR($ASCII($EXTRACT(LEXX,$LENGTH(LEXX)))-1)_"~ "
- +2 FOR
- SET LEXORD=$ORDER(^LEX(757.02,"CODE",LEXORD))
- if '$LENGTH(LEXORD)!($EXTRACT(LEXORD,1,$LENGTH(LEXCTL))'=LEXCTL)
- QUIT
- Begin DoDot:1
- +3 NEW LEXSIEN
- SET LEXSIEN=0
- +4 FOR
- SET LEXSIEN=$ORDER(^LEX(757.02,"CODE",LEXORD,LEXSIEN))
- if +LEXSIEN'>0
- QUIT
- Begin DoDot:2
- +5 NEW LEXND,LEXIEN,LEXCD,LEXPF,LEXTY,LEXSR
- SET LEXND=$GET(^LEX(757.02,+LEXSIEN,0))
- SET LEXIEN=+LEXND
- +6 SET LEXCD=$PIECE(LEXND,"^",2)
- SET LEXPF=$PIECE(LEXND,"^",5)
- SET LEXSR=$PIECE(LEXND,"^",3)
- +7 if ("^"_LEXSRC_"^")'[("^"_LEXSR_"^")
- QUIT
- +8 SET LEXTY=$PIECE($GET(^LEX(757.01,+LEXIEN,1)),"^",2)
- +9 if LEXTY'=1
- QUIT
- if LEXPF'>0
- QUIT
- if $EXTRACT(LEXCD,1,$LENGTH(LEXCTL))'=LEXCTL
- QUIT
- DO ES(LEXIEN,$GET(LEXVDT))
- End DoDot:2
- End DoDot:1
- +10 DO REO
- if +($GET(^TMP(LEX10SUB,$JOB,0)))'>0
- DO LBT
- +11 QUIT
- LBT ; Looup by Text
- +1 KILL ^TMP("LEXSCH",$JOB),^TMP("LEXFND",$JOB),^TMP("LEXHIT",$JOB),LEX
- +2 NEW LEXTMP,LEXFQ,LEXIEN,DIC,LEXSAB
- SET DIC="^LEX(757.01,"
- SET LEXTMP=$GET(LEXVDT)
- +3 DO CONFIG^LEXSET("PXRM","CR1")
- +4 SET ^TMP("LEXSCH",$JOB,"ADF",0)=1
- SET ^TMP("LEXSCH",$JOB,"FIL",0)="I 1"
- +5 SET ^TMP("LEXSCH",$JOB,"FIL",1)="ALL"
- SET ^TMP("LEXSCH",$JOB,"LEN",0)=1
- +6 KILL LEXVDT
- DO LOOK^LEXA(LEXX,"PXRM",1,"CR1")
- if LEXTMP?7N
- SET LEXVDT=LEXTMP
- +7 SET LEXIEN=+$GET(LEX("LIST",1))
- if LEXIEN>0
- DO ES(LEXIEN,$GET(LEXTMP))
- +8 SET LEXFQ=""
- FOR
- SET LEXFQ=$ORDER(^TMP("LEXFND",$JOB,LEXFQ))
- if '$LENGTH(LEXFQ)
- QUIT
- Begin DoDot:1
- +9 SET LEXIEN=0
- FOR
- SET LEXIEN=$ORDER(^TMP("LEXFND",$JOB,LEXFQ,LEXIEN))
- if +LEXIEN'>0
- QUIT
- Begin DoDot:2
- +10 KILL LEXCTL
- DO ES(LEXIEN)
- End DoDot:2
- End DoDot:1
- +11 KILL ^TMP("LEXSCH",$JOB),^TMP("LEXFND",$JOB),^TMP("LEXHIT",$JOB),LEX
- DO REO
- +12 QUIT
- ES(X,Y) ; Expression to Code
- +1 NEW LEXIEN,LEXSIEN,LEXDT
- SET LEXIEN=+($GET(X))
- if +LEXIEN'>0
- QUIT
- SET LEXDT=$PIECE($GET(Y),".",1)
- if LEXDT'?7N
- SET LEXDT=$$DT^XLFDT
- +2 SET LEXSIEN=0
- FOR
- SET LEXSIEN=$ORDER(^LEX(757.02,"B",LEXIEN,LEXSIEN))
- if +LEXSIEN'>0
- QUIT
- Begin DoDot:1
- +3 NEW LEXND,LEXV,LEXEF,LEXHI,LEXST,LEXCO,LEXSR,LEXSB,LEXNM,X,LEX,LEXCT,LEXCD,LEXFIL
- +4 SET LEXV=1
- SET LEXND=$GET(^LEX(757.02,+LEXSIEN,0))
- SET LEXCD=$PIECE(LEXND,"^",2)
- SET LEXSR=$PIECE(LEXND,"^",3)
- +5 if ("^"_LEXSRC_"^")'[("^"_LEXSR_"^")
- QUIT
- +6 IF 0
- IF LEXSR=56
- SET LEXFIL=$$SCT(LEXIEN,LEXDT)
- if LEXFIL'>0
- QUIT
- +7 if '$LENGTH(LEXCD)
- QUIT
- if +LEXSR'>0
- QUIT
- if '$DATA(^LEX(757.03,+LEXSR,0))
- QUIT
- +8 IF +($GET(LEXVER))>0
- IF $GET(LEXVDT)?7N
- Begin DoDot:2
- +9 NEW LEXST
- SET LEXST=$$STATCHK^LEXSRC2(LEXCD,LEXVDT,,LEXSR)
- if +LEXST'>0
- SET LEXV=0
- End DoDot:2
- if LEXV'>0
- QUIT
- +10 if $DATA(^TMP(LEX10SUB,$JOB,+LEXSR,(LEXCD_" ")))
- QUIT
- SET X=$$PERIOD^LEXU(LEXCD,+LEXSR,.LEX)
- +11 SET LEXCT=0
- SET LEXEF=0
- FOR
- SET LEXEF=$ORDER(LEX(LEXEF))
- if +LEXEF'>0
- QUIT
- Begin DoDot:2
- +12 if LEXEF'?7N
- QUIT
- NEW LEXND,LEXDD
- SET LEXND=$GET(LEX(LEXEF))
- SET LEXDD=$GET(LEX(LEXEF,0))
- +13 if $PIECE(LEXND,"^",2)'>0
- QUIT
- if '$LENGTH(LEXDD)
- QUIT
- SET LEXCT=LEXCT+1
- +14 IF '$DATA(^TMP(LEX10SUB,$JOB,+LEXSR,(LEXCD_" ")))
- Begin DoDot:3
- +15 SET ^TMP(LEX10SUB,$JOB,0)=$GET(^TMP(LEX10SUB,$JOB,0))+1
- End DoDot:3
- +16 SET ^TMP(LEX10SUB,$JOB,+LEXSR,(LEXCD_" "),LEXCT)=LEXEF_"^"_LEXND
- +17 SET ^TMP(LEX10SUB,$JOB,+LEXSR,(LEXCD_" "),LEXCT,0)=LEXCD_"^"_LEXDD
- End DoDot:2
- End DoDot:1
- +18 QUIT
- REO ; Reorder Array
- +1 NEW LEXKEY
- SET LEXKEY=""
- FOR
- SET LEXKEY=$ORDER(^TMP(LEX10SUB,$JOB,"IN",LEXKEY))
- if '$LENGTH(LEXKEY)
- QUIT
- Begin DoDot:1
- +2 NEW LEXCD
- SET LEXCD=""
- FOR
- SET LEXCD=$ORDER(^TMP(LEX10SUB,$JOB,"IN",LEXKEY,LEXCD))
- if '$LENGTH(LEXCD)
- QUIT
- Begin DoDot:2
- +3 NEW LEXND,LEXSB,LEXI
- SET LEXND=$GET(^TMP(LEX10SUB,$JOB,"IN",LEXKEY,LEXCD))
- +4 SET LEXSB=$PIECE(LEXND,"^",7)
- if '$LENGTH(LEXSB)
- QUIT
- SET LEXSR=$PIECE(LEXND,"^",6)
- if +LEXSR'>0
- QUIT
- +5 SET LEXI=$ORDER(^TMP(LEX10SUB,$JOB,LEXSR," "),-1)+1
- SET ^TMP(LEX10SUB,$JOB,LEXSR,LEXI)=LEXND
- End DoDot:2
- End DoDot:1
- +6 KILL ^TMP(LEX10SUB,$JOB,"IN")
- +7 QUIT
- IS(X) ; Is a Code
- +1 SET X=$GET(X)
- if '$LENGTH(X)
- QUIT 0
- +2 if $DATA(^LEX(757.02,"CODE",(X_" ")))
- QUIT 1
- +3 if $ORDER(^LEX(757.02,"CODE",(X_" ")))[X
- QUIT 1
- +4 QUIT 0
- SRC(X) ; Re-Create Source String
- +1 NEW LEXX,LEXN,LEXI
- SET LEXN=""
- SET LEXX=$GET(X)
- if '$LENGTH(LEXX)
- QUIT "ALL"
- +2 FOR LEXI=1:1
- if '$LENGTH($PIECE(LEXX,"^",LEXI))
- QUIT
- Begin DoDot:1
- +3 NEW LEXSB,LEXSR
- SET LEXSB=$PIECE(LEXX,"^",LEXI)
- +4 SET LEXSR=$$CS(LEXSB)
- if +LEXSR>0
- SET LEXN=LEXN_"^"_+LEXSR
- End DoDot:1
- +5 SET X=$$TM(LEXN,"^")
- +6 QUIT X
- CS(X) ; Coding System
- +1 NEW LEXIN
- SET LEXIN=$GET(X)
- if '$LENGTH(LEXIN)
- QUIT ""
- +2 if LEXIN?1N.N&($DATA(^LEX(757.03,+LEXIN,0)))
- QUIT +LEXIN
- +3 if $DATA(^LEX(757.03,"ASAB",LEXIN))&($ORDER(^LEX(757.03,"ASAB",LEXIN,0))>0)
- QUIT $ORDER(^LEX(757.03,"ASAB",LEXIN,0))
- +4 if $DATA(^LEX(757.03,"B",LEXIN))&($ORDER(^LEX(757.03,"B",LEXIN,0))>0)
- QUIT $ORDER(^LEX(757.03,"B",LEXIN,0))
- +5 if $DATA(^LEX(757.03,"C",LEXIN))&($ORDER(^LEX(757.03,"C",LEXIN,0))>0)
- QUIT $ORDER(^LEX(757.03,"C",LEXIN,0))
- +6 QUIT ""
- +7 ;
- +8 ; Miscellaneous
- SCT(LEX,LEXVDT) ; Filter by SNOMED CT (SCT) (Human only)
- +1 ;
- +2 ; Input
- +3 ;
- +4 ; LEX IEN of file 757.01
- +5 ; LEXVDT Date to use for screening by codes
- +6 ;
- +7 ; Output
- +8 ;
- +9 ; $$SCT Human SNOMED Code or Null
- +10 ; Excludes Veterinary SNOMED codes
- +11 ;
- +12 NEW LEXEX,LEXMC,LEXD,LEXC,LEXI,LEXO,LEXPL,LEXVT
- SET LEXEX=+($GET(LEX))
- SET LEXD=$GET(LEXVDT)
- if LEXEX'>0
- QUIT 0
- +13 SET LEXC=$SELECT(LEXD?7N:$$ONE^LEXU(+LEXEX,LEXD,"SCT"),1:$$ONE^LEXU(+LEXEX,,"SCT"))
- +14 if '$LENGTH(LEXC)
- QUIT 0
- SET LEXMC=+($GET(^LEX(757.01,+LEXEX,1)))
- if LEXMC'>0
- QUIT 0
- if '$DATA(^LEX(757.1,"B",LEXMC))
- QUIT 0
- +15 SET LEXVT=0
- SET LEXI=0
- FOR
- SET LEXI=$ORDER(^LEX(757.1,"B",LEXMC,LEXI))
- if +LEXI'>0
- QUIT
- Begin DoDot:1
- +16 NEW LEXT,LEXN
- SET LEXT=$PIECE($GET(^LEX(757.1,LEXI,0)),"^",3)
- SET LEXN=$$UP^XLFSTR($PIECE($GET(^LEX(757.12,+LEXT,0)),"^",2))
- if LEXN["VETERINARY"
- SET LEXVT=1
- End DoDot:1
- if LEXVT>0
- QUIT
- +17 SET LEXPL=0
- SET LEXI=0
- FOR
- SET LEXI=$ORDER(^LEX(757.21,"B",LEXEX,LEXI))
- if +LEXI'>0
- QUIT
- Begin DoDot:1
- +18 NEW LEXT,LEXN
- SET LEXT=$PIECE($GET(^LEX(757.21,LEXI,0)),"^",2)
- SET LEXN=$PIECE($GET(^LEXT(757.2,+LEXT,0)),"^",2)
- if LEXN="PLS"
- SET LEXPL=1
- End DoDot:1
- if LEXPL>0
- QUIT
- +19 SET LEXO=1
- if LEXVT=1
- SET LEXO=0
- if LEXPL'>0
- SET LEXO=0
- +20 SET X=LEXO
- +21 QUIT X
- SHO ; Show ^TMP global
- +1 NEW LEXNN,LEXNC,LEXS
- SET LEXS=$GET(LEXSUB)
- if '$LENGTH(LEXS)
- SET LEXS="LEXTAX"
- +2 SET LEXNN="^TMP("""_LEXS_""","_$JOB_")"
- SET LEXNC="^TMP("""_LEXS_""","_$JOB_","
- +3 FOR
- SET LEXNN=$QUERY(@LEXNN)
- if '$LENGTH(LEXNN)!(LEXNN'[LEXNC)
- QUIT
- Begin DoDot:1
- +4 NEW LEXND
- SET LEXND=@LEXNN
- WRITE !,LEXNN,"=",LEXND
- End DoDot:1
- +5 QUIT
- EXP ; Show ^TMP global (expanded display)
- +1 NEW LEXN1,LEXN2,LEXN3,LEXNN,LEXNC,LEXS,LEXTD
- SET LEXS=$GET(LEXSUB)
- if '$LENGTH(LEXS)
- SET LEXS="LEXTAX"
- +2 SET LEXTD=$$DT^XLFDT
- SET LEXN1=0
- FOR
- SET LEXN1=$ORDER(^TMP(LEXS,$JOB,LEXN1))
- if +LEXN1'>0
- QUIT
- Begin DoDot:1
- +3 NEW LEXSNM
- if '$DATA(^LEX(757.03,LEXN1,0))
- QUIT
- +4 SET LEXSNM=$PIECE($GET(^LEX(757.03,LEXN1,0)),"^",2)
- if '$LENGTH(LEXSNM)
- QUIT
- +5 SET LEXN2=""
- FOR
- SET LEXN2=$ORDER(^TMP(LEXS,$JOB,LEXN1,LEXN2))
- if '$LENGTH(LEXN2)
- QUIT
- Begin DoDot:2
- +6 WRITE !,?3,LEXSNM," Code: ",LEXN2
- +7 SET LEXN3=0
- FOR
- SET LEXN3=$ORDER(^TMP(LEXS,$JOB,LEXN1,LEXN2,LEXN3))
- if +LEXN3'>0
- QUIT
- Begin DoDot:3
- +8 NEW LEXN,LEX0,LEXAC,LEXIN,LEXIE,LEXVP,LEXSN,LEXCD,LEXNM,LEXA,LEXI
- +9 SET LEXN=$GET(^TMP(LEXS,$JOB,LEXN1,LEXN2,LEXN3))
- +10 SET LEX0=$GET(^TMP(LEXS,$JOB,LEXN1,LEXN2,LEXN3,0))
- +11 SET LEXAC=$PIECE(LEXN,"^",1)
- SET LEXIN=$PIECE(LEXN,"^",2)
- +12 SET LEXIE=$PIECE(LEXN,"^",3)
- SET LEXVP=$PIECE(LEXN,"^",4)
- +13 SET LEXSN=$PIECE(LEXN,"^",5)
- +14 WRITE !,?5,"Active: ",$$ED(LEXAC)
- if LEXAC>LEXTD
- WRITE " (Pending)"
- +15 WRITE ?36,"Inactive: ",$$ED(LEXIN)
- if LEXIN>LEXTD
- WRITE " (Pending)"
- +16 SET LEX0=$GET(^TMP(LEXS,$JOB,LEXN1,LEXN2,LEXN3,0))
- +17 SET LEXCD=$PIECE(LEX0,"^",1)
- +18 SET LEXNM=$PIECE(LEX0,"^",2)
- SET LEXA(1)=LEXNM
- DO PR^LEXU(.LEXA,(79-36))
- +19 WRITE !,?5," IEN: ",LEXIE
- if $LENGTH($GET(LEXA(1)))
- WRITE ?36,$GET(LEXA(1))
- +20 SET LEXI=1
- FOR
- SET LEXI=$ORDER(LEXA(LEXI))
- if +LEXI'>0
- QUIT
- if $LENGTH($GET(LEXA(LEXI)))
- WRITE !,?36,$GET(LEXA(LEXI))
- End DoDot:3
- End DoDot:2
- End DoDot:1
- +21 QUIT
- ED(X) ; Exernal Date
- +1 SET X=$GET(X)
- if X'?7N
- QUIT "--/--/----"
- +2 SET X=$$FMTE^XLFDT(X,"5Z")
- +3 QUIT X
- VET(X) ; Veterinary Term - 1 = Yes
- +1 NEW LEXEX,LEXMC,LEXD,LEXC,LEXI,LEXO
- SET LEXEX=+($GET(X))
- if LEXEX'>0
- QUIT -1
- +2 SET LEXMC=+($GET(^LEX(757.01,+LEXEX,1)))
- if LEXMC'>0
- QUIT -1
- if '$DATA(^LEX(757.1,"B",LEXMC))
- QUIT -3
- +3 SET LEXO=0
- SET LEXI=0
- FOR
- SET LEXI=$ORDER(^LEX(757.1,"B",LEXMC,LEXI))
- if +LEXI'>0
- QUIT
- Begin DoDot:1
- +4 NEW LEXT,LEXN
- SET LEXT=$PIECE($GET(^LEX(757.1,LEXI,0)),"^",3)
- +5 SET LEXN=$$UP^XLFSTR($PIECE($GET(^LEX(757.12,+LEXT,0)),"^",2))
- +6 if LEXN["VETERINARY"
- SET LEXO=1
- End DoDot:1
- +7 SET X=LEXO
- +8 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