LEX10DU ;ISL/KER - ICD-10 Diagnosis Utilities ;04/21/2014
;;2.0;LEXICON UTILITY;**80**;Sep 23, 1996;Build 1
;
; Global Variables
; ^LEX(757.033 N/A
; ^TMP("DIAGSRCH" SACC 2.3.2.5.1
; ^TMP("LEXDX") SACC 2.3.2.5.1
; ^TMP("LEXTKN" SACC 2.3.2.5.1
;
; External References
; ^DIM ICR 10016
; $$ICDDX^ICDEX ICR 5747
; $$LD^ICDEX ICR 5747
; $$SD^ICDEX ICR 5747
; $$DT^XLFDT ICR 10103
;
; Local Variables NEWed or KILLed by calling
; routine LEX10DBT, LEX10DBC or LEX10CS
; LEXA
; LEXCS
; LEXDATA
; LEXFI
; LEXINC
; LEXVDT
;
Q
REDUCE(X) ; Reduce List
N LEXC,LEXIT,LEXLEN,LEXMAX,LEXPRE,LEXUSE
S LEXUSE=0,LEXLEN=8,LEXPRE=7,LEXMAX=+($G(X))
S:LEXMAX'>0 LEXMAX=30 S LEXCT=+($G(LEXCT)) Q:+LEXCT'>0
S LEXIT=0 F Q:LEXCT'>LEXMAX!(LEXIT) D Q:LEXIT
. S:LEXPRE=LEXLEN LEXIT=1 Q:LEXIT
. N LEXC S LEXC="",LEXCT=0
. F S LEXC=$O(^TMP("LEXDX",$J,LEXC)) Q:'$L(LEXC) D
. . I $L(LEXC)=(LEXLEN+1) D Q
. . . N LEXCAT,LEXIS,LEXNCT,LEXNCD,LEXNPR,LEXCE,LEXTX
. . . S LEXCAT=$$CAT(LEXC),LEXCE=$P(LEXCAT,"^",2)
. . . S LEXTX=$P(LEXCAT,"^",3),LEXCAT=$P(LEXCAT,"^",1)
. . . K ^TMP("LEXDX",$J,LEXC) S LEXUSE=1
. . . Q:$D(^TMP("LEXDX",$J,(LEXCAT_" ")))
. . . S LEXIS=$$ISCAT(LEXCAT)
. . . S LEXNCT=$P(LEXIS,"^",2)
. . . S LEXNCD=$P(LEXIS,"^",3)
. . . S LEXNPR=$P(LEXIS,"^",4)
. . . I $L(LEXCAT),LEXCE?7N,$L(LEXTX) D
. . . . N LEX S LEX=LEXCE_"^"_LEXTX
. . . . S:+($G(LEXNCD))>0 $P(LEX,"^",3)=+($G(LEXNCD))
. . . . S ^TMP("LEXDX",$J,(LEXCAT_" "))="^"_LEX S LEXCT=LEXCT+1
. . S LEXCT=LEXCT+1
. I LEXPRE>3 S LEXLEN=LEXPRE,LEXPRE=LEXPRE-1 Q
. S:LEXPRE=3 LEXIT=1
S LEXC="" F S LEXC=$O(^TMP("LEXDX",$J,LEXC)) Q:'$L(LEXC) D
. S LEXCT=$P($G(^TMP("LEXDX",$J,LEXC)),"^",4) Q:LEXCT'>0
. N LEXCTL,LEXNXT,LEXCT S LEXCTL=$TR(LEXC," ") Q:'$L(LEXCTL)
. S LEXNXT=$O(^TMP("LEXDX",$J,(LEXCTL_" "))) Q:'$L(LEXNXT)
. K:$E(LEXNXT,1,$L(LEXCTL))=LEXCTL ^TMP("LEXDX",$J,(LEXCTL_" "))
Q
ARY ; Build Local Array
N LEXC,LEXACT S LEXC="",LEXACT=0
F S LEXC=$O(^TMP("LEXDX",$J,LEXC)) Q:'$L(LEXC) D
. N LEXSIEN,LEXEIEN,LEXEXP,LEXCAT,LEXND,LEXD,LEXSO,LEXNC
. S LEXND=$G(^TMP("LEXDX",$J,LEXC))
. S LEXSIEN=+LEXND,LEXD=$P($P(LEXND,"^",2),".",1)
. S LEXCAT=$P(LEXND,"^",3),LEXNC=$P(LEXND,"^",4)
. S LEXEIEN=+($G(^LEX(757.02,+LEXSIEN,0)))
. S LEXEXP=$G(^LEX(757.01,+LEXEIEN,0)),LEXSO=$$TM(LEXC)
. I '$L(LEXCAT) Q:LEXSIEN'>0 Q:LEXEIEN'>0 Q:'$L(LEXEXP)
. Q:($G(LEXCDT)?7N)&(LEXD'?7N) Q:'$D(LEXCDT)&(LEXD'?7N) Q:'$L(LEXSO)
. I +LEXSIEN>0 D
. . S LEXACT=LEXACT+1 S LEXA(LEXACT)=LEXSIEN_"^"_LEXSO_"^"_LEXD
. . S LEXA(LEXACT,0)=+LEXEIEN_"^"_LEXEXP
. I +LEXSIEN'>0,$L(LEXCAT) D
. . N LEX S LEX="^"_LEXSO_"^"_LEXD
. . S:+($G(LEXNC))>0 $P(LEX,"^",4)=+($G(LEXNC))
. . S LEXACT=LEXACT+1 S LEXA(LEXACT)=LEX
. . S LEXA(LEXACT,0)="^"_LEXCAT
. S LEXA(0)=LEXACT
S:+($G(LEXA(0)))'>0 LEXA(0)=-1 Q:+($G(LEXA(0)))'>0
S:+($G(LEXUSE))>0&($G(LEXA(0))>0) $P(LEXA(0),"^",2)=1
Q
DXARY ; Build Output Array from Search Results
N LEXOI,LEXC,LEXCO,LEXCT S LEXFI=+($G(LEXFI)) Q:"^80^"'[("^"_LEXFI_"^")
S LEXCS=+($G(LEXCS)) Q:+LEXCS'>0 Q:"^1^30^"'[("^"_LEXCS_"^")
K ^TMP("DIAGSRCH",$J) S (LEXCT,LEXOI)=0
F S LEXOI=$O(LEXOUT(LEXOI)) Q:+LEXOI'>0 D
. N LEXC,LEXI S LEXC=$P($G(LEXOUT(LEXOI)),"^",2) Q:'$L(LEXC)
. S ^TMP("DIAGSRCH",$J,(LEXC_" "))=$G(LEXOUT(LEXOI))
. S ^TMP("DIAGSRCH",$J,(LEXC_" "),0)=$G(LEXOUT(LEXOI,0))
. Q:+($G(LEXCS))'=30 F LEXI=1:1:$L(LEXC) D
. . Q
. . N LEXS,LEXSD,LEXSI,LEXSN,LEXF,LEXFA S LEXS=$E(LEXC,1,($L(LEXC)-LEXI))
. . Q:'$D(^LEX(757.033,"AFRAG",30,(LEXS_" ")))
. . S LEXSD=$O(^LEX(757.033,"AFRAG",30,(LEXS_" "),0))
. . Q:LEXSD'?7N Q:+($G(LEXVDT))<LEXSD
. . S LEXSI=$O(^LEX(757.033,"AFRAG",30,(LEXS_" "),LEXSD,0))
. . Q:+LEXSI'>0 S LEXSN=$$LN(+LEXSI)
. . S:'$L(LEXSN) LEXSN=$$SN(+LEXSI) Q:'$L(LEXSN)
. . S ^TMP("DIAGSRCH",$J,(LEXS_" "))="-^"_LEXS_"^"_LEXSD
. . S ^TMP("DIAGSRCH",$J,(LEXS_" "),0)="-^"_LEXSN
K LEXOUT S LEXCO="" F S LEXCO=$O(^TMP("DIAGSRCH",$J,LEXCO)) Q:'$L(LEXCO) D
. N LEXC,LEXEFF,LEXEIEN,LEXEXP,LEXI,LEXICD,LEXICDT,LEXLD,LEXLDE
. N LEXN1,LEXN2,LEXND,LEXO,LEXP1,LEXP2,LEXP3,LEXPF,LEXPR,LEXS
. N LEXSD,LEXSDE,LEXSIEN,LEXSY,LEXMSG
. S LEXN1=$G(^TMP("DIAGSRCH",$J,LEXCO))
. S LEXN2=$G(^TMP("DIAGSRCH",$J,LEXCO,0))
. S LEXSIEN=+LEXN1,LEXEIEN=+LEXN2
. S LEXC=$P(LEXN1,"^",2),LEXEFF=$P(LEXN1,"^",3)
. S LEXMSG=$$MSG(LEXC)
. S LEXEXP=$P(LEXN2,"^",2)
. I LEXSIEN'>0,LEXEIEN'>0 D Q
. . N LEXO,LEXC,LEXE,LEXT,LEXN,LEXNC,LEXMSG
. . S LEXC=$P(LEXN1,"^",2) Q:'$L(LEXC)
. . S LEXE=$P(LEXN1,"^",3) Q:LEXE'?7N
. . S LEXNC=$P(LEXN1,"^",4)
. . S LEXNC=$S(+LEXNC>0:+LEXNC,1:"")
. . S LEXN=$P(LEXN2,"^",2) Q:'$L(LEXN)
. . S LEXT="CAT"
. . S LEXO=$O(LEXDATA(" "),-1)+1
. . S LEXDATA(LEXO,0)=LEXC_$S($G(LEXEFF)?7N:("^"_LEXEFF),1:"")
. . S:+LEXNC>0 $P(LEXDATA(LEXO,0),"^",3)=+LEXNC
. . S LEXDATA(LEXO,LEXT)=LEXN
. . S LEXDATA(LEXO,"MENU")=LEXN
. . S:$L($G(LEXMSG)) LEXDATA(LEXO,"MSG")=$G(LEXMSG)
. I LEXCS=1!(LEXCS=30) D
. . S LEXICD=$$ICDDX^ICDEX(LEXC,LEXVDT,LEXCS,"E") S (LEXSD,LEXLD)=""
. . S:+LEXICD>0 LEXSD=$$SD^ICDEX(80,+LEXICD,LEXVDT,.LEXSD)
. . I LEXVDT'?7N,$P(LEXSD,"^",1)="-1" D
. . . N LEXSH,LEXT,LEXE S LEXT=$$SDH^ICDEX(80,+LEXICD,.LEXSH)
. . . S LEXE=$O(LEXSH(9999999),-1),LEXS=$G(LEXSH(+LEXE)) S:$L(LEXS) LEXSD=LEXS
. . . S:+($G(LEXSH(0)))>0 LEXSD(0)=$P($G(LEXSH(0)),"^",1,2)
. . S LEXSDE=$P($G(LEXSD(0)),"^",2) S:LEXSDE'?7N LEXSDE="" S LEXLD=""
. . S:+LEXICD>0 LEXLD=$$LD^ICDEX(80,+LEXICD,LEXVDT,.LEXLD)
. . I LEXVDT'?7N,$P(LEXLD,"^",1)="-1" D
. . . N LEXLH,LEXT,LEXE S LEXT=$$LDH^ICDEX(80,+LEXICD,.LEXLH)
. . . S LEXE=$O(LEXLH(9999999),-1),LEXS=$G(LEXLH(+LEXE)) S:$L(LEXS) LEXLD=LEXS
. . . S:+($G(LEXLH(0)))>0 LEXLD(0)=$P($G(LEXLH(0)),"^",1,2)
. . S LEXLDE=$P($G(LEXLD(0)),"^",2) S:LEXLDE'?7N LEXLDE=""
. . S:$E(LEXLD,1,2)="-1" LEXLD=""
. S:LEXSIEN>0&(+LEXEIEN>0) LEXCT=+($G(LEXCT))+1
. S LEXO=$O(LEXDATA(" "),-1)+1,LEXDATA(LEXO,0)=LEXC
. I $D(LEXINC) D
. . S:+LEXSIEN>0 $P(LEXDATA(LEXO,0),"^",2)=+LEXSIEN
. . S:+LEXSIEN>0&(LEXEFF?7N) $P(LEXDATA(LEXO,0),"^",3)=LEXEFF
. I '$D(LEXINC) D
. . S:+LEXSIEN>0&(LEXEFF?7N) $P(LEXDATA(LEXO,0),"^",2)=LEXEFF
. S (LEXDATA(LEXO,"LEX"),LEXDATA(LEXO,"MENU"))=LEXEXP
. S:$L($G(LEXMSG)) LEXDATA(LEXO,"MSG")=$G(LEXMSG)
. S:+LEXEIEN>0 LEXDATA(LEXO,"LEX",1)=+LEXEIEN
. S:+LEXEIEN>0&(LEXEFF?7N) $P(LEXDATA(LEXO,"LEX",1),"^",2)=LEXEFF
. S LEXICDT="" S:$L($G(LEXSD)) LEXDATA(LEXO,"IDS")=LEXSD
. S:$L($G(LEXSD))&(+LEXICD>0) $P(LEXICDT,"^",1)=+LEXICD
. S:$L($G(LEXSD))&(+LEXICD>0)&(LEXSDE?7N) $P(LEXICDT,"^",2)=+LEXSDE
. S:$L(LEXICDT) LEXDATA(LEXO,"IDS",1)=LEXICDT
. S LEXICDT="" S:$L($G(LEXLD)) LEXDATA(LEXO,"IDL")=LEXLD
. S:$L($G(LEXLD))&(+LEXICD>0) $P(LEXICDT,"^",1)=+LEXICD
. S:$L($G(LEXLD))&(+LEXICD>0)&(LEXLDE?7N) $P(LEXICDT,"^",2)=+LEXLDE
. S:$L(LEXICDT) LEXDATA(LEXO,"IDL",1)=LEXICDT
. S LEXDATA(0)=+($G(LEXCT))
. S:+($G(LEXPR))>0 $P(LEXDATA(0),"^",2)=+($G(LEXPR))
. S LEXSY="" D GETSYN^LEXTRAN1("10D",LEXC,LEXVDT,"LEXSY",1)
. S LEXPF=$G(LEXSY("P")),LEXP1=$P(LEXPF,"^",1),LEXP2=$P(LEXPF,"^",2)
. S LEXP3=$P(LEXPF,"^",3) I $L(LEXP1),+LEXP2>0 D
. . S LEXDATA(LEXO,"LEX")=$P(LEXPF,"^",1)
. . S:LEXP2>0 $P(LEXDATA(LEXO,"LEX",1),"^",1)=LEXP2
. . S:LEXP3>0 $P(LEXDATA(LEXO,"LEX",1),"^",2)=LEXP3
. S LEXI=0 F S LEXI=$O(LEXSY("S",LEXI)) Q:+LEXI'>0 D
. . N LEXS,LEXND,LEXP1,LEXP2 S LEXND=$G(LEXSY("S",LEXI))
. . S LEXP1=$P(LEXND,"^",1),LEXP2=+($P(LEXND,"^",2)) Q:LEXP2'>0
. . Q:'$L(LEXP1) S LEXS=$O(LEXDATA(LEXO,"SYN"," "),-1)+1
. . S LEXDATA(LEXO,"SYN",LEXS)=LEXND
. . S LEXDATA(LEXO,"SYN",0)=+LEXS
S:$O(LEXDATA(" "),-1)>0 LEXDATA(0)=$O(LEXDATA(" "),-1)
K ^TMP("DIAGSRCH",$J)
Q
;
; Miscellaneous
ISCAT(CODE) ; Is Code a Category
;
; Input
;
; CODE Code or Category
;
; Output
;
; $$ISCAT 4 Piece "^" Delimited String
;
; 1 Category flag
; 1 CODE is a Category
; 0 CODE is not a Category
;
; 2 Number of Sub-Categories belonging
; to the Category
;
; 3 Number of Codes belonging to the
; Category
;
; 4 Parent Category
; Parent Category
; Null if no Parent Category
;
N CATS,PAR S CODE=$P($G(CODE),"^",1) Q:'$L(CODE) 0
S:$L(CODE)=3&(CODE'[".") CODE=CODE_"."
Q:$L(CODE)>3&(CODE'[".") 0
S CATS=$$INC(CODE),PAR=$$PAR(CODE)
Q:$D(^LEX(757.033,"AFRAG",30,(CODE_" "))) ("1^"_CATS_"^"_PAR)
Q 0
INC(X) ; Category includes Cat/Codes
;
; Input
;
; CODE Code or Category
;
; Output
;
; $$INC 2 Piece "^" Delimited String
;
; 1 Number of Sub-Categories belonging
; to the Category
;
; 2 Number of Codes belonging to the
; Category
;
Q ($$CATS($G(X))_"^"_$$CODES($G(X)))
CATS(X) ; Number of Categories in a Category
;
; Input
;
; X Category
;
; Output
;
; $$CATS Number of Sub-Categories belonging to a Category
;
N CODE,ORG,ORD,CTL S (CTL,CODE)=$G(X),(ORG,ORD)=$E(CODE,1,($L(CODE)-1))_$C($A($E(CODE,$L(CODE)))-1)_"~"
S X=0 F S ORD=$O(^LEX(757.033,"AFRAG",30,ORD)) Q:'$L(ORD)!(ORD'[CTL) S:ORD'=(CODE_" ") X=X+1
Q X
PAR(X) ; Parent Category
N INP,PSN,EXIT,PAR S INP=$G(X),EXIT=0,PAR=""
F PSN=$L(INP):-1:4 D Q:EXIT Q:$L($G(PAR))
. N STR S STR=$E(INP,1,PSN) Q:$L(STR)'<$L(INP) Q:$L(STR)'>3
. Q:'$D(^LEX(757.033,"AFRAG",30,(STR_" ")))
. S PAR=STR,EXIT=1
S X=$S($L(PAR):PAR,1:"")
Q X
CODES(X) ; Number of Codes in a Category
;
; Input
;
; X Category
;
; Output
;
; $$CODES Number of codes belonging to a Category
;
N CODE,ORG,ORD,CTL S (CTL,CODE)=$G(X),(ORG,ORD)=$E(CODE,1,($L(CODE)-1))_$C($A($E(CODE,$L(CODE)))-1)_"~"
S X=0 F S ORD=$O(^LEX(757.02,"ADX",ORD)) Q:'$L(ORD)!(ORD'[CTL) S:ORD'=(CODE_" ") X=X+1
Q X
CAT(CODE) ; Get Category for Code
;
; Input
;
; CODE Code or Category
;
; Output
;
; $$CAT 3 Piece "^" Delimited String
;
; 1 Category
; 2 Effective Date
; 3 Category Name
;
; Null on error
;
S CODE=$G(CODE) Q:'$L(CODE) "" N FRAG,MAX,OUT,TDT,LEN S FRAG=$TR(CODE," ","")
S OUT="",TDT=$P($G(LEXVDT),".",1),MAX=$L(FRAG) F LEN=MAX:-1:3 D Q:$L(OUT)
. N EFF,NAM,IEN S FRAG=$E(FRAG,1,(LEN-1))
. S:$L(FRAG)=3&(FRAG'[".") FRAG=FRAG_"." Q:$L(FRAG)'>3
. S EFF=$O(^LEX(757.033,"AFRAG",30,(FRAG_" ")," "),-1)
. S:TDT?7N EFF=$O(^LEX(757.033,"AFRAG",30,(FRAG_" "),(TDT+.0001)),-1)
. S EFF=$P(EFF,".",1) Q:EFF'?7N I TDT?7N Q:EFF>TDT
. S IEN=$O(^LEX(757.033,"AFRAG",30,(FRAG_" "),+EFF," "),-1)
. S NAM=$$LN(IEN,+EFF) S:'$L(NAM) NAM=$$SN(IEN,+EFF) Q:'$L(NAM)
. S:$L(FRAG)&(EFF?7N)&($L(NAM)) OUT=(FRAG_"^"_EFF_"^"_NAM)
Q OUT
MSG(X) ; Message for Unversioned Search
N LEXCODE,LEXIA,LEXAC,LEXPD,LEXTD S LEXTD=$$DT^XLFDT,LEXCODE=$TR(X," ","")
S:$G(LEXCDT)?7N&($G(LEXCDT)'=LEXTD) LEXTD=$G(LEXCDT)
I $G(LEXCDT)="" S:$G(LEXVDT)?7N&($G(LEXVDT)'=LEXTD) LEXTD=$G(LEXVDT)
Q:'$L(LEXCODE) "" Q:'$D(^LEX(757.02,"ACT",(LEXCODE_" "))) ""
S LEXIA=$O(^LEX(757.02,"ACT",(LEXCODE_" "),2,(LEXTD+.0001)),-1)
S LEXAC=$O(^LEX(757.02,"ACT",(LEXCODE_" "),3,(LEXTD-.0001)),-1)
S LEXPD=$O(^LEX(757.02,"ACT",(LEXCODE_" "),3,(LEXTD)))
I LEXIA?7N,LEXAC?7N,LEXIA>LEXAC D Q X
. S X="Inactive "_$$FMTE^XLFDT(LEXIA,"5Z")
I LEXAC'=LEXTD,LEXPD?7N,LEXPD>LEXTD D Q X
. S X="Pending "_$$FMTE^XLFDT(LEXPD,"5Z")
Q ""
SN(X,EFF) ; Short Name
N IEN,CDT,IMP,EFF,HIS S IEN=+($G(X)),CDT=$G(LEXVDT) S:$G(EFF)?7N CDT=$G(EFF)
S IMP=$$IMPDATE^LEXU(30) S:CDT'?7N CDT=$$DT^XLFDT
S:CDT'>IMP&(IMP?7N) CDT=IMP
S EFF=$O(^LEX(757.033,+IEN,2,"B",(CDT+.001)),-1)
S HIS=$O(^LEX(757.033,+IEN,2,"B",+EFF," "),-1)
S X=$G(^LEX(757.033,+IEN,2,+HIS,1))
Q X
LN(X,EFF) ; Long Name
N IEN,CDT,IMP,EFF,HIS S IEN=+($G(X)),CDT=$G(LEXVDT) S:$G(EFF)?7N CDT=$G(EFF)
S IMP=$$IMPDATE^LEXU(30) S:CDT'?7N CDT=$$DT^XLFDT
S:CDT'>IMP&(IMP?7N) CDT=IMP
S EFF=$O(^LEX(757.033,+IEN,3,"B",(CDT+.001)),-1)
S HIS=$O(^LEX(757.033,+IEN,3,"B",+EFF," "),-1)
S X=$G(^LEX(757.033,+IEN,3,+HIS,1))
Q X
SCR(X,Y) ; Screen
S Y=+($G(Y)) Q:+Y'>0 0 Q:'$D(^LEX(757.01,+Y,0)) 0
N LEXFIL S LEXFIL=$G(X) Q:'$L(LEXFIL) 1 D ^DIM Q:'$D(X) 1
X LEXFIL S X=$T
Q X
SH ; Show TMP
N LEXNN,LEXNC S LEXNN="^TMP(""LEXDX"","_$J_")",LEXNC="^TMP(""LEXDX"","_$J_","
W !!,"3",! F S LEXNN=$q(@LEXNN) Q:'$L(LEXNN)!(LEXNN'[LEXNC) W !,LEXNN,"=",@LEXNN
Q
PT ; Entry point where DA is defined and X is unknown
Q:'$D(DA) S X=^LEX(757.01,DA,0)
PTX ; Entry point to parse string (X must exist)
N LEXOK,LEXTOKS,LEXTOKS2,LEXTOKI,LEXTOKW,LEXTOLKN,LEXOKC,LEXOKN,LEXOKP,LEXTOKAA,LEXTOKAB,LEXTOKAC K ^TMP("LEXTKN",$J) N DA
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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLEX10DU 13470 printed Sep 23, 2025@19:39:19 Page 2
LEX10DU ;ISL/KER - ICD-10 Diagnosis Utilities ;04/21/2014
+1 ;;2.0;LEXICON UTILITY;**80**;Sep 23, 1996;Build 1
+2 ;
+3 ; Global Variables
+4 ; ^LEX(757.033 N/A
+5 ; ^TMP("DIAGSRCH" SACC 2.3.2.5.1
+6 ; ^TMP("LEXDX") SACC 2.3.2.5.1
+7 ; ^TMP("LEXTKN" SACC 2.3.2.5.1
+8 ;
+9 ; External References
+10 ; ^DIM ICR 10016
+11 ; $$ICDDX^ICDEX ICR 5747
+12 ; $$LD^ICDEX ICR 5747
+13 ; $$SD^ICDEX ICR 5747
+14 ; $$DT^XLFDT ICR 10103
+15 ;
+16 ; Local Variables NEWed or KILLed by calling
+17 ; routine LEX10DBT, LEX10DBC or LEX10CS
+18 ; LEXA
+19 ; LEXCS
+20 ; LEXDATA
+21 ; LEXFI
+22 ; LEXINC
+23 ; LEXVDT
+24 ;
+25 QUIT
REDUCE(X) ; Reduce List
+1 NEW LEXC,LEXIT,LEXLEN,LEXMAX,LEXPRE,LEXUSE
+2 SET LEXUSE=0
SET LEXLEN=8
SET LEXPRE=7
SET LEXMAX=+($GET(X))
+3 if LEXMAX'>0
SET LEXMAX=30
SET LEXCT=+($GET(LEXCT))
if +LEXCT'>0
QUIT
+4 SET LEXIT=0
FOR
if LEXCT'>LEXMAX!(LEXIT)
QUIT
Begin DoDot:1
+5 if LEXPRE=LEXLEN
SET LEXIT=1
if LEXIT
QUIT
+6 NEW LEXC
SET LEXC=""
SET LEXCT=0
+7 FOR
SET LEXC=$ORDER(^TMP("LEXDX",$JOB,LEXC))
if '$LENGTH(LEXC)
QUIT
Begin DoDot:2
+8 IF $LENGTH(LEXC)=(LEXLEN+1)
Begin DoDot:3
+9 NEW LEXCAT,LEXIS,LEXNCT,LEXNCD,LEXNPR,LEXCE,LEXTX
+10 SET LEXCAT=$$CAT(LEXC)
SET LEXCE=$PIECE(LEXCAT,"^",2)
+11 SET LEXTX=$PIECE(LEXCAT,"^",3)
SET LEXCAT=$PIECE(LEXCAT,"^",1)
+12 KILL ^TMP("LEXDX",$JOB,LEXC)
SET LEXUSE=1
+13 if $DATA(^TMP("LEXDX",$JOB,(LEXCAT_" ")))
QUIT
+14 SET LEXIS=$$ISCAT(LEXCAT)
+15 SET LEXNCT=$PIECE(LEXIS,"^",2)
+16 SET LEXNCD=$PIECE(LEXIS,"^",3)
+17 SET LEXNPR=$PIECE(LEXIS,"^",4)
+18 IF $LENGTH(LEXCAT)
IF LEXCE?7N
IF $LENGTH(LEXTX)
Begin DoDot:4
+19 NEW LEX
SET LEX=LEXCE_"^"_LEXTX
+20 if +($GET(LEXNCD))>0
SET $PIECE(LEX,"^",3)=+($GET(LEXNCD))
+21 SET ^TMP("LEXDX",$JOB,(LEXCAT_" "))="^"_LEX
SET LEXCT=LEXCT+1
End DoDot:4
End DoDot:3
QUIT
+22 SET LEXCT=LEXCT+1
End DoDot:2
+23 IF LEXPRE>3
SET LEXLEN=LEXPRE
SET LEXPRE=LEXPRE-1
QUIT
+24 if LEXPRE=3
SET LEXIT=1
End DoDot:1
if LEXIT
QUIT
+25 SET LEXC=""
FOR
SET LEXC=$ORDER(^TMP("LEXDX",$JOB,LEXC))
if '$LENGTH(LEXC)
QUIT
Begin DoDot:1
+26 SET LEXCT=$PIECE($GET(^TMP("LEXDX",$JOB,LEXC)),"^",4)
if LEXCT'>0
QUIT
+27 NEW LEXCTL,LEXNXT,LEXCT
SET LEXCTL=$TRANSLATE(LEXC," ")
if '$LENGTH(LEXCTL)
QUIT
+28 SET LEXNXT=$ORDER(^TMP("LEXDX",$JOB,(LEXCTL_" ")))
if '$LENGTH(LEXNXT)
QUIT
+29 if $EXTRACT(LEXNXT,1,$LENGTH(LEXCTL))=LEXCTL
KILL ^TMP("LEXDX",$JOB,(LEXCTL_" "))
End DoDot:1
+30 QUIT
ARY ; Build Local Array
+1 NEW LEXC,LEXACT
SET LEXC=""
SET LEXACT=0
+2 FOR
SET LEXC=$ORDER(^TMP("LEXDX",$JOB,LEXC))
if '$LENGTH(LEXC)
QUIT
Begin DoDot:1
+3 NEW LEXSIEN,LEXEIEN,LEXEXP,LEXCAT,LEXND,LEXD,LEXSO,LEXNC
+4 SET LEXND=$GET(^TMP("LEXDX",$JOB,LEXC))
+5 SET LEXSIEN=+LEXND
SET LEXD=$PIECE($PIECE(LEXND,"^",2),".",1)
+6 SET LEXCAT=$PIECE(LEXND,"^",3)
SET LEXNC=$PIECE(LEXND,"^",4)
+7 SET LEXEIEN=+($GET(^LEX(757.02,+LEXSIEN,0)))
+8 SET LEXEXP=$GET(^LEX(757.01,+LEXEIEN,0))
SET LEXSO=$$TM(LEXC)
+9 IF '$LENGTH(LEXCAT)
if LEXSIEN'>0
QUIT
if LEXEIEN'>0
QUIT
if '$LENGTH(LEXEXP)
QUIT
+10 if ($GET(LEXCDT)?7N)&(LEXD'?7N)
QUIT
if '$DATA(LEXCDT)&(LEXD'?7N)
QUIT
if '$LENGTH(LEXSO)
QUIT
+11 IF +LEXSIEN>0
Begin DoDot:2
+12 SET LEXACT=LEXACT+1
SET LEXA(LEXACT)=LEXSIEN_"^"_LEXSO_"^"_LEXD
+13 SET LEXA(LEXACT,0)=+LEXEIEN_"^"_LEXEXP
End DoDot:2
+14 IF +LEXSIEN'>0
IF $LENGTH(LEXCAT)
Begin DoDot:2
+15 NEW LEX
SET LEX="^"_LEXSO_"^"_LEXD
+16 if +($GET(LEXNC))>0
SET $PIECE(LEX,"^",4)=+($GET(LEXNC))
+17 SET LEXACT=LEXACT+1
SET LEXA(LEXACT)=LEX
+18 SET LEXA(LEXACT,0)="^"_LEXCAT
End DoDot:2
+19 SET LEXA(0)=LEXACT
End DoDot:1
+20 if +($GET(LEXA(0)))'>0
SET LEXA(0)=-1
if +($GET(LEXA(0)))'>0
QUIT
+21 if +($GET(LEXUSE))>0&($GET(LEXA(0))>0)
SET $PIECE(LEXA(0),"^",2)=1
+22 QUIT
DXARY ; Build Output Array from Search Results
+1 NEW LEXOI,LEXC,LEXCO,LEXCT
SET LEXFI=+($GET(LEXFI))
if "^80^"'[("^"_LEXFI_"^")
QUIT
+2 SET LEXCS=+($GET(LEXCS))
if +LEXCS'>0
QUIT
if "^1^30^"'[("^"_LEXCS_"^")
QUIT
+3 KILL ^TMP("DIAGSRCH",$JOB)
SET (LEXCT,LEXOI)=0
+4 FOR
SET LEXOI=$ORDER(LEXOUT(LEXOI))
if +LEXOI'>0
QUIT
Begin DoDot:1
+5 NEW LEXC,LEXI
SET LEXC=$PIECE($GET(LEXOUT(LEXOI)),"^",2)
if '$LENGTH(LEXC)
QUIT
+6 SET ^TMP("DIAGSRCH",$JOB,(LEXC_" "))=$GET(LEXOUT(LEXOI))
+7 SET ^TMP("DIAGSRCH",$JOB,(LEXC_" "),0)=$GET(LEXOUT(LEXOI,0))
+8 if +($GET(LEXCS))'=30
QUIT
FOR LEXI=1:1:$LENGTH(LEXC)
Begin DoDot:2
+9 QUIT
+10 NEW LEXS,LEXSD,LEXSI,LEXSN,LEXF,LEXFA
SET LEXS=$EXTRACT(LEXC,1,($LENGTH(LEXC)-LEXI))
+11 if '$DATA(^LEX(757.033,"AFRAG",30,(LEXS_" ")))
QUIT
+12 SET LEXSD=$ORDER(^LEX(757.033,"AFRAG",30,(LEXS_" "),0))
+13 if LEXSD'?7N
QUIT
if +($GET(LEXVDT))<LEXSD
QUIT
+14 SET LEXSI=$ORDER(^LEX(757.033,"AFRAG",30,(LEXS_" "),LEXSD,0))
+15 if +LEXSI'>0
QUIT
SET LEXSN=$$LN(+LEXSI)
+16 if '$LENGTH(LEXSN)
SET LEXSN=$$SN(+LEXSI)
if '$LENGTH(LEXSN)
QUIT
+17 SET ^TMP("DIAGSRCH",$JOB,(LEXS_" "))="-^"_LEXS_"^"_LEXSD
+18 SET ^TMP("DIAGSRCH",$JOB,(LEXS_" "),0)="-^"_LEXSN
End DoDot:2
End DoDot:1
+19 KILL LEXOUT
SET LEXCO=""
FOR
SET LEXCO=$ORDER(^TMP("DIAGSRCH",$JOB,LEXCO))
if '$LENGTH(LEXCO)
QUIT
Begin DoDot:1
+20 NEW LEXC,LEXEFF,LEXEIEN,LEXEXP,LEXI,LEXICD,LEXICDT,LEXLD,LEXLDE
+21 NEW LEXN1,LEXN2,LEXND,LEXO,LEXP1,LEXP2,LEXP3,LEXPF,LEXPR,LEXS
+22 NEW LEXSD,LEXSDE,LEXSIEN,LEXSY,LEXMSG
+23 SET LEXN1=$GET(^TMP("DIAGSRCH",$JOB,LEXCO))
+24 SET LEXN2=$GET(^TMP("DIAGSRCH",$JOB,LEXCO,0))
+25 SET LEXSIEN=+LEXN1
SET LEXEIEN=+LEXN2
+26 SET LEXC=$PIECE(LEXN1,"^",2)
SET LEXEFF=$PIECE(LEXN1,"^",3)
+27 SET LEXMSG=$$MSG(LEXC)
+28 SET LEXEXP=$PIECE(LEXN2,"^",2)
+29 IF LEXSIEN'>0
IF LEXEIEN'>0
Begin DoDot:2
+30 NEW LEXO,LEXC,LEXE,LEXT,LEXN,LEXNC,LEXMSG
+31 SET LEXC=$PIECE(LEXN1,"^",2)
if '$LENGTH(LEXC)
QUIT
+32 SET LEXE=$PIECE(LEXN1,"^",3)
if LEXE'?7N
QUIT
+33 SET LEXNC=$PIECE(LEXN1,"^",4)
+34 SET LEXNC=$SELECT(+LEXNC>0:+LEXNC,1:"")
+35 SET LEXN=$PIECE(LEXN2,"^",2)
if '$LENGTH(LEXN)
QUIT
+36 SET LEXT="CAT"
+37 SET LEXO=$ORDER(LEXDATA(" "),-1)+1
+38 SET LEXDATA(LEXO,0)=LEXC_$SELECT($GET(LEXEFF)?7N:("^"_LEXEFF),1:"")
+39 if +LEXNC>0
SET $PIECE(LEXDATA(LEXO,0),"^",3)=+LEXNC
+40 SET LEXDATA(LEXO,LEXT)=LEXN
+41 SET LEXDATA(LEXO,"MENU")=LEXN
+42 if $LENGTH($GET(LEXMSG))
SET LEXDATA(LEXO,"MSG")=$GET(LEXMSG)
End DoDot:2
QUIT
+43 IF LEXCS=1!(LEXCS=30)
Begin DoDot:2
+44 SET LEXICD=$$ICDDX^ICDEX(LEXC,LEXVDT,LEXCS,"E")
SET (LEXSD,LEXLD)=""
+45 if +LEXICD>0
SET LEXSD=$$SD^ICDEX(80,+LEXICD,LEXVDT,.LEXSD)
+46 IF LEXVDT'?7N
IF $PIECE(LEXSD,"^",1)="-1"
Begin DoDot:3
+47 NEW LEXSH,LEXT,LEXE
SET LEXT=$$SDH^ICDEX(80,+LEXICD,.LEXSH)
+48 SET LEXE=$ORDER(LEXSH(9999999),-1)
SET LEXS=$GET(LEXSH(+LEXE))
if $LENGTH(LEXS)
SET LEXSD=LEXS
+49 if +($GET(LEXSH(0)))>0
SET LEXSD(0)=$PIECE($GET(LEXSH(0)),"^",1,2)
End DoDot:3
+50 SET LEXSDE=$PIECE($GET(LEXSD(0)),"^",2)
if LEXSDE'?7N
SET LEXSDE=""
SET LEXLD=""
+51 if +LEXICD>0
SET LEXLD=$$LD^ICDEX(80,+LEXICD,LEXVDT,.LEXLD)
+52 IF LEXVDT'?7N
IF $PIECE(LEXLD,"^",1)="-1"
Begin DoDot:3
+53 NEW LEXLH,LEXT,LEXE
SET LEXT=$$LDH^ICDEX(80,+LEXICD,.LEXLH)
+54 SET LEXE=$ORDER(LEXLH(9999999),-1)
SET LEXS=$GET(LEXLH(+LEXE))
if $LENGTH(LEXS)
SET LEXLD=LEXS
+55 if +($GET(LEXLH(0)))>0
SET LEXLD(0)=$PIECE($GET(LEXLH(0)),"^",1,2)
End DoDot:3
+56 SET LEXLDE=$PIECE($GET(LEXLD(0)),"^",2)
if LEXLDE'?7N
SET LEXLDE=""
+57 if $EXTRACT(LEXLD,1,2)="-1"
SET LEXLD=""
End DoDot:2
+58 if LEXSIEN>0&(+LEXEIEN>0)
SET LEXCT=+($GET(LEXCT))+1
+59 SET LEXO=$ORDER(LEXDATA(" "),-1)+1
SET LEXDATA(LEXO,0)=LEXC
+60 IF $DATA(LEXINC)
Begin DoDot:2
+61 if +LEXSIEN>0
SET $PIECE(LEXDATA(LEXO,0),"^",2)=+LEXSIEN
+62 if +LEXSIEN>0&(LEXEFF?7N)
SET $PIECE(LEXDATA(LEXO,0),"^",3)=LEXEFF
End DoDot:2
+63 IF '$DATA(LEXINC)
Begin DoDot:2
+64 if +LEXSIEN>0&(LEXEFF?7N)
SET $PIECE(LEXDATA(LEXO,0),"^",2)=LEXEFF
End DoDot:2
+65 SET (LEXDATA(LEXO,"LEX"),LEXDATA(LEXO,"MENU"))=LEXEXP
+66 if $LENGTH($GET(LEXMSG))
SET LEXDATA(LEXO,"MSG")=$GET(LEXMSG)
+67 if +LEXEIEN>0
SET LEXDATA(LEXO,"LEX",1)=+LEXEIEN
+68 if +LEXEIEN>0&(LEXEFF?7N)
SET $PIECE(LEXDATA(LEXO,"LEX",1),"^",2)=LEXEFF
+69 SET LEXICDT=""
if $LENGTH($GET(LEXSD))
SET LEXDATA(LEXO,"IDS")=LEXSD
+70 if $LENGTH($GET(LEXSD))&(+LEXICD>0)
SET $PIECE(LEXICDT,"^",1)=+LEXICD
+71 if $LENGTH($GET(LEXSD))&(+LEXICD>0)&(LEXSDE?7N)
SET $PIECE(LEXICDT,"^",2)=+LEXSDE
+72 if $LENGTH(LEXICDT)
SET LEXDATA(LEXO,"IDS",1)=LEXICDT
+73 SET LEXICDT=""
if $LENGTH($GET(LEXLD))
SET LEXDATA(LEXO,"IDL")=LEXLD
+74 if $LENGTH($GET(LEXLD))&(+LEXICD>0)
SET $PIECE(LEXICDT,"^",1)=+LEXICD
+75 if $LENGTH($GET(LEXLD))&(+LEXICD>0)&(LEXLDE?7N)
SET $PIECE(LEXICDT,"^",2)=+LEXLDE
+76 if $LENGTH(LEXICDT)
SET LEXDATA(LEXO,"IDL",1)=LEXICDT
+77 SET LEXDATA(0)=+($GET(LEXCT))
+78 if +($GET(LEXPR))>0
SET $PIECE(LEXDATA(0),"^",2)=+($GET(LEXPR))
+79 SET LEXSY=""
DO GETSYN^LEXTRAN1("10D",LEXC,LEXVDT,"LEXSY",1)
+80 SET LEXPF=$GET(LEXSY("P"))
SET LEXP1=$PIECE(LEXPF,"^",1)
SET LEXP2=$PIECE(LEXPF,"^",2)
+81 SET LEXP3=$PIECE(LEXPF,"^",3)
IF $LENGTH(LEXP1)
IF +LEXP2>0
Begin DoDot:2
+82 SET LEXDATA(LEXO,"LEX")=$PIECE(LEXPF,"^",1)
+83 if LEXP2>0
SET $PIECE(LEXDATA(LEXO,"LEX",1),"^",1)=LEXP2
+84 if LEXP3>0
SET $PIECE(LEXDATA(LEXO,"LEX",1),"^",2)=LEXP3
End DoDot:2
+85 SET LEXI=0
FOR
SET LEXI=$ORDER(LEXSY("S",LEXI))
if +LEXI'>0
QUIT
Begin DoDot:2
+86 NEW LEXS,LEXND,LEXP1,LEXP2
SET LEXND=$GET(LEXSY("S",LEXI))
+87 SET LEXP1=$PIECE(LEXND,"^",1)
SET LEXP2=+($PIECE(LEXND,"^",2))
if LEXP2'>0
QUIT
+88 if '$LENGTH(LEXP1)
QUIT
SET LEXS=$ORDER(LEXDATA(LEXO,"SYN"," "),-1)+1
+89 SET LEXDATA(LEXO,"SYN",LEXS)=LEXND
+90 SET LEXDATA(LEXO,"SYN",0)=+LEXS
End DoDot:2
End DoDot:1
+91 if $ORDER(LEXDATA(" "),-1)>0
SET LEXDATA(0)=$ORDER(LEXDATA(" "),-1)
+92 KILL ^TMP("DIAGSRCH",$JOB)
+93 QUIT
+94 ;
+95 ; Miscellaneous
ISCAT(CODE) ; Is Code a Category
+1 ;
+2 ; Input
+3 ;
+4 ; CODE Code or Category
+5 ;
+6 ; Output
+7 ;
+8 ; $$ISCAT 4 Piece "^" Delimited String
+9 ;
+10 ; 1 Category flag
+11 ; 1 CODE is a Category
+12 ; 0 CODE is not a Category
+13 ;
+14 ; 2 Number of Sub-Categories belonging
+15 ; to the Category
+16 ;
+17 ; 3 Number of Codes belonging to the
+18 ; Category
+19 ;
+20 ; 4 Parent Category
+21 ; Parent Category
+22 ; Null if no Parent Category
+23 ;
+24 NEW CATS,PAR
SET CODE=$PIECE($GET(CODE),"^",1)
if '$LENGTH(CODE)
QUIT 0
+25 if $LENGTH(CODE)=3&(CODE'[".")
SET CODE=CODE_"."
+26 if $LENGTH(CODE)>3&(CODE'[".")
QUIT 0
+27 SET CATS=$$INC(CODE)
SET PAR=$$PAR(CODE)
+28 if $DATA(^LEX(757.033,"AFRAG",30,(CODE_" ")))
QUIT ("1^"_CATS_"^"_PAR)
+29 QUIT 0
INC(X) ; Category includes Cat/Codes
+1 ;
+2 ; Input
+3 ;
+4 ; CODE Code or Category
+5 ;
+6 ; Output
+7 ;
+8 ; $$INC 2 Piece "^" Delimited String
+9 ;
+10 ; 1 Number of Sub-Categories belonging
+11 ; to the Category
+12 ;
+13 ; 2 Number of Codes belonging to the
+14 ; Category
+15 ;
+16 QUIT ($$CATS($GET(X))_"^"_$$CODES($GET(X)))
CATS(X) ; Number of Categories in a Category
+1 ;
+2 ; Input
+3 ;
+4 ; X Category
+5 ;
+6 ; Output
+7 ;
+8 ; $$CATS Number of Sub-Categories belonging to a Category
+9 ;
+10 NEW CODE,ORG,ORD,CTL
SET (CTL,CODE)=$GET(X)
SET (ORG,ORD)=$EXTRACT(CODE,1,($LENGTH(CODE)-1))_$CHAR($ASCII($EXTRACT(CODE,$LENGTH(CODE)))-1)_"~"
+11 SET X=0
FOR
SET ORD=$ORDER(^LEX(757.033,"AFRAG",30,ORD))
if '$LENGTH(ORD)!(ORD'[CTL)
QUIT
if ORD'=(CODE_" ")
SET X=X+1
+12 QUIT X
PAR(X) ; Parent Category
+1 NEW INP,PSN,EXIT,PAR
SET INP=$GET(X)
SET EXIT=0
SET PAR=""
+2 FOR PSN=$LENGTH(INP):-1:4
Begin DoDot:1
+3 NEW STR
SET STR=$EXTRACT(INP,1,PSN)
if $LENGTH(STR)'<$LENGTH(INP)
QUIT
if $LENGTH(STR)'>3
QUIT
+4 if '$DATA(^LEX(757.033,"AFRAG",30,(STR_" ")))
QUIT
+5 SET PAR=STR
SET EXIT=1
End DoDot:1
if EXIT
QUIT
if $LENGTH($GET(PAR))
QUIT
+6 SET X=$SELECT($LENGTH(PAR):PAR,1:"")
+7 QUIT X
CODES(X) ; Number of Codes in a Category
+1 ;
+2 ; Input
+3 ;
+4 ; X Category
+5 ;
+6 ; Output
+7 ;
+8 ; $$CODES Number of codes belonging to a Category
+9 ;
+10 NEW CODE,ORG,ORD,CTL
SET (CTL,CODE)=$GET(X)
SET (ORG,ORD)=$EXTRACT(CODE,1,($LENGTH(CODE)-1))_$CHAR($ASCII($EXTRACT(CODE,$LENGTH(CODE)))-1)_"~"
+11 SET X=0
FOR
SET ORD=$ORDER(^LEX(757.02,"ADX",ORD))
if '$LENGTH(ORD)!(ORD'[CTL)
QUIT
if ORD'=(CODE_" ")
SET X=X+1
+12 QUIT X
CAT(CODE) ; Get Category for Code
+1 ;
+2 ; Input
+3 ;
+4 ; CODE Code or Category
+5 ;
+6 ; Output
+7 ;
+8 ; $$CAT 3 Piece "^" Delimited String
+9 ;
+10 ; 1 Category
+11 ; 2 Effective Date
+12 ; 3 Category Name
+13 ;
+14 ; Null on error
+15 ;
+16 SET CODE=$GET(CODE)
if '$LENGTH(CODE)
QUIT ""
NEW FRAG,MAX,OUT,TDT,LEN
SET FRAG=$TRANSLATE(CODE," ","")
+17 SET OUT=""
SET TDT=$PIECE($GET(LEXVDT),".",1)
SET MAX=$LENGTH(FRAG)
FOR LEN=MAX:-1:3
Begin DoDot:1
+18 NEW EFF,NAM,IEN
SET FRAG=$EXTRACT(FRAG,1,(LEN-1))
+19 if $LENGTH(FRAG)=3&(FRAG'[".")
SET FRAG=FRAG_"."
if $LENGTH(FRAG)'>3
QUIT
+20 SET EFF=$ORDER(^LEX(757.033,"AFRAG",30,(FRAG_" ")," "),-1)
+21 if TDT?7N
SET EFF=$ORDER(^LEX(757.033,"AFRAG",30,(FRAG_" "),(TDT+.0001)),-1)
+22 SET EFF=$PIECE(EFF,".",1)
if EFF'?7N
QUIT
IF TDT?7N
if EFF>TDT
QUIT
+23 SET IEN=$ORDER(^LEX(757.033,"AFRAG",30,(FRAG_" "),+EFF," "),-1)
+24 SET NAM=$$LN(IEN,+EFF)
if '$LENGTH(NAM)
SET NAM=$$SN(IEN,+EFF)
if '$LENGTH(NAM)
QUIT
+25 if $LENGTH(FRAG)&(EFF?7N)&($LENGTH(NAM))
SET OUT=(FRAG_"^"_EFF_"^"_NAM)
End DoDot:1
if $LENGTH(OUT)
QUIT
+26 QUIT OUT
MSG(X) ; Message for Unversioned Search
+1 NEW LEXCODE,LEXIA,LEXAC,LEXPD,LEXTD
SET LEXTD=$$DT^XLFDT
SET LEXCODE=$TRANSLATE(X," ","")
+2 if $GET(LEXCDT)?7N&($GET(LEXCDT)'=LEXTD)
SET LEXTD=$GET(LEXCDT)
+3 IF $GET(LEXCDT)=""
if $GET(LEXVDT)?7N&($GET(LEXVDT)'=LEXTD)
SET LEXTD=$GET(LEXVDT)
+4 if '$LENGTH(LEXCODE)
QUIT ""
if '$DATA(^LEX(757.02,"ACT",(LEXCODE_" ")))
QUIT ""
+5 SET LEXIA=$ORDER(^LEX(757.02,"ACT",(LEXCODE_" "),2,(LEXTD+.0001)),-1)
+6 SET LEXAC=$ORDER(^LEX(757.02,"ACT",(LEXCODE_" "),3,(LEXTD-.0001)),-1)
+7 SET LEXPD=$ORDER(^LEX(757.02,"ACT",(LEXCODE_" "),3,(LEXTD)))
+8 IF LEXIA?7N
IF LEXAC?7N
IF LEXIA>LEXAC
Begin DoDot:1
+9 SET X="Inactive "_$$FMTE^XLFDT(LEXIA,"5Z")
End DoDot:1
QUIT X
+10 IF LEXAC'=LEXTD
IF LEXPD?7N
IF LEXPD>LEXTD
Begin DoDot:1
+11 SET X="Pending "_$$FMTE^XLFDT(LEXPD,"5Z")
End DoDot:1
QUIT X
+12 QUIT ""
SN(X,EFF) ; Short Name
+1 NEW IEN,CDT,IMP,EFF,HIS
SET IEN=+($GET(X))
SET CDT=$GET(LEXVDT)
if $GET(EFF)?7N
SET CDT=$GET(EFF)
+2 SET IMP=$$IMPDATE^LEXU(30)
if CDT'?7N
SET CDT=$$DT^XLFDT
+3 if CDT'>IMP&(IMP?7N)
SET CDT=IMP
+4 SET EFF=$ORDER(^LEX(757.033,+IEN,2,"B",(CDT+.001)),-1)
+5 SET HIS=$ORDER(^LEX(757.033,+IEN,2,"B",+EFF," "),-1)
+6 SET X=$GET(^LEX(757.033,+IEN,2,+HIS,1))
+7 QUIT X
LN(X,EFF) ; Long Name
+1 NEW IEN,CDT,IMP,EFF,HIS
SET IEN=+($GET(X))
SET CDT=$GET(LEXVDT)
if $GET(EFF)?7N
SET CDT=$GET(EFF)
+2 SET IMP=$$IMPDATE^LEXU(30)
if CDT'?7N
SET CDT=$$DT^XLFDT
+3 if CDT'>IMP&(IMP?7N)
SET CDT=IMP
+4 SET EFF=$ORDER(^LEX(757.033,+IEN,3,"B",(CDT+.001)),-1)
+5 SET HIS=$ORDER(^LEX(757.033,+IEN,3,"B",+EFF," "),-1)
+6 SET X=$GET(^LEX(757.033,+IEN,3,+HIS,1))
+7 QUIT X
SCR(X,Y) ; Screen
+1 SET Y=+($GET(Y))
if +Y'>0
QUIT 0
if '$DATA(^LEX(757.01,+Y,0))
QUIT 0
+2 NEW LEXFIL
SET LEXFIL=$GET(X)
if '$LENGTH(LEXFIL)
QUIT 1
DO ^DIM
if '$DATA(X)
QUIT 1
+3 XECUTE LEXFIL
SET X=$TEST
+4 QUIT X
SH ; Show TMP
+1 NEW LEXNN,LEXNC
SET LEXNN="^TMP(""LEXDX"","_$JOB_")"
SET LEXNC="^TMP(""LEXDX"","_$JOB_","
+2 WRITE !!,"3",!
FOR
