BSTSAPIA ;GDIT/HS/BEE-Standard Terminology API Program ; 5 Nov 2012 9:53 AM
;;2.0;IHS STANDARD TERMINOLOGY;**1**;Dec 01, 2016;Build 36
;
Q
;
SEARCH(OUT,IN) ;EP - Perform Codeset 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
; 32774 IHS Med Route
; 32770 ECLIPS
; 1552 RxNorm R
; 36 SNOMED CT US Extension
;
; - P4 (Optional) - Subset(s) to filter on (delimited by "~")
; If blank default to "IHS Problem List". For SNOMED lookups
; passing "ALL" searches on all available SNOMED terms.
; - P5 (Optional) - Date to check (default to DT)
; - P6 (Optional) - Maximum number of concepts/terms to return (default 25)
; - P7 (Optional) - Return Info (P-Preferred,S-Synonym,B-Subset,I-IsA
; X-ICD9/ICD10,C-Children,A-Associations,V-Inv Assoc)
; (Default is all - "PSBIXCAV")
; - P8 (Optional) - Pass 1 to NOT return Add/Retire date info
; - P9 (Optional) - Batch Return - Start at record #
; (used in conjunction with P7)
; - P10 (Optional) - Batch Return - # of concepts to return per batch
; (used in conjunction with P6)
; - P11 (Optional) - LOCAL - Pass 1 to perform local listing, otherwise leave
; blank for remote listing
; - P12 (Optional) - DEBUG - Pass 1 to display debug information
; - P13 (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(#) - List of Records
; Please see routine BSTSCDET, tag DETAIL for a detailed description of the
; information being returned by this API in VAR(#).
;
NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BSTSAPIA D UNWIND^%ZTER" ; SAC 2009 2.2.3.17
;
N SEARCH,STYPE,NMID,SUB,SNAPDT,MAX,BCTCHRC,BCTCHCT,LOCAL,INDATE
N RESULT,DEBUG,BSTSR,BSTSI,RET,DAT,BSTSWS,BSTSD,X,%,%H,%D
K @OUT,STS
;
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,4)
S SNAPDT=$P(IN,U,5) S:SNAPDT]"" SNAPDT=$$DATE^BSTSUTIL(SNAPDT)
S:SNAPDT="" SNAPDT=DT_".0001"
S INDATE=$P(SNAPDT,".")
S SNAPDT=$$FMTE^BSTSUTIL(SNAPDT)
S MAX=$P(IN,U,6) S:'MAX MAX=25
S RET=$P(IN,U,7) S:RET="" RET="PSBIXCAV"
S DAT=$P(IN,U,8)
S BCTCHRC=$P(IN,U,9)
S BCTCHCT=$P(IN,U,10) I BCTCHRC,'BCTCHCT S BCTCHCT=MAX
S LOCAL=$P(IN,U,11),LOCAL=$S(LOCAL=1:"1",1:"")
S DEBUG=$P(IN,U,12),DEBUG=$S(DEBUG=1:"1",1:"")
;
;Check for new version
D CHECK^BSTSVRSN
;
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("MPPRM")=$P(IN,U,6) ;BSTS*1.0*6;Mapping parameters
;
S BSTSI=0
;
;Make DTS search call
S BSTSR=1
;
;BSTS*2.0*1;Log search string
D SEARCH^BSTSAPIL(.BSTSWS)
;
;DTS Call
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 D
. ;
. ;Since in local, switch out of "ALL" search
. S:BSTSWS("SUBSET")="ALL" BSTSWS("SUBSET")="IHS PROBLEM ALL SNOMED"
. ;
. ;Make the local call
. S BSTSD=$$SRC^BSTSSRCH("RESULT",.BSTSWS)
;
;Loop through search results and retrieve detail
S BSTSD=$$DETAIL^BSTSSRCH(OUT,.BSTSWS,.RESULT)
S $P(BSTSR,U)=$S(BSTSD=0:0,(+BSTSR)>0:+BSTSR,1:1)
Q BSTSR
;
CODESETS(OUT,IN) ;EP - Return list of available codesets
;
;Input
; OUT - Output variable/global to return information in (VAR)
; IN - P1 (Optional) - LOCAL - Pass 1 to perform local listing, otherwise leave
; blank for remote listing
; - P2 (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(#) - [1]^[2]^[3]
; [1] - Codeset Id
; [2] - Codeset Code
; [3] - Codeset Name
;
NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BSTSAPIA D UNWIND^%ZTER" ; SAC 2009 2.2.3.17
;
N LOCAL,DEBUG,BSTSR,CDCD,CDIEN,BSTSI,X,%,%H,%D
K @OUT
;
I $G(DT)="" D DT^DICRW
S IN=$G(IN,"")
S LOCAL=$P(IN,U),LOCAL=$S(LOCAL=1:"1",1:"")
S DEBUG=$P(IN,U,2),DEBUG=$S(DEBUG=1:"1",1:"")
;
S BSTSI=0
;
;Make update call
S BSTSR=1
I LOCAL'=1 S BSTSR=$$GCDSET^BSTSWSV(DEBUG) S:+BSTSR $P(BSTSR,U)=2
;
;Loop through files and retrieve results
S CDCD="" F S CDCD=$O(^BSTS(9002318.1,"C",CDCD)) Q:CDCD="" D
. S CDIEN="" F S CDIEN=$O(^BSTS(9002318.1,"C",CDCD,CDIEN)) Q:CDIEN="" D
.. NEW CDID,CDCODE,CDNAME
.. S CDID=$$GET1^DIQ(9002318.1,CDIEN_",",.01,"E") Q:CDID=""
.. S CDCODE=$$GET1^DIQ(9002318.1,CDIEN_",",.02,"E") Q:CDCODE=""
.. S CDNAME=$$GET1^DIQ(9002318.1,CDIEN_",",.03,"E")
.. S BSTSI=BSTSI+1,@OUT@(BSTSI)=CDID_U_CDCODE_U_CDNAME
S $P(BSTSR,U)=$S(BSTSI=0:0,(+BSTSR)>0:+BSTSR,1:1)
Q BSTSR
;
VERSIONS(OUT,IN) ;EP - Return a list of available versions for a code set
;
;Input
; OUT - Output variable/global to return information in (VAR)
; IN - P1 (Optional) - Namespace ID - Default to SNOMED US EXT (#36)
; - P2 (Optional) - LOCAL - Pass 1 to perform local listing, otherwise leave
; blank for remote listing
; - P3 (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(#) - [1]^[2]^[3]^[4]
; [1] - Version Id
; [2] - Version Name
; [3] - Version Release Date
; [4] - Version Install Date (if available)
;
NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BSTSAPIA D UNWIND^%ZTER" ; SAC 2009 2.2.3.17
;
N LOCAL,DEBUG,BSTSR,NMID,NMIEN,BSTSI,VRID,X,%,%H,%D
K @OUT
;
I $G(DT)="" D DT^DICRW
S IN=$G(IN,"")
S NMID=$P(IN,U) S:NMID="" NMID=36 S:NMID=30 NMID=36
S LOCAL=$P(IN,U,2),LOCAL=$S(LOCAL=1:"1",1:"")
S DEBUG=$P(IN,U,3),DEBUG=$S(DEBUG=1:"1",1:"")
;
S BSTSI=0
;
;Make update call
S BSTSR=1
I LOCAL'=1,NMID S BSTSR=$$GVRSET^BSTSWSV(NMID,DEBUG) S:+BSTSR $P(BSTSR,U)=2
;
;Loop through files and retrieve results
S NMIEN=$O(^BSTS(9002318.1,"B",NMID,""))
I NMIEN]"" S VRID="" F S VRID=$O(^BSTS(9002318.1,NMIEN,1,"B",VRID)) Q:VRID="" D
. N VRIEN
. S VRIEN="" F S VRIEN=$O(^BSTS(9002318.1,NMIEN,1,"B",VRID,VRIEN)) Q:VRIEN="" D
.. NEW VRNAME,VRRLDT,VRINDT,DA,IENS
.. S DA(1)=NMIEN,DA=VRIEN,IENS=$$IENS^DILF(.DA)
.. S VRNAME=$$GET1^DIQ(9002318.11,IENS,.02,"E") Q:VRNAME=""
.. S VRRLDT=$$FMTE^XLFDT($$GET1^DIQ(9002318.11,IENS,.03,"I"),"5D")
.. S VRINDT=$$FMTE^XLFDT($$GET1^DIQ(9002318.11,IENS,.04,"I"),"5D")
.. S BSTSI=BSTSI+1,@OUT@(BSTSI)=VRID_U_VRNAME_U_VRRLDT_U_VRINDT
S $P(BSTSR,U)=$S(BSTSI=0:0,(+BSTSR)>0:+BSTSR,1:1)
Q BSTSR
;
SUBSET(OUT,IN) ;EP - Return the list of subsets available for a Code Set
;
;
;Input
; OUT - Output variable/global to return information in (VAR)
; IN - P1 (Optional) - Namespace ID - Default to SNOMED US EXT (#36)
; - P2 (Optional) - LOCAL - Pass 1 OR leave blank to perform local listing,
; Pass 2 for remote DTS listing
; - P3 (Optional) - DEBUG - Pass 1 to display debug information
;
;Output
; Function returns - [1]^[2]
; [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(#) - [1]
; [1] - Subset
;
NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BSTSAPIA D UNWIND^%ZTER" ; SAC 2009 2.2.3.17
;
N SUB,NMID,CNT,X,%,%H,RESULT,NMIEN,BSTSR,LOCAL,DEBUG,%D
K @OUT
;
I $G(DT)="" D DT^DICRW
S IN=$G(IN,"")
S NMID=$P(IN,U) S:NMID="" NMID=36 S:NMID=30 NMID=36
S LOCAL=$P(IN,U,2),LOCAL=$S(LOCAL=2:"",1:"1")
S DEBUG=$P(IN,U,3),DEBUG=$S(DEBUG=1:"1",1:"")
;
;Make sure we have a codeset (namespace)
S NMIEN=$O(^BSTS(9002318.1,"B",NMID,"")) Q:NMIEN=""
;
;Make update call
S BSTSR=1
I LOCAL'=1,NMID S BSTSR=$$SUBSET^BSTSWSV("RESULT",NMID,DEBUG) S:+BSTSR $P(BSTSR,U)=2
I $D(RESULT)>9 M @OUT=RESULT
;
;If no results from call get from local
I $D(RESULT)<10 S $P(BSTSR,U)=1,SUB="",CNT=0 F S SUB=$O(^BSTS(9002318.4,"E",NMIEN,SUB)) Q:SUB="" D
. S CNT=CNT+1
. S @OUT@(CNT)=SUB
;
;Mark if no results
I $D(@OUT)<10 S $P(BSTSR,U)=0
Q BSTSR
;
DESC(IN) ;PEP - 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)
;
;Output
; Function returns - [1]^[2]
; [1] - Concept Id
; [2] - Term Description
; [3] - Mapped ICD Values (based on P5 Snapshot Date)
; [4] - Mapped ICD9 Values
; [5] - Prompt for Abnormal/Normal Findings (1-Yes,0-No)
; [6] - Prompt for Laterality (1-Yes,0-No)
; [7] - Default status (Chronic, Personal History, Sub-acute, Admin, Social)
; [8] - Prompt for Healing (RDNM, RDN, RD)
; [9] - List of healing choices to display (ex. 717128007|NL Union;28087009|Delayed)
;
;BSTS*1.0*6;Added piece 5 output - prompt for abnormal findings
NEW VAR,RES,STS,ICD,IC,%D,IC9,ABN,LAT
S STS=$$DSCLKP^BSTSAPIB("VAR",$G(IN))
S RES=$G(VAR(1,"CON"))_U_$G(VAR(1,"PRB","TRM"))
;
;Tack on Mapped ICD values
;
S ICD="",IC="" F S IC=$O(VAR(1,"ICD",IC)) Q:IC="" D
. NEW ICCOD
. S ICCOD=$G(VAR(1,"ICD",IC,"COD")) Q:IC=""
. S ICD=ICD_$S(ICD]"":";",1:"")_ICCOD
;
;Tack on ICD9 values
S IC9="",IC="" F S IC=$O(VAR(1,"IC9",IC)) Q:IC="" D
. NEW ICTYP,ICCOD
. S ICCOD=$G(VAR(1,"IC9",IC,"COD")) Q:IC=""
. S ICTYP=$G(VAR(1,"IC9",IC,"TYP")) Q:ICTYP'="IC9"
. S IC9=IC9_$S(IC9]"":";",1:"")_ICCOD
;
;Abnormal findings prompt
S ABN=$S($G(VAR(1,"ABN"))]"":VAR(1,"ABN"),1:0)
;
;Prompt for laterality
S LAT=$S($G(VAR(1,"LAT"))]"":VAR(1,"LAT"),1:0)
;
;BSTS*1.0*7;Add laterality and default status
;BSTS*2.0;Add healing choices
S RES=RES_U_ICD_U_IC9_U_ABN_U_LAT_U_$G(VAR(1,"STS"))_U_$G(VAR(1,"HEAL"))_U_$$HLCHC^BSTSMAP1($G(VAR(1,"HEAL")))
;
Q RES
;
CONC(IN) ;PEP - Returns basic 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 '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
;
;Output
; Function returns - [1]^[2]^[3]^[4]
; [1] - Description Id of Fully Specified Name
; [2] - Fully Specified Name
; [3] - Description Id of Preferred Term
; [4] - Preferred Term
; [5] - Mapped ICD Values (based on P3 Snapshot Date)
; [6] - Mapped ICD9 Values
; [7] - Prompt for Abnormal/Normal Findings (1-Yes,0-No)
; [8] - Prompt for Laterality (1-Yes,0-No)
; [9] - Default status (Chronic, Personal History, Sub-acute, Admin, Social)
; [10] - Prompt for Healing (RDNM, RDN, RD)
; [11] - List of healing choices to display (ex. 717128007|NL Union;28087009|Delayed)
;
;BSTS*1.0*6;Added piece 7 output - prompt for abnormal findings
NEW VAR,RES,STS,ICD,IC,%D,IC9,ABN,LAT
S STS=$$CNCLKP^BSTSAPIB("VAR",$G(IN))
S RES=$G(VAR(1,"FSN","DSC"))_U_$G(VAR(1,"FSN","TRM"))_U_$G(VAR(1,"PRE","DSC"))_U_$G(VAR(1,"PRE","TRM"))
;
;Tack on Mapped ICD values
;
S ICD="",IC="" F S IC=$O(VAR(1,"ICD",IC)) Q:IC="" D
. NEW ICCOD
. S ICCOD=$G(VAR(1,"ICD",IC,"COD")) Q:IC=""
. S ICD=ICD_$S(ICD]"":";",1:"")_ICCOD
;
;Tack on ICD9 values
S IC9="",IC="" F S IC=$O(VAR(1,"IC9",IC)) Q:IC="" D
. NEW ICTYP,ICCOD
. S ICCOD=$G(VAR(1,"IC9",IC,"COD")) Q:IC=""
. S ICTYP=$G(VAR(1,"IC9",IC,"TYP")) Q:ICTYP'="IC9"
. S IC9=IC9_$S(IC9]"":";",1:"")_ICCOD
;
;Abnormal findings prompt
S ABN=$S($G(VAR(1,"ABN"))]"":VAR(1,"ABN"),1:0)
;
;Prompt for laterality
S LAT=$S($G(VAR(1,"LAT"))]"":VAR(1,"LAT"),1:0)
;
;BSTS*1.0*7;Add laterality and default status
;BSTS*2.0;Add healing choices
S RES=RES_U_ICD_U_IC9_U_ABN_U_LAT_U_$G(VAR(1,"STS"))_U_$G(VAR(1,"HEAL"))_U_$$HLCHC^BSTSMAP1($G(VAR(1,"HEAL")))
;
Q RES
;
ERR ;
D ^%ZTER
Q
BSTSAPIA ;GDIT/HS/BEE-Standard Terminology API Program ; 5 Nov 2012 9:53 AM
+1 ;;2.0;IHS STANDARD TERMINOLOGY;**1**;Dec 01, 2016;Build 36
+2 ;
+3 QUIT
+4 ;
SEARCH(OUT,IN) ;EP - Perform Codeset 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 ; 32774 IHS Med Route
+13 ; 32770 ECLIPS
+14 ; 1552 RxNorm R
+15 ; 36 SNOMED CT US Extension
+16 ;
+17 ; - P4 (Optional) - Subset(s) to filter on (delimited by "~")
+18 ; If blank default to "IHS Problem List". For SNOMED lookups
+19 ; passing "ALL" searches on all available SNOMED terms.
+20 ; - P5 (Optional) - Date to check (default to DT)
+21 ; - P6 (Optional) - Maximum number of concepts/terms to return (default 25)
+22 ; - P7 (Optional) - Return Info (P-Preferred,S-Synonym,B-Subset,I-IsA
+23 ; X-ICD9/ICD10,C-Children,A-Associations,V-Inv Assoc)
+24 ; (Default is all - "PSBIXCAV")
+25 ; - P8 (Optional) - Pass 1 to NOT return Add/Retire date info
+26 ; - P9 (Optional) - Batch Return - Start at record #
+27 ; (used in conjunction with P7)
+28 ; - P10 (Optional) - Batch Return - # of concepts to return per batch
+29 ; (used in conjunction with P6)
+30 ; - P11 (Optional) - LOCAL - Pass 1 to perform local listing, otherwise leave
+31 ; blank for remote listing
+32 ; - P12 (Optional) - DEBUG - Pass 1 to display debug information
+33 ; - P13 (Optional) - Mapping Parameters - Ex. EPI=288527008;VST=2087394;AF=With;PRB=50239
+34 ;
+35 ;Output
+36 ; Function returns - [1]^[2]^[3]
+37 ; [1] - 2:Remote information returned
+38 ; 1:Local information returned
+39 ; 0:No Information Returned
+40 ; [2] - Primary Remote Error Message
+41 ; [3] - Secondary Remote Error Message (if applicable)
+42 ;
+43 ; VAR(#) - List of Records
+44 ; Please see routine BSTSCDET, tag DETAIL for a detailed description of the
+45 ; information being returned by this API in VAR(#).
+46 ;
+47 ; SAC 2009 2.2.3.17
NEW $ESTACK,$ETRAP
SET $ETRAP="D ERR^BSTSAPIA D UNWIND^%ZTER"
+48 ;
+49 NEW SEARCH,STYPE,NMID,SUB,SNAPDT,MAX,BCTCHRC,BCTCHCT,LOCAL,INDATE
+50 NEW RESULT,DEBUG,BSTSR,BSTSI,RET,DAT,BSTSWS,BSTSD,X,%,%H,%D
+51 KILL @OUT,STS
+52 ;
+53 IF $GET(DT)=""
DO DT^DICRW
+54 SET IN=$GET(IN,"")
+55 SET SEARCH=$PIECE(IN,U)
IF ($TRANSLATE(SEARCH," ")="")
QUIT "0^Invalid Search String"
+56 SET STYPE=$PIECE(IN,U,2)
IF STYPE'="F"
IF STYPE'="S"
QUIT "0^Invalid Search Type"
+57 SET NMID=$PIECE(IN,U,3)
IF NMID=""
SET NMID=36
IF NMID=30
SET NMID=36
+58 SET SUB=$PIECE(IN,U,4)
+59 SET SNAPDT=$PIECE(IN,U,5)
IF SNAPDT]""
SET SNAPDT=$$DATE^BSTSUTIL(SNAPDT)
+60 IF SNAPDT=""
SET SNAPDT=DT_".0001"
+61 SET INDATE=$PIECE(SNAPDT,".")
+62 SET SNAPDT=$$FMTE^BSTSUTIL(SNAPDT)
+63 SET MAX=$PIECE(IN,U,6)
IF 'MAX
SET MAX=25
+64 SET RET=$PIECE(IN,U,7)
IF RET=""
SET RET="PSBIXCAV"
+65 SET DAT=$PIECE(IN,U,8)
+66 SET BCTCHRC=$PIECE(IN,U,9)
+67 SET BCTCHCT=$PIECE(IN,U,10)
IF BCTCHRC
IF 'BCTCHCT
SET BCTCHCT=MAX
+68 SET LOCAL=$PIECE(IN,U,11)
SET LOCAL=$SELECT(LOCAL=1:"1",1:"")
+69 SET DEBUG=$PIECE(IN,U,12)
SET DEBUG=$SELECT(DEBUG=1:"1",1:"")
+70 ;
+71 ;Check for new version
+72 DO CHECK^BSTSVRSN
+73 ;
+74 SET BSTSWS("SEARCH")=SEARCH
+75 SET BSTSWS("STYPE")=STYPE
+76 SET BSTSWS("NAMESPACEID")=NMID
+77 SET BSTSWS("SUBSET")=SUB
+78 SET BSTSWS("SNAPDT")=SNAPDT
+79 SET BSTSWS("INDATE")=INDATE
+80 SET BSTSWS("MAXRECS")=MAX
+81 SET BSTSWS("BCTCHRC")=BCTCHRC
+82 SET BSTSWS("BCTCHCT")=BCTCHCT
+83 SET BSTSWS("RET")=RET
+84 SET BSTSWS("DAT")=DAT
+85 ;BSTS*1.0*6;Mapping parameters
SET BSTSWS("MPPRM")=$PIECE(IN,U,6)
+86 ;
+87 SET BSTSI=0
+88 ;
+89 ;Make DTS search call
+90 SET BSTSR=1
+91 ;
+92 ;BSTS*2.0*1;Log search string
+93 DO SEARCH^BSTSAPIL(.BSTSWS)
+94 ;
+95 ;DTS Call
+96 IF LOCAL'=1
SET BSTSR=$$SEARCH^BSTSWSV("RESULT",.BSTSWS,DEBUG)
IF +BSTSR
SET $PIECE(BSTSR,U)=2
+97 ;
+98 ;If no results, try performing local search
+99 IF $DATA(RESULT)<10
Begin DoDot:1
+100 ;
+101 ;Since in local, switch out of "ALL" search
+102 IF BSTSWS("SUBSET")="ALL"
SET BSTSWS("SUBSET")="IHS PROBLEM ALL SNOMED"
+103 ;
+104 ;Make the local call
+105 SET BSTSD=$$SRC^BSTSSRCH("RESULT",.BSTSWS)
End DoDot:1
+106 ;
+107 ;Loop through search results and retrieve detail
+108 SET BSTSD=$$DETAIL^BSTSSRCH(OUT,.BSTSWS,.RESULT)
+109 SET $PIECE(BSTSR,U)=$SELECT(BSTSD=0:0,(+BSTSR)>0:+BSTSR,1:1)
+110 QUIT BSTSR
+111 ;
CODESETS(OUT,IN) ;EP - Return list of available codesets
+1 ;
+2 ;Input
+3 ; OUT - Output variable/global to return information in (VAR)
+4 ; IN - P1 (Optional) - LOCAL - Pass 1 to perform local listing, otherwise leave
+5 ; blank for remote listing
+6 ; - P2 (Optional) - DEBUG - Pass 1 to display debug information
+7 ;
+8 ;Output
+9 ; Function returns - [1]^[2]^[3]
+10 ; [1] - 2:Remote information returned
+11 ; 1:Local information returned
+12 ; 0:No Information Returned
+13 ; [2] - Primary Remote Error Message
+14 ; [3] - Secondary Remote Error Message (if applicable)
+15 ;
+16 ; VAR(#) - [1]^[2]^[3]
+17 ; [1] - Codeset Id
+18 ; [2] - Codeset Code
+19 ; [3] - Codeset Name
+20 ;
+21 ; SAC 2009 2.2.3.17
NEW $ESTACK,$ETRAP
SET $ETRAP="D ERR^BSTSAPIA D UNWIND^%ZTER"
+22 ;
+23 NEW LOCAL,DEBUG,BSTSR,CDCD,CDIEN,BSTSI,X,%,%H,%D
+24 KILL @OUT
+25 ;
+26 IF $GET(DT)=""
DO DT^DICRW
+27 SET IN=$GET(IN,"")
+28 SET LOCAL=$PIECE(IN,U)
SET LOCAL=$SELECT(LOCAL=1:"1",1:"")
+29 SET DEBUG=$PIECE(IN,U,2)
SET DEBUG=$SELECT(DEBUG=1:"1",1:"")
+30 ;
+31 SET BSTSI=0
+32 ;
+33 ;Make update call
+34 SET BSTSR=1
+35 IF LOCAL'=1
SET BSTSR=$$GCDSET^BSTSWSV(DEBUG)
IF +BSTSR
SET $PIECE(BSTSR,U)=2
+36 ;
+37 ;Loop through files and retrieve results
+38 SET CDCD=""
FOR
SET CDCD=$ORDER(^BSTS(9002318.1,"C",CDCD))
IF CDCD=""
QUIT
Begin DoDot:1
+39 SET CDIEN=""
FOR
SET CDIEN=$ORDER(^BSTS(9002318.1,"C",CDCD,CDIEN))
IF CDIEN=""
QUIT
Begin DoDot:2
+40 NEW CDID,CDCODE,CDNAME
+41 SET CDID=$$GET1^DIQ(9002318.1,CDIEN_",",.01,"E")
IF CDID=""
QUIT
+42 SET CDCODE=$$GET1^DIQ(9002318.1,CDIEN_",",.02,"E")
IF CDCODE=""
QUIT
+43 SET CDNAME=$$GET1^DIQ(9002318.1,CDIEN_",",.03,"E")
+44 SET BSTSI=BSTSI+1
SET @OUT@(BSTSI)=CDID_U_CDCODE_U_CDNAME
End DoDot:2
End DoDot:1
+45 SET $PIECE(BSTSR,U)=$SELECT(BSTSI=0:0,(+BSTSR)>0:+BSTSR,1:1)
+46 QUIT BSTSR
+47 ;
VERSIONS(OUT,IN) ;EP - Return a list of available versions for a code set
+1 ;
+2 ;Input
+3 ; OUT - Output variable/global to return information in (VAR)
+4 ; IN - P1 (Optional) - Namespace ID - Default to SNOMED US EXT (#36)
+5 ; - P2 (Optional) - LOCAL - Pass 1 to perform local listing, otherwise leave
+6 ; blank for remote listing
+7 ; - P3 (Optional) - DEBUG - Pass 1 to display debug information
+8 ;
+9 ;Output
+10 ; Function returns - [1]^[2]^[3]
+11 ; [1] - 2:Remote information returned
+12 ; 1:Local information returned
+13 ; 0:No Information Returned
+14 ; [2] - Primary Remote Error Message
+15 ; [3] - Secondary Remote Error Message (if applicable)
+16 ;
+17 ; VAR(#) - [1]^[2]^[3]^[4]
+18 ; [1] - Version Id
+19 ; [2] - Version Name
+20 ; [3] - Version Release Date
+21 ; [4] - Version Install Date (if available)
+22 ;
+23 ; SAC 2009 2.2.3.17
NEW $ESTACK,$ETRAP
SET $ETRAP="D ERR^BSTSAPIA D UNWIND^%ZTER"
+24 ;
+25 NEW LOCAL,DEBUG,BSTSR,NMID,NMIEN,BSTSI,VRID,X,%,%H,%D
+26 KILL @OUT
+27 ;
+28 IF $GET(DT)=""
DO DT^DICRW
+29 SET IN=$GET(IN,"")
+30 SET NMID=$PIECE(IN,U)
IF NMID=""
SET NMID=36
IF NMID=30
SET NMID=36
+31 SET LOCAL=$PIECE(IN,U,2)
SET LOCAL=$SELECT(LOCAL=1:"1",1:"")
+32 SET DEBUG=$PIECE(IN,U,3)
SET DEBUG=$SELECT(DEBUG=1:"1",1:"")
+33 ;
+34 SET BSTSI=0
+35 ;
+36 ;Make update call
+37 SET BSTSR=1
+38 IF LOCAL'=1
IF NMID
SET BSTSR=$$GVRSET^BSTSWSV(NMID,DEBUG)
IF +BSTSR
SET $PIECE(BSTSR,U)=2
+39 ;
+40 ;Loop through files and retrieve results
+41 SET NMIEN=$ORDER(^BSTS(9002318.1,"B",NMID,""))
+42 IF NMIEN]""
SET VRID=""
FOR
SET VRID=$ORDER(^BSTS(9002318.1,NMIEN,1,"B",VRID))
IF VRID=""
QUIT
Begin DoDot:1
+43 NEW VRIEN
+44 SET VRIEN=""
FOR
SET VRIEN=$ORDER(^BSTS(9002318.1,NMIEN,1,"B",VRID,VRIEN))
IF VRIEN=""
QUIT
Begin DoDot:2
+45 NEW VRNAME,VRRLDT,VRINDT,DA,IENS
+46 SET DA(1)=NMIEN
SET DA=VRIEN
SET IENS=$$IENS^DILF(.DA)
+47 SET VRNAME=$$GET1^DIQ(9002318.11,IENS,.02,"E")
IF VRNAME=""
QUIT
+48 SET VRRLDT=$$FMTE^XLFDT($$GET1^DIQ(9002318.11,IENS,.03,"I"),"5D")
+49 SET VRINDT=$$FMTE^XLFDT($$GET1^DIQ(9002318.11,IENS,.04,"I"),"5D")
+50 SET BSTSI=BSTSI+1
SET @OUT@(BSTSI)=VRID_U_VRNAME_U_VRRLDT_U_VRINDT
End DoDot:2
End DoDot:1
+51 SET $PIECE(BSTSR,U)=$SELECT(BSTSI=0:0,(+BSTSR)>0:+BSTSR,1:1)
+52 QUIT BSTSR
+53 ;
SUBSET(OUT,IN) ;EP - Return the list of subsets available for a Code Set
+1 ;
+2 ;
+3 ;Input
+4 ; OUT - Output variable/global to return information in (VAR)
+5 ; IN - P1 (Optional) - Namespace ID - Default to SNOMED US EXT (#36)
+6 ; - P2 (Optional) - LOCAL - Pass 1 OR leave blank to perform local listing,
+7 ; Pass 2 for remote DTS listing
+8 ; - P3 (Optional) - DEBUG - Pass 1 to display debug information
+9 ;
+10 ;Output
+11 ; Function returns - [1]^[2]
+12 ; [1] - 2:Remote information returned
+13 ; 1:Local information returned
+14 ; 0:No Information Returned
+15 ; [2] - Primary Remote Error Message
+16 ; [3] - Secondary Remote Error Message (if applicable)
+17 ;
+18 ; VAR(#) - [1]
+19 ; [1] - Subset
+20 ;
+21 ; SAC 2009 2.2.3.17
NEW $ESTACK,$ETRAP
SET $ETRAP="D ERR^BSTSAPIA D UNWIND^%ZTER"
+22 ;
+23 NEW SUB,NMID,CNT,X,%,%H,RESULT,NMIEN,BSTSR,LOCAL,DEBUG,%D
+24 KILL @OUT
+25 ;
+26 IF $GET(DT)=""
DO DT^DICRW
+27 SET IN=$GET(IN,"")
+28 SET NMID=$PIECE(IN,U)
IF NMID=""
SET NMID=36
IF NMID=30
SET NMID=36
+29 SET LOCAL=$PIECE(IN,U,2)
SET LOCAL=$SELECT(LOCAL=2:"",1:"1")
+30 SET DEBUG=$PIECE(IN,U,3)
SET DEBUG=$SELECT(DEBUG=1:"1",1:"")
+31 ;
+32 ;Make sure we have a codeset (namespace)
+33 SET NMIEN=$ORDER(^BSTS(9002318.1,"B",NMID,""))
IF NMIEN=""
QUIT
+34 ;
+35 ;Make update call
+36 SET BSTSR=1
+37 IF LOCAL'=1
IF NMID
SET BSTSR=$$SUBSET^BSTSWSV("RESULT",NMID,DEBUG)
IF +BSTSR
SET $PIECE(BSTSR,U)=2
+38 IF $DATA(RESULT)>9
MERGE @OUT=RESULT
+39 ;
+40 ;If no results from call get from local
+41 IF $DATA(RESULT)<10
SET $PIECE(BSTSR,U)=1
SET SUB=""
SET CNT=0
FOR
SET SUB=$ORDER(^BSTS(9002318.4,"E",NMIEN,SUB))
IF SUB=""
QUIT
Begin DoDot:1
+42 SET CNT=CNT+1
+43 SET @OUT@(CNT)=SUB
End DoDot:1
+44 ;
+45 ;Mark if no results
+46 IF $DATA(@OUT)<10
SET $PIECE(BSTSR,U)=0
+47 QUIT BSTSR
+48 ;
DESC(IN) ;PEP - 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 ;
+11 ;Output
+12 ; Function returns - [1]^[2]
+13 ; [1] - Concept Id
+14 ; [2] - Term Description
+15 ; [3] - Mapped ICD Values (based on P5 Snapshot Date)
+16 ; [4] - Mapped ICD9 Values
+17 ; [5] - Prompt for Abnormal/Normal Findings (1-Yes,0-No)
+18 ; [6] - Prompt for Laterality (1-Yes,0-No)
+19 ; [7] - Default status (Chronic, Personal History, Sub-acute, Admin, Social)
+20 ; [8] - Prompt for Healing (RDNM, RDN, RD)
+21 ; [9] - List of healing choices to display (ex. 717128007|NL Union;28087009|Delayed)
+22 ;
+23 ;BSTS*1.0*6;Added piece 5 output - prompt for abnormal findings
+24 NEW VAR,RES,STS,ICD,IC,%D,IC9,ABN,LAT
+25 SET STS=$$DSCLKP^BSTSAPIB("VAR",$GET(IN))
+26 SET RES=$GET(VAR(1,"CON"))_U_$GET(VAR(1,"PRB","TRM"))
+27 ;
+28 ;Tack on Mapped ICD values
+29 ;
+30 SET ICD=""
SET IC=""
FOR
SET IC=$ORDER(VAR(1,"ICD",IC))
IF IC=""
QUIT
Begin DoDot:1
+31 NEW ICCOD
+32 SET ICCOD=$GET(VAR(1,"ICD",IC,"COD"))
IF IC=""
QUIT
+33 SET ICD=ICD_$SELECT(ICD]"":";",1:"")_ICCOD
End DoDot:1
+34 ;
+35 ;Tack on ICD9 values
+36 SET IC9=""
SET IC=""
FOR
SET IC=$ORDER(VAR(1,"IC9",IC))
IF IC=""
QUIT
Begin DoDot:1
+37 NEW ICTYP,ICCOD
+38 SET ICCOD=$GET(VAR(1,"IC9",IC,"COD"))
IF IC=""
QUIT
+39 SET ICTYP=$GET(VAR(1,"IC9",IC,"TYP"))
IF ICTYP'="IC9"
QUIT
+40 SET IC9=IC9_$SELECT(IC9]"":";",1:"")_ICCOD
End DoDot:1
+41 ;
+42 ;Abnormal findings prompt
+43 SET ABN=$SELECT($GET(VAR(1,"ABN"))]"":VAR(1,"ABN"),1:0)
+44 ;
+45 ;Prompt for laterality
+46 SET LAT=$SELECT($GET(VAR(1,"LAT"))]"":VAR(1,"LAT"),1:0)
+47 ;
+48 ;BSTS*1.0*7;Add laterality and default status
+49 ;BSTS*2.0;Add healing choices
+50 SET RES=RES_U_ICD_U_IC9_U_ABN_U_LAT_U_$GET(VAR(1,"STS"))_U_$GET(VAR(1,"HEAL"))_U_$$HLCHC^BSTSMAP1($GET(VAR(1,"HEAL")))
+51 ;
+52 QUIT RES
+53 ;
CONC(IN) ;PEP - Returns basic 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 '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 ;
+11 ;Output
+12 ; Function returns - [1]^[2]^[3]^[4]
+13 ; [1] - Description Id of Fully Specified Name
+14 ; [2] - Fully Specified Name
+15 ; [3] - Description Id of Preferred Term
+16 ; [4] - Preferred Term
+17 ; [5] - Mapped ICD Values (based on P3 Snapshot Date)
+18 ; [6] - Mapped ICD9 Values
+19 ; [7] - Prompt for Abnormal/Normal Findings (1-Yes,0-No)
+20 ; [8] - Prompt for Laterality (1-Yes,0-No)
+21 ; [9] - Default status (Chronic, Personal History, Sub-acute, Admin, Social)
+22 ; [10] - Prompt for Healing (RDNM, RDN, RD)
+23 ; [11] - List of healing choices to display (ex. 717128007|NL Union;28087009|Delayed)
+24 ;
+25 ;BSTS*1.0*6;Added piece 7 output - prompt for abnormal findings
+26 NEW VAR,RES,STS,ICD,IC,%D,IC9,ABN,LAT
+27 SET STS=$$CNCLKP^BSTSAPIB("VAR",$GET(IN))
+28 SET RES=$GET(VAR(1,"FSN","DSC"))_U_$GET(VAR(1,"FSN","TRM"))_U_$GET(VAR(1,"PRE","DSC"))_U_$GET(VAR(1,"PRE","TRM"))
+29 ;
+30 ;Tack on Mapped ICD values
+31 ;
+32 SET ICD=""
SET IC=""
FOR
SET IC=$ORDER(VAR(1,"ICD",IC))
IF IC=""
QUIT
Begin DoDot:1
+33 NEW ICCOD
+34 SET ICCOD=$GET(VAR(1,"ICD",IC,"COD"))
IF IC=""
QUIT
+35 SET ICD=ICD_$SELECT(ICD]"":";",1:"")_ICCOD
End DoDot:1
+36 ;
+37 ;Tack on ICD9 values
+38 SET IC9=""
SET IC=""
FOR
SET IC=$ORDER(VAR(1,"IC9",IC))
IF IC=""
QUIT
Begin DoDot:1
+39 NEW ICTYP,ICCOD
+40 SET ICCOD=$GET(VAR(1,"IC9",IC,"COD"))
IF IC=""
QUIT
+41 SET ICTYP=$GET(VAR(1,"IC9",IC,"TYP"))
IF ICTYP'="IC9"
QUIT
+42 SET IC9=IC9_$SELECT(IC9]"":";",1:"")_ICCOD
End DoDot:1
+43 ;
+44 ;Abnormal findings prompt
+45 SET ABN=$SELECT($GET(VAR(1,"ABN"))]"":VAR(1,"ABN"),1:0)
+46 ;
+47 ;Prompt for laterality
+48 SET LAT=$SELECT($GET(VAR(1,"LAT"))]"":VAR(1,"LAT"),1:0)
+49 ;
+50 ;BSTS*1.0*7;Add laterality and default status
+51 ;BSTS*2.0;Add healing choices
+52 SET RES=RES_U_ICD_U_IC9_U_ABN_U_LAT_U_$GET(VAR(1,"STS"))_U_$GET(VAR(1,"HEAL"))_U_$$HLCHC^BSTSMAP1($GET(VAR(1,"HEAL")))
+53 ;
+54 QUIT RES
+55 ;
ERR ;
+1 DO ^%ZTER
+2 QUIT
