Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: BSTSAPIC

BSTSAPIC.m

Go to the documentation of this file. 
  1. 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
  1.  ;
  1.  Q
  1.  ;
  1. MPADVICE(OUT,IN) ;EP - Returns ICD-10 mapping information for a specified Concept Id
  1.  ;
  1.  ;Input
  1.  ; OUT - Output variable/global to return information in (VAR)
  1.  ;  IN - P1 - The Concept Id to look up
  1.  ;     - P2 (Optional) - LOCAL - Pass 1 to perform local listing,
  1.  ;                       Pass 2 for remote DTS listing
  1.  ;     - P3 (Optional) - Exclude add/retired date information
  1.  ;     - P4 (Optional) - DEBUG - Pass 1 to display debug information
  1.  ;
  1.  ;Output
  1.  ; Function returns - [1]^[2]^[3]
  1.  ; [1] - 2:Remote information returned
  1.  ;       1:Local information returned
  1.  ;       0:No Information Returned
  1.  ; [2] - Primary Remote Error Message
  1.  ; [3] - Secondary Remote Error Message (if applicable)
  1.  ;
  1.  ; VAR(#) record is returned for a match
  1.  ; Information returned is in the same (full detail) format
  1.  ; as the detail returned for each record in the
  1.  ; search API
  1.  ;
  1.  ; The VAR(#) list of records returns the mapping information on file for
  1.  ; the specified concept. Multiple records per concept could be returned.
  1.  ;
  1.  ;Format:
  1.  ; VAR(#,"MPADV","VAL")=Mapping Advice
  1.  ; VAR(#,"MPADV","XADT")=Mapping Advice add date
  1.  ; VAR(#,"MPADV","XRDT")=Mapping Advice retire date
  1.  ; VAR(#,"MPCVL","VAL")=Mapping Category Value
  1.  ; VAR(#,"MPCVL","XADT")="Mapping Category Value add date
  1.  ; VAR(#,"MPCVL","XRDT")="Mapping Category Value retire date
  1.  ; VAR(#,"MPGRP","VAL")=Map Group
  1.  ; VAR(#,"MPGRP","XADT")=Map Group add date
  1.  ; VAR(#,"MPGRP","XRDT")=Map Group retire date
  1.  ; VAR(#,"MPPRI","VAL")=Map Priority
  1.  ; VAR(#,"MPPRI","XADT")=Map Priority add date
  1.  ; VAR(#,"MPPRI","XRDT")=Map Priority retire date
  1.  ; VAR(#,"MPRUL","VAL")=Map Rule
  1.  ; VAR(#,"MPRUL","XADT")=Map Rule add date
  1.  ; VAR(#,"MPRUL","XRDT")=Map Rule retire date
  1.  ; VAR(#,"MPTGN","VAL")=Map Target Name
  1.  ; VAR(#,"MPTGN","XADT")=Map Target Name add date
  1.  ; VAR(#,"MPTGN","XRDT")=Map Target Name retire date
  1.  ; VAR(#,"MPTGT","VAL")=Map Target
  1.  ; VAR(#,"MPTGT","XADT")=Map Target add date
  1.  ; VAR(#,"MPTGT","XRDT")=Map Target retire date
  1.  ;
  1.  NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BSTSAPIC D UNWIND^%ZTER" ; SAC 2009 2.2.3.17
  1.  ;
  1.  K @OUT
  1.  ;
  1.  N RESULT,SEARCH,NMID,SNAPDT,MAX,LOCAL,DEBUG,BSTSWS,BSTSR,BSTSD,X,%,%H,DAT,%D
  1.  ;
  1.  I $G(DT)="" D DT^DICRW
  1.  S IN=$G(IN,"")
  1.  S SEARCH=$P(IN,U) I 'SEARCH Q "0^Invalid Concept Id"
  1.  S NMID=36
  1.  S SNAPDT=""
  1.  S MAX=100
  1.  S LOCAL=$P(IN,U,2),LOCAL=$S(LOCAL=2:"",1:"1")
  1.  S DAT=$P(IN,U,3)
  1.  S DEBUG=$P(IN,U,4),DEBUG=$S(DEBUG=1:"1",1:"")
  1.  ;
  1.  S BSTSWS("SEARCH")=SEARCH
  1.  S BSTSWS("STYPE")="F"
  1.  S BSTSWS("NAMESPACEID")=NMID
  1.  S BSTSWS("SUBSET")=""
  1.  S BSTSWS("SNAPDT")=SNAPDT
  1.  S BSTSWS("MAXRECS")=MAX
  1.  S BSTSWS("DAT")=DAT
  1.  ;
  1.  ;Make DTS Lookup call
  1.  S BSTSR=1
  1.  I LOCAL'=1 S BSTSR=$$CNCSR^BSTSWSV("RESULT",.BSTSWS,DEBUG) S:+BSTSR $P(BSTSR,U)=2
  1.  ;
  1.  ;If no results, try performing local search
  1.  I $D(RESULT)<10 S BSTSD=$$CNC^BSTSLKP("RESULT",.BSTSWS)
  1.  ;
  1.  ;If no results and local, try performing DTS lookup
  1.  I $D(RESULT)<10,LOCAL S BSTSR=$$CNCSR^BSTSWSV("RESULT",.BSTSWS,DEBUG) S:+BSTSR $P(BSTSR,U)=2
  1.  ;
  1.  ;Get the detail for the record
  1.  S BSTSD=""
  1.  I $D(RESULT)>1 D
  1.  . S BSTSD=$$ICDMAP(OUT,.BSTSWS,.RESULT)
  1.  S $P(BSTSR,U)=$S(BSTSD=0:0,(+BSTSR)>0:+BSTSR,1:1)
  1.  Q BSTSR
  1.  ;
  1. ICDMAP(OUT,BSTSWS,RESULT) ;EP - Set up mapping output information
  1.  ;
  1.  ;Input
  1.  ; BSTSWS Array
  1.  ; RESULT - [1]^[2]^[3]
  1.  ;          [1] - Concept ID
  1.  ;          [2] - DTS ID
  1.  ;          [3] - Description Id
  1.  ;
  1.  ;Output
  1.  ; Function returns - # Records Returned
  1.  ;
  1.  ; VAR(#) - List of Records - See above call for format
  1.  ;
  1.  N CNT,INMID,XNMID,MCNT,DFLD,%D
  1.  ;
  1.  ;Get the Namespace ID
  1.  S XNMID=$G(BSTSWS("NAMESPACEID"))
  1.  ;
  1.  ;Determine whether to return date fields
  1.  S DFLD=$G(BSTSWS("DAT")) S DFLD=1
  1.  ;
  1.  ;Pull return request
  1.  S INMID=$O(^BSTS(9002318.1,"B",XNMID,""))
  1.  ;
  1.  S MCNT=0,CNT="" F  S CNT=$O(RESULT(CNT)) Q:CNT=""  D
  1.  . ;
  1.  . N CONC,CIEN,MIEN
  1.  . ;
  1.  . ;Get Concept IEN
  1.  . S CONC=$P(RESULT(CNT),U)
  1.  . S CIEN=$O(^BSTS(9002318.4,"C",NMID,CONC,"")) Q:CIEN=""
  1.  . ;
  1.  . ;Pull Mapping Information
  1.  . S (MCNT,MIEN)=0 F  S MIEN=$O(^BSTS(9002318.4,CIEN,2,MIEN)) Q:'MIEN  D
  1.  .. ;
  1.  .. NEW MG,MGRIN,MGROUT,DA,IENS,MP,MPRIN,MPROUT
  1.  .. NEW MT,MTRIN,MTROUT
  1.  .. ;
  1.  .. S DA(1)=CIEN,DA=MIEN,IENS=$$IENS^DILF(.DA)
  1.  .. ;
  1.  .. ;Pull Map Group
  1.  .. S MG=$$GET1^DIQ(9002318.42,IENS,.02,"I")
  1.  .. S MGRIN=$$GET1^DIQ(9002318.42,IENS,.03,"I")
  1.  .. S MGROUT=$$GET1^DIQ(9002318.42,IENS,.04,"I")
  1.  .. S MCNT=MCNT+1
  1.  .. S @OUT@(MCNT,"MPGRP","VAL")=MG
  1.  .. I 'DFLD S @OUT@(MCNT,"MPGRP","XADT")=MGRIN
  1.  .. I 'DFLD S @OUT@(MCNT,"MPGRP","XRDT")=MGROUT
  1.  .. ;
  1.  .. ;Pull Map Priority
  1.  .. S MP=$$GET1^DIQ(9002318.42,IENS,.05,"I")
  1.  .. S MPRIN=$$GET1^DIQ(9002318.42,IENS,.06,"I")
  1.  .. S MPROUT=$$GET1^DIQ(9002318.42,IENS,.07,"I")
  1.  .. S @OUT@(MCNT,"MPPRI","VAL")=MP
  1.  .. I 'DFLD S @OUT@(MCNT,"MPPRI","XADT")=MGRIN
  1.  .. I 'DFLD S @OUT@(MCNT,"MPPRI","XRDT")=MGROUT
  1.  .. ;
  1.  .. ;Pull Map Target
  1.  .. S MT=$$GET1^DIQ(9002318.42,IENS,.08,"I")
  1.  .. S MTRIN=$$GET1^DIQ(9002318.42,IENS,.09,"I")
  1.  .. S MTROUT=$$GET1^DIQ(9002318.42,IENS,.1,"I")
  1.  .. S @OUT@(MCNT,"MPTGT","VAL")=MT
  1.  .. I 'DFLD S @OUT@(MCNT,"MPTGT","XADT")=MTRIN
  1.  .. I 'DFLD S @OUT@(MCNT,"MPTGT","XRDT")=MTROUT
  1.  .. ;
  1.  .. ;Pull Map Advice
  1.  .. D
  1.  ... NEW X,WP,II,MA,LINE,MARIN,MAROUT
  1.  ... S X=$$GET1^DIQ(9002318.42,IENS,1,"","WP")
  1.  ... S MA=""
  1.  ... S II="" F  S II=$O(WP(II)) Q:II=""  S LINE=WP(II) I LINE]"" D
  1.  .... S MA=MA_$S(MA]"":" ",1:"")_LINE
  1.  ... S MARIN=$$GET1^DIQ(9002318.42,IENS,5.01,"I")
  1.  ... S MAROUT=$$GET1^DIQ(9002318.42,IENS,5.02,"I")
  1.  ... S @OUT@(MCNT,"MPADV","VAL")=MA
  1.  ... I 'DFLD S @OUT@(MCNT,"MPADV","XADT")=MARIN
  1.  ... I 'DFLD S @OUT@(MCNT,"MPADV","XRDT")=MAROUT
  1.  .. ;
  1.  .. ;Pull Map Target Name
  1.  .. D
  1.  ... NEW X,WP,II,MT,LINE,MTRIN,MTROUT
  1.  ... S X=$$GET1^DIQ(9002318.42,IENS,2,"","WP")
  1.  ... S MT=""
  1.  ... S II="" F  S II=$O(WP(II)) Q:II=""  S LINE=WP(II) I LINE]"" D
  1.  .... S MT=MT_$S(MT]"":" ",1:"")_LINE
  1.  ... S MTRIN=$$GET1^DIQ(9002318.42,IENS,5.05,"I")
  1.  ... S MTROUT=$$GET1^DIQ(9002318.42,IENS,5.06,"I")
  1.  ... S @OUT@(MCNT,"MPTGN","VAL")=MT
  1.  ... I 'DFLD S @OUT@(MCNT,"MPTGN","XADT")=MTRIN
  1.  ... I 'DFLD S @OUT@(MCNT,"MPTFN","XRDT")=MTROUT
  1.  .. ;
  1.  .. ;Pull Map Rule
  1.  .. D
  1.  ... NEW X,WP,II,MR,LINE,MRRIN,MRROUT
  1.  ... S X=$$GET1^DIQ(9002318.42,IENS,3,"","WP")
  1.  ... S MR=""
  1.  ... S II="" F  S II=$O(WP(II)) Q:II=""  S LINE=WP(II) I LINE]"" D
  1.  .... S MR=MR_$S(MR]"":" ",1:"")_LINE
  1.  ... S MRRIN=$$GET1^DIQ(9002318.42,IENS,5.03,"I")
  1.  ... S MRROUT=$$GET1^DIQ(9002318.42,IENS,5.04,"I")
  1.  ... S @OUT@(MCNT,"MPRUL","VAL")=MR
  1.  ... I 'DFLD S @OUT@(MCNT,"MPRUL","XADT")=MRRIN
  1.  ... I 'DFLD S @OUT@(MCNT,"MPRUL","XRDT")=MRROUT
  1.  .. ;
  1.  .. ;Pull Map Category Value
  1.  .. D
  1.  ... NEW X,WP,II,MCV,LINE,MCVRIN,MCVROUT
  1.  ... S X=$$GET1^DIQ(9002318.42,IENS,4,"","WP")
  1.  ... S MCV=""
  1.  ... S II="" F  S II=$O(WP(II)) Q:II=""  S LINE=WP(II) I LINE]"" D
  1.  .... S MCV=MCV_$S(MCV]"":" ",1:"")_LINE
  1.  ... S MCVRIN=$$GET1^DIQ(9002318.42,IENS,5.07,"I")
  1.  ... S MCVROUT=$$GET1^DIQ(9002318.42,IENS,5.08,"I")
  1.  ... S @OUT@(MCNT,"MPCVL","VAL")=MCV
  1.  ... I 'DFLD S @OUT@(MCNT,"MPCVL","XADT")=MCVRIN
  1.  ... I 'DFLD S @OUT@(MCNT,"MPCVL","XRDT")=MCVROUT
  1.  ;
  1.  Q MCNT
  1.  ;
  1. SUBLST(OUT,IN) ;EP - Retrieve a subset listing
  1.  ;
  1.  ;Input
  1.  ; OUT - Output variable/global to return information in (VAR)
  1.  ;  IN - P1 - The subset to list
  1.  ;     - P2 - The namespace id (default to SNOMED US EXT '36')
  1.  ;     - P3 (Optional) - LOCAL - Pass 1 or blank to perform local listing,
  1.  ;                       Pass 2 for remote DTS listing
  1.  ;     - P4 (Optional) - DEBUG - Pass 1 to display debug information
  1.  ;
  1.  ; BSTSBPRC - If 1, this was called from a background subset refresh
  1.  ;
  1.  ;Output
  1.  ; Function returns - [1]^[2]^[3]
  1.  ; [1] - 2:Remote information returned
  1.  ;       1:Local information returned
  1.  ;       0:No Information Returned
  1.  ; [2] - Primary Remote Error Message
  1.  ; [3] - Secondary Remote Error Message (if applicable)
  1.  ;
  1.  ;
  1.  NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BSTSAPIC D UNWIND^%ZTER" ; SAC 2009 2.2.3.17
  1.  ;
  1.  N SUB,LOCAL,DEBUG,BSTSWS,BSTSR,DLIST,SBCNT,SBNCNT,SLIST,%D,MFAIL,FWAIT,ABORT
  1.  ;
  1.  K @OUT
  1.  ;
  1.  I $G(DT)="" D DT^DICRW
  1.  S IN=$G(IN,"")
  1.  S SUB=$P(IN,U)
  1.  S NMID=$P(IN,U,2) S:NMID="" NMID=36 S:NMID=30 NMID=36
  1.  S LOCAL=$P(IN,U,3),LOCAL=$S(LOCAL=2:"",1:"1")
  1.  S DEBUG=$P(IN,U,4),DEBUG=$S(DEBUG=1:"1",1:"")
  1.  ;
  1.  S BSTSWS("NAMESPACEID")=NMID
  1.  S BSTSWS("SUBSET")=SUB
  1.  S BSTSWS("BSTSBPRC")=$G(BSTSBPRC) K BSTSBPRC
  1.  ;
  1.  ;Set up scratch global
  1.  S DLIST=$NA(^TMP("BSTSCMCL",$J)) ;DTS Return List
  1.  S SLIST=$NA(^TMP("BSTSSUB",$J))
  1.  K @DLIST,@SLIST,@OUT
  1.  ;
  1.  ;Make DTS search call
  1.  S BSTSR=1
  1.  ;
  1.  ;Retrieve Failover Variables
  1.  I $G(BSTSWS("BSTSBPRC"))=1 D
  1.  . S MFAIL=$$FPARMS^BSTSVOFL()
  1.  . S FWAIT=$P(MFAIL,U,2)
  1.  . S MFAIL=$P(MFAIL,U)
  1.  ;
  1.  ;Perform DTS Search
  1.  I LOCAL'=1 S BSTSR=$$SUBLST^BSTSWSV(DLIST,.BSTSWS,DEBUG) S:+BSTSR $P(BSTSR,U)=2
  1.  ;
  1.  ;Perform local search
  1.  I $D(@DLIST)<10 D
  1.  . ;
  1.  . NEW CIEN,CTR,NMIEN
  1.  . ;
  1.  . ;Make sure we have a codeset (namespace)
  1.  . S NMIEN=$O(^BSTS(9002318.1,"B",NMID,"")) Q:NMIEN=""
  1.  . ;
  1.  . S CIEN="" F  S CIEN=$O(^BSTS(9002318.4,"E",NMIEN,SUB,CIEN)) Q:CIEN=""  D
  1.  .. NEW DTSID
  1.  .. S DTSID=$$GET1^DIQ(9002318.4,CIEN_",",.08,"I") Q:DTSID=""
  1.  .. S CTR=$G(CTR)+1,@DLIST@(CTR)=DTSID
  1.  ;
  1.  ;If no results and local, do a DTS lookup
  1.  I $D(@DLIST)<10,LOCAL=1 S BSTSR=$$SUBLST^BSTSWSV(DLIST,.BSTSWS,DEBUG) S:+BSTSR $P(BSTSR,U)=2
  1.  ;
  1.  ;If background process and failure quit
  1.  I $G(BSTSWS("BSTSBPRC"))=1,BSTSR="0^" Q BSTSR
  1.  ;
  1.  M @SLIST=@DLIST
  1.  ;
  1.  ;Loop through results and retrieve info
  1.  S (ABORT,SBCNT)=0,SBNCNT=0 F  S SBCNT=$O(@SLIST@(SBCNT)) Q:'SBCNT  D  Q:ABORT=1
  1.  . NEW CONC,DESC,DTSID,CIEN,PRE,OOD,PRDATA,TERM
  1.  . S DTSID=$G(@SLIST@(SBCNT)) Q:DTSID=""
  1.  . ;
  1.  . ;Pull the concept IEN
  1.  . S CIEN=$O(^BSTS(9002318.4,"D",NMID,DTSID,"")),CONC="",PRE="",TERM=""
  1.  . ;
  1.  . ;Pull the Concept ID
  1.  . I CIEN]"" S CONC=$$GET1^DIQ(9002318.4,CIEN_",",".02","E")
  1.  . ;
  1.  . ;Pull the Preferred Term Description Id
  1.  . S PRDATA="" I CIEN]"" S PRDATA=$$PDESC^BSTSSRCH(CIEN)
  1.  . ;
  1.  . ;See if the concept has already been updated
  1.  . S OOD=0 I CIEN]"" D
  1.  .. NEW LMOD
  1.  .. S LMOD=$$GET1^DIQ(9002318.4,CIEN_",",".12","I")
  1.  .. I LMOD="" S OOD=1 Q
  1.  .. I $$GET1^DIQ(9002318.4,CIEN_",",".11","I")="Y" S OOD=1
  1.  . ;
  1.  . ;If not found or out of date, retrieve detail from server
  1.  . S PRE=$P(PRDATA,U),TERM=$P(PRDATA,U,2)
  1.  . I CIEN=""!(CONC="")!(PRE="")!(OOD) D  Q:ABORT
  1.  .. N STS,SBVAR,TRY,FCNT
  1.  .. ;
  1.  .. ;Foreground call
  1.  .. I $G(BSTSWS("BSTSBPRC"))="" D  Q
  1.  ... S STS=$$DTSLKP^BSTSAPI("SBVAR",DTSID_"^"_NMID_"^^^^1")
  1.  .. ;
  1.  .. ;Background call try until completed - Hang max of 12 times
  1.  .. S FCNT=0 F TRY=1:1:(12*MFAIL) D  I +STS=2!(STS="0^") Q
  1.  ... D RESET^BSTSWSV1 ;Make sure the link is on
  1.  ... S STS=$$DTSLKP^BSTSAPI("SBVAR",DTSID_"^"_NMID_"^^^^1") I +STS=2!(STS="0^") Q  ;Quit if success
  1.  ... S FCNT=FCNT+1 I FCNT'<MFAIL D  ;Fail handling
  1.  .... S ABORT=$$FAIL^BSTSVOFL(MFAIL,FWAIT,TRY,"SUBLST^BSTSAPIC - Processing DTSID: "_DTSID)
  1.  .... I ABORT=1 S ^XTMP("BSTSLCMP","QUIT")=1 D ELOG^BSTSVOFL("SUBSET REFRESH FAILED ON DETAIL LOOKUP: "_DTSID)
  1.  .... S FCNT=0
  1.  . ;
  1.  . ;Look again
  1.  . I CIEN="" S CIEN=$O(^BSTS(9002318.4,"D",NMID,DTSID,"")) Q:CIEN=""
  1.  . ;
  1.  . ;Pull concept id and preferred term description id
  1.  . S CONC=$$GET1^DIQ(9002318.4,CIEN_",",".02","E") Q:CONC=""
  1.  . S PRDATA=$$PDESC^BSTSSRCH(CIEN)
  1.  . S PRE=$P(PRDATA,U) Q:PRE=""
  1.  . S TERM=$P(PRDATA,U,2) Q:TERM=""
  1.  . S SBNCNT=SBNCNT+1,@OUT@(SBNCNT)=CONC_U_PRE_U_TERM
  1.  ;
  1.  S $P(BSTSR,U)=$S(SBNCNT=0:0,(+BSTSR)>0:+BSTSR,1:1)
  1.  Q BSTSR
  1.  ;
  1. ERR ;
  1.  D ^%ZTER
  1.  Q