BSTSAPIF.m

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:"")