LEX10TAX ;ISL/KER - Post ICD-10 Taxonomy Look-up ;04/21/2014
;;2.0;LEXICON UTILITY;**80**;Sep 23, 1996;Build 10
;
; 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
; ^UTILITY($J ICR 10011
;
; External References
; ^DIWP ICR 10011
; 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("LEX","WRD")
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,"LEX",1,"WRD") 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(.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
PR(LEX,X) ; Parse Array
N DIW,DIWF,DIWI,DIWL,DIWR,DIWT,DIWTC,DIWX,DN,LEXI,LEXLEN,LEXC K ^UTILITY($J,"W") Q:'$D(LEX)
S LEXLEN=+($G(X)) S:+LEXLEN'>0 LEXLEN=79 S LEXC=+($G(LEX)) S:+($G(LEXC))'>0 LEXC=$O(LEX(" "),-1) Q:+LEXC'>0
S DIWL=1,DIWF="C"_+LEXLEN S LEXI=0 F S LEXI=$O(LEX(LEXI)) Q:+LEXI=0 S X=$G(LEX(LEXI)) D ^DIWP
K LEX S (LEXC,LEXI)=0 F S LEXI=$O(^UTILITY($J,"W",1,LEXI)) Q:+LEXI=0 D
. S LEX(LEXI)=$$TM($G(^UTILITY($J,"W",1,LEXI,0))," "),LEXC=LEXC+1
S:$L(LEXC) LEX=LEXC K ^UTILITY($J,"W")
Q
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
LEX10TAX ;ISL/KER - Post ICD-10 Taxonomy Look-up ;04/21/2014
+1 ;;2.0;LEXICON UTILITY;**80**;Sep 23, 1996;Build 10
+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 ; ^UTILITY($J ICR 10011
+12 ;
+13 ; External References
+14 ; ^DIWP ICR 10011
+15 ; LOOK^LEXA ICR 2950
+16 ; CONFIG^LEXSET ICR 1609
+17 ; $$STATCHK^LEXSRC2 ICR 4083
+18 ; $$DT^XLFDT ICR 10103
+19 ; $$FMTE^XLFDT ICR 10103
+20 ;
+21 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("LEX","WRD")
+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,"LEX",1,"WRD")
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(.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
PR(LEX,X) ; Parse Array
+1 NEW DIW,DIWF,DIWI,DIWL,DIWR,DIWT,DIWTC,DIWX,DN,LEXI,LEXLEN,LEXC
KILL ^UTILITY($JOB,"W")
IF '$DATA(LEX)
QUIT
+2 SET LEXLEN=+($GET(X))
IF +LEXLEN'>0
SET LEXLEN=79
SET LEXC=+($GET(LEX))
IF +($GET(LEXC))'>0
SET LEXC=$ORDER(LEX(" "),-1)
IF +LEXC'>0
QUIT
+3 SET DIWL=1
SET DIWF="C"_+LEXLEN
SET LEXI=0
FOR
SET LEXI=$ORDER(LEX(LEXI))
IF +LEXI=0
QUIT
SET X=$GET(LEX(LEXI))
DO ^DIWP
+4 KILL LEX
SET (LEXC,LEXI)=0
FOR
SET LEXI=$ORDER(^UTILITY($JOB,"W",1,LEXI))
IF +LEXI=0
QUIT
Begin DoDot:1
+5 SET LEX(LEXI)=$$TM($GET(^UTILITY($JOB,"W",1,LEXI,0))," ")
SET LEXC=LEXC+1
End DoDot:1
+6 IF $LENGTH(LEXC)
SET LEX=LEXC
KILL ^UTILITY($JOB,"W")
+7 QUIT
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
