LEXAR5 ;ISL/KER - Look-up Response (Select Entry) ;05/23/2017
;;2.0;LEXICON UTILITY;**14,25,26,38,55,73,80,103**;Sep 23, 1996;Build 2
;
; Global Variables
; ^LEX(757.011 N/A
; ^YSD(627.7, ICR 1612
;
; External References
; $$ROOT^ICDEX ICR 5747
; $$STATCHK^ICDEX ICR 5747
; $$SYS^ICDEX ICR 5747
; $$STATCHK^ICPTAPIU ICR 1997
; $$DT^XLFDT ICR 10103
; $$UP^XLFSTR ICR 10104
;
; Local Variables NEWed or KILLed Elsewhere
; LEX LEX is killed in LEXA1
;
SETEXP(LEXX) ; Set LEX("SEL","EXP")
S LEXX=+($G(LEXX)) Q:LEXX'>0 Q:'$D(^LEX(757.01,LEXX,0))
N LEXYPE S LEXYPE=$$TYPE(LEXX)
Q:$D(LEX("SEL","EXP","B",LEXX))
N LEXC S LEXC=+($G(LEX("SEL","EXP",0))),LEXC=LEXC+1
S LEX("SEL","EXP",LEXC)=LEXX_"^"_^LEX(757.01,LEXX,0)
S LEX("SEL","EXP",0)=LEXC
S LEX("SEL","EXP","B",LEXX,LEXC)=""
S:LEXYPE'="" LEX("SEL","EXP","C",LEXYPE,LEXC)=""
Q
TYPE(LEXX) ; Expression Type
N LEXYPE S LEXYPE=$P($G(^LEX(757.01,LEXX,1)),"^",2)
I +LEXYPE'>0!('$D(^LEX(757.011,+LEXYPE,0))) S LEXYPE="OTH"
I +LEXYPE>0,$D(^LEX(757.011,+LEXYPE,0)) D
. S LEXYPE=$P($G(^LEX(757.011,+LEXYPE,0)),"^",1)
. S:$L(LEXYPE)<3 LEXYPE="OTH"
. S LEXYPE=$$UP^XLFSTR($E(LEXYPE,1,3))
S LEXX=LEXYPE Q LEXX
SETDEF(LEXX) ; Set LEX("SEL","SIG")
S LEXX=+($G(LEXX)) Q:LEXX=0
Q:'$D(^LEX(757.01,LEXX,3,1,0))
N LEXC,LEXR S LEXR=0
F S LEXR=$O(^LEX(757.01,LEXX,3,LEXR)) Q:+LEXR=0 D
. S LEXC=+($G(LEX("SEL","SIG",0))),LEXC=LEXC+1
. S LEX("SEL","SIG",LEXC)=$G(^LEX(757.01,LEXX,3,LEXR,0))
. S LEX("SEL","SIG",0)=LEXC
Q
SETSTY(LEXX) ; Set LEX("SEL","STY")
S LEXX=+($G(LEXX)) Q:LEXX=0
Q:'$D(^LEX(757.1,"B",LEXX))
N LEXC,LEXR,LEXSC,LEXST S LEXR=0
F S LEXR=$O(^LEX(757.1,"B",LEXX,LEXR)) Q:+LEXR=0 D
. S LEXSC=+($P($G(^LEX(757.1,LEXR,0)),"^",2))
. Q:LEXSC=0 Q:'$D(^LEX(757.11,LEXSC))
. S LEXSC=$P($G(^LEX(757.11,LEXSC,0)),"^",2) Q:'$L(LEXSC)
. S LEXST=+($P($G(^LEX(757.1,LEXR,0)),"^",3))
. Q:LEXST=0 Q:'$D(^LEX(757.12,LEXST))
. S LEXST=$P($G(^LEX(757.12,LEXST,0)),"^",2) Q:'$L(LEXST)
. Q:$D(LEX("SEL","STY","CTL",(LEXSC_"^"_LEXST)))
. S LEXC=+($G(LEX("SEL","STY",0))),LEXC=LEXC+1
. S LEX("SEL","STY",LEXC)=LEXSC_"^"_LEXST
. S LEX("SEL","STY",0)=LEXC
. S LEX("SEL","STY","CTL",(LEXSC_"^"_LEXST))=""
Q
SETSRC(LEXX,LEXVDT) ; Set LEX("SEL","SRC")
D VDT^LEXU N LEXSO,LEXSRC,LEXS,LEXC,LEXLD,LEXLS,LEXSN S LEXS=0
F S LEXS=$O(^LEX(757.02,"B",LEXX,LEXS)) Q:+LEXS=0 D
. S LEXSN=$G(^LEX(757.02,LEXS,0)),LEXSO=$P(LEXSN,"^",2)
. S LEXSRC=$P(LEXSN,"^",3) Q:LEXSRC=0
. Q:+$$STATCHK^LEXSRC2(LEXSO,$G(LEXVDT),,LEXSRC)'=1
. Q:'$D(^LEX(757.02,"AVA",(LEXSO_" "),LEXX))
. S LEXSRC=$P(^LEX(757.03,LEXSRC,0),"^",2) Q:'$L(LEXSRC)
. Q:$D(LEX("SEL","SRC","CTL",(LEXSRC_"^"_LEXSO_"^"_LEXX)))
. S LEXC=+($G(LEX("SEL","SRC",0))),LEXC=LEXC+1
. S LEX("SEL","SRC",LEXC)=LEXSRC_"^"_LEXSO_"^"_LEXX
. S LEX("SEL","SRC","B",LEXSRC,LEXC)=""
. S LEX("SEL","SRC","C",LEXSO,LEXC)=""
. S LEX("SEL","SRC","D",LEXX,LEXC)=""
. S LEX("SEL","SRC",0)=LEXC
. S LEX("SEL","SRC","CTL",(LEXSRC_"^"_LEXSO_"^"_LEXX))=""
D SETVAS(LEXX,+($G(LEXVDT)))
Q
SETVAS(LEXX,LEXVDT) ; Find VA sources for LEX("SEL","VAS")
D VDT^LEXU N LEXSAB,LEXRTN,LEXR,LEXVP
F LEXSAB="ICD","ICP","CPT","CPC","DS4","10D","10P","SCC" D
. N LEXTAG K LEXSRC
. S LEXTAG=$S(LEXSAB="10D":"D10",LEXSAB="10P":"P10",1:LEXSAB)
. S LEXRTN=LEXTAG_"^LEXAR5"
. S:'$L($T(@LEXRTN)) LEXRTN="OTH^LEXAR5"
. D ALL^LEXSRC(LEXX,LEXSAB,LEXVDT)
. I +($G(LEXSRC(0)))>0 D @LEXRTN
Q
;
VA ; VA Sources
ICD ; ICD-9 Diagnosis
Q:'$D(LEXX) S LEXX=+($G(LEXX)) Q:LEXX=0 Q:'$D(^LEX(757.01,LEXX,0))
N LEXRT,LEXFI,LEXSY S LEXSAB=$G(LEXSAB) Q:'$L(LEXSAB)
S LEXFI=80,LEXRT=$$ROOT^ICDEX(LEXFI),LEXSY=$$SYS^ICDEX(LEXSAB) D COM
Q
ICP ; ICD-9 Procedures
Q:'$D(LEXX) S LEXX=+($G(LEXX)) Q:LEXX=0 Q:'$D(^LEX(757.01,LEXX,0))
N LEXRT,LEXFI,LEXSY S LEXSAB=$G(LEXSAB) Q:'$L(LEXSAB)
S LEXFI=80.1,LEXRT=$$ROOT^ICDEX(LEXFI),LEXSY=$$SYS^ICDEX(LEXSAB) D COM
Q
CPT ; Current Procedural Terminology
Q:'$D(LEXX) S LEXX=+($G(LEXX)) Q:LEXX=0 Q:'$D(^LEX(757.01,LEXX,0))
N LEXRT,LEXFI,LEXSY S LEXSAB=$G(LEXSAB) Q:'$L(LEXSAB)
S LEXFI=81,LEXRT="^ICPT(",LEXSY=$O(^LEX(757.02,"ASAB",$E(LEXSAB,1,3),0)) D COM
Q
CPC ; HCPCS Terminology
Q:'$D(LEXX) S LEXX=+($G(LEXX)) Q:LEXX=0 Q:'$D(^LEX(757.01,LEXX,0))
N LEXRT,LEXFI,LEXSY S LEXSAB=$G(LEXSAB) Q:'$L(LEXSAB)
S LEXFI=81,LEXRT="^ICPT(",LEXSY=$O(^LEX(757.02,"ASAB",$E(LEXSAB,1,3),0)) D COM
Q
D10 ; ICD-10 Diagnosis
Q:'$D(LEXX) S LEXX=+($G(LEXX)) Q:LEXX=0 Q:'$D(^LEX(757.01,LEXX,0))
N LEXRT,LEXFI,LEXSY S LEXSAB=$G(LEXSAB) Q:'$L(LEXSAB)
S LEXFI=80,LEXRT=$$ROOT^ICDEX(LEXFI),LEXSY=$$SYS^ICDEX(LEXSAB) D COM
Q
P10 ; ICD-10 Procedures
Q:'$D(LEXX) S LEXX=+($G(LEXX)) Q:LEXX=0 Q:'$D(^LEX(757.01,LEXX,0))
N LEXRT,LEXFI,LEXSY S LEXSAB=$G(LEXSAB) Q:'$L(LEXSAB)
S LEXFI=80.1,LEXRT=$$ROOT^ICDEX(LEXFI),LEXSY=$$SYS^ICDEX(LEXSAB) D COM
Q
DS4 ; DSN-IV Mental Disorders
Q:'$D(LEXX) S LEXX=+($G(LEXX)) Q:LEXX=0 Q:'$D(^LEX(757.01,LEXX,0))
N LEXRT,LEXFI S LEXSAB=$G(LEXSAB) Q:'$L(LEXSAB)
S LEXFI=627.7,LEXRT="^YSD(627.7,",LEXSY=$O(^LEX(757.02,"ASAB",$E(LEXSAB,1,3),0)) D COM
Q
OTH ; Other
Q:'$D(LEXX) S LEXX=+($G(LEXX)) Q:LEXX=0 Q:'$D(^LEX(757.01,LEXX,0))
N LEXRT,LEXFI S LEXSAB=$G(LEXSAB) Q:'$L(LEXSAB)
S LEXFI=757.02,LEXRT="^LEX(757.02,",LEXSY=$O(^LEX(757.02,"ASAB",$E(LEXSAB,1,3),0)) D COM
Q
COM ; Common MUMPS code for all VA Sources
S LEXRT=$G(LEXRT),LEXFI=+($G(LEXFI)),LEXSY=+($G(LEXSY)),LEXSAB=$E($G(LEXSAB),1,3)
Q:'$L($TR(LEXRT,"^(","")) Q:+LEXFI'>0 Q:+LEXSY'>0 Q:$L(LEXSAB)'=3 D VDT^LEXU
N LEXI,LEXO,LEXSO,LEXR,LEXVP
S LEXI=0 F S LEXI=$O(LEXSRC(LEXI)) Q:+LEXI=0 D
. S LEXSO=$G(LEXSRC(LEXI)) Q:LEXSO=""
. S LEXO=$$STAT(LEXSO,+LEXFI,+($G(LEXVDT)),LEXSY) Q:+LEXO'>0
. S LEXO=+($P(LEXO,"^",2)) Q:+LEXO'>0
. S LEXC=+($G(LEX("SEL","VAS",0)))+1
. S LEXVP=+LEXO_";"_$TR(LEXRT,"^","")
. D VAS(+LEXFI,LEXSO,LEXX,LEXVP,LEXC,LEXSAB,LEXSY)
Q
VAS(LEXFI,LEXSO,LEXIEN,LEXV,LEXCNT,LEXSAB,LEXSY) ; Set LEX("SEL","VAS")
Q:'$L(LEXV) Q:$D(LEX("SEL","VAS","V",LEXV))
N LEXT,LEXNAM S LEXSAB=$G(LEXSAB),LEXSY=+($G(LEXSY))
S LEXNAM="" S:+LEXSY>0 LEXNAM=$P($G(^LEX(757.03,+LEXSY,0)),"^",2)
S LEXT=LEXFI_"^"_LEXV_"^"_LEXSO_"^"_LEXIEN
S:$L(LEXSAB)&($L(LEXNAM)) LEXT=LEXT_"^"_LEXSAB_"^"_LEXNAM
S LEX("SEL","VAS",LEXCNT)=LEXT
S LEX("SEL","VAS","B",LEXFI,LEXCNT)=""
S LEX("SEL","VAS","C",LEXSO,LEXCNT)=""
S LEX("SEL","VAS","D",LEXIEN,LEXCNT)=""
S LEX("SEL","VAS","V",LEXV,LEXCNT)=""
S:+LEXSY>0 LEX("SEL","VAS","I",LEXSY,LEXCNT)=""
S LEX("SEL","VAS",0)=LEXCNT
S LEX("SEL","VAS","CTL",LEXT)=""
I $L($G(LEXSAB)) D
. S LEX("SEL","VAS","S",LEXSAB,LEXCNT)=""
. D HIST(LEXSO,LEXSAB,LEXCNT)
Q
STAT(LEXX,LEXFI,LEXDT,LEXSY) ; Status
N LEXS,LEXF,LEXV,LEXO S LEXS=$G(LEXX),LEXF=+($G(LEXFI)),LEXV=$G(LEXDT)
Q:'$L(LEXS) 0 Q:+LEXF'>0 0 S:LEXV'?7N LEXV=$$DT^XLFDT S LEXSY=+($G(LEXSY))
I +($G(LEXF))=80!(+($G(LEXF))=80.1) D
. S LEXO=$$STATCHK^ICDEX(LEXS,+($G(LEXV)),LEXSY)
I +($G(LEXF))=81 D
. S LEXO=$$STATCHK^ICPTAPIU(LEXS,+($G(LEXV)))
I +($G(LEXF))=627.7 S LEXO="" D
. N LEXI S LEXI=0
. F S LEXI=$O(^YSD(627.7,"B",LEXS,LEXI)) Q:+LEXI=0 D Q:$L($G(LEXO))
. . Q:$P($G(^YSD(627.7,LEXI,0)),"^",2)'=4
. . S LEXO=$$STATCHK^ICDEX(LEXS,+($G(LEXV)),1),$P(LEXO,"^",1)=LEXI
I +($G(LEXF))=757.02 D
. S LEXO=$$STATCHK^LEXSRC2(LEXS,+($G(LEXV)),,$G(LEXSAB))
S X=$G(LEXO)
Q X
HIST(LEXSO,LEXSAB,LEXCNT) ; History
Q:'$L($G(LEXSO)) Q:'$L($G(LEXSAB)) Q:+($G(LEXCNT))'>0
N LEXH,LEXE,LEXC,LEXN,LEXT S LEXN=$$HIST^LEXU(LEXSO,LEXSAB,.LEXH)
S LEXC=0,LEXE=0 F S LEXE=$O(LEXH(LEXE)) Q:LEXE'?7N D
. S LEXS="" F S LEXS=$O(LEXH(LEXE,LEXS)) Q:LEXS'?1N D
. . S LEXT=$G(LEXH(LEXE,LEXS)) Q:'$L(LEXT) S LEXC=LEXC+1
. . S LEX("SEL","VAS",+LEXCNT,+LEXC)=LEXE_"^"_LEXS_"^"_LEXT
Q
UP(X) ; Uppercase
Q $TR(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLEXAR5 8079 printed Dec 13, 2024@02:07:04 Page 2
LEXAR5 ;ISL/KER - Look-up Response (Select Entry) ;05/23/2017
+1 ;;2.0;LEXICON UTILITY;**14,25,26,38,55,73,80,103**;Sep 23, 1996;Build 2
+2 ;
+3 ; Global Variables
+4 ; ^LEX(757.011 N/A
+5 ; ^YSD(627.7, ICR 1612
+6 ;
+7 ; External References
+8 ; $$ROOT^ICDEX ICR 5747
+9 ; $$STATCHK^ICDEX ICR 5747
+10 ; $$SYS^ICDEX ICR 5747
+11 ; $$STATCHK^ICPTAPIU ICR 1997
+12 ; $$DT^XLFDT ICR 10103
+13 ; $$UP^XLFSTR ICR 10104
+14 ;
+15 ; Local Variables NEWed or KILLed Elsewhere
+16 ; LEX LEX is killed in LEXA1
+17 ;
SETEXP(LEXX) ; Set LEX("SEL","EXP")
+1 SET LEXX=+($GET(LEXX))
if LEXX'>0
QUIT
if '$DATA(^LEX(757.01,LEXX,0))
QUIT
+2 NEW LEXYPE
SET LEXYPE=$$TYPE(LEXX)
+3 if $DATA(LEX("SEL","EXP","B",LEXX))
QUIT
+4 NEW LEXC
SET LEXC=+($GET(LEX("SEL","EXP",0)))
SET LEXC=LEXC+1
+5 SET LEX("SEL","EXP",LEXC)=LEXX_"^"_^LEX(757.01,LEXX,0)
+6 SET LEX("SEL","EXP",0)=LEXC
+7 SET LEX("SEL","EXP","B",LEXX,LEXC)=""
+8 if LEXYPE'=""
SET LEX("SEL","EXP","C",LEXYPE,LEXC)=""
+9 QUIT
TYPE(LEXX) ; Expression Type
+1 NEW LEXYPE
SET LEXYPE=$PIECE($GET(^LEX(757.01,LEXX,1)),"^",2)
+2 IF +LEXYPE'>0!('$DATA(^LEX(757.011,+LEXYPE,0)))
SET LEXYPE="OTH"
+3 IF +LEXYPE>0
IF $DATA(^LEX(757.011,+LEXYPE,0))
Begin DoDot:1
+4 SET LEXYPE=$PIECE($GET(^LEX(757.011,+LEXYPE,0)),"^",1)
+5 if $LENGTH(LEXYPE)<3
SET LEXYPE="OTH"
+6 SET LEXYPE=$$UP^XLFSTR($EXTRACT(LEXYPE,1,3))
End DoDot:1
+7 SET LEXX=LEXYPE
QUIT LEXX
SETDEF(LEXX) ; Set LEX("SEL","SIG")
+1 SET LEXX=+($GET(LEXX))
if LEXX=0
QUIT
+2 if '$DATA(^LEX(757.01,LEXX,3,1,0))
QUIT
+3 NEW LEXC,LEXR
SET LEXR=0
+4 FOR
SET LEXR=$ORDER(^LEX(757.01,LEXX,3,LEXR))
if +LEXR=0
QUIT
Begin DoDot:1
+5 SET LEXC=+($GET(LEX("SEL","SIG",0)))
SET LEXC=LEXC+1
+6 SET LEX("SEL","SIG",LEXC)=$GET(^LEX(757.01,LEXX,3,LEXR,0))
+7 SET LEX("SEL","SIG",0)=LEXC
End DoDot:1
+8 QUIT
SETSTY(LEXX) ; Set LEX("SEL","STY")
+1 SET LEXX=+($GET(LEXX))
if LEXX=0
QUIT
+2 if '$DATA(^LEX(757.1,"B",LEXX))
QUIT
+3 NEW LEXC,LEXR,LEXSC,LEXST
SET LEXR=0
+4 FOR
SET LEXR=$ORDER(^LEX(757.1,"B",LEXX,LEXR))
if +LEXR=0
QUIT
Begin DoDot:1
+5 SET LEXSC=+($PIECE($GET(^LEX(757.1,LEXR,0)),"^",2))
+6 if LEXSC=0
QUIT
if '$DATA(^LEX(757.11,LEXSC))
QUIT
+7 SET LEXSC=$PIECE($GET(^LEX(757.11,LEXSC,0)),"^",2)
if '$LENGTH(LEXSC)
QUIT
+8 SET LEXST=+($PIECE($GET(^LEX(757.1,LEXR,0)),"^",3))
+9 if LEXST=0
QUIT
if '$DATA(^LEX(757.12,LEXST))
QUIT
+10 SET LEXST=$PIECE($GET(^LEX(757.12,LEXST,0)),"^",2)
if '$LENGTH(LEXST)
QUIT
+11 if $DATA(LEX("SEL","STY","CTL",(LEXSC_"^"_LEXST)))
QUIT
+12 SET LEXC=+($GET(LEX("SEL","STY",0)))
SET LEXC=LEXC+1
+13 SET LEX("SEL","STY",LEXC)=LEXSC_"^"_LEXST
+14 SET LEX("SEL","STY",0)=LEXC
+15 SET LEX("SEL","STY","CTL",(LEXSC_"^"_LEXST))=""
End DoDot:1
+16 QUIT
SETSRC(LEXX,LEXVDT) ; Set LEX("SEL","SRC")
+1 DO VDT^LEXU
NEW LEXSO,LEXSRC,LEXS,LEXC,LEXLD,LEXLS,LEXSN
SET LEXS=0
+2 FOR
SET LEXS=$ORDER(^LEX(757.02,"B",LEXX,LEXS))
if +LEXS=0
QUIT
Begin DoDot:1
+3 SET LEXSN=$GET(^LEX(757.02,LEXS,0))
SET LEXSO=$PIECE(LEXSN,"^",2)
+4 SET LEXSRC=$PIECE(LEXSN,"^",3)
if LEXSRC=0
QUIT
+5 if +$$STATCHK^LEXSRC2(LEXSO,$GET(LEXVDT),,LEXSRC)'=1
QUIT
+6 if '$DATA(^LEX(757.02,"AVA",(LEXSO_" "),LEXX))
QUIT
+7 SET LEXSRC=$PIECE(^LEX(757.03,LEXSRC,0),"^",2)
if '$LENGTH(LEXSRC)
QUIT
+8 if $DATA(LEX("SEL","SRC","CTL",(LEXSRC_"^"_LEXSO_"^"_LEXX)))
QUIT
+9 SET LEXC=+($GET(LEX("SEL","SRC",0)))
SET LEXC=LEXC+1
+10 SET LEX("SEL","SRC",LEXC)=LEXSRC_"^"_LEXSO_"^"_LEXX
+11 SET LEX("SEL","SRC","B",LEXSRC,LEXC)=""
+12 SET LEX("SEL","SRC","C",LEXSO,LEXC)=""
+13 SET LEX("SEL","SRC","D",LEXX,LEXC)=""
+14 SET LEX("SEL","SRC",0)=LEXC
+15 SET LEX("SEL","SRC","CTL",(LEXSRC_"^"_LEXSO_"^"_LEXX))=""
End DoDot:1
+16 DO SETVAS(LEXX,+($GET(LEXVDT)))
+17 QUIT
SETVAS(LEXX,LEXVDT) ; Find VA sources for LEX("SEL","VAS")
+1 DO VDT^LEXU
NEW LEXSAB,LEXRTN,LEXR,LEXVP
+2 FOR LEXSAB="ICD","ICP","CPT","CPC","DS4","10D","10P","SCC"
Begin DoDot:1
+3 NEW LEXTAG
KILL LEXSRC
+4 SET LEXTAG=$SELECT(LEXSAB="10D":"D10",LEXSAB="10P":"P10",1:LEXSAB)
+5 SET LEXRTN=LEXTAG_"^LEXAR5"
+6 if '$LENGTH($TEXT(@LEXRTN))
SET LEXRTN="OTH^LEXAR5"
+7 DO ALL^LEXSRC(LEXX,LEXSAB,LEXVDT)
+8 IF +($GET(LEXSRC(0)))>0
DO @LEXRTN
End DoDot:1
+9 QUIT
+10 ;
VA ; VA Sources
ICD ; ICD-9 Diagnosis
+1 if '$DATA(LEXX)
QUIT
SET LEXX=+($GET(LEXX))
if LEXX=0
QUIT
if '$DATA(^LEX(757.01,LEXX,0))
QUIT
+2 NEW LEXRT,LEXFI,LEXSY
SET LEXSAB=$GET(LEXSAB)
if '$LENGTH(LEXSAB)
QUIT
+3 SET LEXFI=80
SET LEXRT=$$ROOT^ICDEX(LEXFI)
SET LEXSY=$$SYS^ICDEX(LEXSAB)
DO COM
+4 QUIT
ICP ; ICD-9 Procedures
+1 if '$DATA(LEXX)
QUIT
SET LEXX=+($GET(LEXX))
if LEXX=0
QUIT
if '$DATA(^LEX(757.01,LEXX,0))
QUIT
+2 NEW LEXRT,LEXFI,LEXSY
SET LEXSAB=$GET(LEXSAB)
if '$LENGTH(LEXSAB)
QUIT
+3 SET LEXFI=80.1
SET LEXRT=$$ROOT^ICDEX(LEXFI)
SET LEXSY=$$SYS^ICDEX(LEXSAB)
DO COM
+4 QUIT
CPT ; Current Procedural Terminology
+1 if '$DATA(LEXX)
QUIT
SET LEXX=+($GET(LEXX))
if LEXX=0
QUIT
if '$DATA(^LEX(757.01,LEXX,0))
QUIT
+2 NEW LEXRT,LEXFI,LEXSY
SET LEXSAB=$GET(LEXSAB)
if '$LENGTH(LEXSAB)
QUIT
+3 SET LEXFI=81
SET LEXRT="^ICPT("
SET LEXSY=$ORDER(^LEX(757.02,"ASAB",$EXTRACT(LEXSAB,1,3),0))
DO COM
+4 QUIT
CPC ; HCPCS Terminology
+1 if '$DATA(LEXX)
QUIT
SET LEXX=+($GET(LEXX))
if LEXX=0
QUIT
if '$DATA(^LEX(757.01,LEXX,0))
QUIT
+2 NEW LEXRT,LEXFI,LEXSY
SET LEXSAB=$GET(LEXSAB)
if '$LENGTH(LEXSAB)
QUIT
+3 SET LEXFI=81
SET LEXRT="^ICPT("
SET LEXSY=$ORDER(^LEX(757.02,"ASAB",$EXTRACT(LEXSAB,1,3),0))
DO COM
+4 QUIT
D10 ; ICD-10 Diagnosis
+1 if '$DATA(LEXX)
QUIT
SET LEXX=+($GET(LEXX))
if LEXX=0
QUIT
if '$DATA(^LEX(757.01,LEXX,0))
QUIT
+2 NEW LEXRT,LEXFI,LEXSY
SET LEXSAB=$GET(LEXSAB)
if '$LENGTH(LEXSAB)
QUIT
+3 SET LEXFI=80
SET LEXRT=$$ROOT^ICDEX(LEXFI)
SET LEXSY=$$SYS^ICDEX(LEXSAB)
DO COM
+4 QUIT
P10 ; ICD-10 Procedures
+1 if '$DATA(LEXX)
QUIT
SET LEXX=+($GET(LEXX))
if LEXX=0
QUIT
if '$DATA(^LEX(757.01,LEXX,0))
QUIT
+2 NEW LEXRT,LEXFI,LEXSY
SET LEXSAB=$GET(LEXSAB)
if '$LENGTH(LEXSAB)
QUIT
+3 SET LEXFI=80.1
SET LEXRT=$$ROOT^ICDEX(LEXFI)
SET LEXSY=$$SYS^ICDEX(LEXSAB)
DO COM
+4 QUIT
DS4 ; DSN-IV Mental Disorders
+1 if '$DATA(LEXX)
QUIT
SET LEXX=+($GET(LEXX))
if LEXX=0
QUIT
if '$DATA(^LEX(757.01,LEXX,0))
QUIT
+2 NEW LEXRT,LEXFI
SET LEXSAB=$GET(LEXSAB)
if '$LENGTH(LEXSAB)
QUIT
+3 SET LEXFI=627.7
SET LEXRT="^YSD(627.7,"
SET LEXSY=$ORDER(^LEX(757.02,"ASAB",$EXTRACT(LEXSAB,1,3),0))
DO COM
+4 QUIT
OTH ; Other
+1 if '$DATA(LEXX)
QUIT
SET LEXX=+($GET(LEXX))
if LEXX=0
QUIT
if '$DATA(^LEX(757.01,LEXX,0))
QUIT
+2 NEW LEXRT,LEXFI
SET LEXSAB=$GET(LEXSAB)
if '$LENGTH(LEXSAB)
QUIT
+3 SET LEXFI=757.02
SET LEXRT="^LEX(757.02,"
SET LEXSY=$ORDER(^LEX(757.02,"ASAB",$EXTRACT(LEXSAB,1,3),0))
DO COM
+4 QUIT
COM ; Common MUMPS code for all VA Sources
+1 SET LEXRT=$GET(LEXRT)
SET LEXFI=+($GET(LEXFI))
SET LEXSY=+($GET(LEXSY))
SET LEXSAB=$EXTRACT($GET(LEXSAB),1,3)
+2 if '$LENGTH($TRANSLATE(LEXRT,"^(",""))
QUIT
if +LEXFI'>0
QUIT
if +LEXSY'>0
QUIT
if $LENGTH(LEXSAB)'=3
QUIT
DO VDT^LEXU
+3 NEW LEXI,LEXO,LEXSO,LEXR,LEXVP
+4 SET LEXI=0
FOR
SET LEXI=$ORDER(LEXSRC(LEXI))
if +LEXI=0
QUIT
Begin DoDot:1
+5 SET LEXSO=$GET(LEXSRC(LEXI))
if LEXSO=""
QUIT
+6 SET LEXO=$$STAT(LEXSO,+LEXFI,+($GET(LEXVDT)),LEXSY)
if +LEXO'>0
QUIT
+7 SET LEXO=+($PIECE(LEXO,"^",2))
if +LEXO'>0
QUIT
+8 SET LEXC=+($GET(LEX("SEL","VAS",0)))+1
+9 SET LEXVP=+LEXO_";"_$TRANSLATE(LEXRT,"^","")
+10 DO VAS(+LEXFI,LEXSO,LEXX,LEXVP,LEXC,LEXSAB,LEXSY)
End DoDot:1
+11 QUIT
VAS(LEXFI,LEXSO,LEXIEN,LEXV,LEXCNT,LEXSAB,LEXSY) ; Set LEX("SEL","VAS")
+1 if '$LENGTH(LEXV)
QUIT
if $DATA(LEX("SEL","VAS","V",LEXV))
QUIT
+2 NEW LEXT,LEXNAM
SET LEXSAB=$GET(LEXSAB)
SET LEXSY=+($GET(LEXSY))
+3 SET LEXNAM=""
if +LEXSY>0
SET LEXNAM=$PIECE($GET(^LEX(757.03,+LEXSY,0)),"^",2)
+4 SET LEXT=LEXFI_"^"_LEXV_"^"_LEXSO_"^"_LEXIEN
+5 if $LENGTH(LEXSAB)&($LENGTH(LEXNAM))
SET LEXT=LEXT_"^"_LEXSAB_"^"_LEXNAM
+6 SET LEX("SEL","VAS",LEXCNT)=LEXT
+7 SET LEX("SEL","VAS","B",LEXFI,LEXCNT)=""
+8 SET LEX("SEL","VAS","C",LEXSO,LEXCNT)=""
+9 SET LEX("SEL","VAS","D",LEXIEN,LEXCNT)=""
+10 SET LEX("SEL","VAS","V",LEXV,LEXCNT)=""
+11 if +LEXSY>0
SET LEX("SEL","VAS","I",LEXSY,LEXCNT)=""
+12 SET LEX("SEL","VAS",0)=LEXCNT
+13 SET LEX("SEL","VAS","CTL",LEXT)=""
+14 IF $LENGTH($GET(LEXSAB))
Begin DoDot:1
+15 SET LEX("SEL","VAS","S",LEXSAB,LEXCNT)=""
+16 DO HIST(LEXSO,LEXSAB,LEXCNT)
End DoDot:1
+17 QUIT
STAT(LEXX,LEXFI,LEXDT,LEXSY) ; Status
+1 NEW LEXS,LEXF,LEXV,LEXO
SET LEXS=$GET(LEXX)
SET LEXF=+($GET(LEXFI))
SET LEXV=$GET(LEXDT)
+2 if '$LENGTH(LEXS)
QUIT 0
if +LEXF'>0
QUIT 0
if LEXV'?7N
SET LEXV=$$DT^XLFDT
SET LEXSY=+($GET(LEXSY))
+3 IF +($GET(LEXF))=80!(+($GET(LEXF))=80.1)
Begin DoDot:1
+4 SET LEXO=$$STATCHK^ICDEX(LEXS,+($GET(LEXV)),LEXSY)
End DoDot:1
+5 IF +($GET(LEXF))=81
Begin DoDot:1
+6 SET LEXO=$$STATCHK^ICPTAPIU(LEXS,+($GET(LEXV)))
End DoDot:1
+7 IF +($GET(LEXF))=627.7
SET LEXO=""
Begin DoDot:1
+8 NEW LEXI
SET LEXI=0
+9 FOR
SET LEXI=$ORDER(^YSD(627.7,"B",LEXS,LEXI))
if +LEXI=0
QUIT
Begin DoDot:2
+10 if $PIECE($GET(^YSD(627.7,LEXI,0)),"^",2)'=4
QUIT
+11 SET LEXO=$$STATCHK^ICDEX(LEXS,+($GET(LEXV)),1)
SET $PIECE(LEXO,"^",1)=LEXI
End DoDot:2
if $LENGTH($GET(LEXO))
QUIT
End DoDot:1
+12 IF +($GET(LEXF))=757.02
Begin DoDot:1
+13 SET LEXO=$$STATCHK^LEXSRC2(LEXS,+($GET(LEXV)),,$GET(LEXSAB))
End DoDot:1
+14 SET X=$GET(LEXO)
+15 QUIT X
HIST(LEXSO,LEXSAB,LEXCNT) ; History
+1 if '$LENGTH($GET(LEXSO))
QUIT
if '$LENGTH($GET(LEXSAB))
QUIT
if +($GET(LEXCNT))'>0
QUIT
+2 NEW LEXH,LEXE,LEXC,LEXN,LEXT
SET LEXN=$$HIST^LEXU(LEXSO,LEXSAB,.LEXH)
+3 SET LEXC=0
SET LEXE=0
FOR
SET LEXE=$ORDER(LEXH(LEXE))
if LEXE'?7N
QUIT
Begin DoDot:1
+4 SET LEXS=""
FOR
SET LEXS=$ORDER(LEXH(LEXE,LEXS))
if LEXS'?1N
QUIT
Begin DoDot:2
+5 SET LEXT=$GET(LEXH(LEXE,LEXS))
if '$LENGTH(LEXT)
QUIT
SET LEXC=LEXC+1
+6 SET LEX("SEL","VAS",+LEXCNT,+LEXC)=LEXE_"^"_LEXS_"^"_LEXT
End DoDot:2
End DoDot:1
+7 QUIT
UP(X) ; Uppercase
+1 QUIT $TRANSLATE(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
