BSTSCDET ;GDIT/HS/BEE-Get Concept Detail ; 15 Nov 2012 4:26 PM
;;2.0;IHS STANDARD TERMINOLOGY;;Dec 01, 2016;Build 62
Q
;
DETAIL(OUT,BSTSWS,RESULT) ;EP - Return Details for each Concept/Term
;
;Input
; BSTSWS Array
; RESULT - [1]^[2]^[3]
; [1] - Concept ID
; [2] - DTS ID
; [3] - Description Id
;
;Output
; Function returns - # Records Returned
;
; VAR(#) - List of Records - See routine BSTSNDET
; for format
;
N CNT,INMID,XNMID,NCNT,RET,DAT,STYPE,INDATE,CDSET,PARMS
;
;Get the Namespace ID
S XNMID=$G(BSTSWS("NAMESPACEID"))
;
;Pull return request
S RET=$G(BSTSWS("RET"))
S DAT=$G(BSTSWS("DAT"))
S STYPE=$G(BSTSWS("STYPE"))
S INDATE=$G(BSTSWS("INDATE")) S:INDATE="" INDATE=DT
S PARMS=$G(BSTSWS("MPPRM"))
;
;Determine if ICD9 or ICD10
S CDSET=$$ICD10^BSTSUTIL(INDATE)
;
S INMID=$O(^BSTS(9002318.1,"B",XNMID,""))
;
S NCNT=0,CNT="" F S CNT=$O(RESULT(CNT)) Q:CNT="" D
. ;
. N CONC,DESC,CIEN,ADT,RDT,PRB,PRBIEN,ICNT,ISIEN,EQMND
. N BCNT,SBIEN,ICIEN,SCNT,TIEN,DTSID,ACNT,PDESC,CHIEN,EQ
. N ASCNT,ASIEN,ARCNT,ARIEN,AUCNT,AUIEN,IARCNT,IASIEN,TTCNT,TTIEN
. ;
. S CONC=$P(RESULT(CNT),U)
. S DTSID=$P(RESULT(CNT),U,2)
. S DESC=$P(RESULT(CNT),U,3)
. ;
. ;Get Concept IEN
. S CIEN=$$CIEN^BSTSLKP(CONC,XNMID) Q:CIEN=""
. ;
. ;Check for out of date entries
. I ($$GET1^DIQ(9002318.4,CIEN_",",".11","I")="Y")!($$GET1^DIQ(9002318.4,CIEN_",",".12","I")="") D
.. ;NEW STS,VAR
.. ;
.. ;BSTS*1.0*7;Update later
.. ;Check if DTS server is set to local - Quit if local
.. ;S STS=$$CKONOFF^BSTSWSV1() I '+STS S ^XTMP("BSTSPROCQ","C",CIEN)="" Q
.. ;S STS=$$DTSLKP^BSTSAPI("VAR",DTSID_"^"_XNMID)
.. S ^XTMP("BSTSPROCQ","C",CIEN)=""
. ;
. S ADT=$$GET1^DIQ(9002318.4,CIEN,".05","I")
. S RDT=$$GET1^DIQ(9002318.4,CIEN,".06","I")
. ;
. ;If FSN Search retrieve Desc ID for Preferred Term
. S PDESC=$P($$PDESC^BSTSSRCH(CIEN),U) Q:PDESC=""
. I STYPE="F" S DESC=PDESC
. ;
. ;Determine PRB value-For now use FSN or SYN/PRE
. S PRB=DESC
. S PRBIEN=$O(^BSTS(9002318.3,"D",INMID,PRB,"")) Q:PRBIEN=""
. S NCNT=NCNT+1
. S @OUT@(NCNT,"PRB","TRM")=$$GET1^DIQ(9002318.3,PRBIEN_",",1)
. S @OUT@(NCNT,"PRB","DSC")=DESC
. S @OUT@(NCNT,"CON")=CONC
. S @OUT@(NCNT,"DTS")=DTSID
. I 'DAT S @OUT@(NCNT,"XADT")=ADT
. I 'DAT S @OUT@(NCNT,"XRDT")=RDT
. ;
. ;BSTS*1.0*7;Return equivalant concept info
. S EQMND=$G(^BSTS(9002318.4,CIEN,16))
. S @OUT@(NCNT,"EQM","LAT")=$P(EQMND,U)
. S @OUT@(NCNT,"EQM","DTS")=$P(EQMND,U,2)
. S @OUT@(NCNT,"EQM","CON")=$P(EQMND,U,3)
. S @OUT@(NCNT,"EQM","XADT")=$P(EQMND,U,4)
. S @OUT@(NCNT,"EQM","XRDT")=$P(EQMND,U,5)
. S EQ=0 F S EQ=$O(^BSTS(9002318.4,CIEN,15,EQ)) Q:'EQ D
.. NEW EQNODE,EQLAT
.. S EQNODE=$G(^BSTS(9002318.4,CIEN,15,EQ,0))
.. S EQLAT=$P(EQNODE,U) Q:EQLAT=""
.. S @OUT@(NCNT,"EQC",EQLAT,"CON")=$P(EQNODE,U,2)
.. S @OUT@(NCNT,"EQC",EQLAT,"DTS")=$P(EQNODE,U,3)
.. S @OUT@(NCNT,"EQC",EQLAT,"XADT")=$P(EQNODE,U,4)
.. S @OUT@(NCNT,"EQC",EQLAT,"XRDT")=$P(EQNODE,U,5)
. ;
. ;Episodicity Req
. S @OUT@(NCNT,"EPI")=0
. I $D(^BSTS(9002318.4,"J",36,CONC,"EPI")) S @OUT@(NCNT,"EPI")=1
. ;
. ;Pull IsA Relationships
. I RET["I" S (ACNT,ISIEN)=0 F S ISIEN=$O(^BSTS(9002318.4,CIEN,5,ISIEN)) Q:'ISIEN D
.. ;
.. N ISA,DA,IENS,ICONC,ADT,RDT,DTS,FSN
.. S DA(1)=CIEN,DA=ISIEN,IENS=$$IENS^DILF(.DA)
.. S ISA=$$GET1^DIQ(9002318.45,IENS,".01","I") Q:ISA=""
.. S ADT=$$GET1^DIQ(9002318.45,IENS,".02","I")
.. S RDT=$$GET1^DIQ(9002318.45,IENS,".03","I")
.. S ICONC=$$GET1^DIQ(9002318.4,ISA,".02","I")
.. S DTS=$$GET1^DIQ(9002318.4,ISA,".08","I")
.. S FSN=$$GET1^DIQ(9002318.4,ISA,1,"I")
.. S ACNT=ACNT+1
.. S @OUT@(NCNT,"ISA",ACNT,"TRM")=FSN
.. S @OUT@(NCNT,"ISA",ACNT,"CON")=ICONC
.. S @OUT@(NCNT,"ISA",ACNT,"DTS")=DTS
.. Q:DAT ;Exclude ADT/RDT
.. S @OUT@(NCNT,"ISA",ACNT,"XADT")=ADT
.. S @OUT@(NCNT,"ISA",ACNT,"XRDT")=RDT
. ;
. ;RxNorm - Pull TTY
. I XNMID=1552 S (TTCNT,TTIEN)=0 F S TTIEN=$O(^BSTS(9002318.4,CIEN,12,TTIEN)) Q:'TTIEN D
.. ;
.. N TTY,DA,IENS,ICONC,ADT,RDT,DTS,FSN
.. S DA(1)=CIEN,DA=TTIEN,IENS=$$IENS^DILF(.DA)
.. S TTY=$$GET1^DIQ(9002318.412,IENS,".01","I") Q:TTY=""
.. S ADT=$$GET1^DIQ(9002318.412,IENS,".02","I")
.. S RDT=$$GET1^DIQ(9002318.412,IENS,".03","I")
.. S TTCNT=TTCNT+1
.. S @OUT@(NCNT,"TTY",TTCNT,"TTY")=TTY
.. Q:DAT ;Exclude ADT/RDT
.. S @OUT@(NCNT,"TTY",TTCNT,"XADT")=ADT
.. S @OUT@(NCNT,"TTY",TTCNT,"XRDT")=RDT
. ;
. ;Pull Child Relationships
. I RET["C" S (ACNT,CHIEN)=0 F S CHIEN=$O(^BSTS(9002318.4,CIEN,6,CHIEN)) Q:'CHIEN D
.. ;
.. N CHD,DA,IENS,ICONC,ADT,RDT,DTS,FSN
.. S DA(1)=CIEN,DA=CHIEN,IENS=$$IENS^DILF(.DA)
.. S CHD=$$GET1^DIQ(9002318.46,IENS,".01","I") Q:CHD=""
.. S ADT=$$GET1^DIQ(9002318.46,IENS,".02","I")
.. S RDT=$$GET1^DIQ(9002318.46,IENS,".03","I")
.. S ICONC=$$GET1^DIQ(9002318.4,CHD,".02","I")
.. S DTS=$$GET1^DIQ(9002318.4,CHD,".08","I")
.. S FSN=$$GET1^DIQ(9002318.4,CHD,1,"I")
.. S ACNT=ACNT+1
.. S @OUT@(NCNT,"CHD",ACNT,"TRM")=FSN
.. S @OUT@(NCNT,"CHD",ACNT,"CON")=ICONC
.. S @OUT@(NCNT,"CHD",ACNT,"DTS")=DTS
.. Q:DAT ;Exclude ADT/RDT
.. S @OUT@(NCNT,"CHD",ACNT,"XADT")=ADT
.. S @OUT@(NCNT,"CHD",ACNT,"XRDT")=RDT
. ;
. ;Pull Assoc
. I RET["A" S (ASCNT,ARCNT,AUCNT,ASIEN)=0 F S ASIEN=$O(^BSTS(9002318.4,CIEN,9,ASIEN)) Q:'ASIEN D
.. ;
.. N COD,DA,IENS,NAM,DTS
.. S DA(1)=CIEN,DA=ASIEN,IENS=$$IENS^DILF(.DA)
.. S COD=$$GET1^DIQ(9002318.49,IENS,".01","I") Q:COD=""
.. S NAM=$$GET1^DIQ(9002318.49,IENS,".02","I")
.. S DTS=$$GET1^DIQ(9002318.49,IENS,".03","I")
.. ;
.. ;Define SNOMED, RxNorm, and UNII
.. I (NAM=36)!(NAM=1552)!(NAM=5180) D
... NEW CNT,NOD
... S (CNT,NOD)=""
... I NAM=36 S ASCNT=ASCNT+1,CNT=ASCNT,NOD="ASM"
... I NAM=1552 S ARCNT=ARCNT+1,CNT=ARCNT,NOD="ARX"
... I NAM=5180 S AUCNT=AUCNT+1,CNT=AUCNT,NOD="AUN"
... Q:CNT=""
... S @OUT@(NCNT,NOD,CNT,"CON")=COD
... S @OUT@(NCNT,NOD,CNT,"DTS")=DTS
. ;
. ;Pull Inv Associations
. I RET["V" S (IARCNT,IASIEN)=0 F S IASIEN=$O(^BSTS(9002318.4,CIEN,11,IASIEN)) Q:'IASIEN D
.. ;
.. N COD,DA,IENS,NAM,DTS,TRM
.. S DA(1)=CIEN,DA=IASIEN,IENS=$$IENS^DILF(.DA)
.. S COD=$$GET1^DIQ(9002318.411,IENS,".01","I") Q:COD=""
.. S NAM=$$GET1^DIQ(9002318.411,IENS,".02","I")
.. S DTS=$$GET1^DIQ(9002318.411,IENS,".03","I")
.. S TRM=$$GET1^DIQ(9002318.411,IENS,".04","I")
.. ;
.. ;Define RxNorm
.. I (NAM=1552) D
... NEW CNT,NOD
... S (CNT,NOD)=""
... I NAM=1552 S IARCNT=IARCNT+1,CNT=IARCNT,NOD="IAR"
... Q:CNT=""
... S @OUT@(NCNT,NOD,CNT,"CON")=COD
... S @OUT@(NCNT,NOD,CNT,"DTS")=DTS
... S @OUT@(NCNT,NOD,CNT,"TRM")=TRM
. ;
. ;Pull Subsets
. ;BSTS*1.0*6;Capture abnormal/normal,common terms
. ;BSTS*1.0*7;Capture prompt for laterality and default status
. ;BSTS*1.0*8;In ALL SNOMED?
. S @OUT@(NCNT,"LAT")=0
. S @OUT@(NCNT,"ABN")=0
. S @OUT@(NCNT,"CMN")=0
. S @OUT@(NCNT,"PAS")=0
. S @OUT@(NCNT,"STS")=""
. S @OUT@(NCNT,"HEAL")=""
. I RET["B" S (BCNT,SBIEN)=0 F S SBIEN=$O(^BSTS(9002318.4,CIEN,4,SBIEN)) Q:'SBIEN D
.. ;
.. N SUB,DA,IENS,ADT,RDT
.. S DA(1)=CIEN,DA=SBIEN,IENS=$$IENS^DILF(.DA)
.. S SUB=$$GET1^DIQ(9002318.44,IENS,".01","I") Q:SUB=""
.. S ADT=$$GET1^DIQ(9002318.44,IENS,".02","I")
.. S RDT=$$GET1^DIQ(9002318.44,IENS,".03","I")
.. S BCNT=BCNT+1
.. S @OUT@(NCNT,"SUB",BCNT,"SUB")=SUB
.. ;BSTS*1.0*6;Capture abnormal/normal
.. ;BSTS*1.0*7;Capture prompt for default status and laterality
.. ;BSTS*1.0*8;In ALL SNOMED?
.. I SUB="EHR IPL DEFAULT STATUS CHRONIC" S @OUT@(NCNT,"STS")="Chronic"
.. E I SUB="EHR IPL DEFAULT STATUS PHX" S @OUT@(NCNT,"STS")="Personal History"
.. E I SUB="EHR IPL DEFAULT STATUS SUB" S @OUT@(NCNT,"STS")="Sub-acute"
.. E I SUB="EHR IPL DEFAULT STATUS ADMIN" S @OUT@(NCNT,"STS")="Admin"
.. E I SUB="EHR IPL DEFAULT STATUS SOC ENV" S @OUT@(NCNT,"STS")="Social"
.. I SUB="EHR IPL PROMPT FOR LATERALITY" S @OUT@(NCNT,"LAT")=1
.. I SUB="EHR IPL PROMPT ABN FINDINGS" S @OUT@(NCNT,"ABN")=1
.. I SUB="SRCH Common Terms" S @OUT@(NCNT,"CMN")=1
.. I SUB="IHS PROBLEM ALL SNOMED" S @OUT@(NCNT,"PAS")=1
.. I SUB="EHR IPL FX PROMPT HEALING RDNM" S @OUT@(NCNT,"HEAL")="RDNM"
.. E I SUB="EHR IPL FX PROMPT HEALING RDN" S @OUT@(NCNT,"HEAL")="RDN"
.. E I SUB="EHR IPL FX PROMPT HEALING RD" S @OUT@(NCNT,"HEAL")="RD"
.. ;
.. Q:DAT ;Exclude ADT/RDT
.. S @OUT@(NCNT,"SUB",BCNT,"XADT")=ADT
.. S @OUT@(NCNT,"SUB",BCNT,"XRDT")=RDT
. ;
. ;Pull ICD9/ICD10
. I XNMID=36,RET["X" D
.. ;
.. ;BSTS*1.0*6;ICD10 Conditional Mapping
.. NEW ICD10M
.. S ICD10M=""
.. I CDSET,PARMS]"" D
... NEW ICD,PC
... ;
... ;Get the cond maps
... S ICD10M=$$CMAP^BSTSMAP1(CONC,PARMS) Q:ICD10M=""
... F PC=1:1:$L(ICD10M,";") S ICD=$P(ICD10M,";",PC) D
.... S ICNT("ICD")=$G(ICNT("ICD"))+1
.... S:ICD'["." ICD=ICD_"."
.... S @OUT@(NCNT,"ICD",ICNT("ICD"),"COD")=ICD
.... S @OUT@(NCNT,"ICD",ICNT("ICD"),"TYP")="10D"
.. ;
.. ;Perform cond mappings
.. S ICIEN=0 F S ICIEN=$O(^BSTS(9002318.4,CIEN,3,ICIEN)) Q:'ICIEN D
... ;
... N ICD,DA,IENS,ADT,RDT,ICDT
... S DA(1)=CIEN,DA=ICIEN,IENS=$$IENS^DILF(.DA)
... S ICD=$$GET1^DIQ(9002318.43,IENS,".02","I") Q:ICD=""
... S:ICD'["." ICD=ICD_"."
... S ICDT=$$GET1^DIQ(9002318.43,IENS,".03","I")
... S ADT=$$GET1^DIQ(9002318.43,IENS,".04","I")
... S RDT=$$GET1^DIQ(9002318.43,IENS,".05","I")
... ;
... ;Save ICD9 information - Legacy
... I ICDT="IC9" D
.... S ICNT(ICDT)=$G(ICNT(ICDT))+1
.... S @OUT@(NCNT,ICDT,ICNT(ICDT),"COD")=ICD
.... S @OUT@(NCNT,ICDT,ICNT(ICDT),"TYP")=ICDT
.... Q:DAT ;Exclude ADT/RDT
.... S @OUT@(NCNT,ICDT,ICNT(ICDT),"XADT")=ADT
.... S @OUT@(NCNT,ICDT,ICNT(ICDT),"XRDT")=RDT
... ;
... ;Save Current Mapped val
... I (CDSET&(ICDT="10D")&(ICD10M=""))!('CDSET&(ICDT="IC9")) D
.... ;BSTS*1.0*8;Active ICD check
.... I '$$VRSN^BSTSVICD(ICD,"",PARMS) Q
.... S ICNT("ICD")=$G(ICNT("ICD"))+1
.... S @OUT@(NCNT,"ICD",ICNT("ICD"),"COD")=ICD
.... S @OUT@(NCNT,"ICD",ICNT("ICD"),"TYP")=ICDT
.... Q:DAT ;Exclude ADT/RDT
.... S @OUT@(NCNT,"ICD",ICNT("ICD"),"XADT")=ADT
.... S @OUT@(NCNT,"ICD",ICNT("ICD"),"XRDT")=RDT
.. ;
.. ;Add in defaults if needed
.. I $D(@OUT@(NCNT,"ICD"))<10 D
... I CDSET D Q
.... S @OUT@(NCNT,"ICD",1,"COD")="ZZZ.999"
.... S @OUT@(NCNT,"ICD",1,"TYP")="10D"
... E D
.... S @OUT@(NCNT,"ICD",1,"COD")=".9999"
.... S @OUT@(NCNT,"ICD",1,"TYP")="IC9"
. ;
. ;Set up FSN, Synonyms, Preferred
. S SCNT=0,TIEN="" F S TIEN=$O(^BSTS(9002318.3,"C",XNMID,CIEN,TIEN),-1) Q:TIEN="" D
.. N TRM,TYP,ADT,RDT,DSC
.. ;
.. S TYP=$$GET1^DIQ(9002318.3,TIEN_",",.09,"I") Q:TYP=""
.. S TRM=$$GET1^DIQ(9002318.3,TIEN_",",1) Q:TRM=""
.. S DSC=$$GET1^DIQ(9002318.3,TIEN_",",.02,"I") Q:DSC=""
.. S ADT=$$GET1^DIQ(9002318.3,TIEN_",",.06,"I")
.. S RDT=$$GET1^DIQ(9002318.3,TIEN_",",.07,"I")
.. ;
.. ;Handle multiple preferred terms - switch to synonym
.. I $D(@OUT@(NCNT,"PRE")),TYP="P" S TYP="S"
.. ;
.. ;Synonyms
.. I RET["S",TYP="S" D
... S SCNT=SCNT+1,@OUT@(NCNT,"SYN",SCNT,"TRM")=TRM
... S @OUT@(NCNT,"SYN",SCNT,"DSC")=DSC
... Q:DAT ;Exclude ADT/RDT
... S @OUT@(NCNT,"SYN",SCNT,"XADT")=ADT
... S @OUT@(NCNT,"SYN",SCNT,"XRDT")=RDT
.. ;
.. ;Fully specified name
.. I TYP="F"!((XNMID=1552)&(TYP="P")) D
... S @OUT@(NCNT,"FSN","TRM")=TRM
... S @OUT@(NCNT,"FSN","DSC")=DSC
... Q:DAT ;Exclude ADT/RDt
... S @OUT@(NCNT,"FSN","XADT")=ADT
... S @OUT@(NCNT,"FSN","XRDT")=RDT
.. ;
.. ;Preferred term
.. I RET["P",TYP="P" D
... S @OUT@(NCNT,"PRE","TRM")=TRM
... S @OUT@(NCNT,"PRE","DSC")=DSC
... Q:DAT ;Exclude ADT/RDT
... S @OUT@(NCNT,"PRE","XADT")=ADT
... S @OUT@(NCNT,"PRE","XRDT")=RDT
... ;
... ;If STYPE="F" switch problem to preferred values
.. I TYP="P",STYPE="F" D
... S @OUT@(NCNT,"PRB","TRM")=TRM
... S @OUT@(NCNT,"PRB","DSC")=DSC
;
Q NCNT
BSTSCDET ;GDIT/HS/BEE-Get Concept Detail ; 15 Nov 2012 4:26 PM
+1 ;;2.0;IHS STANDARD TERMINOLOGY;;Dec 01, 2016;Build 62
+2 QUIT
+3 ;
DETAIL(OUT,BSTSWS,RESULT) ;EP - Return Details for each Concept/Term
+1 ;
+2 ;Input
+3 ; BSTSWS Array
+4 ; RESULT - [1]^[2]^[3]
+5 ; [1] - Concept ID
+6 ; [2] - DTS ID
+7 ; [3] - Description Id
+8 ;
+9 ;Output
+10 ; Function returns - # Records Returned
+11 ;
+12 ; VAR(#) - List of Records - See routine BSTSNDET
+13 ; for format
+14 ;
+15 NEW CNT,INMID,XNMID,NCNT,RET,DAT,STYPE,INDATE,CDSET,PARMS
+16 ;
+17 ;Get the Namespace ID
+18 SET XNMID=$GET(BSTSWS("NAMESPACEID"))
+19 ;
+20 ;Pull return request
+21 SET RET=$GET(BSTSWS("RET"))
+22 SET DAT=$GET(BSTSWS("DAT"))
+23 SET STYPE=$GET(BSTSWS("STYPE"))
+24 SET INDATE=$GET(BSTSWS("INDATE"))
IF INDATE=""
SET INDATE=DT
+25 SET PARMS=$GET(BSTSWS("MPPRM"))
+26 ;
+27 ;Determine if ICD9 or ICD10
+28 SET CDSET=$$ICD10^BSTSUTIL(INDATE)
+29 ;
+30 SET INMID=$ORDER(^BSTS(9002318.1,"B",XNMID,""))
+31 ;
+32 SET NCNT=0
SET CNT=""
FOR
SET CNT=$ORDER(RESULT(CNT))
IF CNT=""
QUIT
Begin DoDot:1
+33 ;
+34 NEW CONC,DESC,CIEN,ADT,RDT,PRB,PRBIEN,ICNT,ISIEN,EQMND
+35 NEW BCNT,SBIEN,ICIEN,SCNT,TIEN,DTSID,ACNT,PDESC,CHIEN,EQ
+36 NEW ASCNT,ASIEN,ARCNT,ARIEN,AUCNT,AUIEN,IARCNT,IASIEN,TTCNT,TTIEN
+37 ;
+38 SET CONC=$PIECE(RESULT(CNT),U)
+39 SET DTSID=$PIECE(RESULT(CNT),U,2)
+40 SET DESC=$PIECE(RESULT(CNT),U,3)
+41 ;
+42 ;Get Concept IEN
+43 SET CIEN=$$CIEN^BSTSLKP(CONC,XNMID)
IF CIEN=""
QUIT
+44 ;
+45 ;Check for out of date entries
+46 IF ($$GET1^DIQ(9002318.4,CIEN_",",".11","I")="Y")!($$GET1^DIQ(9002318.4,CIEN_",",".12","I")="")
Begin DoDot:2
+47 ;NEW STS,VAR
+48 ;
+49 ;BSTS*1.0*7;Update later
+50 ;Check if DTS server is set to local - Quit if local
+51 ;S STS=$$CKONOFF^BSTSWSV1() I '+STS S ^XTMP("BSTSPROCQ","C",CIEN)="" Q
+52 ;S STS=$$DTSLKP^BSTSAPI("VAR",DTSID_"^"_XNMID)
+53 SET ^XTMP("BSTSPROCQ","C",CIEN)=""
End DoDot:2
+54 ;
+55 SET ADT=$$GET1^DIQ(9002318.4,CIEN,".05","I")
+56 SET RDT=$$GET1^DIQ(9002318.4,CIEN,".06","I")
+57 ;
+58 ;If FSN Search retrieve Desc ID for Preferred Term
+59 SET PDESC=$PIECE($$PDESC^BSTSSRCH(CIEN),U)
IF PDESC=""
QUIT
+60 IF STYPE="F"
SET DESC=PDESC
+61 ;
+62 ;Determine PRB value-For now use FSN or SYN/PRE
+63 SET PRB=DESC
+64 SET PRBIEN=$ORDER(^BSTS(9002318.3,"D",INMID,PRB,""))
IF PRBIEN=""
QUIT
+65 SET NCNT=NCNT+1
+66 SET @OUT@(NCNT,"PRB","TRM")=$$GET1^DIQ(9002318.3,PRBIEN_",",1)
+67 SET @OUT@(NCNT,"PRB","DSC")=DESC
+68 SET @OUT@(NCNT,"CON")=CONC
+69 SET @OUT@(NCNT,"DTS")=DTSID
+70 IF 'DAT
SET @OUT@(NCNT,"XADT")=ADT
+71 IF 'DAT
SET @OUT@(NCNT,"XRDT")=RDT
+72 ;
+73 ;BSTS*1.0*7;Return equivalant concept info
+74 SET EQMND=$GET(^BSTS(9002318.4,CIEN,16))
+75 SET @OUT@(NCNT,"EQM","LAT")=$PIECE(EQMND,U)
+76 SET @OUT@(NCNT,"EQM","DTS")=$PIECE(EQMND,U,2)
+77 SET @OUT@(NCNT,"EQM","CON")=$PIECE(EQMND,U,3)
+78 SET @OUT@(NCNT,"EQM","XADT")=$PIECE(EQMND,U,4)
+79 SET @OUT@(NCNT,"EQM","XRDT")=$PIECE(EQMND,U,5)
+80 SET EQ=0
FOR
SET EQ=$ORDER(^BSTS(9002318.4,CIEN,15,EQ))
IF 'EQ
QUIT
Begin DoDot:2
+81 NEW EQNODE,EQLAT
+82 SET EQNODE=$GET(^BSTS(9002318.4,CIEN,15,EQ,0))
+83 SET EQLAT=$PIECE(EQNODE,U)
IF EQLAT=""
QUIT
+84 SET @OUT@(NCNT,"EQC",EQLAT,"CON")=$PIECE(EQNODE,U,2)
+85 SET @OUT@(NCNT,"EQC",EQLAT,"DTS")=$PIECE(EQNODE,U,3)
+86 SET @OUT@(NCNT,"EQC",EQLAT,"XADT")=$PIECE(EQNODE,U,4)
+87 SET @OUT@(NCNT,"EQC",EQLAT,"XRDT")=$PIECE(EQNODE,U,5)
End DoDot:2
+88 ;
+89 ;Episodicity Req
+90 SET @OUT@(NCNT,"EPI")=0
+91 IF $DATA(^BSTS(9002318.4,"J",36,CONC,"EPI"))
SET @OUT@(NCNT,"EPI")=1
+92 ;
+93 ;Pull IsA Relationships
+94 IF RET["I"
SET (ACNT,ISIEN)=0
FOR
SET ISIEN=$ORDER(^BSTS(9002318.4,CIEN,5,ISIEN))
IF 'ISIEN
QUIT
Begin DoDot:2
+95 ;
+96 NEW ISA,DA,IENS,ICONC,ADT,RDT,DTS,FSN
+97 SET DA(1)=CIEN
SET DA=ISIEN
SET IENS=$$IENS^DILF(.DA)
+98 SET ISA=$$GET1^DIQ(9002318.45,IENS,".01","I")
IF ISA=""
QUIT
+99 SET ADT=$$GET1^DIQ(9002318.45,IENS,".02","I")
+100 SET RDT=$$GET1^DIQ(9002318.45,IENS,".03","I")
+101 SET ICONC=$$GET1^DIQ(9002318.4,ISA,".02","I")
+102 SET DTS=$$GET1^DIQ(9002318.4,ISA,".08","I")
+103 SET FSN=$$GET1^DIQ(9002318.4,ISA,1,"I")
+104 SET ACNT=ACNT+1
+105 SET @OUT@(NCNT,"ISA",ACNT,"TRM")=FSN
+106 SET @OUT@(NCNT,"ISA",ACNT,"CON")=ICONC
+107 SET @OUT@(NCNT,"ISA",ACNT,"DTS")=DTS
+108 ;Exclude ADT/RDT
IF DAT
QUIT
+109 SET @OUT@(NCNT,"ISA",ACNT,"XADT")=ADT
+110 SET @OUT@(NCNT,"ISA",ACNT,"XRDT")=RDT
End DoDot:2
+111 ;
+112 ;RxNorm - Pull TTY
+113 IF XNMID=1552
SET (TTCNT,TTIEN)=0
FOR
SET TTIEN=$ORDER(^BSTS(9002318.4,CIEN,12,TTIEN))
IF 'TTIEN
QUIT
Begin DoDot:2
+114 ;
+115 NEW TTY,DA,IENS,ICONC,ADT,RDT,DTS,FSN
+116 SET DA(1)=CIEN
SET DA=TTIEN
SET IENS=$$IENS^DILF(.DA)
+117 SET TTY=$$GET1^DIQ(9002318.412,IENS,".01","I")
IF TTY=""
QUIT
+118 SET ADT=$$GET1^DIQ(9002318.412,IENS,".02","I")
+119 SET RDT=$$GET1^DIQ(9002318.412,IENS,".03","I")
+120 SET TTCNT=TTCNT+1
+121 SET @OUT@(NCNT,"TTY",TTCNT,"TTY")=TTY
+122 ;Exclude ADT/RDT
IF DAT
QUIT
+123 SET @OUT@(NCNT,"TTY",TTCNT,"XADT")=ADT
+124 SET @OUT@(NCNT,"TTY",TTCNT,"XRDT")=RDT
End DoDot:2
+125 ;
+126 ;Pull Child Relationships
+127 IF RET["C"
SET (ACNT,CHIEN)=0
FOR
SET CHIEN=$ORDER(^BSTS(9002318.4,CIEN,6,CHIEN))
IF 'CHIEN
QUIT
Begin DoDot:2
+128 ;
+129 NEW CHD,DA,IENS,ICONC,ADT,RDT,DTS,FSN
+130 SET DA(1)=CIEN
SET DA=CHIEN
SET IENS=$$IENS^DILF(.DA)
+131 SET CHD=$$GET1^DIQ(9002318.46,IENS,".01","I")
IF CHD=""
QUIT
+132 SET ADT=$$GET1^DIQ(9002318.46,IENS,".02","I")
+133 SET RDT=$$GET1^DIQ(9002318.46,IENS,".03","I")
+134 SET ICONC=$$GET1^DIQ(9002318.4,CHD,".02","I")
+135 SET DTS=$$GET1^DIQ(9002318.4,CHD,".08","I")
+136 SET FSN=$$GET1^DIQ(9002318.4,CHD,1,"I")
+137 SET ACNT=ACNT+1
+138 SET @OUT@(NCNT,"CHD",ACNT,"TRM")=FSN
+139 SET @OUT@(NCNT,"CHD",ACNT,"CON")=ICONC
+140 SET @OUT@(NCNT,"CHD",ACNT,"DTS")=DTS
+141 ;Exclude ADT/RDT
IF DAT
QUIT
+142 SET @OUT@(NCNT,"CHD",ACNT,"XADT")=ADT
+143 SET @OUT@(NCNT,"CHD",ACNT,"XRDT")=RDT
End DoDot:2
+144 ;
+145 ;Pull Assoc
+146 IF RET["A"
SET (ASCNT,ARCNT,AUCNT,ASIEN)=0
FOR
SET ASIEN=$ORDER(^BSTS(9002318.4,CIEN,9,ASIEN))
IF 'ASIEN
QUIT
Begin DoDot:2
+147 ;
+148 NEW COD,DA,IENS,NAM,DTS
+149 SET DA(1)=CIEN
SET DA=ASIEN
SET IENS=$$IENS^DILF(.DA)
+150 SET COD=$$GET1^DIQ(9002318.49,IENS,".01","I")
IF COD=""
QUIT
+151 SET NAM=$$GET1^DIQ(9002318.49,IENS,".02","I")
+152 SET DTS=$$GET1^DIQ(9002318.49,IENS,".03","I")
+153 ;
+154 ;Define SNOMED, RxNorm, and UNII
+155 IF (NAM=36)!(NAM=1552)!(NAM=5180)
Begin DoDot:3
+156 NEW CNT,NOD
+157 SET (CNT,NOD)=""
+158 IF NAM=36
SET ASCNT=ASCNT+1
SET CNT=ASCNT
SET NOD="ASM"
+159 IF NAM=1552
SET ARCNT=ARCNT+1
SET CNT=ARCNT
SET NOD="ARX"
+160 IF NAM=5180
SET AUCNT=AUCNT+1
SET CNT=AUCNT
SET NOD="AUN"
+161 IF CNT=""
QUIT
+162 SET @OUT@(NCNT,NOD,CNT,"CON")=COD
+163 SET @OUT@(NCNT,NOD,CNT,"DTS")=DTS
End DoDot:3
End DoDot:2
+164 ;
+165 ;Pull Inv Associations
+166 IF RET["V"
SET (IARCNT,IASIEN)=0
FOR
SET IASIEN=$ORDER(^BSTS(9002318.4,CIEN,11,IASIEN))
IF 'IASIEN
QUIT
Begin DoDot:2
+167 ;
+168 NEW COD,DA,IENS,NAM,DTS,TRM
+169 SET DA(1)=CIEN
SET DA=IASIEN
SET IENS=$$IENS^DILF(.DA)
+170 SET COD=$$GET1^DIQ(9002318.411,IENS,".01","I")
IF COD=""
QUIT
+171 SET NAM=$$GET1^DIQ(9002318.411,IENS,".02","I")
+172 SET DTS=$$GET1^DIQ(9002318.411,IENS,".03","I")
+173 SET TRM=$$GET1^DIQ(9002318.411,IENS,".04","I")
+174 ;
+175 ;Define RxNorm
+176 IF (NAM=1552)
Begin DoDot:3
+177 NEW CNT,NOD
+178 SET (CNT,NOD)=""
+179 IF NAM=1552
SET IARCNT=IARCNT+1
SET CNT=IARCNT
SET NOD="IAR"
+180 IF CNT=""
QUIT
+181 SET @OUT@(NCNT,NOD,CNT,"CON")=COD
+182 SET @OUT@(NCNT,NOD,CNT,"DTS")=DTS
+183 SET @OUT@(NCNT,NOD,CNT,"TRM")=TRM
End DoDot:3
End DoDot:2
+184 ;
+185 ;Pull Subsets
+186 ;BSTS*1.0*6;Capture abnormal/normal,common terms
+187 ;BSTS*1.0*7;Capture prompt for laterality and default status
+188 ;BSTS*1.0*8;In ALL SNOMED?
+189 SET @OUT@(NCNT,"LAT")=0
+190 SET @OUT@(NCNT,"ABN")=0
+191 SET @OUT@(NCNT,"CMN")=0
+192 SET @OUT@(NCNT,"PAS")=0
+193 SET @OUT@(NCNT,"STS")=""
+194 SET @OUT@(NCNT,"HEAL")=""
+195 IF RET["B"
SET (BCNT,SBIEN)=0
FOR
SET SBIEN=$ORDER(^BSTS(9002318.4,CIEN,4,SBIEN))
IF 'SBIEN
QUIT
Begin DoDot:2
+196 ;
+197 NEW SUB,DA,IENS,ADT,RDT
+198 SET DA(1)=CIEN
SET DA=SBIEN
SET IENS=$$IENS^DILF(.DA)
+199 SET SUB=$$GET1^DIQ(9002318.44,IENS,".01","I")
IF SUB=""
QUIT
+200 SET ADT=$$GET1^DIQ(9002318.44,IENS,".02","I")
+201 SET RDT=$$GET1^DIQ(9002318.44,IENS,".03","I")
+202 SET BCNT=BCNT+1
+203 SET @OUT@(NCNT,"SUB",BCNT,"SUB")=SUB
+204 ;BSTS*1.0*6;Capture abnormal/normal
+205 ;BSTS*1.0*7;Capture prompt for default status and laterality
+206 ;BSTS*1.0*8;In ALL SNOMED?
+207 IF SUB="EHR IPL DEFAULT STATUS CHRONIC"
SET @OUT@(NCNT,"STS")="Chronic"
+208 IF '$TEST
IF SUB="EHR IPL DEFAULT STATUS PHX"
SET @OUT@(NCNT,"STS")="Personal History"
+209 IF '$TEST
IF SUB="EHR IPL DEFAULT STATUS SUB"
SET @OUT@(NCNT,"STS")="Sub-acute"
+210 IF '$TEST
IF SUB="EHR IPL DEFAULT STATUS ADMIN"
SET @OUT@(NCNT,"STS")="Admin"
+211 IF '$TEST
IF SUB="EHR IPL DEFAULT STATUS SOC ENV"
SET @OUT@(NCNT,"STS")="Social"
+212 IF SUB="EHR IPL PROMPT FOR LATERALITY"
SET @OUT@(NCNT,"LAT")=1
+213 IF SUB="EHR IPL PROMPT ABN FINDINGS"
SET @OUT@(NCNT,"ABN")=1
+214 IF SUB="SRCH Common Terms"
SET @OUT@(NCNT,"CMN")=1
+215 IF SUB="IHS PROBLEM ALL SNOMED"
SET @OUT@(NCNT,"PAS")=1
+216 IF SUB="EHR IPL FX PROMPT HEALING RDNM"
SET @OUT@(NCNT,"HEAL")="RDNM"
+217 IF '$TEST
IF SUB="EHR IPL FX PROMPT HEALING RDN"
SET @OUT@(NCNT,"HEAL")="RDN"
+218 IF '$TEST
IF SUB="EHR IPL FX PROMPT HEALING RD"
SET @OUT@(NCNT,"HEAL")="RD"
+219 ;
+220 ;Exclude ADT/RDT
IF DAT
QUIT
+221 SET @OUT@(NCNT,"SUB",BCNT,"XADT")=ADT
+222 SET @OUT@(NCNT,"SUB",BCNT,"XRDT")=RDT
End DoDot:2
+223 ;
+224 ;Pull ICD9/ICD10
+225 IF XNMID=36
IF RET["X"
Begin DoDot:2
+226 ;
+227 ;BSTS*1.0*6;ICD10 Conditional Mapping
+228 NEW ICD10M
+229 SET ICD10M=""
+230 IF CDSET
IF PARMS]""
Begin DoDot:3
+231 NEW ICD,PC
+232 ;
+233 ;Get the cond maps
+234 SET ICD10M=$$CMAP^BSTSMAP1(CONC,PARMS)
IF ICD10M=""
QUIT
+235 FOR PC=1:1:$LENGTH(ICD10M,";")
SET ICD=$PIECE(ICD10M,";",PC)
Begin DoDot:4
+236 SET ICNT("ICD")=$GET(ICNT("ICD"))+1
+237 IF ICD'["."
SET ICD=ICD_"."
+238 SET @OUT@(NCNT,"ICD",ICNT("ICD"),"COD")=ICD
+239 SET @OUT@(NCNT,"ICD",ICNT("ICD"),"TYP")="10D"
End DoDot:4
End DoDot:3
+240 ;
+241 ;Perform cond mappings
+242 SET ICIEN=0
FOR
SET ICIEN=$ORDER(^BSTS(9002318.4,CIEN,3,ICIEN))
IF 'ICIEN
QUIT
Begin DoDot:3
+243 ;
+244 NEW ICD,DA,IENS,ADT,RDT,ICDT
+245 SET DA(1)=CIEN
SET DA=ICIEN
SET IENS=$$IENS^DILF(.DA)
+246 SET ICD=$$GET1^DIQ(9002318.43,IENS,".02","I")
IF ICD=""
QUIT
+247 IF ICD'["."
SET ICD=ICD_"."
+248 SET ICDT=$$GET1^DIQ(9002318.43,IENS,".03","I")
+249 SET ADT=$$GET1^DIQ(9002318.43,IENS,".04","I")
+250 SET RDT=$$GET1^DIQ(9002318.43,IENS,".05","I")
+251 ;
+252 ;Save ICD9 information - Legacy
+253 IF ICDT="IC9"
Begin DoDot:4
+254 SET ICNT(ICDT)=$GET(ICNT(ICDT))+1
+255 SET @OUT@(NCNT,ICDT,ICNT(ICDT),"COD")=ICD
+256 SET @OUT@(NCNT,ICDT,ICNT(ICDT),"TYP")=ICDT
+257 ;Exclude ADT/RDT
IF DAT
QUIT
+258 SET @OUT@(NCNT,ICDT,ICNT(ICDT),"XADT")=ADT
+259 SET @OUT@(NCNT,ICDT,ICNT(ICDT),"XRDT")=RDT
End DoDot:4
+260 ;
+261 ;Save Current Mapped val
+262 IF (CDSET&(ICDT="10D")&(ICD10M=""))!('CDSET&(ICDT="IC9"))
Begin DoDot:4
+263 ;BSTS*1.0*8;Active ICD check
+264 IF '$$VRSN^BSTSVICD(ICD,"",PARMS)
QUIT
+265 SET ICNT("ICD")=$GET(ICNT("ICD"))+1
+266 SET @OUT@(NCNT,"ICD",ICNT("ICD"),"COD")=ICD
+267 SET @OUT@(NCNT,"ICD",ICNT("ICD"),"TYP")=ICDT
+268 ;Exclude ADT/RDT
IF DAT
QUIT
+269 SET @OUT@(NCNT,"ICD",ICNT("ICD"),"XADT")=ADT
+270 SET @OUT@(NCNT,"ICD",ICNT("ICD"),"XRDT")=RDT
End DoDot:4
End DoDot:3
+271 ;
+272 ;Add in defaults if needed
+273 IF $DATA(@OUT@(NCNT,"ICD"))<10
Begin DoDot:3
+274 IF CDSET
Begin DoDot:4
+275 SET @OUT@(NCNT,"ICD",1,"COD")="ZZZ.999"
+276 SET @OUT@(NCNT,"ICD",1,"TYP")="10D"
End DoDot:4
QUIT
+277 IF '$TEST
Begin DoDot:4
+278 SET @OUT@(NCNT,"ICD",1,"COD")=".9999"
+279 SET @OUT@(NCNT,"ICD",1,"TYP")="IC9"
End DoDot:4
End DoDot:3
End DoDot:2
+280 ;
+281 ;Set up FSN, Synonyms, Preferred
+282 SET SCNT=0
SET TIEN=""
FOR
SET TIEN=$ORDER(^BSTS(9002318.3,"C",XNMID,CIEN,TIEN),-1)
IF TIEN=""
QUIT
Begin DoDot:2
+283 NEW TRM,TYP,ADT,RDT,DSC
+284 ;
+285 SET TYP=$$GET1^DIQ(9002318.3,TIEN_",",.09,"I")
IF TYP=""
QUIT
+286 SET TRM=$$GET1^DIQ(9002318.3,TIEN_",",1)
IF TRM=""
QUIT
+287 SET DSC=$$GET1^DIQ(9002318.3,TIEN_",",.02,"I")
IF DSC=""
QUIT
+288 SET ADT=$$GET1^DIQ(9002318.3,TIEN_",",.06,"I")
+289 SET RDT=$$GET1^DIQ(9002318.3,TIEN_",",.07,"I")
+290 ;
+291 ;Handle multiple preferred terms - switch to synonym
+292 IF $DATA(@OUT@(NCNT,"PRE"))
IF TYP="P"
SET TYP="S"
+293 ;
+294 ;Synonyms
+295 IF RET["S"
IF TYP="S"
Begin DoDot:3
+296 SET SCNT=SCNT+1
SET @OUT@(NCNT,"SYN",SCNT,"TRM")=TRM
+297 SET @OUT@(NCNT,"SYN",SCNT,"DSC")=DSC
+298 ;Exclude ADT/RDT
IF DAT
QUIT
+299 SET @OUT@(NCNT,"SYN",SCNT,"XADT")=ADT
+300 SET @OUT@(NCNT,"SYN",SCNT,"XRDT")=RDT
End DoDot:3
+301 ;
+302 ;Fully specified name
+303 IF TYP="F"!((XNMID=1552)&(TYP="P"))
Begin DoDot:3
+304 SET @OUT@(NCNT,"FSN","TRM")=TRM
+305 SET @OUT@(NCNT,"FSN","DSC")=DSC
+306 ;Exclude ADT/RDt
IF DAT
QUIT
+307 SET @OUT@(NCNT,"FSN","XADT")=ADT
+308 SET @OUT@(NCNT,"FSN","XRDT")=RDT
End DoDot:3
+309 ;
+310 ;Preferred term
+311 IF RET["P"
IF TYP="P"
Begin DoDot:3
+312 SET @OUT@(NCNT,"PRE","TRM")=TRM
+313 SET @OUT@(NCNT,"PRE","DSC")=DSC
+314 ;Exclude ADT/RDT
IF DAT
QUIT
+315 SET @OUT@(NCNT,"PRE","XADT")=ADT
+316 SET @OUT@(NCNT,"PRE","XRDT")=RDT
+317 ;
+318 ;If STYPE="F" switch problem to preferred values
End DoDot:3
+319 IF TYP="P"
IF STYPE="F"
Begin DoDot:3
+320 SET @OUT@(NCNT,"PRB","TRM")=TRM
+321 SET @OUT@(NCNT,"PRB","DSC")=DSC
End DoDot:3
End DoDot:2
End DoDot:1
+322 ;
+323 QUIT NCNT
