BSTSAPIF ;GDIT/HS/BEE-Standard Terminology API Function Calls ; 5 Nov 2012 9:53 AM
;;2.0;IHS STANDARD TERMINOLOGY;**1**;Dec 01, 2016;Build 36
;
Q
;
VSBTRMF(IN) ;PEP - Returns whether a given term is in a particular subset
;
;Input
; OUT - Output variable/global to return information in (VAR)
; IN - P1 - Description Id of term to check
; - P2 - The subset to look in
; - P3 (Optional) - The code set Id (default SNOMED US EXT '36')
; - P4 (Optional) - LOCAL - Pass 1 to perform local listing, otherwise leave
; blank for remote listing
; - P5 (Optional) - DEBUG - Pass 1 to display debug information
;
;Output
;
; VAR = 1:Term is in the provided subset
; 0:Term is not in the provided subset
;
NEW FOUT,STS,%D
;
S STS=$$VALSBTRM^BSTSAPIB("FOUT",IN)
Q FOUT
;
ICD2SMD(OUT,IN) ;EP - Returns a list of SMOMED codes for the specified ICD9 code
;
;Input
; OUT - OUTPUT array of SNOMED concepts to return
; IN - The ICD9 Code to search on
;
I $G(IN)="" Q
;
NEW NMID,CIEN,RCNT,%D
;
;Get IEN for SNOMED
S NMID=$O(^BSTS(9002318.1,"B",36,"")) Q:NMID=""
;
;Loop through entries and find matches
S RCNT=0,CIEN="" F S CIEN=$O(^BSTS(9002318.4,"I",NMID,IN,CIEN)) Q:CIEN="" D
. ;
. NEW DTSID,CONC
. ;
. S DTSID=$$GET1^DIQ(9002318.4,CIEN_",",.08,"I") Q:DTSID=""
. ;
. S CONC=$$GET1^DIQ(9002318.4,CIEN_",",.02,"I") Q:CONC=""
. ;
. ;Set up return entry
. S RCNT=RCNT+1 S @OUT@(RCNT)=CONC_U_DTSID
Q 1
;
DILKP(OUT,IN) ;EP - Performs a drug ingredient lookup on a specified value
;
;Input
; IN - P1 - The exact term to lookup
; - P2 - Lookup Type (N-NDC,V-VUID)
; - P3 (Optional) - LOCAL - Pass 1 or blank to perform local listing
; Pass 2 for a remote DTS listing
; - P4 (Optional) - DEBUG - Pass 1 to display debug information
; - P5 (System Use Only) - TBYPASS - Pass 1 to bypass server timeout checks, otherwise
; leave blank. Do not use for regular calls
;
;Output
; Function returns - [1]^[2]^[3]
; [1] - 2:Remote information returned
; 1:Local information returned
; 0:No Information Returned
; [2] - Primary Remote Error Message
; [3] - Secondary Remote Error Message (if applicable)
;
; VAR(#) record is returned for any exact match
;
; VAR(1,"RXN","CON")=RxNorm Code
; VAR(1,"RXN","TRM")=RxNorm Term
; VAR(1,"RXN","TDC")=RxNorm Tradename code
; VAR(1,"RXN","TDT")=RxNorm Tradename term
; VAR(1,"RXN","TTY")=First TTY value for the RxNorm
;
NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BSTSAPIF D UNWIND^%ZTER" ; SAC 2009 2.2.3.17
;
N SEARCH,NMID,SNAPDT,MAX,LOCAL,NMIEN,RLIST,I,LTYPE,RXSTR,UNSTR,%D
N RESULT,DEBUG,BSTSR,BSTSI,BSTSWS,RES,BSTSD,X,%,%H,UPSRCH,CONC,CONCDT,TBYPASS
K @OUT
;
I $G(DT)="" D DT^DICRW
S IN=$G(IN,"")
S SEARCH=$P(IN,U) I $TR(SEARCH," ")="" Q "0^Invalid Search String"
S LTYPE=$P(IN,U,2) I LTYPE'="N",LTYPE'="V" Q "0^Invalid Lookup Type"
S SNAPDT=DT_".2400"
S SNAPDT=$$FMDT2XML^BSTSUTIL(SNAPDT)
S LOCAL=$P(IN,U,3),LOCAL=$S(LOCAL=2:"",1:"1")
S DEBUG=$P(IN,U,4),DEBUG=$S(DEBUG=1:"1",1:"")
S TBYPASS=$P(IN,U,5),TBYPASS=$S(TBYPASS=1:"1",1:"")
;
S BSTSWS("SEARCH")=SEARCH
S BSTSWS("SNAPDT")=SNAPDT
S BSTSWS("MAXRECS")=100
S BSTSWS("TBYPASS")=TBYPASS
;
S BSTSWS("NAMESPACEID")=1552
I LTYPE="N" S BSTSWS("PROPERTY")=110,BSTSWS("LTYPE")="N"
E S BSTSWS("PROPERTY")=209,BSTSWS("LTYPE")="V"
S NMID=1552
;
;Perform RxNorm DTS Lookup
;
;Make DTS Lookup call
S BSTSR=1,BSTSD=""
I LOCAL'=1 S BSTSR=$$DILKP^BSTSWSV1("RESULT",.BSTSWS,DEBUG) S:+BSTSR $P(BSTSR,U)=2
;
;If no results, try performing local search
I $D(RESULT)<10 S BSTSD=$$VNLKP^BSTSLKP("RESULT",.BSTSWS)
;
;If local search and no record try DTS Lookup
I $D(RESULT)<10,LOCAL S BSTSR=$$DILKP^BSTSWSV1("RESULT",.BSTSWS,DEBUG) S:+BSTSR $P(BSTSR,U)=2,BSTSD=""
;
;Define output for no results
S:$D(RESULT)<10 BSTSD=0
;
;Get the concept information
S CONC=$P($G(RESULT(1)),U)
S RXSTR=""
;
S:CONC]"" RXSTR=$$CNCLKP^BSTSAPI("CONCDT",CONC_"^"_BSTSWS("NAMESPACEID")_"^^1")
S @OUT@(1,"RXN","CON")=CONC
S @OUT@(1,"RXN","TRM")=$G(CONCDT(1,"FSN","TRM")) ;$P(RXSTR,U,2)
S @OUT@(1,"RXN","TDC")=$G(CONCDT(1,"IAR",1,"CON"))
S @OUT@(1,"RXN","TDT")=$G(CONCDT(1,"IAR",1,"TRM"))
S @OUT@(1,"RXN","TTY")=$G(CONCDT(1,"TTY",1,"TTY"))
;
S $P(BSTSR,U)=$S(BSTSD=0:0,(+BSTSR)>0:+BSTSR,1:1)
Q BSTSR
;
ASSOC(IN) ;EP - Returns the associations for each type (SMD, RxNorm, UNII)
;
;Input
; IN - P1 - The exact term to lookup
; - P2 (Optional) - The code set Id or Name (default SNOMED US EXT '36')
; ID NAME
; 32770 ECLIPS
; 5180 FDA UNII
; 32773 GMRA Allergies with Maps
; 32772 GMRA Signs Symptoms
; 32771 IHS VANDF
; 32774 IHS Med Route
; 1552 RxNorm R
; 36 SNOMED CT US Extension
; - P3 (Optional) - Snapshot Date to check (default DT)
; - P4 (Optional) - LOCAL - Pass 1 or blank to perform local listing
; Pass 2 for remote DTS listing
; - P5 (Optional) - DEBUG - Pass 1 to display debug information
;
;Output
;Function returns - [1]^[2]^[3]
; Where:
; [1] - SNOMED Association(s) - ";" Delimited
; [2] - RxNorm Association(s) - ";" Delimited
; [3] - UNII Association(s) - ";" Delimited
;
NEW RES,BSTSVAR,%D
;
S RES=$$VALTERM^BSTSAPI("BSTSVAR",$G(IN))
I +RES D Q RES
. ;
. NEW CNT,SMD,RXN,UNI,CON
. ;
. ;SNOMED
. S (SMD,CNT)="" F S CNT=$O(BSTSVAR(1,"ASM",CNT)) Q:CNT="" D
.. S CON=$G(BSTSVAR(1,"ASM",CNT,"CON")) Q:CON=""
.. S SMD=SMD_$S(SMD]"":";",1:"")_CON
. ;
. ;RxNorm
. S (RXN,CNT)="" F S CNT=$O(BSTSVAR(1,"ARX",CNT)) Q:CNT="" D
.. S CON=$G(BSTSVAR(1,"ARX",CNT,"CON")) Q:CON=""
.. S RXN=RXN_$S(RXN]"":";",1:"")_CON
. ;
. ;UNII
. S (UNI,CNT)="" F S CNT=$O(BSTSVAR(1,"AUN",CNT)) Q:CNT="" D
.. S CON=$G(BSTSVAR(1,"AUN",CNT,"CON")) Q:CON=""
.. S UNI=UNI_$S(UNI]"":";",1:"")_CON
.;
. S RES=SMD_U_RXN_U_UNI
;
Q ""
;
DI2RX(IN) ;EP - Performs a drug ingredient lookup on a specified value
; Returns only the first RxNorm mapping as a function call output
;
;Input
; IN - P1 - The exact term to lookup
; - P2 - Lookup Type (N-NDC,V-VUID)
; - P3 (Optional) - LOCAL - Pass 1 or blank to perform local listing,
; Pass 2 for remote DTS listing
; - P4 (Optional) - DEBUG - Pass 1 to display debug information
;
;Output
; Function returns - [1]^[2]
; [1] - The RxNorm Code of the first RxNorm mapping (if more than one)
; [2] - The RxNorm Term of the first RxNorm mapping
; [3] - The RxNorm Tradename code
; [4] - The RxNorm Tradename term
; [5] - The first TTY value for the RxNorm
;
;
NEW DOUT,STS,RES,%D
;
S STS=$$DILKP^BSTSAPI("DOUT",IN)
I 'STS Q ""
S $P(RES,U)=$G(DOUT(1,"RXN","CON"))
S $P(RES,U,2)=$G(DOUT(1,"RXN","TRM"))
S $P(RES,U,3)=$G(DOUT(1,"RXN","TDC"))
S $P(RES,U,4)=$G(DOUT(1,"RXN","TDT"))
S $P(RES,U,5)=$G(DOUT(1,"RXN","TTY"))
Q RES
;
USEARCH(OUT,IN) ;EP - Perform Codeset Universe Search
;
;Input
; OUT - Output variable/global to return information in (VAR)
; IN - P1 - Search string
; - P2 - Search Type - (F-Fully specified name, S-Synonyms)
; - P3 (Optional) - Namespace ID - Default to SNOMED US EXT (#36)
; ID NAME
; 5180 FDA UNII
; 32773 GMRA Allergies with Maps
; 32772 GMRA Signs Symptoms
; 32771 IHS VANDF
; 1552 RxNorm R
; 36 SNOMED CT US Extension
;
; - P4 (Optional) - Maximum number of concepts/terms to return (default 25)
; - P5 (Optional) - DEBUG - Pass 1 to display debug information
;
;Output
; Function returns - [1]^[2]^[3]
; [1] - 2:Remote information returned
; 1:Local information returned
; 0:No Information Returned
; [2] - Primary Remote Error Message
; [3] - Secondary Remote Error Message (if applicable)
;
; VAR(#) - List of Records
;
NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BSTSAPIF D UNWIND^%ZTER" ; SAC 2009 2.2.3.17
;
N SEARCH,STYPE,NMID,SUB,SNAPDT,MAX,BCTCHRC,BCTCHCT,LOCAL,SLIST,%D
N RESULT,DEBUG,BSTSR,BSTSI,RET,DAT,BSTSWS,BSTSD,X,%,%H,INDATE
K @OUT
;
I $G(U)="" S U="^"
I $G(DT)="" D DT^DICRW
S IN=$G(IN,"")
S SEARCH=$P(IN,U) Q:($TR(SEARCH," ")="") "0^Invalid Search String"
S STYPE=$P(IN,U,2) I STYPE'="F",STYPE'="S" Q "0^Invalid Search Type"
S NMID=$P(IN,U,3) S:NMID="" NMID=36 S:NMID=30 NMID=36
S SUB=$P(IN,U,6)
S SNAPDT="" S:SNAPDT]"" SNAPDT=$$DATE^BSTSUTIL(SNAPDT)
S INDATE=$P(SNAPDT,".")
S:SNAPDT="" SNAPDT=DT_".0001"
S SNAPDT=$$FMTE^BSTSUTIL(SNAPDT)
S MAX=$P(IN,U,5) S:'MAX MAX=25
S RET="PSBIXCA"
S DAT=""
S BCTCHRC=""
S BCTCHCT="" I BCTCHRC,'BCTCHCT S BCTCHCT=MAX
S LOCAL=""
S DEBUG=$P(IN,U,6),DEBUG=$S(DEBUG=1:"1",1:"")
;
S BSTSWS("SEARCH")=SEARCH
S BSTSWS("STYPE")=STYPE
S BSTSWS("NAMESPACEID")=NMID
S BSTSWS("SUBSET")=SUB
S BSTSWS("SNAPDT")=SNAPDT
S BSTSWS("INDATE")=INDATE
S BSTSWS("MAXRECS")=MAX
S BSTSWS("BCTCHRC")=BCTCHRC
S BSTSWS("BCTCHCT")=BCTCHCT
S BSTSWS("RET")=RET
S BSTSWS("DAT")=DAT
S BSTSWS("DEBUG")=DEBUG
;
S BSTSI=0
;
;Make DTS search call
S BSTSR=1
;
;DTS Call
S BSTSR=$$USEARCH^BSTSWSV1(OUT,.BSTSWS,DEBUG) S:+BSTSR $P(BSTSR,U)=2
;
;Now loop through and get the detail
I $D(RESULT) D
. ;
. NEW DLIST,ERSLT
. ;
. ;Define scratch global
. S DLIST=$NA(^TMP("BSTSCMCL",$J)) ;DTS Return List
. ;
. NEW RCNT
. ;
. S RCNT="" F S RCNT=$O(RESULT(RCNT)) Q:RCNT="" D
.. ;
.. NEW REC,CONCID,DTSID,DSCID,STATUS
.. S REC=RESULT(RCNT)
.. ;
.. S CONCID=$P(RESULT(RCNT),"^")
.. S DTSID=$P(RESULT(RCNT),"^",2)
.. S DSCID=$P(RESULT(RCNT),"^",3)
.. ;
.. ;Not Found or in need of update
.. S BSTSWS("DTSID")=DTSID
.. ;
.. ;Clear result file
.. K @DLIST
.. ;
.. ;Get Detail for concept
.. S STATUS=$$DETAIL^BSTSCMCL(.BSTSWS,.ERSLT)
.. ;
.. ;Assemble output for RPC
.. S @SLIST@(RCNT)=$P($G(@DLIST@(1,"CONCEPTID")),U)
;
Q BSTSR
;
;BSTS*1.0*7;Added EQUIV API Call
EQUIV(OUT,IN) ;PEP - Returns equivalent laterality concepts
;
;Input
; OUT - Output variable/global to return information in (VAR)
; IN - P1 - Concept Id
; - P2 - Laterality Attribute|Qualifier
; 7771000 or 272741003|7771000 - Laterality|Left
; 24028007 or 272741003|24028007 - Laterality|Right
; 51440002 or 272741003|51440002 - Laterality|Bilateral
;
;Output
; OUT(#) = Matching Concept ID [1] ^ Matching Laterality Attribute|Qualifier [2] ^ Exact Match (1/0) [3]
; ^ entry is lateralized or is an equivalent lateralized concept (1/0)
;BSTS*2.0*1;Now returning all lateralized concepts for an unlateralized input concept
NEW CONC,LAT,NCNT,BSTSVAR,STS,ENTLOG,AT,ECNC,ATLAT,MLAT,LTLST,LT,LTLAT
;
I $G(IN)="" Q
I $G(OUT)="" Q
;
K @OUT
;
;Retrieve concept id
S CONC=$P(IN,U) Q:CONC=""
S ATLAT=$P(IN,U,2) I ATLAT]"",$L(ATLAT,"|")=1 S ATLAT="272741003"_"|"_ATLAT
S LAT=$P(ATLAT,"|",2)
S AT=$P(ATLAT,"|")
;
;Get the concept detail
S STS=$$CNCLKP^BSTSAPI("BSTSVAR",CONC)
;
;Set up the passed in entry, and if laterality non-lateralized entry
S NCNT=$G(NCNT)+1,@OUT@(NCNT)=CONC_U_ATLAT_U_1_U_$S(ATLAT]"":1,$G(BSTSVAR(1,"EQM","LAT"))]"":1,1:"0") S:ATLAT]"" LTLAT(CONC,ATLAT)=""
I ATLAT="" S ENTLOG(CONC)=""
E S ENTLOG(CONC,ATLAT)=""
I ATLAT]"" D
. S NCNT=$G(NCNT)+1,@OUT@(NCNT)=CONC_U_U_0_U
. S ENTLOG(CONC)=""
;
;Now look for a matching equivalant concept
S ECNC=$G(BSTSVAR(1,"EQM","CON")) I ECNC]"" D
. NEW ELAT
. S ELAT=$G(BSTSVAR(1,"EQM","LAT")) S:ELAT]"" ELAT="272741003|"_$O(^BSTS(9002318.6,"D","LAT",ELAT,""))
. S NCNT=$G(NCNT)+1,@OUT@(NCNT)=ECNC_U_ELAT_U_1_U S:ELAT]"" LTLST(ECNC,ELAT)=""
. I ELAT="" S ENTLOG(ECNC)="" Q
. ;
. ;Log entry
. S ENTLOG(ECNC,ELAT)=""
. ;
. ;If laterality, catch the parent concept as well as non-exact match
. S NCNT=$G(NCNT)+1,@OUT@(NCNT)=ECNC_U_U_0_U
. Q
;
;Now look for a concept with matching laterality
S MLAT="" F S MLAT=$O(BSTSVAR(1,"EQC",MLAT)) Q:MLAT="" D
. NEW ILAT,CON
. ;
. ;Get SNOMED for the laterality
. S ILAT=$O(^BSTS(9002318.6,"D","LAT",MLAT,"")) Q:ILAT=""
. ;
. ;Get the concept
. S CON=$G(BSTSVAR(1,"EQC",MLAT,"CON"))
. ;
. ;Look for match - if not a match return as non-exact match
. I LAT'=ILAT D Q
.. I LAT="" D
... S NCNT=$G(NCNT)+1,@OUT@(NCNT)=CON_U_U_0_U
... I $G(BSTSVAR(1,"LAT")),'$D(ENTLOG(CONC,ILAT)) S NCNT=$G(NCNT)+1,@OUT@(NCNT)=CONC_U_"272741003|"_ILAT_U_0 S:ILAT]"" LTLST(CONC,"272741003|"_ILAT)=""
. ;
. ;Set entry
. S NCNT=$G(NCNT)+1,@OUT@(NCNT)=CON_U_U_1_U
;
;BSTS*2.0*1;Add remaining lateralized concepts
I ATLAT="",$G(BSTSVAR(1,"LAT")) F LT="272741003|7771000","272741003|24028007","272741003|51440002" I '$D(LTLST(CONC,LT)) D
. S NCNT=$G(NCNT)+1,@OUT@(NCNT)=CONC_U_LT_U_0_U
;
Q
;
ERR ;
D ^%ZTER
Q
BSTSAPIF ;GDIT/HS/BEE-Standard Terminology API Function Calls ; 5 Nov 2012 9:53 AM
+1 ;;2.0;IHS STANDARD TERMINOLOGY;**1**;Dec 01, 2016;Build 36
+2 ;
+3 QUIT
+4 ;
VSBTRMF(IN) ;PEP - Returns whether a given term is in a particular subset
+1 ;
+2 ;Input
+3 ; OUT - Output variable/global to return information in (VAR)
+4 ; IN - P1 - Description Id of term to check
+5 ; - P2 - The subset to look in
+6 ; - P3 (Optional) - The code set Id (default SNOMED US EXT '36')
+7 ; - P4 (Optional) - LOCAL - Pass 1 to perform local listing, otherwise leave
+8 ; blank for remote listing
+9 ; - P5 (Optional) - DEBUG - Pass 1 to display debug information
+10 ;
+11 ;Output
+12 ;
+13 ; VAR = 1:Term is in the provided subset
+14 ; 0:Term is not in the provided subset
+15 ;
+16 NEW FOUT,STS,%D
+17 ;
+18 SET STS=$$VALSBTRM^BSTSAPIB("FOUT",IN)
+19 QUIT FOUT
+20 ;
ICD2SMD(OUT,IN) ;EP - Returns a list of SMOMED codes for the specified ICD9 code
+1 ;
+2 ;Input
+3 ; OUT - OUTPUT array of SNOMED concepts to return
+4 ; IN - The ICD9 Code to search on
+5 ;
+6 IF $GET(IN)=""
QUIT
+7 ;
+8 NEW NMID,CIEN,RCNT,%D
+9 ;
+10 ;Get IEN for SNOMED
+11 SET NMID=$ORDER(^BSTS(9002318.1,"B",36,""))
IF NMID=""
QUIT
+12 ;
+13 ;Loop through entries and find matches
+14 SET RCNT=0
SET CIEN=""
FOR
SET CIEN=$ORDER(^BSTS(9002318.4,"I",NMID,IN,CIEN))
IF CIEN=""
QUIT
Begin DoDot:1
+15 ;
+16 NEW DTSID,CONC
+17 ;
+18 SET DTSID=$$GET1^DIQ(9002318.4,CIEN_",",.08,"I")
IF DTSID=""
QUIT
+19 ;
+20 SET CONC=$$GET1^DIQ(9002318.4,CIEN_",",.02,"I")
IF CONC=""
QUIT
+21 ;
+22 ;Set up return entry
+23 SET RCNT=RCNT+1
SET @OUT@(RCNT)=CONC_U_DTSID
End DoDot:1
+24 QUIT 1
+25 ;
DILKP(OUT,IN) ;EP - Performs a drug ingredient lookup on a specified value
+1 ;
+2 ;Input
+3 ; IN - P1 - The exact term to lookup
+4 ; - P2 - Lookup Type (N-NDC,V-VUID)
+5 ; - P3 (Optional) - LOCAL - Pass 1 or blank to perform local listing
+6 ; Pass 2 for a remote DTS listing
+7 ; - P4 (Optional) - DEBUG - Pass 1 to display debug information
+8 ; - P5 (System Use Only) - TBYPASS - Pass 1 to bypass server timeout checks, otherwise
+9 ; leave blank. Do not use for regular calls
+10 ;
+11 ;Output
+12 ; Function returns - [1]^[2]^[3]
+13 ; [1] - 2:Remote information returned
+14 ; 1:Local information returned
+15 ; 0:No Information Returned
+16 ; [2] - Primary Remote Error Message
+17 ; [3] - Secondary Remote Error Message (if applicable)
+18 ;
+19 ; VAR(#) record is returned for any exact match
+20 ;
+21 ; VAR(1,"RXN","CON")=RxNorm Code
+22 ; VAR(1,"RXN","TRM")=RxNorm Term
+23 ; VAR(1,"RXN","TDC")=RxNorm Tradename code
+24 ; VAR(1,"RXN","TDT")=RxNorm Tradename term
+25 ; VAR(1,"RXN","TTY")=First TTY value for the RxNorm
+26 ;
+27 ; SAC 2009 2.2.3.17
NEW $ESTACK,$ETRAP
SET $ETRAP="D ERR^BSTSAPIF D UNWIND^%ZTER"
+28 ;
+29 NEW SEARCH,NMID,SNAPDT,MAX,LOCAL,NMIEN,RLIST,I,LTYPE,RXSTR,UNSTR,%D
+30 NEW RESULT,DEBUG,BSTSR,BSTSI,BSTSWS,RES,BSTSD,X,%,%H,UPSRCH,CONC,CONCDT,TBYPASS
+31 KILL @OUT
+32 ;
+33 IF $GET(DT)=""
DO DT^DICRW
+34 SET IN=$GET(IN,"")
+35 SET SEARCH=$PIECE(IN,U)
IF $TRANSLATE(SEARCH," ")=""
QUIT "0^Invalid Search String"
+36 SET LTYPE=$PIECE(IN,U,2)
IF LTYPE'="N"
IF LTYPE'="V"
QUIT "0^Invalid Lookup Type"
+37 SET SNAPDT=DT_".2400"
+38 SET SNAPDT=$$FMDT2XML^BSTSUTIL(SNAPDT)
+39 SET LOCAL=$PIECE(IN,U,3)
SET LOCAL=$SELECT(LOCAL=2:"",1:"1")
+40 SET DEBUG=$PIECE(IN,U,4)
SET DEBUG=$SELECT(DEBUG=1:"1",1:"")
+41 SET TBYPASS=$PIECE(IN,U,5)
SET TBYPASS=$SELECT(TBYPASS=1:"1",1:"")
+42 ;
+43 SET BSTSWS("SEARCH")=SEARCH
+44 SET BSTSWS("SNAPDT")=SNAPDT
+45 SET BSTSWS("MAXRECS")=100
+46 SET BSTSWS("TBYPASS")=TBYPASS
+47 ;
+48 SET BSTSWS("NAMESPACEID")=1552
+49 IF LTYPE="N"
SET BSTSWS("PROPERTY")=110
SET BSTSWS("LTYPE")="N"
+50 IF '$TEST
SET BSTSWS("PROPERTY")=209
SET BSTSWS("LTYPE")="V"
+51 SET NMID=1552
+52 ;
+53 ;Perform RxNorm DTS Lookup
+54 ;
+55 ;Make DTS Lookup call
+56 SET BSTSR=1
SET BSTSD=""
+57 IF LOCAL'=1
SET BSTSR=$$DILKP^BSTSWSV1("RESULT",.BSTSWS,DEBUG)
IF +BSTSR
SET $PIECE(BSTSR,U)=2
+58 ;
+59 ;If no results, try performing local search
+60 IF $DATA(RESULT)<10
SET BSTSD=$$VNLKP^BSTSLKP("RESULT",.BSTSWS)
+61 ;
+62 ;If local search and no record try DTS Lookup
+63 IF $DATA(RESULT)<10
IF LOCAL
SET BSTSR=$$DILKP^BSTSWSV1("RESULT",.BSTSWS,DEBUG)
IF +BSTSR
SET $PIECE(BSTSR,U)=2
SET BSTSD=""
+64 ;
+65 ;Define output for no results
+66 IF $DATA(RESULT)<10
SET BSTSD=0
+67 ;
+68 ;Get the concept information
+69 SET CONC=$PIECE($GET(RESULT(1)),U)
+70 SET RXSTR=""
+71 ;
+72 IF CONC]""
SET RXSTR=$$CNCLKP^BSTSAPI("CONCDT",CONC_"^"_BSTSWS("NAMESPACEID")_"^^1")
+73 SET @OUT@(1,"RXN","CON")=CONC
+74 ;$P(RXSTR,U,2)
SET @OUT@(1,"RXN","TRM")=$GET(CONCDT(1,"FSN","TRM"))
+75 SET @OUT@(1,"RXN","TDC")=$GET(CONCDT(1,"IAR",1,"CON"))
+76 SET @OUT@(1,"RXN","TDT")=$GET(CONCDT(1,"IAR",1,"TRM"))
+77 SET @OUT@(1,"RXN","TTY")=$GET(CONCDT(1,"TTY",1,"TTY"))
+78 ;
+79 SET $PIECE(BSTSR,U)=$SELECT(BSTSD=0:0,(+BSTSR)>0:+BSTSR,1:1)
+80 QUIT BSTSR
+81 ;
ASSOC(IN) ;EP - Returns the associations for each type (SMD, RxNorm, UNII)
+1 ;
+2 ;Input
+3 ; IN - P1 - The exact term to lookup
+4 ; - P2 (Optional) - The code set Id or Name (default SNOMED US EXT '36')
+5 ; ID NAME
+6 ; 32770 ECLIPS
+7 ; 5180 FDA UNII
+8 ; 32773 GMRA Allergies with Maps
+9 ; 32772 GMRA Signs Symptoms
+10 ; 32771 IHS VANDF
+11 ; 32774 IHS Med Route
+12 ; 1552 RxNorm R
+13 ; 36 SNOMED CT US Extension
+14 ; - P3 (Optional) - Snapshot Date to check (default DT)
+15 ; - P4 (Optional) - LOCAL - Pass 1 or blank to perform local listing
+16 ; Pass 2 for remote DTS listing
+17 ; - P5 (Optional) - DEBUG - Pass 1 to display debug information
+18 ;
+19 ;Output
+20 ;Function returns - [1]^[2]^[3]
+21 ; Where:
+22 ; [1] - SNOMED Association(s) - ";" Delimited
+23 ; [2] - RxNorm Association(s) - ";" Delimited
+24 ; [3] - UNII Association(s) - ";" Delimited
+25 ;
+26 NEW RES,BSTSVAR,%D
+27 ;
+28 SET RES=$$VALTERM^BSTSAPI("BSTSVAR",$GET(IN))
+29 IF +RES
Begin DoDot:1
+30 ;
+31 NEW CNT,SMD,RXN,UNI,CON
+32 ;
+33 ;SNOMED
+34 SET (SMD,CNT)=""
FOR
SET CNT=$ORDER(BSTSVAR(1,"ASM",CNT))
IF CNT=""
QUIT
Begin DoDot:2
+35 SET CON=$GET(BSTSVAR(1,"ASM",CNT,"CON"))
IF CON=""
QUIT
+36 SET SMD=SMD_$SELECT(SMD]"":";",1:"")_CON
End DoDot:2
+37 ;
+38 ;RxNorm
+39 SET (RXN,CNT)=""
FOR
SET CNT=$ORDER(BSTSVAR(1,"ARX",CNT))
IF CNT=""
QUIT
Begin DoDot:2
+40 SET CON=$GET(BSTSVAR(1,"ARX",CNT,"CON"))
IF CON=""
QUIT
+41 SET RXN=RXN_$SELECT(RXN]"":";",1:"")_CON
End DoDot:2
+42 ;
+43 ;UNII
+44 SET (UNI,CNT)=""
FOR
SET CNT=$ORDER(BSTSVAR(1,"AUN",CNT))
IF CNT=""
QUIT
Begin DoDot:2
+45 SET CON=$GET(BSTSVAR(1,"AUN",CNT,"CON"))
IF CON=""
QUIT
+46 SET UNI=UNI_$SELECT(UNI]"":";",1:"")_CON
End DoDot:2
+47 ;
+48 SET RES=SMD_U_RXN_U_UNI
End DoDot:1
QUIT RES
+49 ;
+50 QUIT ""
+51 ;
DI2RX(IN) ;EP - Performs a drug ingredient lookup on a specified value
+1 ; Returns only the first RxNorm mapping as a function call output
+2 ;
+3 ;Input
+4 ; IN - P1 - The exact term to lookup
+5 ; - P2 - Lookup Type (N-NDC,V-VUID)
+6 ; - P3 (Optional) - LOCAL - Pass 1 or blank to perform local listing,
+7 ; Pass 2 for remote DTS listing
+8 ; - P4 (Optional) - DEBUG - Pass 1 to display debug information
+9 ;
+10 ;Output
+11 ; Function returns - [1]^[2]
+12 ; [1] - The RxNorm Code of the first RxNorm mapping (if more than one)
+13 ; [2] - The RxNorm Term of the first RxNorm mapping
+14 ; [3] - The RxNorm Tradename code
+15 ; [4] - The RxNorm Tradename term
+16 ; [5] - The first TTY value for the RxNorm
+17 ;
+18 ;
+19 NEW DOUT,STS,RES,%D
+20 ;
+21 SET STS=$$DILKP^BSTSAPI("DOUT",IN)
+22 IF 'STS
QUIT ""
+23 SET $PIECE(RES,U)=$GET(DOUT(1,"RXN","CON"))
+24 SET $PIECE(RES,U,2)=$GET(DOUT(1,"RXN","TRM"))
+25 SET $PIECE(RES,U,3)=$GET(DOUT(1,"RXN","TDC"))
+26 SET $PIECE(RES,U,4)=$GET(DOUT(1,"RXN","TDT"))
+27 SET $PIECE(RES,U,5)=$GET(DOUT(1,"RXN","TTY"))
+28 QUIT RES
+29 ;
USEARCH(OUT,IN) ;EP - Perform Codeset Universe Search
+1 ;
+2 ;Input
+3 ; OUT - Output variable/global to return information in (VAR)
+4 ; IN - P1 - Search string
+5 ; - P2 - Search Type - (F-Fully specified name, S-Synonyms)
+6 ; - P3 (Optional) - Namespace ID - Default to SNOMED US EXT (#36)
+7 ; ID NAME
+8 ; 5180 FDA UNII
+9 ; 32773 GMRA Allergies with Maps
+10 ; 32772 GMRA Signs Symptoms
+11 ; 32771 IHS VANDF
+12 ; 1552 RxNorm R
+13 ; 36 SNOMED CT US Extension
+14 ;
+15 ; - P4 (Optional) - Maximum number of concepts/terms to return (default 25)
+16 ; - P5 (Optional) - DEBUG - Pass 1 to display debug information
+17 ;
+18 ;Output
+19 ; Function returns - [1]^[2]^[3]
+20 ; [1] - 2:Remote information returned
+21 ; 1:Local information returned
+22 ; 0:No Information Returned
+23 ; [2] - Primary Remote Error Message
+24 ; [3] - Secondary Remote Error Message (if applicable)
+25 ;
+26 ; VAR(#) - List of Records
+27 ;
+28 ; SAC 2009 2.2.3.17
NEW $ESTACK,$ETRAP
SET $ETRAP="D ERR^BSTSAPIF D UNWIND^%ZTER"
+29 ;
+30 NEW SEARCH,STYPE,NMID,SUB,SNAPDT,MAX,BCTCHRC,BCTCHCT,LOCAL,SLIST,%D
+31 NEW RESULT,DEBUG,BSTSR,BSTSI,RET,DAT,BSTSWS,BSTSD,X,%,%H,INDATE
+32 KILL @OUT
+33 ;
+34 IF $GET(U)=""
SET U="^"
+35 IF $GET(DT)=""
DO DT^DICRW
+36 SET IN=$GET(IN,"")
+37 SET SEARCH=$PIECE(IN,U)
IF ($TRANSLATE(SEARCH," ")="")
QUIT "0^Invalid Search String"
+38 SET STYPE=$PIECE(IN,U,2)
IF STYPE'="F"
IF STYPE'="S"
QUIT "0^Invalid Search Type"
+39 SET NMID=$PIECE(IN,U,3)
IF NMID=""
SET NMID=36
IF NMID=30
SET NMID=36
+40 SET SUB=$PIECE(IN,U,6)
+41 SET SNAPDT=""
IF SNAPDT]""
SET SNAPDT=$$DATE^BSTSUTIL(SNAPDT)
+42 SET INDATE=$PIECE(SNAPDT,".")
+43 IF SNAPDT=""
SET SNAPDT=DT_".0001"
+44 SET SNAPDT=$$FMTE^BSTSUTIL(SNAPDT)
+45 SET MAX=$PIECE(IN,U,5)
IF 'MAX
SET MAX=25
+46 SET RET="PSBIXCA"
+47 SET DAT=""
+48 SET BCTCHRC=""
+49 SET BCTCHCT=""
IF BCTCHRC
IF 'BCTCHCT
SET BCTCHCT=MAX
+50 SET LOCAL=""
+51 SET DEBUG=$PIECE(IN,U,6)
SET DEBUG=$SELECT(DEBUG=1:"1",1:"")
+52 ;
+53 SET BSTSWS("SEARCH")=SEARCH
+54 SET BSTSWS("STYPE")=STYPE
+55 SET BSTSWS("NAMESPACEID")=NMID
+56 SET BSTSWS("SUBSET")=SUB
+57 SET BSTSWS("SNAPDT")=SNAPDT
+58 SET BSTSWS("INDATE")=INDATE
+59 SET BSTSWS("MAXRECS")=MAX
+60 SET BSTSWS("BCTCHRC")=BCTCHRC
+61 SET BSTSWS("BCTCHCT")=BCTCHCT
+62 SET BSTSWS("RET")=RET
+63 SET BSTSWS("DAT")=DAT
+64 SET BSTSWS("DEBUG")=DEBUG
+65 ;
+66 SET BSTSI=0
+67 ;
+68 ;Make DTS search call
+69 SET BSTSR=1
+70 ;
+71 ;DTS Call
+72 SET BSTSR=$$USEARCH^BSTSWSV1(OUT,.BSTSWS,DEBUG)
IF +BSTSR
SET $PIECE(BSTSR,U)=2
+73 ;
+74 ;Now loop through and get the detail
+75 IF $DATA(RESULT)
Begin DoDot:1
+76 ;
+77 NEW DLIST,ERSLT
+78 ;
+79 ;Define scratch global
+80 ;DTS Return List
SET DLIST=$NAME(^TMP("BSTSCMCL",$JOB))
+81 ;
+82 NEW RCNT
+83 ;
+84 SET RCNT=""
FOR
SET RCNT=$ORDER(RESULT(RCNT))
IF RCNT=""
QUIT
Begin DoDot:2
+85 ;
+86 NEW REC,CONCID,DTSID,DSCID,STATUS
+87 SET REC=RESULT(RCNT)
+88 ;
+89 SET CONCID=$PIECE(RESULT(RCNT),"^")
+90 SET DTSID=$PIECE(RESULT(RCNT),"^",2)
+91 SET DSCID=$PIECE(RESULT(RCNT),"^",3)
+92 ;
+93 ;Not Found or in need of update
+94 SET BSTSWS("DTSID")=DTSID
+95 ;
+96 ;Clear result file
+97 KILL @DLIST
+98 ;
+99 ;Get Detail for concept
+100 SET STATUS=$$DETAIL^BSTSCMCL(.BSTSWS,.ERSLT)
+101 ;
+102 ;Assemble output for RPC
+103 SET @SLIST@(RCNT)=$PIECE($GET(@DLIST@(1,"CONCEPTID")),U)
End DoDot:2
End DoDot:1
+104 ;
+105 QUIT BSTSR
+106 ;
+107 ;BSTS*1.0*7;Added EQUIV API Call
EQUIV(OUT,IN) ;PEP - Returns equivalent laterality concepts
+1 ;
+2 ;Input
+3 ; OUT - Output variable/global to return information in (VAR)
+4 ; IN - P1 - Concept Id
+5 ; - P2 - Laterality Attribute|Qualifier
+6 ; 7771000 or 272741003|7771000 - Laterality|Left
+7 ; 24028007 or 272741003|24028007 - Laterality|Right
+8 ; 51440002 or 272741003|51440002 - Laterality|Bilateral
+9 ;
+10 ;Output
+11 ; OUT(#) = Matching Concept ID [1] ^ Matching Laterality Attribute|Qualifier [2] ^ Exact Match (1/0) [3]
+12 ; ^ entry is lateralized or is an equivalent lateralized concept (1/0)
+13 ;BSTS*2.0*1;Now returning all lateralized concepts for an unlateralized input concept
+14 NEW CONC,LAT,NCNT,BSTSVAR,STS,ENTLOG,AT,ECNC,ATLAT,MLAT,LTLST,LT,LTLAT
+15 ;
+16 IF $GET(IN)=""
QUIT
+17 IF $GET(OUT)=""
QUIT
+18 ;
+19 KILL @OUT
+20 ;
+21 ;Retrieve concept id
+22 SET CONC=$PIECE(IN,U)
IF CONC=""
QUIT
+23 SET ATLAT=$PIECE(IN,U,2)
IF ATLAT]""
IF $LENGTH(ATLAT,"|")=1
SET ATLAT="272741003"_"|"_ATLAT
+24 SET LAT=$PIECE(ATLAT,"|",2)
+25 SET AT=$PIECE(ATLAT,"|")
+26 ;
+27 ;Get the concept detail
+28 SET STS=$$CNCLKP^BSTSAPI("BSTSVAR",CONC)
+29 ;
+30 ;Set up the passed in entry, and if laterality non-lateralized entry
+31 SET NCNT=$GET(NCNT)+1
SET @OUT@(NCNT)=CONC_U_ATLAT_U_1_U_$SELECT(ATLAT]"":1,$GET(BSTSVAR(1,"EQM","LAT"))]"":1,1:"0")
IF ATLAT]""
SET LTLAT(CONC,ATLAT)=""
+32 IF ATLAT=""
SET ENTLOG(CONC)=""
+33 IF '$TEST
SET ENTLOG(CONC,ATLAT)=""
+34 IF ATLAT]""
Begin DoDot:1
+35 SET NCNT=$GET(NCNT)+1
SET @OUT@(NCNT)=CONC_U_U_0_U
+36 SET ENTLOG(CONC)=""
End DoDot:1
+37 ;
+38 ;Now look for a matching equivalant concept
+39 SET ECNC=$GET(BSTSVAR(1,"EQM","CON"))
IF ECNC]""
Begin DoDot:1
+40 NEW ELAT
+41 SET ELAT=$GET(BSTSVAR(1,"EQM","LAT"))
IF ELAT]""
SET ELAT="272741003|"_$ORDER(^BSTS(9002318.6,"D","LAT",ELAT,""))
+42 SET NCNT=$GET(NCNT)+1
SET @OUT@(NCNT)=ECNC_U_ELAT_U_1_U
IF ELAT]""
SET LTLST(ECNC,ELAT)=""
+43 IF ELAT=""
SET ENTLOG(ECNC)=""
QUIT
+44 ;
+45 ;Log entry
+46 SET ENTLOG(ECNC,ELAT)=""
+47 ;
+48 ;If laterality, catch the parent concept as well as non-exact match
+49 SET NCNT=$GET(NCNT)+1
SET @OUT@(NCNT)=ECNC_U_U_0_U
+50 QUIT
End DoDot:1
+51 ;
+52 ;Now look for a concept with matching laterality
+53 SET MLAT=""
FOR
SET MLAT=$ORDER(BSTSVAR(1,"EQC",MLAT))
IF MLAT=""
QUIT
Begin DoDot:1
+54 NEW ILAT,CON
+55 ;
+56 ;Get SNOMED for the laterality
+57 SET ILAT=$ORDER(^BSTS(9002318.6,"D","LAT",MLAT,""))
IF ILAT=""
QUIT
+58 ;
+59 ;Get the concept
+60 SET CON=$GET(BSTSVAR(1,"EQC",MLAT,"CON"))
+61 ;
+62 ;Look for match - if not a match return as non-exact match
+63 IF LAT'=ILAT
Begin DoDot:2
+64 IF LAT=""
Begin DoDot:3
+65 SET NCNT=$GET(NCNT)+1
SET @OUT@(NCNT)=CON_U_U_0_U
+66 IF $GET(BSTSVAR(1,"LAT"))
IF '$DATA(ENTLOG(CONC,ILAT))
SET NCNT=$GET(NCNT)+1
SET @OUT@(NCNT)=CONC_U_"272741003|"_ILAT_U_0
IF ILAT]""
SET LTLST(CONC,"272741003|"_ILAT)=""
End DoDot:3
End DoDot:2
QUIT
+67 ;
+68 ;Set entry
+69 SET NCNT=$GET(NCNT)+1
SET @OUT@(NCNT)=CON_U_U_1_U
End DoDot:1
+70 ;
+71 ;BSTS*2.0*1;Add remaining lateralized concepts
+72 IF ATLAT=""
IF $GET(BSTSVAR(1,"LAT"))
FOR LT="272741003|7771000","272741003|24028007","272741003|51440002"
IF '$DATA(LTLST(CONC,LT))
Begin DoDot:1
+73 SET NCNT=$GET(NCNT)+1
SET @OUT@(NCNT)=CONC_U_LT_U_0_U
End DoDot:1
+74 ;
+75 QUIT
+76 ;
ERR ;
+1 DO ^%ZTER
+2 QUIT
