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

BSTSCDET.m

Go to the documentation of this file. 
  1. BSTSCDET ;GDIT/HS/BEE-Get Concept Detail ; 15 Nov 2012  4:26 PM
  1.  ;;2.0;IHS STANDARD TERMINOLOGY;;Dec 01, 2016;Build 62
  1.  Q
  1.  ;
  1. DETAIL(OUT,BSTSWS,RESULT) ;EP - Return Details for each Concept/Term
  1.  ;
  1.  ;Input
  1.  ; BSTSWS Array
  1.  ; RESULT - [1]^[2]^[3]
  1.  ;          [1] - Concept ID
  1.  ;          [2] - DTS ID
  1.  ;          [3] - Description Id
  1.  ;
  1.  ;Output
  1.  ; Function returns - # Records Returned
  1.  ;
  1.  ; VAR(#) - List of Records - See routine BSTSNDET
  1.  ;                            for format
  1.  ;
  1.  N CNT,INMID,XNMID,NCNT,RET,DAT,STYPE,INDATE,CDSET,PARMS
  1.  ;
  1.  ;Get the Namespace ID
  1.  S XNMID=$G(BSTSWS("NAMESPACEID"))
  1.  ;
  1.  ;Pull return request
  1.  S RET=$G(BSTSWS("RET"))
  1.  S DAT=$G(BSTSWS("DAT"))
  1.  S STYPE=$G(BSTSWS("STYPE"))
  1.  S INDATE=$G(BSTSWS("INDATE")) S:INDATE="" INDATE=DT
  1.  S PARMS=$G(BSTSWS("MPPRM"))
  1.  ;
  1.  ;Determine if ICD9 or ICD10
  1.  S CDSET=$$ICD10^BSTSUTIL(INDATE)
  1.  ;
  1.  S INMID=$O(^BSTS(9002318.1,"B",XNMID,""))
  1.  ;
  1.  S NCNT=0,CNT="" F  S CNT=$O(RESULT(CNT)) Q:CNT=""  D
  1.  . ;
  1.  . N CONC,DESC,CIEN,ADT,RDT,PRB,PRBIEN,ICNT,ISIEN,EQMND
  1.  . N BCNT,SBIEN,ICIEN,SCNT,TIEN,DTSID,ACNT,PDESC,CHIEN,EQ
  1.  . N ASCNT,ASIEN,ARCNT,ARIEN,AUCNT,AUIEN,IARCNT,IASIEN,TTCNT,TTIEN
  1.  . ;
  1.  . S CONC=$P(RESULT(CNT),U)
  1.  . S DTSID=$P(RESULT(CNT),U,2)
  1.  . S DESC=$P(RESULT(CNT),U,3)
  1.  . ;
  1.  . ;Get Concept IEN
  1.  . S CIEN=$$CIEN^BSTSLKP(CONC,XNMID) Q:CIEN=""
  1.  . ;
  1.  . ;Check for out of date entries
  1.  . I ($$GET1^DIQ(9002318.4,CIEN_",",".11","I")="Y")!($$GET1^DIQ(9002318.4,CIEN_",",".12","I")="") D
  1.  .. ;NEW STS,VAR
  1.  .. ;
  1.  .. ;BSTS*1.0*7;Update later
  1.  .. ;Check if DTS server is set to local - Quit if local
  1.  .. ;S STS=$$CKONOFF^BSTSWSV1() I '+STS S ^XTMP("BSTSPROCQ","C",CIEN)="" Q
  1.  .. ;S STS=$$DTSLKP^BSTSAPI("VAR",DTSID_"^"_XNMID)
  1.  .. S ^XTMP("BSTSPROCQ","C",CIEN)=""
  1.  . ;
  1.  . S ADT=$$GET1^DIQ(9002318.4,CIEN,".05","I")
  1.  . S RDT=$$GET1^DIQ(9002318.4,CIEN,".06","I")
  1.  . ;
  1.  . ;If FSN Search retrieve Desc ID for Preferred Term
  1.  . S PDESC=$P($$PDESC^BSTSSRCH(CIEN),U) Q:PDESC=""
  1.  . I STYPE="F" S DESC=PDESC
  1.  . ;
  1.  . ;Determine PRB value-For now use FSN or SYN/PRE
  1.  . S PRB=DESC
  1.  . S PRBIEN=$O(^BSTS(9002318.3,"D",INMID,PRB,"")) Q:PRBIEN=""
  1.  . S NCNT=NCNT+1
  1.  . S @OUT@(NCNT,"PRB","TRM")=$$GET1^DIQ(9002318.3,PRBIEN_",",1)
  1.  . S @OUT@(NCNT,"PRB","DSC")=DESC
  1.  . S @OUT@(NCNT,"CON")=CONC
  1.  . S @OUT@(NCNT,"DTS")=DTSID
  1.  . I 'DAT S @OUT@(NCNT,"XADT")=ADT
  1.  . I 'DAT S @OUT@(NCNT,"XRDT")=RDT
  1.  . ;
  1.  . ;BSTS*1.0*7;Return equivalant concept info
  1.  . S EQMND=$G(^BSTS(9002318.4,CIEN,16))
  1.  . S @OUT@(NCNT,"EQM","LAT")=$P(EQMND,U)
  1.  . S @OUT@(NCNT,"EQM","DTS")=$P(EQMND,U,2)
  1.  . S @OUT@(NCNT,"EQM","CON")=$P(EQMND,U,3)
  1.  . S @OUT@(NCNT,"EQM","XADT")=$P(EQMND,U,4)
  1.  . S @OUT@(NCNT,"EQM","XRDT")=$P(EQMND,U,5)
  1.  . S EQ=0 F  S EQ=$O(^BSTS(9002318.4,CIEN,15,EQ)) Q:'EQ  D
  1.  .. NEW EQNODE,EQLAT
  1.  .. S EQNODE=$G(^BSTS(9002318.4,CIEN,15,EQ,0))
  1.  .. S EQLAT=$P(EQNODE,U) Q:EQLAT=""
  1.  .. S @OUT@(NCNT,"EQC",EQLAT,"CON")=$P(EQNODE,U,2)
  1.  .. S @OUT@(NCNT,"EQC",EQLAT,"DTS")=$P(EQNODE,U,3)
  1.  .. S @OUT@(NCNT,"EQC",EQLAT,"XADT")=$P(EQNODE,U,4)
  1.  .. S @OUT@(NCNT,"EQC",EQLAT,"XRDT")=$P(EQNODE,U,5)
  1.  . ;
  1.  . ;Episodicity Req
  1.  . S @OUT@(NCNT,"EPI")=0
  1.  . I $D(^BSTS(9002318.4,"J",36,CONC,"EPI")) S @OUT@(NCNT,"EPI")=1
  1.  . ;
  1.  . ;Pull IsA Relationships
  1.  . I RET["I" S (ACNT,ISIEN)=0 F  S ISIEN=$O(^BSTS(9002318.4,CIEN,5,ISIEN)) Q:'ISIEN  D
  1.  .. ;
  1.  .. N ISA,DA,IENS,ICONC,ADT,RDT,DTS,FSN
  1.  .. S DA(1)=CIEN,DA=ISIEN,IENS=$$IENS^DILF(.DA)
  1.  .. S ISA=$$GET1^DIQ(9002318.45,IENS,".01","I") Q:ISA=""
  1.  .. S ADT=$$GET1^DIQ(9002318.45,IENS,".02","I")
  1.  .. S RDT=$$GET1^DIQ(9002318.45,IENS,".03","I")
  1.  .. S ICONC=$$GET1^DIQ(9002318.4,ISA,".02","I")
  1.  .. S DTS=$$GET1^DIQ(9002318.4,ISA,".08","I")
  1.  .. S FSN=$$GET1^DIQ(9002318.4,ISA,1,"I")
  1.  .. S ACNT=ACNT+1
  1.  .. S @OUT@(NCNT,"ISA",ACNT,"TRM")=FSN
  1.  .. S @OUT@(NCNT,"ISA",ACNT,"CON")=ICONC
  1.  .. S @OUT@(NCNT,"ISA",ACNT,"DTS")=DTS
  1.  .. Q:DAT  ;Exclude ADT/RDT
  1.  .. S @OUT@(NCNT,"ISA",ACNT,"XADT")=ADT
  1.  .. S @OUT@(NCNT,"ISA",ACNT,"XRDT")=RDT
  1.  . ;
  1.  . ;RxNorm - Pull TTY
  1.  . I XNMID=1552 S (TTCNT,TTIEN)=0 F  S TTIEN=$O(^BSTS(9002318.4,CIEN,12,TTIEN)) Q:'TTIEN  D
  1.  .. ;
  1.  .. N TTY,DA,IENS,ICONC,ADT,RDT,DTS,FSN
  1.  .. S DA(1)=CIEN,DA=TTIEN,IENS=$$IENS^DILF(.DA)
  1.  .. S TTY=$$GET1^DIQ(9002318.412,IENS,".01","I") Q:TTY=""
  1.  .. S ADT=$$GET1^DIQ(9002318.412,IENS,".02","I")
  1.  .. S RDT=$$GET1^DIQ(9002318.412,IENS,".03","I")
  1.  .. S TTCNT=TTCNT+1
  1.  .. S @OUT@(NCNT,"TTY",TTCNT,"TTY")=TTY
  1.  .. Q:DAT  ;Exclude ADT/RDT
  1.  .. S @OUT@(NCNT,"TTY",TTCNT,"XADT")=ADT
  1.  .. S @OUT@(NCNT,"TTY",TTCNT,"XRDT")=RDT
  1.  . ;
  1.  . ;Pull Child Relationships
  1.  . I RET["C" S (ACNT,CHIEN)=0 F  S CHIEN=$O(^BSTS(9002318.4,CIEN,6,CHIEN)) Q:'CHIEN  D
  1.  .. ;
  1.  .. N CHD,DA,IENS,ICONC,ADT,RDT,DTS,FSN
  1.  .. S DA(1)=CIEN,DA=CHIEN,IENS=$$IENS^DILF(.DA)
  1.  .. S CHD=$$GET1^DIQ(9002318.46,IENS,".01","I") Q:CHD=""
  1.  .. S ADT=$$GET1^DIQ(9002318.46,IENS,".02","I")
  1.  .. S RDT=$$GET1^DIQ(9002318.46,IENS,".03","I")
  1.  .. S ICONC=$$GET1^DIQ(9002318.4,CHD,".02","I")
  1.  .. S DTS=$$GET1^DIQ(9002318.4,CHD,".08","I")
  1.  .. S FSN=$$GET1^DIQ(9002318.4,CHD,1,"I")
  1.  .. S ACNT=ACNT+1
  1.  .. S @OUT@(NCNT,"CHD",ACNT,"TRM")=FSN
  1.  .. S @OUT@(NCNT,"CHD",ACNT,"CON")=ICONC
  1.  .. S @OUT@(NCNT,"CHD",ACNT,"DTS")=DTS
  1.  .. Q:DAT  ;Exclude ADT/RDT
  1.  .. S @OUT@(NCNT,"CHD",ACNT,"XADT")=ADT
  1.  .. S @OUT@(NCNT,"CHD",ACNT,"XRDT")=RDT
  1.  . ;
  1.  . ;Pull Assoc
  1.  . I RET["A" S (ASCNT,ARCNT,AUCNT,ASIEN)=0 F  S ASIEN=$O(^BSTS(9002318.4,CIEN,9,ASIEN)) Q:'ASIEN  D
  1.  .. ;
  1.  .. N COD,DA,IENS,NAM,DTS
  1.  .. S DA(1)=CIEN,DA=ASIEN,IENS=$$IENS^DILF(.DA)
  1.  .. S COD=$$GET1^DIQ(9002318.49,IENS,".01","I") Q:COD=""
  1.  .. S NAM=$$GET1^DIQ(9002318.49,IENS,".02","I")
  1.  .. S DTS=$$GET1^DIQ(9002318.49,IENS,".03","I")
  1.  .. ;
  1.  .. ;Define SNOMED, RxNorm, and UNII
  1.  .. I (NAM=36)!(NAM=1552)!(NAM=5180) D
  1.  ... NEW CNT,NOD
  1.  ... S (CNT,NOD)=""
  1.  ... I NAM=36 S ASCNT=ASCNT+1,CNT=ASCNT,NOD="ASM"
  1.  ... I NAM=1552 S ARCNT=ARCNT+1,CNT=ARCNT,NOD="ARX"
  1.  ... I NAM=5180 S AUCNT=AUCNT+1,CNT=AUCNT,NOD="AUN"
  1.  ... Q:CNT=""
  1.  ... S @OUT@(NCNT,NOD,CNT,"CON")=COD
  1.  ... S @OUT@(NCNT,NOD,CNT,"DTS")=DTS
  1.  . ;
  1.  . ;Pull Inv Associations
  1.  . I RET["V" S (IARCNT,IASIEN)=0 F  S IASIEN=$O(^BSTS(9002318.4,CIEN,11,IASIEN)) Q:'IASIEN  D
  1.  .. ;
  1.  .. N COD,DA,IENS,NAM,DTS,TRM
  1.  .. S DA(1)=CIEN,DA=IASIEN,IENS=$$IENS^DILF(.DA)
  1.  .. S COD=$$GET1^DIQ(9002318.411,IENS,".01","I") Q:COD=""
  1.  .. S NAM=$$GET1^DIQ(9002318.411,IENS,".02","I")
  1.  .. S DTS=$$GET1^DIQ(9002318.411,IENS,".03","I")
  1.  .. S TRM=$$GET1^DIQ(9002318.411,IENS,".04","I")
  1.  .. ;
  1.  .. ;Define RxNorm
  1.  .. I (NAM=1552) D
  1.  ... NEW CNT,NOD
  1.  ... S (CNT,NOD)=""
  1.  ... I NAM=1552 S IARCNT=IARCNT+1,CNT=IARCNT,NOD="IAR"
  1.  ... Q:CNT=""
  1.  ... S @OUT@(NCNT,NOD,CNT,"CON")=COD
  1.  ... S @OUT@(NCNT,NOD,CNT,"DTS")=DTS
  1.  ... S @OUT@(NCNT,NOD,CNT,"TRM")=TRM
  1.  . ;
  1.  . ;Pull Subsets
  1.  . ;BSTS*1.0*6;Capture abnormal/normal,common terms
  1.  . ;BSTS*1.0*7;Capture prompt for laterality and default status
  1.  . ;BSTS*1.0*8;In ALL SNOMED?
  1.  . S @OUT@(NCNT,"LAT")=0
  1.  . S @OUT@(NCNT,"ABN")=0
  1.  . S @OUT@(NCNT,"CMN")=0
  1.  . S @OUT@(NCNT,"PAS")=0
  1.  . S @OUT@(NCNT,"STS")=""
  1.  . S @OUT@(NCNT,"HEAL")=""
  1.  . I RET["B" S (BCNT,SBIEN)=0 F  S SBIEN=$O(^BSTS(9002318.4,CIEN,4,SBIEN)) Q:'SBIEN  D
  1.  .. ;
  1.  .. N SUB,DA,IENS,ADT,RDT
  1.  .. S DA(1)=CIEN,DA=SBIEN,IENS=$$IENS^DILF(.DA)
  1.  .. S SUB=$$GET1^DIQ(9002318.44,IENS,".01","I") Q:SUB=""
  1.  .. S ADT=$$GET1^DIQ(9002318.44,IENS,".02","I")
  1.  .. S RDT=$$GET1^DIQ(9002318.44,IENS,".03","I")
  1.  .. S BCNT=BCNT+1
  1.  .. S @OUT@(NCNT,"SUB",BCNT,"SUB")=SUB
  1.  .. ;BSTS*1.0*6;Capture abnormal/normal
  1.  .. ;BSTS*1.0*7;Capture prompt for default status and laterality
  1.  .. ;BSTS*1.0*8;In ALL SNOMED?
  1.  .. I SUB="EHR IPL DEFAULT STATUS CHRONIC" S @OUT@(NCNT,"STS")="Chronic"
  1.  .. E  I SUB="EHR IPL DEFAULT STATUS PHX" S @OUT@(NCNT,"STS")="Personal History"
  1.  .. E  I SUB="EHR IPL DEFAULT STATUS SUB" S @OUT@(NCNT,"STS")="Sub-acute"
  1.  .. E  I SUB="EHR IPL DEFAULT STATUS ADMIN" S @OUT@(NCNT,"STS")="Admin"
  1.  .. E  I SUB="EHR IPL DEFAULT STATUS SOC ENV" S @OUT@(NCNT,"STS")="Social"
  1.  .. I SUB="EHR IPL PROMPT FOR LATERALITY" S @OUT@(NCNT,"LAT")=1
  1.  .. I SUB="EHR IPL PROMPT ABN FINDINGS" S @OUT@(NCNT,"ABN")=1
  1.  .. I SUB="SRCH Common Terms" S @OUT@(NCNT,"CMN")=1
  1.  .. I SUB="IHS PROBLEM ALL SNOMED" S @OUT@(NCNT,"PAS")=1
  1.  .. I SUB="EHR IPL FX PROMPT HEALING RDNM" S @OUT@(NCNT,"HEAL")="RDNM"
  1.  .. E  I SUB="EHR IPL FX PROMPT HEALING RDN" S @OUT@(NCNT,"HEAL")="RDN"
  1.  .. E  I SUB="EHR IPL FX PROMPT HEALING RD" S @OUT@(NCNT,"HEAL")="RD"
  1.  .. ;
  1.  .. Q:DAT  ;Exclude ADT/RDT
  1.  .. S @OUT@(NCNT,"SUB",BCNT,"XADT")=ADT
  1.  .. S @OUT@(NCNT,"SUB",BCNT,"XRDT")=RDT
  1.  . ;
  1.  . ;Pull ICD9/ICD10
  1.  . I XNMID=36,RET["X" D
  1.  .. ;
  1.  .. ;BSTS*1.0*6;ICD10 Conditional Mapping
  1.  .. NEW ICD10M
  1.  .. S ICD10M=""
  1.  .. I CDSET,PARMS]"" D
  1.  ... NEW ICD,PC
  1.  ... ;
  1.  ... ;Get the cond maps
  1.  ... S ICD10M=$$CMAP^BSTSMAP1(CONC,PARMS) Q:ICD10M=""
  1.  ... F PC=1:1:$L(ICD10M,";") S ICD=$P(ICD10M,";",PC) D
  1.  .... S ICNT("ICD")=$G(ICNT("ICD"))+1
  1.  .... S:ICD'["." ICD=ICD_"."
  1.  .... S @OUT@(NCNT,"ICD",ICNT("ICD"),"COD")=ICD
  1.  .... S @OUT@(NCNT,"ICD",ICNT("ICD"),"TYP")="10D"
  1.  .. ;
  1.  .. ;Perform cond mappings
  1.  .. S ICIEN=0 F  S ICIEN=$O(^BSTS(9002318.4,CIEN,3,ICIEN)) Q:'ICIEN  D
  1.  ... ;
  1.  ... N ICD,DA,IENS,ADT,RDT,ICDT
  1.  ... S DA(1)=CIEN,DA=ICIEN,IENS=$$IENS^DILF(.DA)
  1.  ... S ICD=$$GET1^DIQ(9002318.43,IENS,".02","I") Q:ICD=""
  1.  ... S:ICD'["." ICD=ICD_"."
  1.  ... S ICDT=$$GET1^DIQ(9002318.43,IENS,".03","I")
  1.  ... S ADT=$$GET1^DIQ(9002318.43,IENS,".04","I")
  1.  ... S RDT=$$GET1^DIQ(9002318.43,IENS,".05","I")
  1.  ... ;
  1.  ... ;Save ICD9 information - Legacy
  1.  ... I ICDT="IC9" D
  1.  .... S ICNT(ICDT)=$G(ICNT(ICDT))+1
  1.  .... S @OUT@(NCNT,ICDT,ICNT(ICDT),"COD")=ICD
  1.  .... S @OUT@(NCNT,ICDT,ICNT(ICDT),"TYP")=ICDT
  1.  .... Q:DAT  ;Exclude ADT/RDT
  1.  .... S @OUT@(NCNT,ICDT,ICNT(ICDT),"XADT")=ADT
  1.  .... S @OUT@(NCNT,ICDT,ICNT(ICDT),"XRDT")=RDT
  1.  ... ;
  1.  ... ;Save Current Mapped val
  1.  ... I (CDSET&(ICDT="10D")&(ICD10M=""))!('CDSET&(ICDT="IC9")) D
  1.  .... ;BSTS*1.0*8;Active ICD check
  1.  .... I '$$VRSN^BSTSVICD(ICD,"",PARMS) Q
  1.  .... S ICNT("ICD")=$G(ICNT("ICD"))+1
  1.  .... S @OUT@(NCNT,"ICD",ICNT("ICD"),"COD")=ICD
  1.  .... S @OUT@(NCNT,"ICD",ICNT("ICD"),"TYP")=ICDT
  1.  .... Q:DAT  ;Exclude ADT/RDT
  1.  .... S @OUT@(NCNT,"ICD",ICNT("ICD"),"XADT")=ADT
  1.  .... S @OUT@(NCNT,"ICD",ICNT("ICD"),"XRDT")=RDT
  1.  .. ;
  1.  .. ;Add in defaults if needed
  1.  .. I $D(@OUT@(NCNT,"ICD"))<10 D
  1.  ... I CDSET D  Q
  1.  .... S @OUT@(NCNT,"ICD",1,"COD")="ZZZ.999"
  1.  .... S @OUT@(NCNT,"ICD",1,"TYP")="10D"
  1.  ... E  D
  1.  .... S @OUT@(NCNT,"ICD",1,"COD")=".9999"
  1.  .... S @OUT@(NCNT,"ICD",1,"TYP")="IC9"
  1.  . ;
  1.  . ;Set up FSN, Synonyms, Preferred
  1.  . S SCNT=0,TIEN="" F  S TIEN=$O(^BSTS(9002318.3,"C",XNMID,CIEN,TIEN),-1) Q:TIEN=""  D
  1.  .. N TRM,TYP,ADT,RDT,DSC
  1.  .. ;
  1.  .. S TYP=$$GET1^DIQ(9002318.3,TIEN_",",.09,"I") Q:TYP=""
  1.  .. S TRM=$$GET1^DIQ(9002318.3,TIEN_",",1) Q:TRM=""
  1.  .. S DSC=$$GET1^DIQ(9002318.3,TIEN_",",.02,"I") Q:DSC=""
  1.  .. S ADT=$$GET1^DIQ(9002318.3,TIEN_",",.06,"I")
  1.  .. S RDT=$$GET1^DIQ(9002318.3,TIEN_",",.07,"I")
  1.  .. ;
  1.  .. ;Handle multiple preferred terms - switch to synonym
  1.  .. I $D(@OUT@(NCNT,"PRE")),TYP="P" S TYP="S"
  1.  .. ;
  1.  .. ;Synonyms
  1.  .. I RET["S",TYP="S" D
  1.  ... S SCNT=SCNT+1,@OUT@(NCNT,"SYN",SCNT,"TRM")=TRM
  1.  ... S @OUT@(NCNT,"SYN",SCNT,"DSC")=DSC
  1.  ... Q:DAT  ;Exclude ADT/RDT
  1.  ... S @OUT@(NCNT,"SYN",SCNT,"XADT")=ADT
  1.  ... S @OUT@(NCNT,"SYN",SCNT,"XRDT")=RDT
  1.  .. ;
  1.  .. ;Fully specified name
  1.  .. I TYP="F"!((XNMID=1552)&(TYP="P")) D
  1.  ... S @OUT@(NCNT,"FSN","TRM")=TRM
  1.  ... S @OUT@(NCNT,"FSN","DSC")=DSC
  1.  ... Q:DAT  ;Exclude ADT/RDt
  1.  ... S @OUT@(NCNT,"FSN","XADT")=ADT
  1.  ... S @OUT@(NCNT,"FSN","XRDT")=RDT
  1.  .. ;
  1.  .. ;Preferred term
  1.  .. I RET["P",TYP="P" D
  1.  ... S @OUT@(NCNT,"PRE","TRM")=TRM
  1.  ... S @OUT@(NCNT,"PRE","DSC")=DSC
  1.  ... Q:DAT  ;Exclude ADT/RDT
  1.  ... S @OUT@(NCNT,"PRE","XADT")=ADT
  1.  ... S @OUT@(NCNT,"PRE","XRDT")=RDT
  1.  ... ;
  1.  ... ;If STYPE="F" switch problem to preferred values
  1.  .. I TYP="P",STYPE="F" D
  1.  ... S @OUT@(NCNT,"PRB","TRM")=TRM
  1.  ... S @OUT@(NCNT,"PRB","DSC")=DSC
  1.  ;
  1.  Q NCNT