BSTSDTS4 ;GDIT/HS/BEE-Standard Terminology DTS Calls/Processing ; 5 Nov 2012 9:53 AM
;;2.0;IHS STANDARD TERMINOLOGY;;Dec 01, 2016;Build 62
;
Q
;
USEARCH(OUT,BSTSWS) ;EP - DTS4 UNIVERSE Search Call
;
NEW STS,II,SEARCH,STYPE,SLIST,DLIST,OCNT,MAX,NMID,RES
;
S SEARCH=$G(BSTSWS("SEARCH"))
S STYPE=$G(BSTSWS("STYPE"))
S SLIST=$NA(^TMP("BSTSSLST",$J)) ;Sorted List
S DLIST=$NA(^TMP("BSTSCMCL",$J)) ;DTS Return List
K @SLIST,@DLIST,@OUT
S OCNT=0
;
;Determine maximum to return
S MAX=$G(BSTSWS("MAXRECS")) S:MAX="" MAX=25
S NMID=$G(BSTSWS("NAMESPACEID")) S:NMID="" NMID=36 S:NMID=30 NMID=36
;
;Loop through each word
S BSTSWS("SEARCH")=SEARCH
;
;Perform DTS Search
I STYPE="S" S STS=$$TRMSRCH^BSTSCMCL(.BSTSWS,.RES) I $G(BSTSWS("DEBUG")) W !!,STS
;
;Perform DTS concept search
I STYPE="F" S STS=$$CONSRCH^BSTSCMCL(.BSTSWS,.RES) I $G(BSTSWS("DEBUG")) W !!,STS
;
;Loop through results and retrieve detail
M @SLIST=@DLIST
;
I $O(@SLIST@(""))]"" S II="" F S II=$O(@SLIST@(II)) Q:II="" D
. NEW DTSID,DSCID,CONC,STATUS,CONCID,FSNT,FSND,REL,SYN
. NEW SUB,ERSLT,PRD,PRT,PRSY,ASSOC,MAPP
. ;
. S DTSID=$P(@SLIST@(II),U) Q:DTSID=""
. S DSCID=$P(@SLIST@(II),U,2) I STYPE="S",DSCID="" Q
. ;
. I $G(BSTSWS("DEBUG")) W !,"DTSID: ",DTSID
. ;
. ;Check for maximum
. I $G(OCNT)'<MAX Q
. ;
. ;Look for detail stored locally
. S CONC=$$CONC^BSTSDTS0(DTSID,.BSTSWS)
. ;
. I $G(BSTSWS("DEBUG")) W !!,"DETAIL CONC: ",CONC
. ;
. ;Now get the detail
. ;
. ;Not Found or in need of update
. S BSTSWS("DTSID")=DTSID
. ;
. ;Clear result file
. K @DLIST
. ;
. ;Get Detail for concept
. S STATUS=$$DETAIL^BSTSCMCL(.BSTSWS,.ERSLT)
. ;
. ;Concept ID
. S CONCID=$P($G(@DLIST@(1,"CONCEPTID")),U)
. ;
. ;FSN
. S FSNT=$P($G(@DLIST@(1,"FSN",1)),U)
. S FSND=""
. ;
. ;ISA
. S REL="" I $D(@DLIST@(1,"ISA")) D
.. NEW ICNT
.. S ICNT="" F S ICNT=$O(@DLIST@(1,"ISA",ICNT)) Q:ICNT="" D
... NEW DTS,TRM
... S DTS=$P($G(@DLIST@(1,"ISA",ICNT,0)),"^")
... S TRM=$P($G(@DLIST@(1,"ISA",ICNT,1)),"^")
... S REL=REL_$S(REL]"":$C(28),1:"")_DTS_$C(29)_TRM_$C(29)_"ISA"
. ;
. ;Child
. I $D(@DLIST@(1,"SUBC")) D
.. NEW ICNT
.. S ICNT="" F S ICNT=$O(@DLIST@(1,"SUBC",ICNT)) Q:ICNT="" D
... NEW DTS,TRM
... S DTS=$P($G(@DLIST@(1,"SUBC",ICNT,0)),"^")
... S TRM=$P($G(@DLIST@(1,"SUBC",ICNT,1)),"^")
... S REL=REL_$S(REL]"":$C(28),1:"")_DTS_$C(29)_TRM_$C(29)_"CHD"
. ;
. ;Synonyms
. S SYN="",(PRT,PRD)="",PRSY="S" I $D(@DLIST@(1,"SYN")) D
.. NEW ICNT
.. S ICNT="" F S ICNT=$O(@DLIST@(1,"SYN",ICNT)) Q:ICNT="" D
... NEW TRM,DSC,PS
... S TRM=$P($G(@DLIST@(1,"SYN",ICNT,1)),"^")
... S PS=$P($G(@DLIST@(1,"SYN",ICNT,0)),"^",2)
... S DSC=$P($G(@DLIST@(1,"SYN",ICNT,0)),"^")
... ;
... ;Look for FSN
... I TRM]"",FSNT=TRM D I $G(@DLIST@(1,"NAMESP"))=36 Q
.... S FSND=DSC
... ;
... I DSCID]"",DSCID=DSC D
.... S PRD=DSCID,PRT=TRM
.... S:PS=1 PRSY="P"
... I DSCID="",PS=1 S PRD=DSC,PRT=TRM
... S SYN=SYN_$S(SYN]"":$C(28),1:"")_DSC_$C(29)_TRM_$C(29)_$S(PS=1:"Preferred",1:"Synonym")
. ;
. ;Subsets
. S SUB="" I $D(@DLIST@(1,"SUB")) D
.. NEW ICNT
.. S ICNT="" F S ICNT=$O(@DLIST@(1,"SUB",ICNT)) Q:ICNT="" D
... NEW SB
... S SB=$P($G(@DLIST@(1,"SUB",ICNT)),U)
... S SUB=SUB_$S(SUB]"":$C(28),1:"")_SB
. ;
. ;Associations
. S ASSOC="" I $D(@DLIST@(1,"ASC")) D
.. NEW ICNT
.. S ICNT="" F S ICNT=$O(@DLIST@(1,"ASC",ICNT)) Q:ICNT="" D
... NEW ANODE,ASC,ASN,AST,CDIEN
... S ANODE=$G(@DLIST@(1,"ASC",ICNT))
... S ASC=$P(ANODE,U)
... S ASN=$P(ANODE,U,2) Q:ASN=""
... S CDIEN=$O(^BSTS(9002318.1,"B",ASN,"")) Q:CDIEN=""
... S ASN=$$GET1^DIQ(9002318.1,CDIEN_",",.03,"I") Q:ASN=""
... S AST=$P(ANODE,U,4) S:AST["[" ASC=""
... S ASSOC=ASSOC_$S(ASSOC]"":$C(28),1:"")_ASN_": "_AST_$S(ASC="":"",1:" ["_ASC_"]")
. ;
. ;Mappings
. S MAPP="" I $D(@DLIST@(1,"NDC")) D
.. NEW ICNT
.. S ICNT="" F S ICNT=$O(@DLIST@(1,"NDC",ICNT)) Q:ICNT="" D
... NEW NDC
... S NDC=$P($G(@DLIST@(1,"NDC",ICNT)),U)
... S MAPP=MAPP_$S(MAPP]"":$C(28),1:"")_"NDC: "_NDC
. ;
. ;VUID
. I $D(@DLIST@(1,"VUID")) D
.. NEW ICNT
.. S ICNT="" F S ICNT=$O(@DLIST@(1,"VUID",ICNT)) Q:ICNT="" D
... NEW VUID
... S VUID=$P($G(@DLIST@(1,"VUID",ICNT)),U)
... S MAPP=MAPP_$S(MAPP]"":$C(28),1:"")_"VUID: "_VUID
. ;
. ;Save the detail
. S OCNT=OCNT+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
;
K @DLIST,@SLIST
;
Q STS
;
EQLAT(CONCDA,BSTSC,GL) ;Update Equivalent Concepts
;
;Called by UPDATE^BSTSDTS0
;
Q:CONCDA=""
Q:GL=""
;
NEW PC,LTNODE
;
;Clear out existing entries
D
. NEW EQLCNT
. S EQLCNT=0 F S EQLCNT=$O(^BSTS(9002318.4,CONCDA,15,EQLCNT)) Q:'EQLCNT D
.. NEW DA,DIK
.. S DA(1)=CONCDA,DA=EQLCNT
.. S DIK="^BSTS(9002318.4,"_DA(1)_",15," D ^DIK
;
;Now save Equivalent Concepts
I $D(@GL@("AEQ"))>1 D
. ;
. NEW EQLCNT
. S EQLCNT="" F S EQLCNT=$O(@GL@("AEQ",EQLCNT)) Q:EQLCNT="" D
.. ;
.. NEW DIC,DA,X,Y,IENS,DLAYGO,NODE,DTSID,LCONC,LATV,IREV,OREV
.. S NODE=$G(@GL@("AEQ",EQLCNT))
.. ;
.. ;Get laterality
.. S LATV=$P(NODE,U)
.. S LATV=$S(LATV="LeftVariant":"Left",LATV="RightVariant":"Right",LATV="RightAndLeftVariant":"Bilateral",LATV="BilateralVariant":"Bilateral",1:"")
.. Q:LATV=""
.. ;
.. S DTSID=$P(NODE,U,2) Q:DTSID="" ;Get DTSID of equivalent
.. S LCONC=$P(NODE,U,3) Q:LCONC="" ;Get CONC ID of equivalent
.. S IREV=$P(NODE,U,4)
.. S OREV=$P(NODE,U,5)
.. ;
.. S DA(1)=CONCDA
.. S DIC(0)="LX",DIC="^BSTS(9002318.4,"_DA(1)_",15,"
.. S X=LATV
.. S DLAYGO=9002318.415 D ^DIC
.. ;
.. ;Quit on fail
.. I +Y<0 Q
.. ;
.. ;Save remaining fields
.. S (DA)=+Y,IENS=$$IENS^DILF(.DA)
.. S BSTSC(9002318.415,IENS,".02")=LCONC
.. S BSTSC(9002318.415,IENS,".03")=DTSID
.. S BSTSC(9002318.415,IENS,".04")=$$DTS2FMDT^BSTSUTIL(IREV,1)
.. S BSTSC(9002318.415,IENS,".05")=$$DTS2FMDT^BSTSUTIL(OREV,1)
;
;Save equivalent information for lateralized concepts
;
;Clear out existing entries
S LTNODE=$G(^BSTS(9002318.4,CONCDA,16))
F PC=1:1:5 S $P(LTNODE,U,PC)=""
S ^BSTS(9002318.4,CONCDA,16)=LTNODE
;
;Set new values
I $D(@GL@("AIEQ"))>1 D
. NEW AIEQ,LATV
. S AIEQ=$G(@GL@("AIEQ",1))
. S LATV=$P(AIEQ,U)
. S BSTSC(9002318.4,CONCDA_",",16.01)=$S(LATV="LeftVariant":"Left",LATV="RightVariant":"Right",LATV="RightAndLeftVariant":"Bilateral",LATV="BilateralVariant":"Bilateral",1:"")
. S BSTSC(9002318.4,CONCDA_",",16.02)=$P(AIEQ,U,2)
. S BSTSC(9002318.4,CONCDA_",",16.03)=$P(AIEQ,U,3)
. S BSTSC(9002318.4,CONCDA_",",16.04)=$$DTS2FMDT^BSTSUTIL($P(AIEQ,U,4),1)
. S BSTSC(9002318.4,CONCDA_",",16.05)=$$DTS2FMDT^BSTSUTIL($P(AIEQ,U,5),1)
;
Q
;
;BSTS*1.0*7;Added equivalency retrieval call
EQLST(DLIST,ABORT,FCNT,STS,TRY,MFAIL,BSTSWS,ERSLT,CNT,SLIST,FWAIT) ;Get List Equivalency Concepts - 32780
NEW TR
K @DLIST
S ^XTMP("BSTSLCMP","STS")="Generating a list of equivalency concepts"
;
F TR=1:1:60 D I +STS Q
.S (ABORT,FCNT,STS)=0 F TRY=1:1:(12*MFAIL) D I +STS!(STS="0^") Q
.. D RESET^BSTSWSV1 ;Reset the DTS link to on
.. S STS=$$ACODEQ^BSTSCMCL(.BSTSWS,.ERSLT) I +STS!(STS="0^") Q
.. S FCNT=FCNT+1 I FCNT'<MFAIL H FWAIT S FCNT=0 ;Fail handling
.. S FCNT=FCNT+1 I FCNT'<MFAIL D ;Fail handling
... S ABORT=$$FAIL^BSTSVOFL(MFAIL,FWAIT,TRY,"EQLST^BSTSDTS4 - Call to $$ACODEQ^BSTSCMCL")
... I ABORT=1 S STS="0^" S ^XTMP("BSTSLCMP","QUIT")=1 D ELOG^BSTSVOFL("SNOMED EQUIVALENCY LOOKUP FAILED")
... S FCNT=0
. I '+STS H TR
;
;Quit on failure
I +STS=0 Q 0
;
;Merge results to second scratch global
S CNT=0 F S CNT=$O(@DLIST@(CNT)) Q:'CNT D
. NEW DTSID,LAST
. S DTSID=$P(@DLIST@(CNT),U) Q:DTSID=""
. I $D(@SLIST@("DTS",DTSID)) Q
. S LAST=$O(@SLIST@("A"),-1)+1
. S @SLIST@(LAST)=@DLIST@(CNT)
. S @SLIST@("DTS",DTSID)=LAST
;
Q +STS
;
SCODE(BSTSWS,ACODE) ;Retrieve list of concepts in subsets and refresh
;
;Input
;BSTSWS - Array of connection settings
;ACODE - If 1 do no process items here
;
NEW SLIST,DLIST,SBCNT,MFAIL,FWAIT,TRY,FCNT,STS,ABORT,ERSLT,LENTRY,REVIN,X1,X2,X,RUNSTRT,TR
;
S ACODE=$G(ACODE)
;
;Get the current date
S RUNSTRT=DT
;
;Get future date and set up revision in
S X1=DT,X2=2 D C^%DTC
S BSTSWS("REVIN")=$$FMTE^XLFDT(X,"7")
;
S SLIST=$NA(^XTMP("BSTSLCMP")) ;Returned List
S DLIST=$NA(^TMP("BSTSCMCL",$J))
K @DLIST
;
;Retrieve Failover Variables
S MFAIL=$$FPARMS^BSTSVOFL()
S FWAIT=$P(MFAIL,U,2)
S MFAIL=$P(MFAIL,U)
;
;Get later date
S X1=DT,X2=60 D C^%DTC
;
;Set up Monitoring Global
I 'ACODE D
. S ^XTMP("BSTSLCMP",0)=X_U_DT_U_"SNOMED subset refresh update running - Getting list"
. K ^XTMP("BSTSLCMP","STS")
;
;Get list of concepts in subsets
S ^XTMP("BSTSLCMP","STS")="Generating a list of concepts in subsets"
;
;BSTS*1.0*8;Extra error handling
F TR=1:1:60 D I +STS Q
.S (ABORT,FCNT,STS)=0 F TRY=1:1:(12*MFAIL) D I +STS!(STS="0^") Q
.. D RESET^BSTSWSV1 ;Reset the DTS link to on
.. S STS=$$SCODE^BSTSCMCL(.BSTSWS,.ERSLT) I +STS!(STS="0^") Q
.. S FCNT=FCNT+1 I FCNT'<MFAIL H FWAIT S FCNT=0 ;Fail handling
.. S FCNT=FCNT+1 I FCNT'<MFAIL D ;Fail handling
... S ABORT=$$FAIL^BSTSVOFL(MFAIL,FWAIT,TRY,"SCODE^BSTSDTS4 - Call to $$SCODE^BSTSCMCL")
... I ABORT=1 S STS="0^" S ^XTMP("BSTSLCMP","QUIT")=1 D ELOG^BSTSVOFL("SUBSET REFRESH LOOKUP FAILED")
... S FCNT=0
. I '+STS H TR
;
;Quit on failure
I +STS=0 Q 0
;
;Merge results to second scratch global
S SBCNT=0 F S SBCNT=$O(@DLIST@(SBCNT)) Q:'SBCNT D
. NEW DTSID,LAST
. S DTSID=$P(@DLIST@(SBCNT),U) Q:DTSID=""
. I $D(@SLIST@("DTS",DTSID)) Q
. S LAST=$O(@SLIST@("A"),-1)+1
. S @SLIST@(LAST)=@DLIST@(SBCNT)
. S @SLIST@("DTS",DTSID)=LAST
;
;Do not process if part of main update
I ACODE Q 1
;
;Get last entry
S LENTRY=$O(@SLIST@("A"),-1)
;
;Now process each entry
S (ABORT,SBCNT)=0 F S SBCNT=$O(@SLIST@(SBCNT)) Q:'SBCNT D Q:$D(^XTMP("BSTSLCMP","QUIT"))
. NEW DTSID,VAR,TRY,FCNT,CIEN,SKIP
. ;
. ;Get DTSId
. S DTSID=$P(@SLIST@(SBCNT),U) Q:DTSID=""
. ;
. ;Check last modified - skip if today
. S CIEN=$O(^BSTS(9002318.4,"D",36,DTSID,""))
. S SKIP=0 I CIEN]"" D
.. NEW OOD,LMOD
.. ;
.. ;Force update of out of date concepts
.. S OOD=$$GET1^DIQ(9002318.4,CIEN_",",.11,"I") I OOD="Y" Q
.. I $$GET1^DIQ(9002318.4,CIEN_",",.03,"I")="P" Q ;Always process partial entries
.. S LMOD=$$GET1^DIQ(9002318.4,CIEN_",",.12,"I") I LMOD'<RUNSTRT S SKIP=1
.. I SKIP=1 S $P(@SLIST@(SBCNT),U,2)="Skipped"
. I SKIP Q
. ;
. S ^XTMP("BSTSLCMP","STS")="Getting concept details for DTSID: "_DTSID_" (Entry "_SBCNT_" of "_LENTRY_")"
. ;
. ;Pull detail from DTS - Hang max of 12 times
. S (ABORT,FCNT)=0 F TRY=1:1:(12*MFAIL) D I +STS=2!(STS="0^") K @SLIST@(SBCNT) Q
.. D RESET^BSTSWSV1 ;Reset the DTS link to on
.. S STS=$$DTSLKP^BSTSAPI("VAR",DTSID_"^36^^^^1") I +STS=2!(STS="0^") Q
.. S FCNT=FCNT+1 I FCNT'<MFAIL D ;Fail handling
... S ABORT=$$FAIL^BSTSVOFL(MFAIL,FWAIT,TRY,"SCODE^BSTSDTS4 - Getting Update for entry: "_DTSID)
... I ABORT=1 S ^XTMP("BSTSLCMP","QUIT")=1 D ELOG^BSTSVOFL("SNOMED SUBSET REFRESH FAILED ON DETAIL LOOKUP: "_DTSID)
... S FCNT=0
;
;Clear status
K ^XTMP("BSTSLCMP","STS")
;
I 'STS Q 0
Q 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
+2 ;
+3 QUIT
+4 ;
USEARCH(OUT,BSTSWS) ;EP - DTS4 UNIVERSE Search Call
+1 ;
+2 NEW STS,II,SEARCH,STYPE,SLIST,DLIST,OCNT,MAX,NMID,RES
+3 ;
+4 SET SEARCH=$GET(BSTSWS("SEARCH"))
+5 SET STYPE=$GET(BSTSWS("STYPE"))
+6 ;Sorted List
SET SLIST=$NAME(^TMP("BSTSSLST",$JOB))
+7 ;DTS Return List
SET DLIST=$NAME(^TMP("BSTSCMCL",$JOB))
+8 KILL @SLIST,@DLIST,@OUT
+9 SET OCNT=0
+10 ;
+11 ;Determine maximum to return
+12 SET MAX=$GET(BSTSWS("MAXRECS"))
IF MAX=""
SET MAX=25
+13 SET NMID=$GET(BSTSWS("NAMESPACEID"))
IF NMID=""
SET NMID=36
IF NMID=30
SET NMID=36
+14 ;
+15 ;Loop through each word
+16 SET BSTSWS("SEARCH")=SEARCH
+17 ;
+18 ;Perform DTS Search
+19 IF STYPE="S"
SET STS=$$TRMSRCH^BSTSCMCL(.BSTSWS,.RES)
IF $GET(BSTSWS("DEBUG"))
WRITE !!,STS
+20 ;
+21 ;Perform DTS concept search
+22 IF STYPE="F"
SET STS=$$CONSRCH^BSTSCMCL(.BSTSWS,.RES)
IF $GET(BSTSWS("DEBUG"))
WRITE !!,STS
+23 ;
+24 ;Loop through results and retrieve detail
+25 MERGE @SLIST=@DLIST
+26 ;
+27 IF $ORDER(@SLIST@(""))]""
SET II=""
FOR
SET II=$ORDER(@SLIST@(II))
IF II=""
QUIT
Begin DoDot:1
+28 NEW DTSID,DSCID,CONC,STATUS,CONCID,FSNT,FSND,REL,SYN
+29 NEW SUB,ERSLT,PRD,PRT,PRSY,ASSOC,MAPP
+30 ;
+31 SET DTSID=$PIECE(@SLIST@(II),U)
IF DTSID=""
QUIT
+32 SET DSCID=$PIECE(@SLIST@(II),U,2)
IF STYPE="S"
IF DSCID=""
QUIT
+33 ;
+34 IF $GET(BSTSWS("DEBUG"))
WRITE !,"DTSID: ",DTSID
+35 ;
+36 ;Check for maximum
+37 IF $GET(OCNT)'<MAX
QUIT
+38 ;
+39 ;Look for detail stored locally
+40 SET CONC=$$CONC^BSTSDTS0(DTSID,.BSTSWS)
+41 ;
+42 IF $GET(BSTSWS("DEBUG"))
WRITE !!,"DETAIL CONC: ",CONC
+43 ;
+44 ;Now get the detail
+45 ;
+46 ;Not Found or in need of update
+47 SET BSTSWS("DTSID")=DTSID
+48 ;
+49 ;Clear result file
+50 KILL @DLIST
+51 ;
+52 ;Get Detail for concept
+53 SET STATUS=$$DETAIL^BSTSCMCL(.BSTSWS,.ERSLT)
+54 ;
+55 ;Concept ID
+56 SET CONCID=$PIECE($GET(@DLIST@(1,"CONCEPTID")),U)
+57 ;
+58 ;FSN
+59 SET FSNT=$PIECE($GET(@DLIST@(1,"FSN",1)),U)
+60 SET FSND=""
+61 ;
+62 ;ISA
+63 SET REL=""
IF $DATA(@DLIST@(1,"ISA"))
Begin DoDot:2
+64 NEW ICNT
+65 SET ICNT=""
FOR
SET ICNT=$ORDER(@DLIST@(1,"ISA",ICNT))
IF ICNT=""
QUIT
Begin DoDot:3
+66 NEW DTS,TRM
+67 SET DTS=$PIECE($GET(@DLIST@(1,"ISA",ICNT,0)),"^")
+68 SET TRM=$PIECE($GET(@DLIST@(1,"ISA",ICNT,1)),"^")
+69 SET REL=REL_$SELECT(REL]"":$CHAR(28),1:"")_DTS_$CHAR(29)_TRM_$CHAR(29)_"ISA"
End DoDot:3
End DoDot:2
+70 ;
+71 ;Child
+72 IF $DATA(@DLIST@(1,"SUBC"))
Begin DoDot:2
+73 NEW ICNT
+74 SET ICNT=""
FOR
SET ICNT=$ORDER(@DLIST@(1,"SUBC",ICNT))
IF ICNT=""
QUIT
Begin DoDot:3
+75 NEW DTS,TRM
+76 SET DTS=$PIECE($GET(@DLIST@(1,"SUBC",ICNT,0)),"^")
+77 SET TRM=$PIECE($GET(@DLIST@(1,"SUBC",ICNT,1)),"^")
+78 SET REL=REL_$SELECT(REL]"":$CHAR(28),1:"")_DTS_$CHAR(29)_TRM_$CHAR(29)_"CHD"
End DoDot:3
End DoDot:2
+79 ;
+80 ;Synonyms
+81 SET SYN=""
SET (PRT,PRD)=""
SET PRSY="S"
IF $DATA(@DLIST@(1,"SYN"))
Begin DoDot:2
+82 NEW ICNT
+83 SET ICNT=""
FOR
SET ICNT=$ORDER(@DLIST@(1,"SYN",ICNT))
IF ICNT=""
QUIT
Begin DoDot:3
+84 NEW TRM,DSC,PS
+85 SET TRM=$PIECE($GET(@DLIST@(1,"SYN",ICNT,1)),"^")
+86 SET PS=$PIECE($GET(@DLIST@(1,"SYN",ICNT,0)),"^",2)
+87 SET DSC=$PIECE($GET(@DLIST@(1,"SYN",ICNT,0)),"^")
+88 ;
+89 ;Look for FSN
+90 IF TRM]""
IF FSNT=TRM
Begin DoDot:4
+91 SET FSND=DSC
End DoDot:4
IF $GET(@DLIST@(1,"NAMESP"))=36
QUIT
+92 ;
+93 IF DSCID]""
IF DSCID=DSC
Begin DoDot:4
+94 SET PRD=DSCID
SET PRT=TRM
+95 IF PS=1
SET PRSY="P"
End DoDot:4
+96 IF DSCID=""
IF PS=1
SET PRD=DSC
SET PRT=TRM
+97 SET SYN=SYN_$SELECT(SYN]"":$CHAR(28),1:"")_DSC_$CHAR(29)_TRM_$CHAR(29)_$SELECT(PS=1:"Preferred",1:"Synonym")
End DoDot:3
End DoDot:2
+98 ;
+99 ;Subsets
+100 SET SUB=""
IF $DATA(@DLIST@(1,"SUB"))
Begin DoDot:2
+101 NEW ICNT
+102 SET ICNT=""
FOR
SET ICNT=$ORDER(@DLIST@(1,"SUB",ICNT))
IF ICNT=""
QUIT
Begin DoDot:3
+103 NEW SB
+104 SET SB=$PIECE($GET(@DLIST@(1,"SUB",ICNT)),U)
+105 SET SUB=SUB_$SELECT(SUB]"":$CHAR(28),1:"")_SB
End DoDot:3
End DoDot:2
+106 ;
+107 ;Associations
+108 SET ASSOC=""
IF $DATA(@DLIST@(1,"ASC"))
Begin DoDot:2
+109 NEW ICNT
+110 SET ICNT=""
FOR
SET ICNT=$ORDER(@DLIST@(1,"ASC",ICNT))
IF ICNT=""
QUIT
Begin DoDot:3
+111 NEW ANODE,ASC,ASN,AST,CDIEN
+112 SET ANODE=$GET(@DLIST@(1,"ASC",ICNT))
+113 SET ASC=$PIECE(ANODE,U)
+114 SET ASN=$PIECE(ANODE,U,2)
IF ASN=""
QUIT
+115 SET CDIEN=$ORDER(^BSTS(9002318.1,"B",ASN,""))
IF CDIEN=""
QUIT
+116 SET ASN=$$GET1^DIQ(9002318.1,CDIEN_",",.03,"I")
IF ASN=""
QUIT
+117 SET AST=$PIECE(ANODE,U,4)
IF AST["["
SET ASC=""
+118 SET ASSOC=ASSOC_$SELECT(ASSOC]"":$CHAR(28),1:"")_ASN_": "_AST_$SELECT(ASC="":"",1:" ["_ASC_"]")
End DoDot:3
End DoDot:2
+119 ;
+120 ;Mappings
+121 SET MAPP=""
IF $DATA(@DLIST@(1,"NDC"))
Begin DoDot:2
+122 NEW ICNT
+123 SET ICNT=""
FOR
SET ICNT=$ORDER(@DLIST@(1,"NDC",ICNT))
IF ICNT=""
QUIT
Begin DoDot:3
+124 NEW NDC
+125 SET NDC=$PIECE($GET(@DLIST@(1,"NDC",ICNT)),U)
+126 SET MAPP=MAPP_$SELECT(MAPP]"":$CHAR(28),1:"")_"NDC: "_NDC
End DoDot:3
End DoDot:2
+127 ;
+128 ;VUID
+129 IF $DATA(@DLIST@(1,"VUID"))
Begin DoDot:2
+130 NEW ICNT
+131 SET ICNT=""
FOR
SET ICNT=$ORDER(@DLIST@(1,"VUID",ICNT))
IF ICNT=""
QUIT
Begin DoDot:3
+132 NEW VUID
+133 SET VUID=$PIECE($GET(@DLIST@(1,"VUID",ICNT)),U)
+134 SET MAPP=MAPP_$SELECT(MAPP]"":$CHAR(28),1:"")_"VUID: "_VUID
End DoDot:3
End DoDot:2
+135 ;
+136 ;Save the detail
+137 SET OCNT=OCNT+1
+138 SET @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
End DoDot:1
+139 ;
+140 KILL @DLIST,@SLIST
+141 ;
+142 QUIT STS
+143 ;
EQLAT(CONCDA,BSTSC,GL) ;Update Equivalent Concepts
+1 ;
+2 ;Called by UPDATE^BSTSDTS0
+3 ;
+4 IF CONCDA=""
QUIT
+5 IF GL=""
QUIT
+6 ;
+7 NEW PC,LTNODE
+8 ;
+9 ;Clear out existing entries
+10 Begin DoDot:1
+11 NEW EQLCNT
+12 SET EQLCNT=0
FOR
SET EQLCNT=$ORDER(^BSTS(9002318.4,CONCDA,15,EQLCNT))
IF 'EQLCNT
QUIT
Begin DoDot:2
+13 NEW DA,DIK
+14 SET DA(1)=CONCDA
SET DA=EQLCNT
+15 SET DIK="^BSTS(9002318.4,"_DA(1)_",15,"
DO ^DIK
End DoDot:2
End DoDot:1
+16 ;
+17 ;Now save Equivalent Concepts
+18 IF $DATA(@GL@("AEQ"))>1
Begin DoDot:1
+19 ;
+20 NEW EQLCNT
+21 SET EQLCNT=""
FOR
SET EQLCNT=$ORDER(@GL@("AEQ",EQLCNT))
IF EQLCNT=""
QUIT
Begin DoDot:2
+22 ;
+23 NEW DIC,DA,X,Y,IENS,DLAYGO,NODE,DTSID,LCONC,LATV,IREV,OREV
+24 SET NODE=$GET(@GL@("AEQ",EQLCNT))
+25 ;
+26 ;Get laterality
+27 SET LATV=$PIECE(NODE,U)
+28 SET LATV=$SELECT(LATV="LeftVariant":"Left",LATV="RightVariant":"Right",LATV="RightAndLeftVariant":"Bilateral",LATV="BilateralVariant":"Bilateral",1:"")
+29 IF LATV=""
QUIT
+30 ;
+31 ;Get DTSID of equivalent
SET DTSID=$PIECE(NODE,U,2)
IF DTSID=""
QUIT
+32 ;Get CONC ID of equivalent
SET LCONC=$PIECE(NODE,U,3)
IF LCONC=""
QUIT
+33 SET IREV=$PIECE(NODE,U,4)
+34 SET OREV=$PIECE(NODE,U,5)
+35 ;
+36 SET DA(1)=CONCDA
+37 SET DIC(0)="LX"
SET DIC="^BSTS(9002318.4,"_DA(1)_",15,"
+38 SET X=LATV
+39 SET DLAYGO=9002318.415
DO ^DIC
+40 ;
+41 ;Quit on fail
+42 IF +Y<0
QUIT
+43 ;
+44 ;Save remaining fields
+45 SET (DA)=+Y
SET IENS=$$IENS^DILF(.DA)
+46 SET BSTSC(9002318.415,IENS,".02")=LCONC
+47 SET BSTSC(9002318.415,IENS,".03")=DTSID
+48 SET BSTSC(9002318.415,IENS,".04")=$$DTS2FMDT^BSTSUTIL(IREV,1)
+49 SET BSTSC(9002318.415,IENS,".05")=$$DTS2FMDT^BSTSUTIL(OREV,1)
End DoDot:2
End DoDot:1
+50 ;
+51 ;Save equivalent information for lateralized concepts
+52 ;
+53 ;Clear out existing entries
+54 SET LTNODE=$GET(^BSTS(9002318.4,CONCDA,16))
+55 FOR PC=1:1:5
SET $PIECE(LTNODE,U,PC)=""
+56 SET ^BSTS(9002318.4,CONCDA,16)=LTNODE
+57 ;
+58 ;Set new values
+59 IF $DATA(@GL@("AIEQ"))>1
Begin DoDot:1
+60 NEW AIEQ,LATV
+61 SET AIEQ=$GET(@GL@("AIEQ",1))
+62 SET LATV=$PIECE(AIEQ,U)
+63 SET BSTSC(9002318.4,CONCDA_",",16.01)=$SELECT(LATV="LeftVariant":"Left",LATV="RightVariant":"Right",LATV="RightAndLeftVariant":"Bilateral",LATV="BilateralVariant":"Bilateral",1:"")
+64 SET BSTSC(9002318.4,CONCDA_",",16.02)=$PIECE(AIEQ,U,2)
+65 SET BSTSC(9002318.4,CONCDA_",",16.03)=$PIECE(AIEQ,U,3)
+66 SET BSTSC(9002318.4,CONCDA_",",16.04)=$$DTS2FMDT^BSTSUTIL($PIECE(AIEQ,U,4),1)
+67 SET BSTSC(9002318.4,CONCDA_",",16.05)=$$DTS2FMDT^BSTSUTIL($PIECE(AIEQ,U,5),1)
End DoDot:1
+68 ;
+69 QUIT
+70 ;
+71 ;BSTS*1.0*7;Added equivalency retrieval call
EQLST(DLIST,ABORT,FCNT,STS,TRY,MFAIL,BSTSWS,ERSLT,CNT,SLIST,FWAIT) ;Get List Equivalency Concepts - 32780
+1 NEW TR
+2 KILL @DLIST
+3 SET ^XTMP("BSTSLCMP","STS")="Generating a list of equivalency concepts"
+4 ;
+5 FOR TR=1:1:60
Begin DoDot:1
+6 SET (ABORT,FCNT,STS)=0
FOR TRY=1:1:(12*MFAIL)
Begin DoDot:2
+7 ;Reset the DTS link to on
DO RESET^BSTSWSV1
+8 SET STS=$$ACODEQ^BSTSCMCL(.BSTSWS,.ERSLT)
IF +STS!(STS="0^")
QUIT
+9 ;Fail handling
SET FCNT=FCNT+1
IF FCNT'<MFAIL
HANG FWAIT
SET FCNT=0
+10 ;Fail handling
SET FCNT=FCNT+1
IF FCNT'<MFAIL
Begin DoDot:3
+11 SET ABORT=$$FAIL^BSTSVOFL(MFAIL,FWAIT,TRY,"EQLST^BSTSDTS4 - Call to $$ACODEQ^BSTSCMCL")
+12 IF ABORT=1
SET STS="0^"
SET ^XTMP("BSTSLCMP","QUIT")=1
DO ELOG^BSTSVOFL("SNOMED EQUIVALENCY LOOKUP FAILED")
+13 SET FCNT=0
End DoDot:3
End DoDot:2
IF +STS!(STS="0^")
QUIT
+14 IF '+STS
HANG TR
End DoDot:1
IF +STS
QUIT
+15 ;
+16 ;Quit on failure
+17 IF +STS=0
QUIT 0
+18 ;
+19 ;Merge results to second scratch global
+20 SET CNT=0
FOR
SET CNT=$ORDER(@DLIST@(CNT))
IF 'CNT
QUIT
Begin DoDot:1
+21 NEW DTSID,LAST
+22 SET DTSID=$PIECE(@DLIST@(CNT),U)
IF DTSID=""
QUIT
+23 IF $DATA(@SLIST@("DTS",DTSID))
QUIT
+24 SET LAST=$ORDER(@SLIST@("A"),-1)+1
+25 SET @SLIST@(LAST)=@DLIST@(CNT)
+26 SET @SLIST@("DTS",DTSID)=LAST
End DoDot:1
+27 ;
+28 QUIT +STS
+29 ;
SCODE(BSTSWS,ACODE) ;Retrieve list of concepts in subsets and refresh
+1 ;
+2 ;Input
+3 ;BSTSWS - Array of connection settings
+4 ;ACODE - If 1 do no process items here
+5 ;
+6 NEW SLIST,DLIST,SBCNT,MFAIL,FWAIT,TRY,FCNT,STS,ABORT,ERSLT,LENTRY,REVIN,X1,X2,X,RUNSTRT,TR
+7 ;
+8 SET ACODE=$GET(ACODE)
+9 ;
+10 ;Get the current date
+11 SET RUNSTRT=DT
+12 ;
+13 ;Get future date and set up revision in
+14 SET X1=DT
SET X2=2
DO C^%DTC
+15 SET BSTSWS("REVIN")=$$FMTE^XLFDT(X,"7")
+16 ;
+17 ;Returned List
SET SLIST=$NAME(^XTMP("BSTSLCMP"))
+18 SET DLIST=$NAME(^TMP("BSTSCMCL",$JOB))
+19 KILL @DLIST
+20 ;
+21 ;Retrieve Failover Variables
+22 SET MFAIL=$$FPARMS^BSTSVOFL()
+23 SET FWAIT=$PIECE(MFAIL,U,2)
+24 SET MFAIL=$PIECE(MFAIL,U)
+25 ;
+26 ;Get later date
+27 SET X1=DT
SET X2=60
DO C^%DTC
+28 ;
+29 ;Set up Monitoring Global
+30 IF 'ACODE
Begin DoDot:1
+31 SET ^XTMP("BSTSLCMP",0)=X_U_DT_U_"SNOMED subset refresh update running - Getting list"
+32 KILL ^XTMP("BSTSLCMP","STS")
End DoDot:1
+33 ;
+34 ;Get list of concepts in subsets
+35 SET ^XTMP("BSTSLCMP","STS")="Generating a list of concepts in subsets"
+36 ;
+37 ;BSTS*1.0*8;Extra error handling
+38 FOR TR=1:1:60
Begin DoDot:1
+39 SET (ABORT,FCNT,STS)=0
FOR TRY=1:1:(12*MFAIL)
Begin DoDot:2
+40 ;Reset the DTS link to on
DO RESET^BSTSWSV1
+41 SET STS=$$SCODE^BSTSCMCL(.BSTSWS,.ERSLT)
IF +STS!(STS="0^")
QUIT
+42 ;Fail handling
SET FCNT=FCNT+1
IF FCNT'<MFAIL
HANG FWAIT
SET FCNT=0
+43 ;Fail handling
SET FCNT=FCNT+1
IF FCNT'<MFAIL
Begin DoDot:3
+44 SET ABORT=$$FAIL^BSTSVOFL(MFAIL,FWAIT,TRY,"SCODE^BSTSDTS4 - Call to $$SCODE^BSTSCMCL")
+45 IF ABORT=1
SET STS="0^"
SET ^XTMP("BSTSLCMP","QUIT")=1
DO ELOG^BSTSVOFL("SUBSET REFRESH LOOKUP FAILED")
+46 SET FCNT=0
End DoDot:3
End DoDot:2
IF +STS!(STS="0^")
QUIT
+47 IF '+STS
HANG TR
End DoDot:1
IF +STS
QUIT
+48 ;
+49 ;Quit on failure
+50 IF +STS=0
QUIT 0
+51 ;
+52 ;Merge results to second scratch global
+53 SET SBCNT=0
FOR
SET SBCNT=$ORDER(@DLIST@(SBCNT))
IF 'SBCNT
QUIT
Begin DoDot:1
+54 NEW DTSID,LAST
+55 SET DTSID=$PIECE(@DLIST@(SBCNT),U)
IF DTSID=""
QUIT
+56 IF $DATA(@SLIST@("DTS",DTSID))
QUIT
+57 SET LAST=$ORDER(@SLIST@("A"),-1)+1
+58 SET @SLIST@(LAST)=@DLIST@(SBCNT)
+59 SET @SLIST@("DTS",DTSID)=LAST
End DoDot:1
+60 ;
+61 ;Do not process if part of main update
+62 IF ACODE
QUIT 1
+63 ;
+64 ;Get last entry
+65 SET LENTRY=$ORDER(@SLIST@("A"),-1)
+66 ;
+67 ;Now process each entry
+68 SET (ABORT,SBCNT)=0
FOR
SET SBCNT=$ORDER(@SLIST@(SBCNT))
IF 'SBCNT
QUIT
Begin DoDot:1
+69 NEW DTSID,VAR,TRY,FCNT,CIEN,SKIP
+70 ;
+71 ;Get DTSId
+72 SET DTSID=$PIECE(@SLIST@(SBCNT),U)
IF DTSID=""
QUIT
+73 ;
+74 ;Check last modified - skip if today
+75 SET CIEN=$ORDER(^BSTS(9002318.4,"D",36,DTSID,""))
+76 SET SKIP=0
IF CIEN]""
Begin DoDot:2
+77 NEW OOD,LMOD
+78 ;
+79 ;Force update of out of date concepts
+80 SET OOD=$$GET1^DIQ(9002318.4,CIEN_",",.11,"I")
IF OOD="Y"
QUIT
+81 ;Always process partial entries
IF $$GET1^DIQ(9002318.4,CIEN_",",.03,"I")="P"
QUIT
+82 SET LMOD=$$GET1^DIQ(9002318.4,CIEN_",",.12,"I")
IF LMOD'<RUNSTRT
SET SKIP=1
+83 IF SKIP=1
SET $PIECE(@SLIST@(SBCNT),U,2)="Skipped"
End DoDot:2
+84 IF SKIP
QUIT
+85 ;
+86 SET ^XTMP("BSTSLCMP","STS")="Getting concept details for DTSID: "_DTSID_" (Entry "_SBCNT_" of "_LENTRY_")"
+87 ;
+88 ;Pull detail from DTS - Hang max of 12 times
+89 SET (ABORT,FCNT)=0
FOR TRY=1:1:(12*MFAIL)
Begin DoDot:2
+90 ;Reset the DTS link to on
DO RESET^BSTSWSV1
+91 SET STS=$$DTSLKP^BSTSAPI("VAR",DTSID_"^36^^^^1")
IF +STS=2!(STS="0^")
QUIT
+92 ;Fail handling
SET FCNT=FCNT+1
IF FCNT'<MFAIL
Begin DoDot:3
+93 SET ABORT=$$FAIL^BSTSVOFL(MFAIL,FWAIT,TRY,"SCODE^BSTSDTS4 - Getting Update for entry: "_DTSID)
+94 IF ABORT=1
SET ^XTMP("BSTSLCMP","QUIT")=1
DO ELOG^BSTSVOFL("SNOMED SUBSET REFRESH FAILED ON DETAIL LOOKUP: "_DTSID)
+95 SET FCNT=0
End DoDot:3
End DoDot:2
IF +STS=2!(STS="0^")
KILL @SLIST@(SBCNT)
QUIT
End DoDot:1
IF $DATA(^XTMP("BSTSLCMP","QUIT"))
QUIT
+96 ;
+97 ;Clear status
+98 KILL ^XTMP("BSTSLCMP","STS")
+99 ;
+100 IF 'STS
QUIT 0
+101 QUIT 1
