BSTSAPIC ;GDIT/HS/BEE-Standard Terminology API Program ; 5 Nov 2012 9:53 AM
;;2.0;IHS STANDARD TERMINOLOGY;;Dec 01, 2016;Build 62
;
Q
;
MPADVICE(OUT,IN) ;EP - Returns ICD-10 mapping 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) - LOCAL - Pass 1 to perform local listing,
; Pass 2 for remote DTS listing
; - P3 (Optional) - Exclude add/retired date information
; - P4 (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(#) 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
;
; The VAR(#) list of records returns the mapping information on file for
; the specified concept. Multiple records per concept could be returned.
;
;Format:
; VAR(#,"MPADV","VAL")=Mapping Advice
; VAR(#,"MPADV","XADT")=Mapping Advice add date
; VAR(#,"MPADV","XRDT")=Mapping Advice retire date
; VAR(#,"MPCVL","VAL")=Mapping Category Value
; VAR(#,"MPCVL","XADT")="Mapping Category Value add date
; VAR(#,"MPCVL","XRDT")="Mapping Category Value retire date
; VAR(#,"MPGRP","VAL")=Map Group
; VAR(#,"MPGRP","XADT")=Map Group add date
; VAR(#,"MPGRP","XRDT")=Map Group retire date
; VAR(#,"MPPRI","VAL")=Map Priority
; VAR(#,"MPPRI","XADT")=Map Priority add date
; VAR(#,"MPPRI","XRDT")=Map Priority retire date
; VAR(#,"MPRUL","VAL")=Map Rule
; VAR(#,"MPRUL","XADT")=Map Rule add date
; VAR(#,"MPRUL","XRDT")=Map Rule retire date
; VAR(#,"MPTGN","VAL")=Map Target Name
; VAR(#,"MPTGN","XADT")=Map Target Name add date
; VAR(#,"MPTGN","XRDT")=Map Target Name retire date
; VAR(#,"MPTGT","VAL")=Map Target
; VAR(#,"MPTGT","XADT")=Map Target add date
; VAR(#,"MPTGT","XRDT")=Map Target retire date
;
NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BSTSAPIC D UNWIND^%ZTER" ; SAC 2009 2.2.3.17
;
K @OUT
;
N RESULT,SEARCH,NMID,SNAPDT,MAX,LOCAL,DEBUG,BSTSWS,BSTSR,BSTSD,X,%,%H,DAT,%D
;
I $G(DT)="" D DT^DICRW
S IN=$G(IN,"")
S SEARCH=$P(IN,U) I 'SEARCH Q "0^Invalid Concept Id"
S NMID=36
S SNAPDT=""
S MAX=100
S LOCAL=$P(IN,U,2),LOCAL=$S(LOCAL=2:"",1:"1")
S DAT=$P(IN,U,3)
S DEBUG=$P(IN,U,4),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("MAXRECS")=MAX
S BSTSWS("DAT")=DAT
;
;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 no results and local, try performing 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=""
I $D(RESULT)>1 D
. S BSTSD=$$ICDMAP(OUT,.BSTSWS,.RESULT)
S $P(BSTSR,U)=$S(BSTSD=0:0,(+BSTSR)>0:+BSTSR,1:1)
Q BSTSR
;
ICDMAP(OUT,BSTSWS,RESULT) ;EP - Set up mapping output information
;
;Input
; BSTSWS Array
; RESULT - [1]^[2]^[3]
; [1] - Concept ID
; [2] - DTS ID
; [3] - Description Id
;
;Output
; Function returns - # Records Returned
;
; VAR(#) - List of Records - See above call for format
;
N CNT,INMID,XNMID,MCNT,DFLD,%D
;
;Get the Namespace ID
S XNMID=$G(BSTSWS("NAMESPACEID"))
;
;Determine whether to return date fields
S DFLD=$G(BSTSWS("DAT")) S DFLD=1
;
;Pull return request
S INMID=$O(^BSTS(9002318.1,"B",XNMID,""))
;
S MCNT=0,CNT="" F S CNT=$O(RESULT(CNT)) Q:CNT="" D
. ;
. N CONC,CIEN,MIEN
. ;
. ;Get Concept IEN
. S CONC=$P(RESULT(CNT),U)
. S CIEN=$O(^BSTS(9002318.4,"C",NMID,CONC,"")) Q:CIEN=""
. ;
. ;Pull Mapping Information
. S (MCNT,MIEN)=0 F S MIEN=$O(^BSTS(9002318.4,CIEN,2,MIEN)) Q:'MIEN D
.. ;
.. NEW MG,MGRIN,MGROUT,DA,IENS,MP,MPRIN,MPROUT
.. NEW MT,MTRIN,MTROUT
.. ;
.. S DA(1)=CIEN,DA=MIEN,IENS=$$IENS^DILF(.DA)
.. ;
.. ;Pull Map Group
.. S MG=$$GET1^DIQ(9002318.42,IENS,.02,"I")
.. S MGRIN=$$GET1^DIQ(9002318.42,IENS,.03,"I")
.. S MGROUT=$$GET1^DIQ(9002318.42,IENS,.04,"I")
.. S MCNT=MCNT+1
.. S @OUT@(MCNT,"MPGRP","VAL")=MG
.. I 'DFLD S @OUT@(MCNT,"MPGRP","XADT")=MGRIN
.. I 'DFLD S @OUT@(MCNT,"MPGRP","XRDT")=MGROUT
.. ;
.. ;Pull Map Priority
.. S MP=$$GET1^DIQ(9002318.42,IENS,.05,"I")
.. S MPRIN=$$GET1^DIQ(9002318.42,IENS,.06,"I")
.. S MPROUT=$$GET1^DIQ(9002318.42,IENS,.07,"I")
.. S @OUT@(MCNT,"MPPRI","VAL")=MP
.. I 'DFLD S @OUT@(MCNT,"MPPRI","XADT")=MGRIN
.. I 'DFLD S @OUT@(MCNT,"MPPRI","XRDT")=MGROUT
.. ;
.. ;Pull Map Target
.. S MT=$$GET1^DIQ(9002318.42,IENS,.08,"I")
.. S MTRIN=$$GET1^DIQ(9002318.42,IENS,.09,"I")
.. S MTROUT=$$GET1^DIQ(9002318.42,IENS,.1,"I")
.. S @OUT@(MCNT,"MPTGT","VAL")=MT
.. I 'DFLD S @OUT@(MCNT,"MPTGT","XADT")=MTRIN
.. I 'DFLD S @OUT@(MCNT,"MPTGT","XRDT")=MTROUT
.. ;
.. ;Pull Map Advice
.. D
... NEW X,WP,II,MA,LINE,MARIN,MAROUT
... S X=$$GET1^DIQ(9002318.42,IENS,1,"","WP")
... S MA=""
... S II="" F S II=$O(WP(II)) Q:II="" S LINE=WP(II) I LINE]"" D
.... S MA=MA_$S(MA]"":" ",1:"")_LINE
... S MARIN=$$GET1^DIQ(9002318.42,IENS,5.01,"I")
... S MAROUT=$$GET1^DIQ(9002318.42,IENS,5.02,"I")
... S @OUT@(MCNT,"MPADV","VAL")=MA
... I 'DFLD S @OUT@(MCNT,"MPADV","XADT")=MARIN
... I 'DFLD S @OUT@(MCNT,"MPADV","XRDT")=MAROUT
.. ;
.. ;Pull Map Target Name
.. D
... NEW X,WP,II,MT,LINE,MTRIN,MTROUT
... S X=$$GET1^DIQ(9002318.42,IENS,2,"","WP")
... S MT=""
... S II="" F S II=$O(WP(II)) Q:II="" S LINE=WP(II) I LINE]"" D
.... S MT=MT_$S(MT]"":" ",1:"")_LINE
... S MTRIN=$$GET1^DIQ(9002318.42,IENS,5.05,"I")
... S MTROUT=$$GET1^DIQ(9002318.42,IENS,5.06,"I")
... S @OUT@(MCNT,"MPTGN","VAL")=MT
... I 'DFLD S @OUT@(MCNT,"MPTGN","XADT")=MTRIN
... I 'DFLD S @OUT@(MCNT,"MPTFN","XRDT")=MTROUT
.. ;
.. ;Pull Map Rule
.. D
... NEW X,WP,II,MR,LINE,MRRIN,MRROUT
... S X=$$GET1^DIQ(9002318.42,IENS,3,"","WP")
... S MR=""
... S II="" F S II=$O(WP(II)) Q:II="" S LINE=WP(II) I LINE]"" D
.... S MR=MR_$S(MR]"":" ",1:"")_LINE
... S MRRIN=$$GET1^DIQ(9002318.42,IENS,5.03,"I")
... S MRROUT=$$GET1^DIQ(9002318.42,IENS,5.04,"I")
... S @OUT@(MCNT,"MPRUL","VAL")=MR
... I 'DFLD S @OUT@(MCNT,"MPRUL","XADT")=MRRIN
... I 'DFLD S @OUT@(MCNT,"MPRUL","XRDT")=MRROUT
.. ;
.. ;Pull Map Category Value
.. D
... NEW X,WP,II,MCV,LINE,MCVRIN,MCVROUT
... S X=$$GET1^DIQ(9002318.42,IENS,4,"","WP")
... S MCV=""
... S II="" F S II=$O(WP(II)) Q:II="" S LINE=WP(II) I LINE]"" D
.... S MCV=MCV_$S(MCV]"":" ",1:"")_LINE
... S MCVRIN=$$GET1^DIQ(9002318.42,IENS,5.07,"I")
... S MCVROUT=$$GET1^DIQ(9002318.42,IENS,5.08,"I")
... S @OUT@(MCNT,"MPCVL","VAL")=MCV
... I 'DFLD S @OUT@(MCNT,"MPCVL","XADT")=MCVRIN
... I 'DFLD S @OUT@(MCNT,"MPCVL","XRDT")=MCVROUT
;
Q MCNT
;
SUBLST(OUT,IN) ;EP - Retrieve a subset listing
;
;Input
; OUT - Output variable/global to return information in (VAR)
; IN - P1 - The subset to list
; - P2 - The namespace id (default to 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
;
; BSTSBPRC - If 1, this was called from a background subset refresh
;
;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)
;
;
NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BSTSAPIC D UNWIND^%ZTER" ; SAC 2009 2.2.3.17
;
N SUB,LOCAL,DEBUG,BSTSWS,BSTSR,DLIST,SBCNT,SBNCNT,SLIST,%D,MFAIL,FWAIT,ABORT
;
K @OUT
;
I $G(DT)="" D DT^DICRW
S IN=$G(IN,"")
S SUB=$P(IN,U)
S NMID=$P(IN,U,2) S:NMID="" NMID=36 S:NMID=30 NMID=36
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("NAMESPACEID")=NMID
S BSTSWS("SUBSET")=SUB
S BSTSWS("BSTSBPRC")=$G(BSTSBPRC) K BSTSBPRC
;
;Set up scratch global
S DLIST=$NA(^TMP("BSTSCMCL",$J)) ;DTS Return List
S SLIST=$NA(^TMP("BSTSSUB",$J))
K @DLIST,@SLIST,@OUT
;
;Make DTS search call
S BSTSR=1
;
;Retrieve Failover Variables
I $G(BSTSWS("BSTSBPRC"))=1 D
. S MFAIL=$$FPARMS^BSTSVOFL()
. S FWAIT=$P(MFAIL,U,2)
. S MFAIL=$P(MFAIL,U)
;
;Perform DTS Search
I LOCAL'=1 S BSTSR=$$SUBLST^BSTSWSV(DLIST,.BSTSWS,DEBUG) S:+BSTSR $P(BSTSR,U)=2
;
;Perform local search
I $D(@DLIST)<10 D
. ;
. NEW CIEN,CTR,NMIEN
. ;
. ;Make sure we have a codeset (namespace)
. S NMIEN=$O(^BSTS(9002318.1,"B",NMID,"")) Q:NMIEN=""
. ;
. S CIEN="" F S CIEN=$O(^BSTS(9002318.4,"E",NMIEN,SUB,CIEN)) Q:CIEN="" D
.. NEW DTSID
.. S DTSID=$$GET1^DIQ(9002318.4,CIEN_",",.08,"I") Q:DTSID=""
.. S CTR=$G(CTR)+1,@DLIST@(CTR)=DTSID
;
;If no results and local, do a DTS lookup
I $D(@DLIST)<10,LOCAL=1 S BSTSR=$$SUBLST^BSTSWSV(DLIST,.BSTSWS,DEBUG) S:+BSTSR $P(BSTSR,U)=2
;
;If background process and failure quit
I $G(BSTSWS("BSTSBPRC"))=1,BSTSR="0^" Q BSTSR
;
M @SLIST=@DLIST
;
;Loop through results and retrieve info
S (ABORT,SBCNT)=0,SBNCNT=0 F S SBCNT=$O(@SLIST@(SBCNT)) Q:'SBCNT D Q:ABORT=1
. NEW CONC,DESC,DTSID,CIEN,PRE,OOD,PRDATA,TERM
. S DTSID=$G(@SLIST@(SBCNT)) Q:DTSID=""
. ;
. ;Pull the concept IEN
. S CIEN=$O(^BSTS(9002318.4,"D",NMID,DTSID,"")),CONC="",PRE="",TERM=""
. ;
. ;Pull the Concept ID
. I CIEN]"" S CONC=$$GET1^DIQ(9002318.4,CIEN_",",".02","E")
. ;
. ;Pull the Preferred Term Description Id
. S PRDATA="" I CIEN]"" S PRDATA=$$PDESC^BSTSSRCH(CIEN)
. ;
. ;See if the concept has already been updated
. S OOD=0 I CIEN]"" D
.. NEW LMOD
.. S LMOD=$$GET1^DIQ(9002318.4,CIEN_",",".12","I")
.. I LMOD="" S OOD=1 Q
.. I $$GET1^DIQ(9002318.4,CIEN_",",".11","I")="Y" S OOD=1
. ;
. ;If not found or out of date, retrieve detail from server
. S PRE=$P(PRDATA,U),TERM=$P(PRDATA,U,2)
. I CIEN=""!(CONC="")!(PRE="")!(OOD) D Q:ABORT
.. N STS,SBVAR,TRY,FCNT
.. ;
.. ;Foreground call
.. I $G(BSTSWS("BSTSBPRC"))="" D Q
... S STS=$$DTSLKP^BSTSAPI("SBVAR",DTSID_"^"_NMID_"^^^^1")
.. ;
.. ;Background call try until completed - Hang max of 12 times
.. S FCNT=0 F TRY=1:1:(12*MFAIL) D I +STS=2!(STS="0^") Q
... D RESET^BSTSWSV1 ;Make sure the link is on
... S STS=$$DTSLKP^BSTSAPI("SBVAR",DTSID_"^"_NMID_"^^^^1") I +STS=2!(STS="0^") Q ;Quit if success
... S FCNT=FCNT+1 I FCNT'<MFAIL D ;Fail handling
.... S ABORT=$$FAIL^BSTSVOFL(MFAIL,FWAIT,TRY,"SUBLST^BSTSAPIC - Processing DTSID: "_DTSID)
.... I ABORT=1 S ^XTMP("BSTSLCMP","QUIT")=1 D ELOG^BSTSVOFL("SUBSET REFRESH FAILED ON DETAIL LOOKUP: "_DTSID)
.... S FCNT=0
. ;
. ;Look again
. I CIEN="" S CIEN=$O(^BSTS(9002318.4,"D",NMID,DTSID,"")) Q:CIEN=""
. ;
. ;Pull concept id and preferred term description id
. S CONC=$$GET1^DIQ(9002318.4,CIEN_",",".02","E") Q:CONC=""
. S PRDATA=$$PDESC^BSTSSRCH(CIEN)
. S PRE=$P(PRDATA,U) Q:PRE=""
. S TERM=$P(PRDATA,U,2) Q:TERM=""
. S SBNCNT=SBNCNT+1,@OUT@(SBNCNT)=CONC_U_PRE_U_TERM
;
S $P(BSTSR,U)=$S(SBNCNT=0:0,(+BSTSR)>0:+BSTSR,1:1)
Q BSTSR
;
ERR ;
D ^%ZTER
Q
BSTSAPIC ;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 ;
MPADVICE(OUT,IN) ;EP - Returns ICD-10 mapping 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) - LOCAL - Pass 1 to perform local listing,
+6 ; Pass 2 for remote DTS listing
+7 ; - P3 (Optional) - Exclude add/retired date information
+8 ; - P4 (Optional) - DEBUG - Pass 1 to display debug information
+9 ;
+10 ;Output
+11 ; Function returns - [1]^[2]^[3]
+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(#) record is returned for a match
+19 ; Information returned is in the same (full detail) format
+20 ; as the detail returned for each record in the
+21 ; search API
+22 ;
+23 ; The VAR(#) list of records returns the mapping information on file for
+24 ; the specified concept. Multiple records per concept could be returned.
+25 ;
+26 ;Format:
+27 ; VAR(#,"MPADV","VAL")=Mapping Advice
+28 ; VAR(#,"MPADV","XADT")=Mapping Advice add date
+29 ; VAR(#,"MPADV","XRDT")=Mapping Advice retire date
+30 ; VAR(#,"MPCVL","VAL")=Mapping Category Value
+31 ; VAR(#,"MPCVL","XADT")="Mapping Category Value add date
+32 ; VAR(#,"MPCVL","XRDT")="Mapping Category Value retire date
+33 ; VAR(#,"MPGRP","VAL")=Map Group
+34 ; VAR(#,"MPGRP","XADT")=Map Group add date
+35 ; VAR(#,"MPGRP","XRDT")=Map Group retire date
+36 ; VAR(#,"MPPRI","VAL")=Map Priority
+37 ; VAR(#,"MPPRI","XADT")=Map Priority add date
+38 ; VAR(#,"MPPRI","XRDT")=Map Priority retire date
+39 ; VAR(#,"MPRUL","VAL")=Map Rule
+40 ; VAR(#,"MPRUL","XADT")=Map Rule add date
+41 ; VAR(#,"MPRUL","XRDT")=Map Rule retire date
+42 ; VAR(#,"MPTGN","VAL")=Map Target Name
+43 ; VAR(#,"MPTGN","XADT")=Map Target Name add date
+44 ; VAR(#,"MPTGN","XRDT")=Map Target Name retire date
+45 ; VAR(#,"MPTGT","VAL")=Map Target
+46 ; VAR(#,"MPTGT","XADT")=Map Target add date
+47 ; VAR(#,"MPTGT","XRDT")=Map Target retire date
+48 ;
+49 ; SAC 2009 2.2.3.17
NEW $ESTACK,$ETRAP
SET $ETRAP="D ERR^BSTSAPIC D UNWIND^%ZTER"
+50 ;
+51 KILL @OUT
+52 ;
+53 NEW RESULT,SEARCH,NMID,SNAPDT,MAX,LOCAL,DEBUG,BSTSWS,BSTSR,BSTSD,X,%,%H,DAT,%D
+54 ;
+55 IF $GET(DT)=""
DO DT^DICRW
+56 SET IN=$GET(IN,"")
+57 SET SEARCH=$PIECE(IN,U)
IF 'SEARCH
QUIT "0^Invalid Concept Id"
+58 SET NMID=36
+59 SET SNAPDT=""
+60 SET MAX=100
+61 SET LOCAL=$PIECE(IN,U,2)
SET LOCAL=$SELECT(LOCAL=2:"",1:"1")
+62 SET DAT=$PIECE(IN,U,3)
+63 SET DEBUG=$PIECE(IN,U,4)
SET DEBUG=$SELECT(DEBUG=1:"1",1:"")
+64 ;
+65 SET BSTSWS("SEARCH")=SEARCH
+66 SET BSTSWS("STYPE")="F"
+67 SET BSTSWS("NAMESPACEID")=NMID
+68 SET BSTSWS("SUBSET")=""
+69 SET BSTSWS("SNAPDT")=SNAPDT
+70 SET BSTSWS("MAXRECS")=MAX
+71 SET BSTSWS("DAT")=DAT
+72 ;
+73 ;Make DTS Lookup call
+74 SET BSTSR=1
+75 IF LOCAL'=1
SET BSTSR=$$CNCSR^BSTSWSV("RESULT",.BSTSWS,DEBUG)
IF +BSTSR
SET $PIECE(BSTSR,U)=2
+76 ;
+77 ;If no results, try performing local search
+78 IF $DATA(RESULT)<10
SET BSTSD=$$CNC^BSTSLKP("RESULT",.BSTSWS)
+79 ;
+80 ;If no results and local, try performing DTS lookup
+81 IF $DATA(RESULT)<10
IF LOCAL
SET BSTSR=$$CNCSR^BSTSWSV("RESULT",.BSTSWS,DEBUG)
IF +BSTSR
SET $PIECE(BSTSR,U)=2
+82 ;
+83 ;Get the detail for the record
+84 SET BSTSD=""
+85 IF $DATA(RESULT)>1
Begin DoDot:1
+86 SET BSTSD=$$ICDMAP(OUT,.BSTSWS,.RESULT)
End DoDot:1
+87 SET $PIECE(BSTSR,U)=$SELECT(BSTSD=0:0,(+BSTSR)>0:+BSTSR,1:1)
+88 QUIT BSTSR
+89 ;
ICDMAP(OUT,BSTSWS,RESULT) ;EP - Set up mapping output information
+1 ;
+2 ;Input
+3 ; BSTSWS Array
+4 ; RESULT - [1]^[2]^[3]
+5 ; [1] - Concept ID
+6 ; [2] - DTS ID
+7 ; [3] - Description Id
+8 ;
+9 ;Output
+10 ; Function returns - # Records Returned
+11 ;
+12 ; VAR(#) - List of Records - See above call for format
+13 ;
+14 NEW CNT,INMID,XNMID,MCNT,DFLD,%D
+15 ;
+16 ;Get the Namespace ID
+17 SET XNMID=$GET(BSTSWS("NAMESPACEID"))
+18 ;
+19 ;Determine whether to return date fields
+20 SET DFLD=$GET(BSTSWS("DAT"))
SET DFLD=1
+21 ;
+22 ;Pull return request
+23 SET INMID=$ORDER(^BSTS(9002318.1,"B",XNMID,""))
+24 ;
+25 SET MCNT=0
SET CNT=""
FOR
SET CNT=$ORDER(RESULT(CNT))
IF CNT=""
QUIT
Begin DoDot:1
+26 ;
+27 NEW CONC,CIEN,MIEN
+28 ;
+29 ;Get Concept IEN
+30 SET CONC=$PIECE(RESULT(CNT),U)
+31 SET CIEN=$ORDER(^BSTS(9002318.4,"C",NMID,CONC,""))
IF CIEN=""
QUIT
+32 ;
+33 ;Pull Mapping Information
+34 SET (MCNT,MIEN)=0
FOR
SET MIEN=$ORDER(^BSTS(9002318.4,CIEN,2,MIEN))
IF 'MIEN
QUIT
Begin DoDot:2
+35 ;
+36 NEW MG,MGRIN,MGROUT,DA,IENS,MP,MPRIN,MPROUT
+37 NEW MT,MTRIN,MTROUT
+38 ;
+39 SET DA(1)=CIEN
SET DA=MIEN
SET IENS=$$IENS^DILF(.DA)
+40 ;
+41 ;Pull Map Group
+42 SET MG=$$GET1^DIQ(9002318.42,IENS,.02,"I")
+43 SET MGRIN=$$GET1^DIQ(9002318.42,IENS,.03,"I")
+44 SET MGROUT=$$GET1^DIQ(9002318.42,IENS,.04,"I")
+45 SET MCNT=MCNT+1
+46 SET @OUT@(MCNT,"MPGRP","VAL")=MG
+47 IF 'DFLD
SET @OUT@(MCNT,"MPGRP","XADT")=MGRIN
+48 IF 'DFLD
SET @OUT@(MCNT,"MPGRP","XRDT")=MGROUT
+49 ;
+50 ;Pull Map Priority
+51 SET MP=$$GET1^DIQ(9002318.42,IENS,.05,"I")
+52 SET MPRIN=$$GET1^DIQ(9002318.42,IENS,.06,"I")
+53 SET MPROUT=$$GET1^DIQ(9002318.42,IENS,.07,"I")
+54 SET @OUT@(MCNT,"MPPRI","VAL")=MP
+55 IF 'DFLD
SET @OUT@(MCNT,"MPPRI","XADT")=MGRIN
+56 IF 'DFLD
SET @OUT@(MCNT,"MPPRI","XRDT")=MGROUT
+57 ;
+58 ;Pull Map Target
+59 SET MT=$$GET1^DIQ(9002318.42,IENS,.08,"I")
+60 SET MTRIN=$$GET1^DIQ(9002318.42,IENS,.09,"I")
+61 SET MTROUT=$$GET1^DIQ(9002318.42,IENS,.1,"I")
+62 SET @OUT@(MCNT,"MPTGT","VAL")=MT
+63 IF 'DFLD
SET @OUT@(MCNT,"MPTGT","XADT")=MTRIN
+64 IF 'DFLD
SET @OUT@(MCNT,"MPTGT","XRDT")=MTROUT
+65 ;
+66 ;Pull Map Advice
+67 Begin DoDot:3
+68 NEW X,WP,II,MA,LINE,MARIN,MAROUT
+69 SET X=$$GET1^DIQ(9002318.42,IENS,1,"","WP")
+70 SET MA=""
+71 SET II=""
FOR
SET II=$ORDER(WP(II))
IF II=""
QUIT
SET LINE=WP(II)
IF LINE]""
Begin DoDot:4
+72 SET MA=MA_$SELECT(MA]"":" ",1:"")_LINE
End DoDot:4
+73 SET MARIN=$$GET1^DIQ(9002318.42,IENS,5.01,"I")
+74 SET MAROUT=$$GET1^DIQ(9002318.42,IENS,5.02,"I")
+75 SET @OUT@(MCNT,"MPADV","VAL")=MA
+76 IF 'DFLD
SET @OUT@(MCNT,"MPADV","XADT")=MARIN
+77 IF 'DFLD
SET @OUT@(MCNT,"MPADV","XRDT")=MAROUT
End DoDot:3
+78 ;
+79 ;Pull Map Target Name
+80 Begin DoDot:3
+81 NEW X,WP,II,MT,LINE,MTRIN,MTROUT
+82 SET X=$$GET1^DIQ(9002318.42,IENS,2,"","WP")
+83 SET MT=""
+84 SET II=""
FOR
SET II=$ORDER(WP(II))
IF II=""
QUIT
SET LINE=WP(II)
IF LINE]""
Begin DoDot:4
+85 SET MT=MT_$SELECT(MT]"":" ",1:"")_LINE
End DoDot:4
+86 SET MTRIN=$$GET1^DIQ(9002318.42,IENS,5.05,"I")
+87 SET MTROUT=$$GET1^DIQ(9002318.42,IENS,5.06,"I")
+88 SET @OUT@(MCNT,"MPTGN","VAL")=MT
+89 IF 'DFLD
SET @OUT@(MCNT,"MPTGN","XADT")=MTRIN
+90 IF 'DFLD
SET @OUT@(MCNT,"MPTFN","XRDT")=MTROUT
End DoDot:3
+91 ;
+92 ;Pull Map Rule
+93 Begin DoDot:3
+94 NEW X,WP,II,MR,LINE,MRRIN,MRROUT
+95 SET X=$$GET1^DIQ(9002318.42,IENS,3,"","WP")
+96 SET MR=""
+97 SET II=""
FOR
SET II=$ORDER(WP(II))
IF II=""
QUIT
SET LINE=WP(II)
IF LINE]""
Begin DoDot:4
+98 SET MR=MR_$SELECT(MR]"":" ",1:"")_LINE
End DoDot:4
+99 SET MRRIN=$$GET1^DIQ(9002318.42,IENS,5.03,"I")
+100 SET MRROUT=$$GET1^DIQ(9002318.42,IENS,5.04,"I")
+101 SET @OUT@(MCNT,"MPRUL","VAL")=MR
+102 IF 'DFLD
SET @OUT@(MCNT,"MPRUL","XADT")=MRRIN
+103 IF 'DFLD
SET @OUT@(MCNT,"MPRUL","XRDT")=MRROUT
End DoDot:3
+104 ;
+105 ;Pull Map Category Value
+106 Begin DoDot:3
+107 NEW X,WP,II,MCV,LINE,MCVRIN,MCVROUT
+108 SET X=$$GET1^DIQ(9002318.42,IENS,4,"","WP")
+109 SET MCV=""
+110 SET II=""
FOR
SET II=$ORDER(WP(II))
IF II=""
QUIT
SET LINE=WP(II)
IF LINE]""
Begin DoDot:4
+111 SET MCV=MCV_$SELECT(MCV]"":" ",1:"")_LINE
End DoDot:4
+112 SET MCVRIN=$$GET1^DIQ(9002318.42,IENS,5.07,"I")
+113 SET MCVROUT=$$GET1^DIQ(9002318.42,IENS,5.08,"I")
+114 SET @OUT@(MCNT,"MPCVL","VAL")=MCV
+115 IF 'DFLD
SET @OUT@(MCNT,"MPCVL","XADT")=MCVRIN
+116 IF 'DFLD
SET @OUT@(MCNT,"MPCVL","XRDT")=MCVROUT
End DoDot:3
End DoDot:2
End DoDot:1
+117 ;
+118 QUIT MCNT
+119 ;
SUBLST(OUT,IN) ;EP - Retrieve a subset listing
+1 ;
+2 ;Input
+3 ; OUT - Output variable/global to return information in (VAR)
+4 ; IN - P1 - The subset to list
+5 ; - P2 - The namespace id (default to 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 ;
+10 ; BSTSBPRC - If 1, this was called from a background subset refresh
+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 ;
+21 ; SAC 2009 2.2.3.17
NEW $ESTACK,$ETRAP
SET $ETRAP="D ERR^BSTSAPIC D UNWIND^%ZTER"
+22 ;
+23 NEW SUB,LOCAL,DEBUG,BSTSWS,BSTSR,DLIST,SBCNT,SBNCNT,SLIST,%D,MFAIL,FWAIT,ABORT
+24 ;
+25 KILL @OUT
+26 ;
+27 IF $GET(DT)=""
DO DT^DICRW
+28 SET IN=$GET(IN,"")
+29 SET SUB=$PIECE(IN,U)
+30 SET NMID=$PIECE(IN,U,2)
IF NMID=""
SET NMID=36
IF NMID=30
SET NMID=36
+31 SET LOCAL=$PIECE(IN,U,3)
SET LOCAL=$SELECT(LOCAL=2:"",1:"1")
+32 SET DEBUG=$PIECE(IN,U,4)
SET DEBUG=$SELECT(DEBUG=1:"1",1:"")
+33 ;
+34 SET BSTSWS("NAMESPACEID")=NMID
+35 SET BSTSWS("SUBSET")=SUB
+36 SET BSTSWS("BSTSBPRC")=$GET(BSTSBPRC)
KILL BSTSBPRC
+37 ;
+38 ;Set up scratch global
+39 ;DTS Return List
SET DLIST=$NAME(^TMP("BSTSCMCL",$JOB))
+40 SET SLIST=$NAME(^TMP("BSTSSUB",$JOB))
+41 KILL @DLIST,@SLIST,@OUT
+42 ;
+43 ;Make DTS search call
+44 SET BSTSR=1
+45 ;
+46 ;Retrieve Failover Variables
+47 IF $GET(BSTSWS("BSTSBPRC"))=1
Begin DoDot:1
+48 SET MFAIL=$$FPARMS^BSTSVOFL()
+49 SET FWAIT=$PIECE(MFAIL,U,2)
+50 SET MFAIL=$PIECE(MFAIL,U)
End DoDot:1
+51 ;
+52 ;Perform DTS Search
+53 IF LOCAL'=1
SET BSTSR=$$SUBLST^BSTSWSV(DLIST,.BSTSWS,DEBUG)
IF +BSTSR
SET $PIECE(BSTSR,U)=2
+54 ;
+55 ;Perform local search
+56 IF $DATA(@DLIST)<10
Begin DoDot:1
+57 ;
+58 NEW CIEN,CTR,NMIEN
+59 ;
+60 ;Make sure we have a codeset (namespace)
+61 SET NMIEN=$ORDER(^BSTS(9002318.1,"B",NMID,""))
IF NMIEN=""
QUIT
+62 ;
+63 SET CIEN=""
FOR
SET CIEN=$ORDER(^BSTS(9002318.4,"E",NMIEN,SUB,CIEN))
IF CIEN=""
QUIT
Begin DoDot:2
+64 NEW DTSID
+65 SET DTSID=$$GET1^DIQ(9002318.4,CIEN_",",.08,"I")
IF DTSID=""
QUIT
+66 SET CTR=$GET(CTR)+1
SET @DLIST@(CTR)=DTSID
End DoDot:2
End DoDot:1
+67 ;
+68 ;If no results and local, do a DTS lookup
+69 IF $DATA(@DLIST)<10
IF LOCAL=1
SET BSTSR=$$SUBLST^BSTSWSV(DLIST,.BSTSWS,DEBUG)
IF +BSTSR
SET $PIECE(BSTSR,U)=2
+70 ;
+71 ;If background process and failure quit
+72 IF $GET(BSTSWS("BSTSBPRC"))=1
IF BSTSR="0^"
QUIT BSTSR
+73 ;
+74 MERGE @SLIST=@DLIST
+75 ;
+76 ;Loop through results and retrieve info
+77 SET (ABORT,SBCNT)=0
SET SBNCNT=0
FOR
SET SBCNT=$ORDER(@SLIST@(SBCNT))
IF 'SBCNT
QUIT
Begin DoDot:1
+78 NEW CONC,DESC,DTSID,CIEN,PRE,OOD,PRDATA,TERM
+79 SET DTSID=$GET(@SLIST@(SBCNT))
IF DTSID=""
QUIT
+80 ;
+81 ;Pull the concept IEN
+82 SET CIEN=$ORDER(^BSTS(9002318.4,"D",NMID,DTSID,""))
SET CONC=""
SET PRE=""
SET TERM=""
+83 ;
+84 ;Pull the Concept ID
+85 IF CIEN]""
SET CONC=$$GET1^DIQ(9002318.4,CIEN_",",".02","E")
+86 ;
+87 ;Pull the Preferred Term Description Id
+88 SET PRDATA=""
IF CIEN]""
SET PRDATA=$$PDESC^BSTSSRCH(CIEN)
+89 ;
+90 ;See if the concept has already been updated
+91 SET OOD=0
IF CIEN]""
Begin DoDot:2
+92 NEW LMOD
+93 SET LMOD=$$GET1^DIQ(9002318.4,CIEN_",",".12","I")
+94 IF LMOD=""
SET OOD=1
QUIT
+95 IF $$GET1^DIQ(9002318.4,CIEN_",",".11","I")="Y"
SET OOD=1
End DoDot:2
+96 ;
+97 ;If not found or out of date, retrieve detail from server
+98 SET PRE=$PIECE(PRDATA,U)
SET TERM=$PIECE(PRDATA,U,2)
+99 IF CIEN=""!(CONC="")!(PRE="")!(OOD)
Begin DoDot:2
+100 NEW STS,SBVAR,TRY,FCNT
+101 ;
+102 ;Foreground call
+103 IF $GET(BSTSWS("BSTSBPRC"))=""
Begin DoDot:3
+104 SET STS=$$DTSLKP^BSTSAPI("SBVAR",DTSID_"^"_NMID_"^^^^1")
End DoDot:3
QUIT
+105 ;
+106 ;Background call try until completed - Hang max of 12 times
+107 SET FCNT=0
FOR TRY=1:1:(12*MFAIL)
Begin DoDot:3
+108 ;Make sure the link is on
DO RESET^BSTSWSV1
+109 ;Quit if success
SET STS=$$DTSLKP^BSTSAPI("SBVAR",DTSID_"^"_NMID_"^^^^1")
IF +STS=2!(STS="0^")
QUIT
+110 ;Fail handling
SET FCNT=FCNT+1
IF FCNT'<MFAIL
Begin DoDot:4
+111 SET ABORT=$$FAIL^BSTSVOFL(MFAIL,FWAIT,TRY,"SUBLST^BSTSAPIC - Processing DTSID: "_DTSID)
+112 IF ABORT=1
SET ^XTMP("BSTSLCMP","QUIT")=1
DO ELOG^BSTSVOFL("SUBSET REFRESH FAILED ON DETAIL LOOKUP: "_DTSID)
+113 SET FCNT=0
End DoDot:4
End DoDot:3
IF +STS=2!(STS="0^")
QUIT
End DoDot:2
IF ABORT
QUIT
+114 ;
+115 ;Look again
+116 IF CIEN=""
SET CIEN=$ORDER(^BSTS(9002318.4,"D",NMID,DTSID,""))
IF CIEN=""
QUIT
+117 ;
+118 ;Pull concept id and preferred term description id
+119 SET CONC=$$GET1^DIQ(9002318.4,CIEN_",",".02","E")
IF CONC=""
QUIT
+120 SET PRDATA=$$PDESC^BSTSSRCH(CIEN)
+121 SET PRE=$PIECE(PRDATA,U)
IF PRE=""
QUIT
+122 SET TERM=$PIECE(PRDATA,U,2)
IF TERM=""
QUIT
+123 SET SBNCNT=SBNCNT+1
SET @OUT@(SBNCNT)=CONC_U_PRE_U_TERM
End DoDot:1
IF ABORT=1
QUIT
+124 ;
+125 SET $PIECE(BSTSR,U)=$SELECT(SBNCNT=0:0,(+BSTSR)>0:+BSTSR,1:1)
+126 QUIT BSTSR
+127 ;
ERR ;
+1 DO ^%ZTER
+2 QUIT
