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

LEXAR5.m

Go to the documentation of this file.
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")