BSTSAPIB ;GDIT/HS/BEE-Standard Terminology API Program ; 5 Nov 2012 9:53 AM
;;2.0;IHS STANDARD TERMINOLOGY;;Dec 01, 2016;Build 62
;
Q
;
VALTERM(OUT,IN) ;PEP - Returns whether a given term is a valid
;
;Input
; OUT - Output variable/global to return information in (VAR)
; 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
; - P6 (Optional) - Mapping Parameters - Ex. EPI=288527008;VST=2087394;AF=With;PRB=50239
;
;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(s) returned for any exact match
; Please see routine BSTSCDET, tag DETAIL for a detailed description of the
; information being returned by this API.
;
NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BSTSAPIB D UNWIND^%ZTER" ; SAC 2009 2.2.3.17
;
N SEARCH,NMID,SNAPDT,MAX,LOCAL,NMIEN,RLIST,I,NSEARCH,C,%D
N RESULT,DEBUG,BSTSR,BSTSI,BSTSWS,RES,BSTSD,X,%,%H,UPSRCH,INDATE
K @OUT,STS
;
I $G(DT)="" D DT^DICRW
S IN=$G(IN,"")
S SEARCH=$P(IN,U) I $TR(SEARCH," ")="" Q "0^Invalid Search String"
S UPSRCH=$$UP^XLFSTR(SEARCH)
S NMID=$P(IN,U,2) S:NMID="" NMID=36 S:NMID=30 NMID=36
;
;Convert namespace to number if needed
I NMID'?1N.N D I NMID="" Q "0^Invalid Namespace"
. S NMID=$O(^BSTS(9002318.1,"D",NMID,"")) Q:NMID=""
. S NMID=$$GET1^DIQ(9002318.1,NMID_",",".01","I")
;
S SNAPDT=$P(IN,U,3) S:SNAPDT]"" SNAPDT=$$DATE^BSTSUTIL(SNAPDT)
S:SNAPDT="" SNAPDT=DT_".0001"
S INDATE=$P(SNAPDT,".")
S SNAPDT=$$FMTE^BSTSUTIL(SNAPDT)
S MAX=50
S LOCAL=$P(IN,U,4),LOCAL=$S(LOCAL=2:"",1:"1")
S DEBUG=$P(IN,U,5),DEBUG=$S(DEBUG=1:"1",1:"")
;
;Handle strings with "'"
S NSEARCH="" F I=1:1:$L(SEARCH) S C=$E(SEARCH,I),NSEARCH=NSEARCH_$S(C="'":"'",1:"")_C
S BSTSWS("SEARCH")=NSEARCH
S BSTSWS("STYPE")="S"
S BSTSWS("NAMESPACEID")=NMID
S BSTSWS("SUBSET")=""
S BSTSWS("SNAPDT")=SNAPDT
S BSTSWS("INDATE")=INDATE
S BSTSWS("MAXRECS")=MAX
S BSTSWS("BCTCHRC")=""
S BSTSWS("BCTCHCT")=""
S BSTSWS("RET")="PSCBIXAV"
S BSTSWS("DAT")=""
S BSTSWS("EXACTMATCH")="T"
S BSTSWS("MPPRM")=$P(IN,U,7) ;BSTS*1.0*6;Mapping parameters
;
;Check for new version
D CHECK^BSTSVRSN
;
;Make DTS Lookup call
S BSTSR=1
I LOCAL'=1 S BSTSR=$$SEARCH^BSTSWSV("RESULT",.BSTSWS,DEBUG) S:+BSTSR $P(BSTSR,U)=2
;
;If no results, try performing local search
I $D(RESULT)<10 S BSTSD=$$SRC^BSTSSRCH("RESULT",.BSTSWS)
;
;If local search and no record try DTS Lookup
I $D(RESULT)<10,LOCAL S BSTSR=$$SEARCH^BSTSWSV("RESULT",.BSTSWS,DEBUG) S:+BSTSR $P(BSTSR,U)=2
;
;Now loop through and find exact term - Combine like terms
;
S NMIEN=$O(^BSTS(9002318.1,"B",NMID,""))
S RES="" F S RES=$O(RESULT(RES)) Q:RES="" D
. N REC,DIEN,TIEN,TERM,MATCH
. S MATCH=0
. S REC=RESULT(RES)
. S DIEN=$P(REC,U,3) Q:DIEN=""
. S TIEN=$O(^BSTS(9002318.3,"D",NMIEN,DIEN,"")) Q:TIEN=""
. S TERM=$$GET1^DIQ(9002318.3,TIEN_",",1,"E") Q:TERM=""
. ;
. ;Perform regular match
. I UPSRCH=($$UP^XLFSTR(TERM)) S MATCH=1
. ;
. ;Perform special concept search for UNII
. I MATCH=0,NMID=5180 D
.. N FSN,CIEN,DSC,CON
.. S CIEN=$$GET1^DIQ(9002318.3,TIEN_",",.03,"I") Q:CIEN=""
.. S FSN=$$GET1^DIQ(9002318.4,CIEN_",",1,"I") Q:FSN=""
.. I UPSRCH'=($$UP^XLFSTR(FSN)) Q
.. S CON=$$GET1^DIQ(9002318.4,CIEN_",",.02,"I") Q:CON=""
.. S DSC=$P($$CONC^BSTSAPI(CON_"^5180"),"^") Q:DSC=""
.. S $P(RESULT(RES),U,3)=DSC
.. S MATCH=1
. ;
. I MATCH=0 K RESULT(RES) Q
. ;
. Q:$D(RLIST($P(RESULT(RES),U,1,2)))
. S RLIST($P(RESULT(RES),U,1,2))=$P(RESULT(RES),U,3)
K RESULT S RES="" F I=1:1 S RES=$O(RLIST(RES)) Q:RES="" S RESULT(I)=RES_U_RLIST(RES)
;
;Get the detail for the record
S BSTSD=0
I $D(RESULT)>1 D
. S BSTSWS("STYPE")="S"
. S BSTSD=$$DETAIL^BSTSSRCH(OUT,.BSTSWS,.RESULT)
S $P(BSTSR,U)=$S(BSTSD=0:0,(+BSTSR)>0:+BSTSR,1:1)
Q BSTSR
;
DSCLKP(OUT,IN) ;EP - Returns detail information for a specified Description Id
;
;Input
; OUT - Output variable/global to return information in (VAR)
; IN - P1 - The Description Id to look up
; - P2 (Optional) - The code set Id (default SNOMED US EXT '36')
; - 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
; - P5 (Optional) - Snapshot Date to check (default DT)
; - P6 (Optional) - Mapping Parameters - Ex. EPI=288527008;VST=2087394;AF=With;PRB=50239
;
;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
; Information returned is in the same (full detail) format
; as the detail returned for each record in the
; search API
;
NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BSTSAPIB D UNWIND^%ZTER" ; SAC 2009 2.2.3.17
;
K @OUT
;
N RESULT,SEARCH,NMID,SNAPDT,MAX,LOCAL,DEBUG,BSTSWS,BSTSR,BSTSD,X,%,%H,DIFILE,%D,INDATE
;
I $G(DT)="" D DT^DICRW
S IN=$G(IN,"")
S SEARCH=$P(IN,U) I SEARCH="" Q "0^Invalid Description Id"
S NMID=$P(IN,U,2) S:NMID="" NMID=36 S:NMID=30 NMID=36
S SNAPDT=$P(IN,U,5)
S:SNAPDT="" SNAPDT=DT
S SNAPDT=SNAPDT_".2400"
S INDATE=$P(SNAPDT,".")
S SNAPDT=$$FMDT2XML^BSTSUTIL(SNAPDT)
S MAX=100
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 BSTSWS("SEARCH")=SEARCH
S BSTSWS("STYPE")="S"
S BSTSWS("NAMESPACEID")=NMID
S BSTSWS("SUBSET")=""
S BSTSWS("SNAPDT")=SNAPDT
S BSTSWS("INDATE")=INDATE
S BSTSWS("MAXRECS")=MAX
S BSTSWS("BCTCHRC")=""
S BSTSWS("BCTCHCT")=""
S BSTSWS("RET")="PSCBIXAV"
S BSTSWS("DAT")=""
S BSTSWS("MPPRM")=$P(IN,U,6) ;BSTS*1.0*6;Mapping parameters
;
;Make DTS Lookup call
S BSTSR=1
I LOCAL'=1 S BSTSR=$$DSCLKP^BSTSWSV("RESULT",.BSTSWS,DEBUG) S:+BSTSR $P(BSTSR,U)=2
;
;If no results, try performing local search
I $D(RESULT)<10 S BSTSD=$$DSC^BSTSLKP("RESULT",.BSTSWS)
;
;If local search and no record try DTS Lookup
I $D(RESULT)<10,LOCAL S BSTSR=$$DSCLKP^BSTSWSV("RESULT",.BSTSWS,DEBUG) S:+BSTSR $P(BSTSR,U)=2
;
;Get the detail for the record
S BSTSD=0
I $D(RESULT)>1 D
. S BSTSD=$$DETAIL^BSTSSRCH(OUT,.BSTSWS,.RESULT)
S $P(BSTSR,U)=$S(BSTSD=0:0,(+BSTSR)>0:+BSTSR,1:1)
Q BSTSR
;
DTSLKP(OUT,IN) ;EP - Returns detail information for a specified DTS Id
;
;Input
; OUT - Output variable/global to return information in (VAR)
; IN - P1 - The DTS Id to look up
; - P2 (Optional) - The code set Id (default SNOMED US EXT '36')
; - P3 (Optional) - Snapshot Date to check (default DT)
; - P4 (Optional) - LOCAL - Pass 1 to perform local listing, otherwise leave
; blank for remote listing
; - P5 (Optional) - DEBUG - Pass 1 to display debug information
; - P6 (System Use Only) - TBYPASS - Pass 1 to bypass server timeout checks, otherwise
; leave blank. Do not use for regular calls
; - P7 (Optional) - Mapping Parameters - Ex. EPI=288527008;VST=2087394;AF=With;PRB=50239
;
;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 a match
; Information returned is in the same (full detail) format
; as the detail returned for each record in the
; search API
;
NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BSTSAPIB D UNWIND^%ZTER" ; SAC 2009 2.2.3.17
;
K @OUT
;
N RESULT,SEARCH,NMID,SNAPDT,MAX,LOCAL,DEBUG,BSTSWS,BSTSR,BSTSD,X,%,%H
N DIFILE,%D,INDATE,TBYPASS
;
I $G(DT)="" D DT^DICRW
S IN=$G(IN,"")
S SEARCH=$P(IN,U) I 'SEARCH Q "0^Invalid DTS Id"
S NMID=$P(IN,U,2) S:NMID="" NMID=36 S:NMID=30 NMID=36
S SNAPDT=$P(IN,U,3) S:SNAPDT]"" SNAPDT=$$DATE^BSTSUTIL(SNAPDT)
;BSTS*1.0*6;Default snapshot date to one day in the future
;S:SNAPDT="" SNAPDT=DT_".0001"
I SNAPDT="" D
. NEW X1,X2,X
. S X1=DT,X2=1
. D C^%DTC
. S SNAPDT=X_".0001"
S INDATE=$P(SNAPDT,".")
S SNAPDT=$$FMTE^BSTSUTIL(SNAPDT)
S MAX=100
S LOCAL=$P(IN,U,4),LOCAL=$S(LOCAL=1:"1",1:"")
S DEBUG=$P(IN,U,5),DEBUG=$S(DEBUG=1:"1",1:"")
S TBYPASS=$P(IN,U,6),TBYPASS=$S(TBYPASS=1:"1",1:"")
;
S BSTSWS("SEARCH")=SEARCH
S BSTSWS("STYPE")="F"
S BSTSWS("NAMESPACEID")=NMID
S BSTSWS("SUBSET")=""
S BSTSWS("SNAPDT")=SNAPDT
S BSTSWS("INDATE")=INDATE
S BSTSWS("MAXRECS")=MAX
S BSTSWS("BCTCHRC")=""
S BSTSWS("BCTCHCT")=""
S BSTSWS("RET")="PSCBIXAV"
S BSTSWS("DAT")=""
S BSTSWS("TBYPASS")=TBYPASS
S BSTSWS("MPPRM")=$P(IN,U,7) ;BSTS*1.0*6;Mapping parameters
;
;Make DTS Lookup call
S BSTSR=1
;
I LOCAL'=1 S BSTSR=$$DTSSR^BSTSWSV("RESULT",.BSTSWS,DEBUG) S:+BSTSR $P(BSTSR,U)=2
;
;If no results, try performing local search
I $D(RESULT)<10 S BSTSD=$$DTS^BSTSLKP("RESULT",.BSTSWS)
;
;If no results and local, make DTS call
I $D(RESULT)<10,LOCAL S BSTSR=$$DTSSR^BSTSWSV("RESULT",.BSTSWS,DEBUG) S:+BSTSR $P(BSTSR,U)=2
;
;Get the detail for the record
S BSTSD=0
I $D(RESULT)>1 D
. S BSTSWS("STYPE")="F"
. S BSTSD=$$DETAIL^BSTSSRCH(OUT,.BSTSWS,.RESULT)
S $P(BSTSR,U)=$S(BSTSD=0:0,(+BSTSR)>0:+BSTSR,1:1)
Q BSTSR
;
CNCLKP(OUT,IN) ;EP - Returns detail information for a specified Concept Id
;
;Input
; OUT - Output variable/global to return information in (VAR)
; IN - P1 - The Concept Id to look up
; - P2 (Optional) - The code set Id (default SNOMED US EXT '36')
; - 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
; - P6 (Optional) - Mapping Parameters - Ex. EPI=288527008;VST=2087394;AF=With;PRB=50239
;
;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 a match
; Information returned is in the same (full detail) format
; as the detail returned for each record in the
; search API
;
NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BSTSAPIB D UNWIND^%ZTER" ; SAC 2009 2.2.3.17
;
K @OUT
;
N RESULT,SEARCH,NMID,SNAPDT,MAX,LOCAL,DEBUG,BSTSWS,BSTSR,BSTSD,X,%,%H,DIFILE,%D,INDATE
;
I $G(DT)="" D DT^DICRW
S IN=$G(IN,"")
S SEARCH=$P(IN,U) I SEARCH="" Q "0^Invalid Concept Id"
S NMID=$P(IN,U,2) S:NMID="" NMID=36 S:NMID=30 NMID=36
S SNAPDT=$P(IN,U,3) S:SNAPDT="" SNAPDT=DT
S INDATE=$P(SNAPDT,".")
S SNAPDT=SNAPDT_".2400"
S SNAPDT=$$FMDT2XML^BSTSUTIL(SNAPDT)
S MAX=100
S LOCAL=$P(IN,U,4),LOCAL=$S(LOCAL=2:"",1:"1")
S DEBUG=$P(IN,U,5),DEBUG=$S(DEBUG=1:"1",1:"")
;
S BSTSWS("SEARCH")=SEARCH
S BSTSWS("STYPE")="F"
S BSTSWS("NAMESPACEID")=NMID
S BSTSWS("SUBSET")=""
S BSTSWS("SNAPDT")=SNAPDT
S BSTSWS("INDATE")=INDATE
S BSTSWS("MAXRECS")=MAX
S BSTSWS("BCTCHRC")=""
S BSTSWS("BCTCHCT")=""
S BSTSWS("RET")="PSCBIXAV"
S BSTSWS("DAT")=""
S BSTSWS("MPPRM")=$P(IN,U,6) ;BSTS*1.0*6;Mapping parameters
;
;Make DTS Lookup call
S BSTSR=1
I LOCAL'=1 S BSTSR=$$CNCSR^BSTSWSV("RESULT",.BSTSWS,DEBUG) S:+BSTSR $P(BSTSR,U)=2
;
;If no results, try performing local search
I $D(RESULT)<10 S BSTSD=$$CNC^BSTSLKP("RESULT",.BSTSWS)
;
;If local search and no results try doing DTS lookup
I $D(RESULT)<10,LOCAL S BSTSR=$$CNCSR^BSTSWSV("RESULT",.BSTSWS,DEBUG) S:+BSTSR $P(BSTSR,U)=2
;
;Get the detail for the record
S BSTSD=0
I $D(RESULT)>1 D
. S BSTSWS("STYPE")="F"
. S BSTSD=$$DETAIL^BSTSSRCH(OUT,.BSTSWS,.RESULT)
S $P(BSTSR,U)=$S(BSTSD=0:0,(+BSTSR)>0:+BSTSR,1:1)
Q BSTSR
;
VALSBTRM(OUT,IN) ;EP - 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 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]
; [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)
;
; Single VAR record is returned
; VAR = 1:Term is in the provided subset, 0:Term is not in the provided subset
;
NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BSTSAPIB D UNWIND^%ZTER" ; SAC 2009 2.2.3.17
;
NEW NMID,DSC,SUB,LOCAL,DEBUG,DIN,SBVAR,BSTSR,SB,%D
;
K @OUT
;
I $G(DT)="" D DT^DICRW
S IN=$G(IN,"")
S NMID=$P(IN,U,3) S:NMID="" NMID=36 S:NMID=30 NMID=36
S DSC=$P(IN,U) I DSC="" S @OUT=0 Q "0^Missing Description Id"
S SUB=$P(IN,U,2) I SUB="" S @OUT=0 Q "0^Missing Subset"
S LOCAL=$P(IN,U,4)
S DEBUG=$P(IN,U,5)
S DIN=DSC_U_NMID_U_LOCAL_U_DEBUG
;
;Retrieve the detail for the term
S BSTSR=$$DSCLKP^BSTSAPI("SBVAR",DIN)
;
S @OUT=0
;
;Loop through subsets for a match
S SB="" F S SB=$O(SBVAR(1,"SUB",SB)) Q:SB="" I $G(SBVAR(1,"SUB",SB,"SUB"))=SUB S @OUT=1 Q
;
Q BSTSR
;
ERR ;
D ^%ZTER
Q
BSTSAPIB ;GDIT/HS/BEE-Standard Terminology API Program ; 5 Nov 2012 9:53 AM
+1 ;;2.0;IHS STANDARD TERMINOLOGY;;Dec 01, 2016;Build 62
+2 ;
+3 QUIT
+4 ;
VALTERM(OUT,IN) ;PEP - Returns whether a given term is a valid
+1 ;
+2 ;Input
+3 ; OUT - Output variable/global to return information in (VAR)
+4 ; IN - P1 - The exact term to lookup
+5 ; - P2 (Optional) - The code set Id or Name (default SNOMED US EXT '36')
+6 ; ID NAME
+7 ; 32770 ECLIPS
+8 ; 5180 FDA UNII
+9 ; 32773 GMRA Allergies with Maps
+10 ; 32772 GMRA Signs Symptoms
+11 ; 32771 IHS VANDF
+12 ; 32774 IHS Med Route
+13 ; 1552 RxNorm R
+14 ; 36 SNOMED CT US Extension
+15 ;
+16 ; - P3 (Optional) - Snapshot Date to check (default DT)
+17 ; - P4 (Optional) - LOCAL - Pass 1 or blank to perform local listing,
+18 ; Pass 2 for remote DTS listing
+19 ; - P5 (Optional) - DEBUG - Pass 1 to display debug information
+20 ; - P6 (Optional) - Mapping Parameters - Ex. EPI=288527008;VST=2087394;AF=With;PRB=50239
+21 ;
+22 ;Output
+23 ; Function returns - [1]^[2]^[3]
+24 ; [1] - 2:Remote information returned
+25 ; 1:Local information returned
+26 ; 0:No Information Returned
+27 ; [2] - Primary Remote Error Message
+28 ; [3] - Secondary Remote Error Message (if applicable)
+29 ;
+30 ; VAR(#) record(s) returned for any exact match
+31 ; Please see routine BSTSCDET, tag DETAIL for a detailed description of the
+32 ; information being returned by this API.
+33 ;
+34 ; SAC 2009 2.2.3.17
NEW $ESTACK,$ETRAP
SET $ETRAP="D ERR^BSTSAPIB D UNWIND^%ZTER"
+35 ;
+36 NEW SEARCH,NMID,SNAPDT,MAX,LOCAL,NMIEN,RLIST,I,NSEARCH,C,%D
+37 NEW RESULT,DEBUG,BSTSR,BSTSI,BSTSWS,RES,BSTSD,X,%,%H,UPSRCH,INDATE
+38 KILL @OUT,STS
+39 ;
+40 IF $GET(DT)=""
DO DT^DICRW
+41 SET IN=$GET(IN,"")
+42 SET SEARCH=$PIECE(IN,U)
IF $TRANSLATE(SEARCH," ")=""
QUIT "0^Invalid Search String"
+43 SET UPSRCH=$$UP^XLFSTR(SEARCH)
+44 SET NMID=$PIECE(IN,U,2)
IF NMID=""
SET NMID=36
IF NMID=30
SET NMID=36
+45 ;
+46 ;Convert namespace to number if needed
+47 IF NMID'?1N.N
Begin DoDot:1
+48 SET NMID=$ORDER(^BSTS(9002318.1,"D",NMID,""))
IF NMID=""
QUIT
+49 SET NMID=$$GET1^DIQ(9002318.1,NMID_",",".01","I")
End DoDot:1
IF NMID=""
QUIT "0^Invalid Namespace"
+50 ;
+51 SET SNAPDT=$PIECE(IN,U,3)
IF SNAPDT]""
SET SNAPDT=$$DATE^BSTSUTIL(SNAPDT)
+52 IF SNAPDT=""
SET SNAPDT=DT_".0001"
+53 SET INDATE=$PIECE(SNAPDT,".")
+54 SET SNAPDT=$$FMTE^BSTSUTIL(SNAPDT)
+55 SET MAX=50
+56 SET LOCAL=$PIECE(IN,U,4)
SET LOCAL=$SELECT(LOCAL=2:"",1:"1")
+57 SET DEBUG=$PIECE(IN,U,5)
SET DEBUG=$SELECT(DEBUG=1:"1",1:"")
+58 ;
+59 ;Handle strings with "'"
+60 SET NSEARCH=""
FOR I=1:1:$LENGTH(SEARCH)
SET C=$EXTRACT(SEARCH,I)
SET NSEARCH=NSEARCH_$SELECT(C="'":"'",1:"")_C
+61 SET BSTSWS("SEARCH")=NSEARCH
+62 SET BSTSWS("STYPE")="S"
+63 SET BSTSWS("NAMESPACEID")=NMID
+64 SET BSTSWS("SUBSET")=""
+65 SET BSTSWS("SNAPDT")=SNAPDT
+66 SET BSTSWS("INDATE")=INDATE
+67 SET BSTSWS("MAXRECS")=MAX
+68 SET BSTSWS("BCTCHRC")=""
+69 SET BSTSWS("BCTCHCT")=""
+70 SET BSTSWS("RET")="PSCBIXAV"
+71 SET BSTSWS("DAT")=""
+72 SET BSTSWS("EXACTMATCH")="T"
+73 ;BSTS*1.0*6;Mapping parameters
SET BSTSWS("MPPRM")=$PIECE(IN,U,7)
+74 ;
+75 ;Check for new version
+76 DO CHECK^BSTSVRSN
+77 ;
+78 ;Make DTS Lookup call
+79 SET BSTSR=1
+80 IF LOCAL'=1
SET BSTSR=$$SEARCH^BSTSWSV("RESULT",.BSTSWS,DEBUG)
IF +BSTSR
SET $PIECE(BSTSR,U)=2
+81 ;
+82 ;If no results, try performing local search
+83 IF $DATA(RESULT)<10
SET BSTSD=$$SRC^BSTSSRCH("RESULT",.BSTSWS)
+84 ;
+85 ;If local search and no record try DTS Lookup
+86 IF $DATA(RESULT)<10
IF LOCAL
SET BSTSR=$$SEARCH^BSTSWSV("RESULT",.BSTSWS,DEBUG)
IF +BSTSR
SET $PIECE(BSTSR,U)=2
+87 ;
+88 ;Now loop through and find exact term - Combine like terms
+89 ;
+90 SET NMIEN=$ORDER(^BSTS(9002318.1,"B",NMID,""))
+91 SET RES=""
FOR
SET RES=$ORDER(RESULT(RES))
IF RES=""
QUIT
Begin DoDot:1
+92 NEW REC,DIEN,TIEN,TERM,MATCH
+93 SET MATCH=0
+94 SET REC=RESULT(RES)
+95 SET DIEN=$PIECE(REC,U,3)
IF DIEN=""
QUIT
+96 SET TIEN=$ORDER(^BSTS(9002318.3,"D",NMIEN,DIEN,""))
IF TIEN=""
QUIT
+97 SET TERM=$$GET1^DIQ(9002318.3,TIEN_",",1,"E")
IF TERM=""
QUIT
+98 ;
+99 ;Perform regular match
+100 IF UPSRCH=($$UP^XLFSTR(TERM))
SET MATCH=1
+101 ;
+102 ;Perform special concept search for UNII
+103 IF MATCH=0
IF NMID=5180
Begin DoDot:2
+104 NEW FSN,CIEN,DSC,CON
+105 SET CIEN=$$GET1^DIQ(9002318.3,TIEN_",",.03,"I")
IF CIEN=""
QUIT
+106 SET FSN=$$GET1^DIQ(9002318.4,CIEN_",",1,"I")
IF FSN=""
QUIT
+107 IF UPSRCH'=($$UP^XLFSTR(FSN))
QUIT
+108 SET CON=$$GET1^DIQ(9002318.4,CIEN_",",.02,"I")
IF CON=""
QUIT
+109 SET DSC=$PIECE($$CONC^BSTSAPI(CON_"^5180"),"^")
IF DSC=""
QUIT
+110 SET $PIECE(RESULT(RES),U,3)=DSC
+111 SET MATCH=1
End DoDot:2
+112 ;
+113 IF MATCH=0
KILL RESULT(RES)
QUIT
+114 ;
+115 IF $DATA(RLIST($PIECE(RESULT(RES),U,1,2)))
QUIT
+116 SET RLIST($PIECE(RESULT(RES),U,1,2))=$PIECE(RESULT(RES),U,3)
End DoDot:1
+117 KILL RESULT
SET RES=""
FOR I=1:1
SET RES=$ORDER(RLIST(RES))
IF RES=""
QUIT
SET RESULT(I)=RES_U_RLIST(RES)
+118 ;
+119 ;Get the detail for the record
+120 SET BSTSD=0
+121 IF $DATA(RESULT)>1
Begin DoDot:1
+122 SET BSTSWS("STYPE")="S"
+123 SET BSTSD=$$DETAIL^BSTSSRCH(OUT,.BSTSWS,.RESULT)
End DoDot:1
+124 SET $PIECE(BSTSR,U)=$SELECT(BSTSD=0:0,(+BSTSR)>0:+BSTSR,1:1)
+125 QUIT BSTSR
+126 ;
DSCLKP(OUT,IN) ;EP - Returns detail information for a specified Description Id
+1 ;
+2 ;Input
+3 ; OUT - Output variable/global to return information in (VAR)
+4 ; IN - P1 - The Description Id to look up
+5 ; - P2 (Optional) - The code set Id (default SNOMED US EXT '36')
+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 ; - P5 (Optional) - Snapshot Date to check (default DT)
+10 ; - P6 (Optional) - Mapping Parameters - Ex. EPI=288527008;VST=2087394;AF=With;PRB=50239
+11 ;
+12 ;Output
+13 ; Function returns - [1]^[2]^[3]
+14 ; [1] - 2:Remote information returned
+15 ; 1:Local information returned
+16 ; 0:No Information Returned
+17 ; [2] - Primary Remote Error Message
+18 ; [3] - Secondary Remote Error Message (if applicable)
+19 ;
+20 ; VAR(#) record is returned for any exact match
+21 ; Information returned is in the same (full detail) format
+22 ; as the detail returned for each record in the
+23 ; search API
+24 ;
+25 ; SAC 2009 2.2.3.17
NEW $ESTACK,$ETRAP
SET $ETRAP="D ERR^BSTSAPIB D UNWIND^%ZTER"
+26 ;
+27 KILL @OUT
+28 ;
+29 NEW RESULT,SEARCH,NMID,SNAPDT,MAX,LOCAL,DEBUG,BSTSWS,BSTSR,BSTSD,X,%,%H,DIFILE,%D,INDATE
+30 ;
+31 IF $GET(DT)=""
DO DT^DICRW
+32 SET IN=$GET(IN,"")
+33 SET SEARCH=$PIECE(IN,U)
IF SEARCH=""
QUIT "0^Invalid Description Id"
+34 SET NMID=$PIECE(IN,U,2)
IF NMID=""
SET NMID=36
IF NMID=30
SET NMID=36
+35 SET SNAPDT=$PIECE(IN,U,5)
+36 IF SNAPDT=""
SET SNAPDT=DT
+37 SET SNAPDT=SNAPDT_".2400"
+38 SET INDATE=$PIECE(SNAPDT,".")
+39 SET SNAPDT=$$FMDT2XML^BSTSUTIL(SNAPDT)
+40 SET MAX=100
+41 SET LOCAL=$PIECE(IN,U,3)
SET LOCAL=$SELECT(LOCAL=2:"",1:"1")
+42 SET DEBUG=$PIECE(IN,U,4)
SET DEBUG=$SELECT(DEBUG=1:"1",1:"")
+43 ;
+44 SET BSTSWS("SEARCH")=SEARCH
+45 SET BSTSWS("STYPE")="S"
+46 SET BSTSWS("NAMESPACEID")=NMID
+47 SET BSTSWS("SUBSET")=""
+48 SET BSTSWS("SNAPDT")=SNAPDT
+49 SET BSTSWS("INDATE")=INDATE
+50 SET BSTSWS("MAXRECS")=MAX
+51 SET BSTSWS("BCTCHRC")=""
+52 SET BSTSWS("BCTCHCT")=""
+53 SET BSTSWS("RET")="PSCBIXAV"
+54 SET BSTSWS("DAT")=""
+55 ;BSTS*1.0*6;Mapping parameters
SET BSTSWS("MPPRM")=$PIECE(IN,U,6)
+56 ;
+57 ;Make DTS Lookup call
+58 SET BSTSR=1
+59 IF LOCAL'=1
SET BSTSR=$$DSCLKP^BSTSWSV("RESULT",.BSTSWS,DEBUG)
IF +BSTSR
SET $PIECE(BSTSR,U)=2
+60 ;
+61 ;If no results, try performing local search
+62 IF $DATA(RESULT)<10
SET BSTSD=$$DSC^BSTSLKP("RESULT",.BSTSWS)
+63 ;
+64 ;If local search and no record try DTS Lookup
+65 IF $DATA(RESULT)<10
IF LOCAL
SET BSTSR=$$DSCLKP^BSTSWSV("RESULT",.BSTSWS,DEBUG)
IF +BSTSR
SET $PIECE(BSTSR,U)=2
+66 ;
+67 ;Get the detail for the record
+68 SET BSTSD=0
+69 IF $DATA(RESULT)>1
Begin DoDot:1
+70 SET BSTSD=$$DETAIL^BSTSSRCH(OUT,.BSTSWS,.RESULT)
End DoDot:1
+71 SET $PIECE(BSTSR,U)=$SELECT(BSTSD=0:0,(+BSTSR)>0:+BSTSR,1:1)
+72 QUIT BSTSR
+73 ;
DTSLKP(OUT,IN) ;EP - Returns detail information for a specified DTS Id
+1 ;
+2 ;Input
+3 ; OUT - Output variable/global to return information in (VAR)
+4 ; IN - P1 - The DTS Id to look up
+5 ; - P2 (Optional) - The code set Id (default SNOMED US EXT '36')
+6 ; - P3 (Optional) - Snapshot Date to check (default DT)
+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 ; - P6 (System Use Only) - TBYPASS - Pass 1 to bypass server timeout checks, otherwise
+11 ; leave blank. Do not use for regular calls
+12 ; - P7 (Optional) - Mapping Parameters - Ex. EPI=288527008;VST=2087394;AF=With;PRB=50239
+13 ;
+14 ;Output
+15 ; Function returns - [1]^[2]^[3]
+16 ; [1] - 2:Remote information returned
+17 ; 1:Local information returned
+18 ; 0:No Information Returned
+19 ; [2] - Primary Remote Error Message
+20 ; [3] - Secondary Remote Error Message (if applicable)
+21 ;
+22 ; VAR(#) record is returned for a match
+23 ; Information returned is in the same (full detail) format
+24 ; as the detail returned for each record in the
+25 ; search API
+26 ;
+27 ; SAC 2009 2.2.3.17
NEW $ESTACK,$ETRAP
SET $ETRAP="D ERR^BSTSAPIB D UNWIND^%ZTER"
+28 ;
+29 KILL @OUT
+30 ;
+31 NEW RESULT,SEARCH,NMID,SNAPDT,MAX,LOCAL,DEBUG,BSTSWS,BSTSR,BSTSD,X,%,%H
+32 NEW DIFILE,%D,INDATE,TBYPASS
+33 ;
+34 IF $GET(DT)=""
DO DT^DICRW
+35 SET IN=$GET(IN,"")
+36 SET SEARCH=$PIECE(IN,U)
IF 'SEARCH
QUIT "0^Invalid DTS Id"
+37 SET NMID=$PIECE(IN,U,2)
IF NMID=""
SET NMID=36
IF NMID=30
SET NMID=36
+38 SET SNAPDT=$PIECE(IN,U,3)
IF SNAPDT]""
SET SNAPDT=$$DATE^BSTSUTIL(SNAPDT)
+39 ;BSTS*1.0*6;Default snapshot date to one day in the future
+40 ;S:SNAPDT="" SNAPDT=DT_".0001"
+41 IF SNAPDT=""
Begin DoDot:1
+42 NEW X1,X2,X
+43 SET X1=DT
SET X2=1
+44 DO C^%DTC
+45 SET SNAPDT=X_".0001"
End DoDot:1
+46 SET INDATE=$PIECE(SNAPDT,".")
+47 SET SNAPDT=$$FMTE^BSTSUTIL(SNAPDT)
+48 SET MAX=100
+49 SET LOCAL=$PIECE(IN,U,4)
SET LOCAL=$SELECT(LOCAL=1:"1",1:"")
+50 SET DEBUG=$PIECE(IN,U,5)
SET DEBUG=$SELECT(DEBUG=1:"1",1:"")
+51 SET TBYPASS=$PIECE(IN,U,6)
SET TBYPASS=$SELECT(TBYPASS=1:"1",1:"")
+52 ;
+53 SET BSTSWS("SEARCH")=SEARCH
+54 SET BSTSWS("STYPE")="F"
+55 SET BSTSWS("NAMESPACEID")=NMID
+56 SET BSTSWS("SUBSET")=""
+57 SET BSTSWS("SNAPDT")=SNAPDT
+58 SET BSTSWS("INDATE")=INDATE
+59 SET BSTSWS("MAXRECS")=MAX
+60 SET BSTSWS("BCTCHRC")=""
+61 SET BSTSWS("BCTCHCT")=""
+62 SET BSTSWS("RET")="PSCBIXAV"
+63 SET BSTSWS("DAT")=""
+64 SET BSTSWS("TBYPASS")=TBYPASS
+65 ;BSTS*1.0*6;Mapping parameters
SET BSTSWS("MPPRM")=$PIECE(IN,U,7)
+66 ;
+67 ;Make DTS Lookup call
+68 SET BSTSR=1
+69 ;
+70 IF LOCAL'=1
SET BSTSR=$$DTSSR^BSTSWSV("RESULT",.BSTSWS,DEBUG)
IF +BSTSR
SET $PIECE(BSTSR,U)=2
+71 ;
+72 ;If no results, try performing local search
+73 IF $DATA(RESULT)<10
SET BSTSD=$$DTS^BSTSLKP("RESULT",.BSTSWS)
+74 ;
+75 ;If no results and local, make DTS call
+76 IF $DATA(RESULT)<10
IF LOCAL
SET BSTSR=$$DTSSR^BSTSWSV("RESULT",.BSTSWS,DEBUG)
IF +BSTSR
SET $PIECE(BSTSR,U)=2
+77 ;
+78 ;Get the detail for the record
+79 SET BSTSD=0
+80 IF $DATA(RESULT)>1
Begin DoDot:1
+81 SET BSTSWS("STYPE")="F"
+82 SET BSTSD=$$DETAIL^BSTSSRCH(OUT,.BSTSWS,.RESULT)
End DoDot:1
+83 SET $PIECE(BSTSR,U)=$SELECT(BSTSD=0:0,(+BSTSR)>0:+BSTSR,1:1)
+84 QUIT BSTSR
+85 ;
CNCLKP(OUT,IN) ;EP - Returns detail information for a specified Concept Id
+1 ;
+2 ;Input
+3 ; OUT - Output variable/global to return information in (VAR)
+4 ; IN - P1 - The Concept Id to look up
+5 ; - P2 (Optional) - The code set Id (default SNOMED US EXT '36')
+6 ; - P3 (Optional) - Snapshot Date to check (default DT)
+7 ; - P4 (Optional) - LOCAL - Pass 1 or blank to perform local listing,
+8 ; Pass 2 for remote DTS listing
+9 ; - P5 (Optional) - DEBUG - Pass 1 to display debug information
+10 ; - P6 (Optional) - Mapping Parameters - Ex. EPI=288527008;VST=2087394;AF=With;PRB=50239
+11 ;
+12 ;Output
+13 ; Function returns - [1]^[2]^[3]
+14 ; [1] - 2:Remote information returned
+15 ; 1:Local information returned
+16 ; 0:No Information Returned
+17 ; [2] - Primary Remote Error Message
+18 ; [3] - Secondary Remote Error Message (if applicable)
+19 ;
+20 ; VAR(#) record is returned for a match
+21 ; Information returned is in the same (full detail) format
+22 ; as the detail returned for each record in the
+23 ; search API
+24 ;
+25 ; SAC 2009 2.2.3.17
NEW $ESTACK,$ETRAP
SET $ETRAP="D ERR^BSTSAPIB D UNWIND^%ZTER"
+26 ;
+27 KILL @OUT
+28 ;
+29 NEW RESULT,SEARCH,NMID,SNAPDT,MAX,LOCAL,DEBUG,BSTSWS,BSTSR,BSTSD,X,%,%H,DIFILE,%D,INDATE
+30 ;
+31 IF $GET(DT)=""
DO DT^DICRW
+32 SET IN=$GET(IN,"")
+33 SET SEARCH=$PIECE(IN,U)
IF SEARCH=""
QUIT "0^Invalid Concept Id"
+34 SET NMID=$PIECE(IN,U,2)
IF NMID=""
SET NMID=36
IF NMID=30
SET NMID=36
+35 SET SNAPDT=$PIECE(IN,U,3)
IF SNAPDT=""
SET SNAPDT=DT
+36 SET INDATE=$PIECE(SNAPDT,".")
+37 SET SNAPDT=SNAPDT_".2400"
+38 SET SNAPDT=$$FMDT2XML^BSTSUTIL(SNAPDT)
+39 SET MAX=100
+40 SET LOCAL=$PIECE(IN,U,4)
SET LOCAL=$SELECT(LOCAL=2:"",1:"1")
+41 SET DEBUG=$PIECE(IN,U,5)
SET DEBUG=$SELECT(DEBUG=1:"1",1:"")
+42 ;
+43 SET BSTSWS("SEARCH")=SEARCH
+44 SET BSTSWS("STYPE")="F"
+45 SET BSTSWS("NAMESPACEID")=NMID
+46 SET BSTSWS("SUBSET")=""
+47 SET BSTSWS("SNAPDT")=SNAPDT
+48 SET BSTSWS("INDATE")=INDATE
+49 SET BSTSWS("MAXRECS")=MAX
+50 SET BSTSWS("BCTCHRC")=""
+51 SET BSTSWS("BCTCHCT")=""
+52 SET BSTSWS("RET")="PSCBIXAV"
+53 SET BSTSWS("DAT")=""
+54 ;BSTS*1.0*6;Mapping parameters
SET BSTSWS("MPPRM")=$PIECE(IN,U,6)
+55 ;
+56 ;Make DTS Lookup call
+57 SET BSTSR=1
+58 IF LOCAL'=1
SET BSTSR=$$CNCSR^BSTSWSV("RESULT",.BSTSWS,DEBUG)
IF +BSTSR
SET $PIECE(BSTSR,U)=2
+59 ;
+60 ;If no results, try performing local search
+61 IF $DATA(RESULT)<10
SET BSTSD=$$CNC^BSTSLKP("RESULT",.BSTSWS)
+62 ;
+63 ;If local search and no results try doing DTS lookup
+64 IF $DATA(RESULT)<10
IF LOCAL
SET BSTSR=$$CNCSR^BSTSWSV("RESULT",.BSTSWS,DEBUG)
IF +BSTSR
SET $PIECE(BSTSR,U)=2
+65 ;
+66 ;Get the detail for the record
+67 SET BSTSD=0
+68 IF $DATA(RESULT)>1
Begin DoDot:1
+69 SET BSTSWS("STYPE")="F"
+70 SET BSTSD=$$DETAIL^BSTSSRCH(OUT,.BSTSWS,.RESULT)
End DoDot:1
+71 SET $PIECE(BSTSR,U)=$SELECT(BSTSD=0:0,(+BSTSR)>0:+BSTSR,1:1)
+72 QUIT BSTSR
+73 ;
VALSBTRM(OUT,IN) ;EP - 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 or blank to perform local listing,
+8 ; Pass 2 for remote DTS listing
+9 ; - P5 (Optional) - DEBUG - Pass 1 to display debug information
+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 ; Single VAR record is returned
+20 ; VAR = 1:Term is in the provided subset, 0:Term is not in the provided subset
+21 ;
+22 ; SAC 2009 2.2.3.17
NEW $ESTACK,$ETRAP
SET $ETRAP="D ERR^BSTSAPIB D UNWIND^%ZTER"
+23 ;
+24 NEW NMID,DSC,SUB,LOCAL,DEBUG,DIN,SBVAR,BSTSR,SB,%D
+25 ;
+26 KILL @OUT
+27 ;
+28 IF $GET(DT)=""
DO DT^DICRW
+29 SET IN=$GET(IN,"")
+30 SET NMID=$PIECE(IN,U,3)
IF NMID=""
SET NMID=36
IF NMID=30
SET NMID=36
+31 SET DSC=$PIECE(IN,U)
IF DSC=""
SET @OUT=0
QUIT "0^Missing Description Id"
+32 SET SUB=$PIECE(IN,U,2)
IF SUB=""
SET @OUT=0
QUIT "0^Missing Subset"
+33 SET LOCAL=$PIECE(IN,U,4)
+34 SET DEBUG=$PIECE(IN,U,5)
+35 SET DIN=DSC_U_NMID_U_LOCAL_U_DEBUG
+36 ;
+37 ;Retrieve the detail for the term
+38 SET BSTSR=$$DSCLKP^BSTSAPI("SBVAR",DIN)
+39 ;
+40 SET @OUT=0
+41 ;
+42 ;Loop through subsets for a match
+43 SET SB=""
FOR
SET SB=$ORDER(SBVAR(1,"SUB",SB))
IF SB=""
QUIT
IF $GET(SBVAR(1,"SUB",SB,"SUB"))=SUB
SET @OUT=1
QUIT
+44 ;
+45 QUIT BSTSR
+46 ;
ERR ;
+1 DO ^%ZTER
+2 QUIT
