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

BSTSDTS4.m

Go to the documentation of this file. 
  1. BSTSDTS4 ;GDIT/HS/BEE-Standard Terminology DTS Calls/Processing ; 5 Nov 2012  9:53 AM
  1.  ;;2.0;IHS STANDARD TERMINOLOGY;;Dec 01, 2016;Build 62
  1.  ;
  1.  Q
  1.  ;
  1. USEARCH(OUT,BSTSWS) ;EP - DTS4 UNIVERSE Search Call
  1.  ;
  1.  NEW STS,II,SEARCH,STYPE,SLIST,DLIST,OCNT,MAX,NMID,RES
  1.  ;
  1.  S SEARCH=$G(BSTSWS("SEARCH"))
  1.  S STYPE=$G(BSTSWS("STYPE"))
  1.  S SLIST=$NA(^TMP("BSTSSLST",$J)) ;Sorted List
  1.  S DLIST=$NA(^TMP("BSTSCMCL",$J)) ;DTS Return List
  1.  K @SLIST,@DLIST,@OUT
  1.  S OCNT=0
  1.  ;
  1.  ;Determine maximum to return
  1.  S MAX=$G(BSTSWS("MAXRECS")) S:MAX="" MAX=25
  1.  S NMID=$G(BSTSWS("NAMESPACEID")) S:NMID="" NMID=36 S:NMID=30 NMID=36
  1.  ;
  1.  ;Loop through each word
  1.  S BSTSWS("SEARCH")=SEARCH
  1.  ;
  1.  ;Perform DTS Search
  1.  I STYPE="S" S STS=$$TRMSRCH^BSTSCMCL(.BSTSWS,.RES) I $G(BSTSWS("DEBUG")) W !!,STS
  1.  ;
  1.  ;Perform DTS concept search
  1.  I STYPE="F" S STS=$$CONSRCH^BSTSCMCL(.BSTSWS,.RES) I $G(BSTSWS("DEBUG")) W !!,STS
  1.  ;
  1.  ;Loop through results and retrieve detail
  1.  M @SLIST=@DLIST
  1.  ;
  1.  I $O(@SLIST@(""))]"" S II="" F  S II=$O(@SLIST@(II)) Q:II=""  D
  1.  . NEW DTSID,DSCID,CONC,STATUS,CONCID,FSNT,FSND,REL,SYN
  1.  . NEW SUB,ERSLT,PRD,PRT,PRSY,ASSOC,MAPP
  1.  . ;
  1.  . S DTSID=$P(@SLIST@(II),U) Q:DTSID=""
  1.  . S DSCID=$P(@SLIST@(II),U,2) I STYPE="S",DSCID="" Q
  1.  . ;
  1.  . I $G(BSTSWS("DEBUG")) W !,"DTSID: ",DTSID
  1.  . ;
  1.  . ;Check for maximum
  1.  . I $G(OCNT)'<MAX Q
  1.  . ;
  1.  . ;Look for detail stored locally
  1.  . S CONC=$$CONC^BSTSDTS0(DTSID,.BSTSWS)
  1.  . ;
  1.  . I $G(BSTSWS("DEBUG")) W !!,"DETAIL CONC: ",CONC
  1.  . ;
  1.  . ;Now get the detail
  1.  . ;
  1.  . ;Not Found or in need of update
  1.  . S BSTSWS("DTSID")=DTSID
  1.  . ;
  1.  . ;Clear result file
  1.  . K @DLIST
  1.  . ;
  1.  . ;Get Detail for concept
  1.  . S STATUS=$$DETAIL^BSTSCMCL(.BSTSWS,.ERSLT)
  1.  . ;
  1.  . ;Concept ID
  1.  . S CONCID=$P($G(@DLIST@(1,"CONCEPTID")),U)
  1.  . ;
  1.  . ;FSN
  1.  . S FSNT=$P($G(@DLIST@(1,"FSN",1)),U)
  1.  . S FSND=""
  1.  . ;
  1.  . ;ISA
  1.  . S REL="" I $D(@DLIST@(1,"ISA")) D
  1.  .. NEW ICNT
  1.  .. S ICNT="" F  S ICNT=$O(@DLIST@(1,"ISA",ICNT)) Q:ICNT=""  D
  1.  ... NEW DTS,TRM
  1.  ... S DTS=$P($G(@DLIST@(1,"ISA",ICNT,0)),"^")
  1.  ... S TRM=$P($G(@DLIST@(1,"ISA",ICNT,1)),"^")
  1.  ... S REL=REL_$S(REL]"":$C(28),1:"")_DTS_$C(29)_TRM_$C(29)_"ISA"
  1.  . ;
  1.  . ;Child
  1.  . I $D(@DLIST@(1,"SUBC")) D
  1.  .. NEW ICNT
  1.  .. S ICNT="" F  S ICNT=$O(@DLIST@(1,"SUBC",ICNT)) Q:ICNT=""  D
  1.  ... NEW DTS,TRM
  1.  ... S DTS=$P($G(@DLIST@(1,"SUBC",ICNT,0)),"^")
  1.  ... S TRM=$P($G(@DLIST@(1,"SUBC",ICNT,1)),"^")
  1.  ... S REL=REL_$S(REL]"":$C(28),1:"")_DTS_$C(29)_TRM_$C(29)_"CHD"
  1.  . ;
  1.  . ;Synonyms
  1.  . S SYN="",(PRT,PRD)="",PRSY="S" I $D(@DLIST@(1,"SYN")) D
  1.  .. NEW ICNT
  1.  .. S ICNT="" F  S ICNT=$O(@DLIST@(1,"SYN",ICNT)) Q:ICNT=""  D
  1.  ... NEW TRM,DSC,PS
  1.  ... S TRM=$P($G(@DLIST@(1,"SYN",ICNT,1)),"^")
  1.  ... S PS=$P($G(@DLIST@(1,"SYN",ICNT,0)),"^",2)
  1.  ... S DSC=$P($G(@DLIST@(1,"SYN",ICNT,0)),"^")
  1.  ... ;
  1.  ... ;Look for FSN
  1.  ... I TRM]"",FSNT=TRM D  I $G(@DLIST@(1,"NAMESP"))=36 Q
  1.  .... S FSND=DSC
  1.  ... ;
  1.  ... I DSCID]"",DSCID=DSC D
  1.  .... S PRD=DSCID,PRT=TRM
  1.  .... S:PS=1 PRSY="P"
  1.  ... I DSCID="",PS=1 S PRD=DSC,PRT=TRM
  1.  ... S SYN=SYN_$S(SYN]"":$C(28),1:"")_DSC_$C(29)_TRM_$C(29)_$S(PS=1:"Preferred",1:"Synonym")
  1.  . ;
  1.  . ;Subsets
  1.  . S SUB="" I $D(@DLIST@(1,"SUB")) D
  1.  .. NEW ICNT
  1.  .. S ICNT="" F  S ICNT=$O(@DLIST@(1,"SUB",ICNT)) Q:ICNT=""  D
  1.  ... NEW SB
  1.  ... S SB=$P($G(@DLIST@(1,"SUB",ICNT)),U)
  1.  ... S SUB=SUB_$S(SUB]"":$C(28),1:"")_SB
  1.  . ;
  1.  . ;Associations
  1.  . S ASSOC="" I $D(@DLIST@(1,"ASC")) D
  1.  .. NEW ICNT
  1.  .. S ICNT="" F  S ICNT=$O(@DLIST@(1,"ASC",ICNT)) Q:ICNT=""  D
  1.  ... NEW ANODE,ASC,ASN,AST,CDIEN
  1.  ... S ANODE=$G(@DLIST@(1,"ASC",ICNT))
  1.  ... S ASC=$P(ANODE,U)
  1.  ... S ASN=$P(ANODE,U,2) Q:ASN=""
  1.  ... S CDIEN=$O(^BSTS(9002318.1,"B",ASN,"")) Q:CDIEN=""
  1.  ... S ASN=$$GET1^DIQ(9002318.1,CDIEN_",",.03,"I") Q:ASN=""
  1.  ... S AST=$P(ANODE,U,4) S:AST["[" ASC=""
  1.  ... S ASSOC=ASSOC_$S(ASSOC]"":$C(28),1:"")_ASN_": "_AST_$S(ASC="":"",1:" ["_ASC_"]")
  1.  . ;
  1.  . ;Mappings
  1.  . S MAPP="" I $D(@DLIST@(1,"NDC")) D
  1.  .. NEW ICNT
  1.  .. S ICNT="" F  S ICNT=$O(@DLIST@(1,"NDC",ICNT)) Q:ICNT=""  D
  1.  ... NEW NDC
  1.  ... S NDC=$P($G(@DLIST@(1,"NDC",ICNT)),U)
  1.  ... S MAPP=MAPP_$S(MAPP]"":$C(28),1:"")_"NDC: "_NDC
  1.  . ;
  1.  . ;VUID
  1.  . I $D(@DLIST@(1,"VUID")) D
  1.  .. NEW ICNT
  1.  .. S ICNT="" F  S ICNT=$O(@DLIST@(1,"VUID",ICNT)) Q:ICNT=""  D
  1.  ... NEW VUID
  1.  ... S VUID=$P($G(@DLIST@(1,"VUID",ICNT)),U)
  1.  ... S MAPP=MAPP_$S(MAPP]"":$C(28),1:"")_"VUID: "_VUID
  1.  . ;
  1.  . ;Save the detail
  1.  . S OCNT=OCNT+1
  1.  . S @OUT@(OCNT)=CONCID_U_PRT_U_PRD_U_FSNT_U_FSND_U_SYN_U_REL_U_DTSID_U_SUB_U_PRSY_U_ASSOC_U_MAPP
  1.  ;
  1.  K @DLIST,@SLIST
  1.  ;
  1.  Q STS
  1.  ;
  1. EQLAT(CONCDA,BSTSC,GL) ;Update Equivalent Concepts
  1.  ;
  1.  ;Called by UPDATE^BSTSDTS0
  1.  ;
  1.  Q:CONCDA=""
  1.  Q:GL=""
  1.  ;
  1.  NEW PC,LTNODE
  1.  ;
  1.  ;Clear out existing entries
  1.  D
  1.  . NEW EQLCNT
  1.  . S EQLCNT=0 F  S EQLCNT=$O(^BSTS(9002318.4,CONCDA,15,EQLCNT)) Q:'EQLCNT  D
  1.  .. NEW DA,DIK
  1.  .. S DA(1)=CONCDA,DA=EQLCNT
  1.  .. S DIK="^BSTS(9002318.4,"_DA(1)_",15," D ^DIK
  1.  ;
  1.  ;Now save Equivalent Concepts
  1.  I $D(@GL@("AEQ"))>1 D
  1.  . ;
  1.  . NEW EQLCNT
  1.  . S EQLCNT="" F  S EQLCNT=$O(@GL@("AEQ",EQLCNT)) Q:EQLCNT=""  D
  1.  .. ;
  1.  .. NEW DIC,DA,X,Y,IENS,DLAYGO,NODE,DTSID,LCONC,LATV,IREV,OREV
  1.  .. S NODE=$G(@GL@("AEQ",EQLCNT))
  1.  .. ;
  1.  .. ;Get laterality
  1.  .. S LATV=$P(NODE,U)
  1.  .. S LATV=$S(LATV="LeftVariant":"Left",LATV="RightVariant":"Right",LATV="RightAndLeftVariant":"Bilateral",LATV="BilateralVariant":"Bilateral",1:"")
  1.  .. Q:LATV=""
  1.  .. ;
  1.  .. S DTSID=$P(NODE,U,2) Q:DTSID=""  ;Get DTSID of equivalent
  1.  .. S LCONC=$P(NODE,U,3) Q:LCONC=""  ;Get CONC ID of equivalent
  1.  .. S IREV=$P(NODE,U,4)
  1.  .. S OREV=$P(NODE,U,5)
  1.  .. ;
  1.  .. S DA(1)=CONCDA
  1.  .. S DIC(0)="LX",DIC="^BSTS(9002318.4,"_DA(1)_",15,"
  1.  .. S X=LATV
  1.  .. S DLAYGO=9002318.415 D ^DIC
  1.  .. ;
  1.  .. ;Quit on fail
  1.  .. I +Y<0 Q
  1.  .. ;
  1.  .. ;Save remaining fields
  1.  .. S (DA)=+Y,IENS=$$IENS^DILF(.DA)
  1.  .. S BSTSC(9002318.415,IENS,".02")=LCONC
  1.  .. S BSTSC(9002318.415,IENS,".03")=DTSID
  1.  .. S BSTSC(9002318.415,IENS,".04")=$$DTS2FMDT^BSTSUTIL(IREV,1)
  1.  .. S BSTSC(9002318.415,IENS,".05")=$$DTS2FMDT^BSTSUTIL(OREV,1)
  1.  ;
  1.  ;Save equivalent information for lateralized concepts
  1.  ;
  1.  ;Clear out existing entries
  1.  S LTNODE=$G(^BSTS(9002318.4,CONCDA,16))
  1.  F PC=1:1:5 S $P(LTNODE,U,PC)=""
  1.  S ^BSTS(9002318.4,CONCDA,16)=LTNODE
  1.  ;
  1.  ;Set new values
  1.  I $D(@GL@("AIEQ"))>1 D
  1.  . NEW AIEQ,LATV
  1.  . S AIEQ=$G(@GL@("AIEQ",1))
  1.  . S LATV=$P(AIEQ,U)
  1.  . S BSTSC(9002318.4,CONCDA_",",16.01)=$S(LATV="LeftVariant":"Left",LATV="RightVariant":"Right",LATV="RightAndLeftVariant":"Bilateral",LATV="BilateralVariant":"Bilateral",1:"")
  1.  . S BSTSC(9002318.4,CONCDA_",",16.02)=$P(AIEQ,U,2)
  1.  . S BSTSC(9002318.4,CONCDA_",",16.03)=$P(AIEQ,U,3)
  1.  . S BSTSC(9002318.4,CONCDA_",",16.04)=$$DTS2FMDT^BSTSUTIL($P(AIEQ,U,4),1)
  1.  . S BSTSC(9002318.4,CONCDA_",",16.05)=$$DTS2FMDT^BSTSUTIL($P(AIEQ,U,5),1)
  1.  ;
  1.  Q
  1.  ;
  1.  ;BSTS*1.0*7;Added equivalency retrieval call
  1. EQLST(DLIST,ABORT,FCNT,STS,TRY,MFAIL,BSTSWS,ERSLT,CNT,SLIST,FWAIT) ;Get List Equivalency Concepts - 32780
  1.  NEW TR
  1.  K @DLIST
  1.  S ^XTMP("BSTSLCMP","STS")="Generating a list of equivalency concepts"
  1.  ;
  1.  F TR=1:1:60 D  I +STS Q
  1.  .S (ABORT,FCNT,STS)=0 F TRY=1:1:(12*MFAIL) D  I +STS!(STS="0^") Q
  1.  .. D RESET^BSTSWSV1  ;Reset the DTS link to on
  1.  .. S STS=$$ACODEQ^BSTSCMCL(.BSTSWS,.ERSLT) I +STS!(STS="0^") Q
  1.  .. S FCNT=FCNT+1 I FCNT'<MFAIL H FWAIT S FCNT=0 ;Fail handling
  1.  .. S FCNT=FCNT+1 I FCNT'<MFAIL D  ;Fail handling
  1.  ... S ABORT=$$FAIL^BSTSVOFL(MFAIL,FWAIT,TRY,"EQLST^BSTSDTS4 - Call to $$ACODEQ^BSTSCMCL")
  1.  ... I ABORT=1 S STS="0^" S ^XTMP("BSTSLCMP","QUIT")=1 D ELOG^BSTSVOFL("SNOMED EQUIVALENCY LOOKUP FAILED")
  1.  ... S FCNT=0
  1.  . I '+STS H TR
  1.  ;
  1.  ;Quit on failure
  1.  I +STS=0 Q 0
  1.  ;
  1.  ;Merge results to second scratch global
  1.  S CNT=0 F  S CNT=$O(@DLIST@(CNT)) Q:'CNT  D
  1.  . NEW DTSID,LAST
  1.  . S DTSID=$P(@DLIST@(CNT),U) Q:DTSID=""
  1.  . I $D(@SLIST@("DTS",DTSID)) Q
  1.  . S LAST=$O(@SLIST@("A"),-1)+1
  1.  . S @SLIST@(LAST)=@DLIST@(CNT)
  1.  . S @SLIST@("DTS",DTSID)=LAST
  1.  ;
  1.  Q +STS
  1.  ;
  1. SCODE(BSTSWS,ACODE) ;Retrieve list of concepts in subsets and refresh
  1.  ;
  1.  ;Input
  1.  ;BSTSWS - Array of connection settings
  1.  ;ACODE - If 1 do no process items here
  1.  ;
  1.  NEW SLIST,DLIST,SBCNT,MFAIL,FWAIT,TRY,FCNT,STS,ABORT,ERSLT,LENTRY,REVIN,X1,X2,X,RUNSTRT,TR
  1.  ;
  1.  S ACODE=$G(ACODE)
  1.  ;
  1.  ;Get the current date
  1.  S RUNSTRT=DT
  1.  ;
  1.  ;Get future date and set up revision in
  1.  S X1=DT,X2=2 D C^%DTC
  1.  S BSTSWS("REVIN")=$$FMTE^XLFDT(X,"7")
  1.  ;
  1.  S SLIST=$NA(^XTMP("BSTSLCMP")) ;Returned List
  1.  S DLIST=$NA(^TMP("BSTSCMCL",$J))
  1.  K @DLIST
  1.  ;
  1.  ;Retrieve Failover Variables
  1.  S MFAIL=$$FPARMS^BSTSVOFL()
  1.  S FWAIT=$P(MFAIL,U,2)
  1.  S MFAIL=$P(MFAIL,U)
  1.  ;
  1.  ;Get later date
  1.  S X1=DT,X2=60 D C^%DTC
  1.  ;
  1.  ;Set up Monitoring Global
  1.  I 'ACODE D
  1.  . S ^XTMP("BSTSLCMP",0)=X_U_DT_U_"SNOMED subset refresh update running - Getting list"
  1.  . K ^XTMP("BSTSLCMP","STS")
  1.  ;
  1.  ;Get list of concepts in subsets
  1.  S ^XTMP("BSTSLCMP","STS")="Generating a list of concepts in subsets"
  1.  ;
  1.  ;BSTS*1.0*8;Extra error handling
  1.  F TR=1:1:60 D  I +STS Q
  1.  .S (ABORT,FCNT,STS)=0 F TRY=1:1:(12*MFAIL) D  I +STS!(STS="0^") Q
  1.  .. D RESET^BSTSWSV1  ;Reset the DTS link to on
  1.  .. S STS=$$SCODE^BSTSCMCL(.BSTSWS,.ERSLT) I +STS!(STS="0^") Q
  1.  .. S FCNT=FCNT+1 I FCNT'<MFAIL H FWAIT S FCNT=0 ;Fail handling
  1.  .. S FCNT=FCNT+1 I FCNT'<MFAIL D  ;Fail handling
  1.  ... S ABORT=$$FAIL^BSTSVOFL(MFAIL,FWAIT,TRY,"SCODE^BSTSDTS4 - Call to $$SCODE^BSTSCMCL")
  1.  ... I ABORT=1 S STS="0^" S ^XTMP("BSTSLCMP","QUIT")=1 D ELOG^BSTSVOFL("SUBSET REFRESH LOOKUP FAILED")
  1.  ... S FCNT=0
  1.  . I '+STS H TR
  1.  ;
  1.  ;Quit on failure
  1.  I +STS=0 Q 0
  1.  ;
  1.  ;Merge results to second scratch global
  1.  S SBCNT=0 F  S SBCNT=$O(@DLIST@(SBCNT)) Q:'SBCNT  D
  1.  . NEW DTSID,LAST
  1.  . S DTSID=$P(@DLIST@(SBCNT),U) Q:DTSID=""
  1.  . I $D(@SLIST@("DTS",DTSID)) Q
  1.  . S LAST=$O(@SLIST@("A"),-1)+1
  1.  . S @SLIST@(LAST)=@DLIST@(SBCNT)
  1.  . S @SLIST@("DTS",DTSID)=LAST
  1.  ;
  1.  ;Do not process if part of main update
  1.  I ACODE Q 1
  1.  ;
  1.  ;Get last entry
  1.  S LENTRY=$O(@SLIST@("A"),-1)
  1.  ;
  1.  ;Now process each entry
  1.  S (ABORT,SBCNT)=0 F  S SBCNT=$O(@SLIST@(SBCNT)) Q:'SBCNT  D  Q:$D(^XTMP("BSTSLCMP","QUIT"))
  1.  . NEW DTSID,VAR,TRY,FCNT,CIEN,SKIP
  1.  . ;
  1.  . ;Get DTSId
  1.  . S DTSID=$P(@SLIST@(SBCNT),U) Q:DTSID=""
  1.  . ;
  1.  . ;Check last modified - skip if today
  1.  . S CIEN=$O(^BSTS(9002318.4,"D",36,DTSID,""))
  1.  . S SKIP=0 I CIEN]"" D
  1.  .. NEW OOD,LMOD
  1.  .. ;
  1.  .. ;Force update of out of date concepts
  1.  .. S OOD=$$GET1^DIQ(9002318.4,CIEN_",",.11,"I") I OOD="Y" Q
  1.  .. I $$GET1^DIQ(9002318.4,CIEN_",",.03,"I")="P" Q  ;Always process partial entries
  1.  .. S LMOD=$$GET1^DIQ(9002318.4,CIEN_",",.12,"I") I LMOD'<RUNSTRT S SKIP=1
  1.  .. I SKIP=1 S $P(@SLIST@(SBCNT),U,2)="Skipped"
  1.  . I SKIP Q
  1.  . ;
  1.  . S ^XTMP("BSTSLCMP","STS")="Getting concept details for DTSID: "_DTSID_" (Entry "_SBCNT_" of "_LENTRY_")"
  1.  . ;
  1.  . ;Pull detail from DTS - Hang max of 12 times
  1.  . S (ABORT,FCNT)=0 F TRY=1:1:(12*MFAIL) D  I +STS=2!(STS="0^") K @SLIST@(SBCNT) Q
  1.  .. D RESET^BSTSWSV1  ;Reset the DTS link to on
  1.  .. S STS=$$DTSLKP^BSTSAPI("VAR",DTSID_"^36^^^^1") I +STS=2!(STS="0^") Q
  1.  .. S FCNT=FCNT+1 I FCNT'<MFAIL D  ;Fail handling
  1.  ... S ABORT=$$FAIL^BSTSVOFL(MFAIL,FWAIT,TRY,"SCODE^BSTSDTS4 - Getting Update for entry: "_DTSID)
  1.  ... I ABORT=1 S ^XTMP("BSTSLCMP","QUIT")=1 D ELOG^BSTSVOFL("SNOMED SUBSET REFRESH FAILED ON DETAIL LOOKUP: "_DTSID)
  1.  ... S FCNT=0
  1.  ;
  1.  ;Clear status
  1.  K ^XTMP("BSTSLCMP","STS")
  1.  ;
  1.  I 'STS Q 0
  1.  Q 1