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. 
  1. 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
  1.  ;               
  1.  ; Global Variables
  1.  ;    ^LEX(757.011        N/A
  1.  ;    ^YSD(627.7,         ICR   1612
  1.  ;               
  1.  ; External References
  1.  ;    $$ROOT^ICDEX        ICR   5747
  1.  ;    $$STATCHK^ICDEX     ICR   5747
  1.  ;    $$SYS^ICDEX         ICR   5747
  1.  ;    $$STATCHK^ICPTAPIU  ICR   1997
  1.  ;    $$DT^XLFDT          ICR  10103
  1.  ;    $$UP^XLFSTR         ICR  10104
  1.  ;               
  1.  ; Local Variables NEWed or KILLed Elsewhere
  1.  ;    LEX    LEX is killed in LEXA1
  1.  ;               
  1. SETEXP(LEXX)   ; Set LEX("SEL","EXP")
  1.  S LEXX=+($G(LEXX)) Q:LEXX'>0  Q:'$D(^LEX(757.01,LEXX,0))
  1.  N LEXYPE S LEXYPE=$$TYPE(LEXX)
  1.  Q:$D(LEX("SEL","EXP","B",LEXX))
  1.  N LEXC S LEXC=+($G(LEX("SEL","EXP",0))),LEXC=LEXC+1
  1.  S LEX("SEL","EXP",LEXC)=LEXX_"^"_^LEX(757.01,LEXX,0)
  1.  S LEX("SEL","EXP",0)=LEXC
  1.  S LEX("SEL","EXP","B",LEXX,LEXC)=""
  1.  S:LEXYPE'="" LEX("SEL","EXP","C",LEXYPE,LEXC)=""
  1.  Q
  1. TYPE(LEXX)     ; Expression Type
  1.  N LEXYPE S LEXYPE=$P($G(^LEX(757.01,LEXX,1)),"^",2)
  1.  I +LEXYPE'>0!('$D(^LEX(757.011,+LEXYPE,0))) S LEXYPE="OTH"
  1.  I +LEXYPE>0,$D(^LEX(757.011,+LEXYPE,0)) D
  1.  . S LEXYPE=$P($G(^LEX(757.011,+LEXYPE,0)),"^",1)
  1.  . S:$L(LEXYPE)<3 LEXYPE="OTH"
  1.  . S LEXYPE=$$UP^XLFSTR($E(LEXYPE,1,3))
  1.  S LEXX=LEXYPE Q LEXX
  1. SETDEF(LEXX)   ; Set LEX("SEL","SIG")
  1.  S LEXX=+($G(LEXX)) Q:LEXX=0
  1.  Q:'$D(^LEX(757.01,LEXX,3,1,0))
  1.  N LEXC,LEXR S LEXR=0
  1.  F  S LEXR=$O(^LEX(757.01,LEXX,3,LEXR)) Q:+LEXR=0  D
  1.  . S LEXC=+($G(LEX("SEL","SIG",0))),LEXC=LEXC+1
  1.  . S LEX("SEL","SIG",LEXC)=$G(^LEX(757.01,LEXX,3,LEXR,0))
  1.  . S LEX("SEL","SIG",0)=LEXC
  1.  Q
  1. SETSTY(LEXX)   ; Set LEX("SEL","STY")
  1.  S LEXX=+($G(LEXX)) Q:LEXX=0
  1.  Q:'$D(^LEX(757.1,"B",LEXX))
  1.  N LEXC,LEXR,LEXSC,LEXST S LEXR=0
  1.  F  S LEXR=$O(^LEX(757.1,"B",LEXX,LEXR)) Q:+LEXR=0  D
  1.  . S LEXSC=+($P($G(^LEX(757.1,LEXR,0)),"^",2))
  1.  . Q:LEXSC=0  Q:'$D(^LEX(757.11,LEXSC))
  1.  . S LEXSC=$P($G(^LEX(757.11,LEXSC,0)),"^",2) Q:'$L(LEXSC)
  1.  . S LEXST=+($P($G(^LEX(757.1,LEXR,0)),"^",3))
  1.  . Q:LEXST=0  Q:'$D(^LEX(757.12,LEXST))
  1.  . S LEXST=$P($G(^LEX(757.12,LEXST,0)),"^",2) Q:'$L(LEXST)
  1.  . Q:$D(LEX("SEL","STY","CTL",(LEXSC_"^"_LEXST)))
  1.  . S LEXC=+($G(LEX("SEL","STY",0))),LEXC=LEXC+1
  1.  . S LEX("SEL","STY",LEXC)=LEXSC_"^"_LEXST
  1.  . S LEX("SEL","STY",0)=LEXC
  1.  . S LEX("SEL","STY","CTL",(LEXSC_"^"_LEXST))=""
  1.  Q
  1. SETSRC(LEXX,LEXVDT)     ; Set LEX("SEL","SRC")
  1.  D VDT^LEXU N LEXSO,LEXSRC,LEXS,LEXC,LEXLD,LEXLS,LEXSN S LEXS=0
  1.  F  S LEXS=$O(^LEX(757.02,"B",LEXX,LEXS)) Q:+LEXS=0  D
  1.  . S LEXSN=$G(^LEX(757.02,LEXS,0)),LEXSO=$P(LEXSN,"^",2)
  1.  . S LEXSRC=$P(LEXSN,"^",3) Q:LEXSRC=0
  1.  . Q:+$$STATCHK^LEXSRC2(LEXSO,$G(LEXVDT),,LEXSRC)'=1
  1.  . Q:'$D(^LEX(757.02,"AVA",(LEXSO_" "),LEXX))
  1.  . S LEXSRC=$P(^LEX(757.03,LEXSRC,0),"^",2) Q:'$L(LEXSRC)
  1.  . Q:$D(LEX("SEL","SRC","CTL",(LEXSRC_"^"_LEXSO_"^"_LEXX)))
  1.  . S LEXC=+($G(LEX("SEL","SRC",0))),LEXC=LEXC+1
  1.  . S LEX("SEL","SRC",LEXC)=LEXSRC_"^"_LEXSO_"^"_LEXX
  1.  . S LEX("SEL","SRC","B",LEXSRC,LEXC)=""
  1.  . S LEX("SEL","SRC","C",LEXSO,LEXC)=""
  1.  . S LEX("SEL","SRC","D",LEXX,LEXC)=""
  1.  . S LEX("SEL","SRC",0)=LEXC
  1.  . S LEX("SEL","SRC","CTL",(LEXSRC_"^"_LEXSO_"^"_LEXX))=""
  1.  D SETVAS(LEXX,+($G(LEXVDT)))
  1.  Q
  1. SETVAS(LEXX,LEXVDT)     ; Find VA sources for LEX("SEL","VAS")
  1.  D VDT^LEXU N LEXSAB,LEXRTN,LEXR,LEXVP
  1.  F LEXSAB="ICD","ICP","CPT","CPC","DS4","10D","10P","SCC" D
  1.  . N LEXTAG K LEXSRC
  1.  . S LEXTAG=$S(LEXSAB="10D":"D10",LEXSAB="10P":"P10",1:LEXSAB)
  1.  . S LEXRTN=LEXTAG_"^LEXAR5"
  1.  . S:'$L($T(@LEXRTN)) LEXRTN="OTH^LEXAR5"
  1.  . D ALL^LEXSRC(LEXX,LEXSAB,LEXVDT)
  1.  . I +($G(LEXSRC(0)))>0 D @LEXRTN
  1.  Q
  1.  ;
  1. VA ; VA Sources
  1. ICD ;   ICD-9 Diagnosis
  1.  Q:'$D(LEXX)  S LEXX=+($G(LEXX)) Q:LEXX=0  Q:'$D(^LEX(757.01,LEXX,0))
  1.  N LEXRT,LEXFI,LEXSY S LEXSAB=$G(LEXSAB) Q:'$L(LEXSAB)
  1.  S LEXFI=80,LEXRT=$$ROOT^ICDEX(LEXFI),LEXSY=$$SYS^ICDEX(LEXSAB) D COM
  1.  Q
  1. ICP ;   ICD-9 Procedures
  1.  Q:'$D(LEXX)  S LEXX=+($G(LEXX)) Q:LEXX=0  Q:'$D(^LEX(757.01,LEXX,0))
  1.  N LEXRT,LEXFI,LEXSY S LEXSAB=$G(LEXSAB) Q:'$L(LEXSAB)
  1.  S LEXFI=80.1,LEXRT=$$ROOT^ICDEX(LEXFI),LEXSY=$$SYS^ICDEX(LEXSAB) D COM
  1.  Q
  1. CPT ;   Current Procedural Terminology
  1.  Q:'$D(LEXX)  S LEXX=+($G(LEXX)) Q:LEXX=0  Q:'$D(^LEX(757.01,LEXX,0))
  1.  N LEXRT,LEXFI,LEXSY S LEXSAB=$G(LEXSAB) Q:'$L(LEXSAB)
  1.  S LEXFI=81,LEXRT="^ICPT(",LEXSY=$O(^LEX(757.02,"ASAB",$E(LEXSAB,1,3),0)) D COM
  1.  Q
  1. CPC ;   HCPCS Terminology
  1.  Q:'$D(LEXX)  S LEXX=+($G(LEXX)) Q:LEXX=0  Q:'$D(^LEX(757.01,LEXX,0))
  1.  N LEXRT,LEXFI,LEXSY S LEXSAB=$G(LEXSAB) Q:'$L(LEXSAB)
  1.  S LEXFI=81,LEXRT="^ICPT(",LEXSY=$O(^LEX(757.02,"ASAB",$E(LEXSAB,1,3),0)) D COM
  1.  Q
  1. D10 ;   ICD-10 Diagnosis
  1.  Q:'$D(LEXX)  S LEXX=+($G(LEXX)) Q:LEXX=0  Q:'$D(^LEX(757.01,LEXX,0))
  1.  N LEXRT,LEXFI,LEXSY S LEXSAB=$G(LEXSAB) Q:'$L(LEXSAB)
  1.  S LEXFI=80,LEXRT=$$ROOT^ICDEX(LEXFI),LEXSY=$$SYS^ICDEX(LEXSAB) D COM
  1.  Q
  1. P10 ;   ICD-10 Procedures
  1.  Q:'$D(LEXX)  S LEXX=+($G(LEXX)) Q:LEXX=0  Q:'$D(^LEX(757.01,LEXX,0))
  1.  N LEXRT,LEXFI,LEXSY S LEXSAB=$G(LEXSAB) Q:'$L(LEXSAB)
  1.  S LEXFI=80.1,LEXRT=$$ROOT^ICDEX(LEXFI),LEXSY=$$SYS^ICDEX(LEXSAB) D COM
  1.  Q
  1. DS4 ;   DSN-IV Mental Disorders
  1.  Q:'$D(LEXX)  S LEXX=+($G(LEXX)) Q:LEXX=0  Q:'$D(^LEX(757.01,LEXX,0))
  1.  N LEXRT,LEXFI S LEXSAB=$G(LEXSAB) Q:'$L(LEXSAB)
  1.  S LEXFI=627.7,LEXRT="^YSD(627.7,",LEXSY=$O(^LEX(757.02,"ASAB",$E(LEXSAB,1,3),0)) D COM
  1.  Q
  1. OTH ;   Other
  1.  Q:'$D(LEXX)  S LEXX=+($G(LEXX)) Q:LEXX=0  Q:'$D(^LEX(757.01,LEXX,0))
  1.  N LEXRT,LEXFI S LEXSAB=$G(LEXSAB) Q:'$L(LEXSAB)
  1.  S LEXFI=757.02,LEXRT="^LEX(757.02,",LEXSY=$O(^LEX(757.02,"ASAB",$E(LEXSAB,1,3),0)) D COM
  1.  Q
  1. COM ; Common MUMPS code for all VA Sources
  1.  S LEXRT=$G(LEXRT),LEXFI=+($G(LEXFI)),LEXSY=+($G(LEXSY)),LEXSAB=$E($G(LEXSAB),1,3)
  1.  Q:'$L($TR(LEXRT,"^(",""))  Q:+LEXFI'>0  Q:+LEXSY'>0  Q:$L(LEXSAB)'=3  D VDT^LEXU
  1.  N LEXI,LEXO,LEXSO,LEXR,LEXVP
  1.  S LEXI=0 F  S LEXI=$O(LEXSRC(LEXI)) Q:+LEXI=0  D
  1.  . S LEXSO=$G(LEXSRC(LEXI)) Q:LEXSO=""
  1.  . S LEXO=$$STAT(LEXSO,+LEXFI,+($G(LEXVDT)),LEXSY) Q:+LEXO'>0
  1.  . S LEXO=+($P(LEXO,"^",2)) Q:+LEXO'>0
  1.  . S LEXC=+($G(LEX("SEL","VAS",0)))+1
  1.  . S LEXVP=+LEXO_";"_$TR(LEXRT,"^","")
  1.  . D VAS(+LEXFI,LEXSO,LEXX,LEXVP,LEXC,LEXSAB,LEXSY)
  1.  Q
  1. VAS(LEXFI,LEXSO,LEXIEN,LEXV,LEXCNT,LEXSAB,LEXSY)     ; Set LEX("SEL","VAS")
  1.  Q:'$L(LEXV)  Q:$D(LEX("SEL","VAS","V",LEXV))
  1.  N LEXT,LEXNAM S LEXSAB=$G(LEXSAB),LEXSY=+($G(LEXSY))
  1.  S LEXNAM="" S:+LEXSY>0 LEXNAM=$P($G(^LEX(757.03,+LEXSY,0)),"^",2)
  1.  S LEXT=LEXFI_"^"_LEXV_"^"_LEXSO_"^"_LEXIEN
  1.  S:$L(LEXSAB)&($L(LEXNAM)) LEXT=LEXT_"^"_LEXSAB_"^"_LEXNAM
  1.  S LEX("SEL","VAS",LEXCNT)=LEXT
  1.  S LEX("SEL","VAS","B",LEXFI,LEXCNT)=""
  1.  S LEX("SEL","VAS","C",LEXSO,LEXCNT)=""
  1.  S LEX("SEL","VAS","D",LEXIEN,LEXCNT)=""
  1.  S LEX("SEL","VAS","V",LEXV,LEXCNT)=""
  1.  S:+LEXSY>0 LEX("SEL","VAS","I",LEXSY,LEXCNT)=""
  1.  S LEX("SEL","VAS",0)=LEXCNT
  1.  S LEX("SEL","VAS","CTL",LEXT)=""
  1.  I $L($G(LEXSAB)) D
  1.  . S LEX("SEL","VAS","S",LEXSAB,LEXCNT)=""
  1.  . D HIST(LEXSO,LEXSAB,LEXCNT)
  1.  Q
  1. STAT(LEXX,LEXFI,LEXDT,LEXSY) ; Status
  1.  N LEXS,LEXF,LEXV,LEXO S LEXS=$G(LEXX),LEXF=+($G(LEXFI)),LEXV=$G(LEXDT)
  1.  Q:'$L(LEXS) 0  Q:+LEXF'>0 0  S:LEXV'?7N LEXV=$$DT^XLFDT S LEXSY=+($G(LEXSY))
  1.  I +($G(LEXF))=80!(+($G(LEXF))=80.1) D
  1.  . S LEXO=$$STATCHK^ICDEX(LEXS,+($G(LEXV)),LEXSY)
  1.  I +($G(LEXF))=81 D
  1.  . S LEXO=$$STATCHK^ICPTAPIU(LEXS,+($G(LEXV)))
  1.  I +($G(LEXF))=627.7 S LEXO="" D
  1.  . N LEXI S LEXI=0
  1.  . F  S LEXI=$O(^YSD(627.7,"B",LEXS,LEXI)) Q:+LEXI=0  D  Q:$L($G(LEXO))
  1.  . . Q:$P($G(^YSD(627.7,LEXI,0)),"^",2)'=4
  1.  . . S LEXO=$$STATCHK^ICDEX(LEXS,+($G(LEXV)),1),$P(LEXO,"^",1)=LEXI
  1.  I +($G(LEXF))=757.02 D
  1.  . S LEXO=$$STATCHK^LEXSRC2(LEXS,+($G(LEXV)),,$G(LEXSAB))
  1.  S X=$G(LEXO)
  1.  Q X
  1. HIST(LEXSO,LEXSAB,LEXCNT) ; History
  1.  Q:'$L($G(LEXSO))  Q:'$L($G(LEXSAB))  Q:+($G(LEXCNT))'>0
  1.  N LEXH,LEXE,LEXC,LEXN,LEXT S LEXN=$$HIST^LEXU(LEXSO,LEXSAB,.LEXH)
  1.  S LEXC=0,LEXE=0 F  S LEXE=$O(LEXH(LEXE)) Q:LEXE'?7N  D
  1.  . S LEXS="" F  S LEXS=$O(LEXH(LEXE,LEXS)) Q:LEXS'?1N  D
  1.  . . S LEXT=$G(LEXH(LEXE,LEXS)) Q:'$L(LEXT)  S LEXC=LEXC+1
  1.  . . S LEX("SEL","VAS",+LEXCNT,+LEXC)=LEXE_"^"_LEXS_"^"_LEXT
  1.  Q
  1. UP(X) ; Uppercase
  1.  Q $TR(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")