BSTSDTS5 ;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
;
CDST ;EP - Update IHS Standard Terminology Codeset
;
;Tasked by BSTSVRSC, tab CCHK. Var NMIEN should be set
;
S NMIEN=$G(NMIEN) I NMIEN="" Q
;
;Lock
L +^BSTS(9002318.1,0):0 E Q
;
NEW BSTSWS,RESULT,NMID,STS,VRSN,BSTS,ICONC,CIEN,X1,X2,X,NVIEN,NVLCL,MFAIL,FWAIT,TRY,FCNT,ABORT,TRY
;
;Get ext codeset Id
S NMID=$$GET1^DIQ(9002318.1,NMIEN_",",.01,"I") I NMID="" G XCDST
;
;Update LAST VERSION CHECK so proc won't keep getting called
S BSTS(9002318.1,NMIEN_",",.05)=DT
D FILE^DIE("","BSTS","ERROR")
;
;Online?
S STS="" F TRY=1:1:60 D I +STS=2 Q
. D RESET^BSTSWSV1 ;Reset the DTS link to on
. S STS=$$VERSIONS^BSTSAPI("VRSN") ;Try
. I +STS'=2 H TRY
I +STS'=2 G XCDST
;
;Reset Monitoring GBL
K ^XTMP("BSTSLCMP")
;
;Get later date
S X1=DT,X2=60 D C^%DTC
;
;Set Monitoring GBL
S ^XTMP("BSTSLCMP",0)=X_U_DT_U_"Cache refresh running for "_NMID
;
;Mark as OOD
S ^XTMP("BSTSLCMP","STS")="Marking entries as out of date"
S ICONC="" F S ICONC=$O(^BSTS(9002318.4,"C",NMID,ICONC)) Q:ICONC="" S CIEN="" F S CIEN=$O(^BSTS(9002318.4,"C",NMID,ICONC,CIEN)) Q:CIEN="" D
. NEW BSTS,ERR,LMOD
. ;
. ;Mark OOD
. S BSTS(9002318.4,CIEN_",",".12")=""
. D FILE^DIE("","BSTS","ERR")
;
;Make call to proc
S ^XTMP("BSTSLCMP","STS")="Performing Refresh from DTS"
S BSTSWS("NAMESPACEID")=NMID
S BSTSWS("REVIN")=$$FMTE^XLFDT(DT,"7")
S STS=$$CSTMCDST^BSTSWSV1("RESULT",.BSTSWS)
I +STS=0 G XCDST ;Quit if update failed
I $D(^XTMP("BSTSLCMP","QUIT")) G XCDST
;
;Now refresh entries for codeset that have not been updated (to handle deletes)
S ICONC="" F S ICONC=$O(^BSTS(9002318.4,"C",NMID,ICONC)) Q:ICONC="" D Q:$D(^XTMP("BSTSLCMP","QUIT"))
. S CIEN="" F S CIEN=$O(^BSTS(9002318.4,"C",NMID,ICONC,CIEN)) Q:CIEN="" D Q:$D(^XTMP("BSTSLCMP","QUIT"))
.. NEW BSTS,ERR,TIEN,DA,DIK
.. ;
.. ;Quit if updated
.. I $$GET1^DIQ(9002318.4,CIEN_",",".12","I")]"" Q
.. ;
.. ;Update monitor
.. S ^XTMP("BSTSLCMP","STS")="Removing retired mapping "_CIEN
.. ;
.. ;First remove terms
.. S TIEN="" F S TIEN=$O(^BSTS(9002318.3,"C",NMID,CIEN,TIEN)) Q:TIEN="" D
... NEW DA,DIK
... S DA=TIEN,DIK="^BSTS(9002318.3," D ^DIK
.. ;
.. ;Remove concept
.. S DA=CIEN,DIK="^BSTS(9002318.4," D ^DIK
;
;Retrieve Failover Vars
S MFAIL=$$FPARMS^BSTSVOFL()
S FWAIT=$P(MFAIL,U,2)
S MFAIL=$P(MFAIL,U)
;
;Loop through, grab concept that mappings linked to
S ABORT=0,ICONC="" F S ICONC=$O(^BSTS(9002318.4,"C",NMID,ICONC)) Q:ICONC="" D Q:$D(^XTMP("BSTSLCMP","QUIT"))
. NEW IEN
. S IEN="" F S IEN=$O(^BSTS(9002318.4,"C",NMID,ICONC,IEN)) Q:IEN="" D Q:$D(^XTMP("BSTSLCMP","QUIT"))
.. NEW AS
.. S AS=0 F S AS=$O(^BSTS(9002318.4,IEN,9,AS)) Q:'AS D
... NEW NODE,NM,DTS,VAR,FCNT,TRY
... S NODE=$G(^BSTS(9002318.4,IEN,9,AS,0))
... S ^XTMP("BSTSLCMP","STS")="Getting Association details for entry: "_ICONC
... S NM=$P(NODE,U,2) Q:NM=""
... S DTS=$P(NODE,U,3) Q:DTS=""
... ;
... ;Update entry-Hang max of 12 times
... S (FCNT,STS)=0 F TRY=1:1:(12*MFAIL) D I +STS=2!(STS="0^") Q
.... D RESET^BSTSWSV1 ;Reset the DTS link to on
.... S STS=$$DTSLKP^BSTSAPI("VAR",DTS_"^"_NM) I +STS=2!(STS="0^") Q
.... S FCNT=FCNT+1 I FCNT'<MFAIL D ;Fail handling
..... S ABORT=$$FAIL^BSTSVOFL(MFAIL,FWAIT,TRY,"CDST^BSTSVRSC - Getting Assoc for entry: "_DTS)
..... I ABORT=1 S ^XTMP("BSTSLCMP","QUIT")=1 D ELOG^BSTSVOFL("CUSTOM CODESET REFRESH FAILED ON DETAIL ENTRY: "_DTS)
..... S FCNT=0
;
;Check for failure
I +STS=0 G XCDST
I $D(^XTMP("BSTSLCMP","QUIT")) G XCDST
;
;Get current version from mult
S NVIEN=$O(^BSTS(9002318.1,NMIEN,1,"A"),-1)
S NVLCL="" I +NVIEN>0 D
. NEW DA,IENS
. S DA(1)=NMIEN,DA=+NVIEN,IENS=$$IENS^DILF(.DA)
. S NVLCL=$$GET1^DIQ(9002318.11,IENS,".01","I")
;
;Save CURRENT VERSION
I NVLCL]"" D
. NEW BSTS,ERROR
. S BSTS(9002318.1,NMIEN_",",.04)=NVLCL
. D FILE^DIE("","BSTS","ERROR")
;
;Reset Monitoring GBL
XCDST NEW FAIL
S FAIL=$S($D(^XTMP("BSTSLCMP","QUIT")):1,1:0)
K ^XTMP("BSTSLCMP")
S:FAIL ^XTMP("BSTSLCMP","QUIT")=1
;
;Unlock
L -^BSTS(9002318.1,0)
;
Q
;
CSTMCDST(RET,BSTSWS) ;Get list of custom codeset entries
;
NEW SLIST,DLIST,CNT,NMID,MFAIL,FWAIT,TRY,FCNT,STS,ABORT,ERSLT,LENTRY,TR,NMIEN
;
S NMID=$G(BSTSWS("NAMESPACEID")) Q:NMID="" 0
;
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)
;
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=$$CSTMCDST^BSTSCMCL(.BSTSWS,.ERSLT) I +STS!(STS="0^") Q
.. S FCNT=FCNT+1 I FCNT'<MFAIL D ;Fail handling
... S ABORT=$$FAIL^BSTSVOFL(MFAIL,FWAIT,TRY,"CSTMCDST^BSTSDTS3 - Calling CSTMCDST^BSTSCMCL")
... I ABORT=1 S STS="0^" S ^XTMP("BSTSLCMP","QUIT")=1 D ELOG^BSTSVOFL("CUSTOM CODESET "_NMID_" MAPPING LOOKUP FAILED")
... S FCNT=0
. I '+STS H TR
;
;Quit on failure
I +STS=0 Q 0
;
;Get last entry
S LENTRY=$O(@DLIST@(""),-1)
;
;Move results to second scratch global
S CNT=0 F S CNT=$O(@DLIST@(CNT)) Q:'CNT S @SLIST@(CNT)=@DLIST@(CNT)
;
;Now loop through and process each entry
S (ABORT,CNT)=0 F S CNT=$O(@SLIST@(CNT)) Q:'CNT D Q:$D(^XTMP("BSTSLCMP","QUIT"))
. NEW DTSID,VAR,TRY,FCNT,DTSNODE
. ;
. ;Get the DTSId
. S DTSNODE=$G(@SLIST@(CNT))
. S DTSID=$P(DTSNODE,U) Q:DTSID=""
. ;
. S ^XTMP("BSTSLCMP","STS")="Getting mapping details for DTSID: "_DTSID_" (Entry "_CNT_" of "_LENTRY_")"
. ;
. ;Pull detail from DTS - Hang max of 12 times
. S FCNT=0 F TRY=1:1:(12*MFAIL) D I +STS=2!(STS="0^") Q
.. D RESET^BSTSWSV1 ;Reset the DTS link to on
.. D CLEAR^BSTSDTSC(DTSNODE,NMID) ;Clear existing entry
.. S STS=$$DTSLKP^BSTSAPI("VAR",DTSID_"^"_NMID_"^^^^1") I +STS=2!(STS="0^") Q
.. S FCNT=FCNT+1 I FCNT'<MFAIL D ;Fail handling
... S ABORT=$$FAIL^BSTSVOFL(MFAIL,FWAIT,TRY,"CSTMCDST^BSTSDTS3 - Getting Update for entry: "_DTSID)
... I ABORT=1 S ^XTMP("BSTSLCMP","QUIT")=1 D ELOG^BSTSVOFL("CUSTOM CODESET "_NMID_" MAPPING FAILED ON DETAIL LOOKUP: "_DTSID)
... S FCNT=0
. ;
. ;Remove entry
. K @SLIST@(CNT)
;
Q STS
;
RCODE(BSTSWS,ACODE) ;Retrieve list of concepts in RxNorm 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_"RxNorm 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=$$RCODE^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,"RCODE^BSTSDTS5 - Call to $$RCODE^BSTSCMCL")
... I ABORT=1 S STS="0^" S ^XTMP("BSTSLCMP","QUIT")=1 D ELOG^BSTSVOFL("RXNORM 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
.. 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_"^1552^^^^1") I +STS=2!(STS="0^") Q
.. S FCNT=FCNT+1 I FCNT'<MFAIL D ;Fail handling
... S ABORT=$$FAIL^BSTSVOFL(MFAIL,FWAIT,TRY,"RCODE^BSTSDTS5 - Getting Update for entry: "_DTSID)
... I ABORT=1 S ^XTMP("BSTSLCMP","QUIT")=1 D ELOG^BSTSVOFL("RXNORM SUBSET REFRESH FAILED ON DETAIL LOOKUP: "_DTSID)
... S FCNT=0
;
;Clear status
K ^XTMP("BSTSLCMP","STS")
;
I 'STS Q 0
Q 1
;
;BSTS*1.0*8;Update RxNorm Subsets
UPRSUB(GL,CONCDA,BSTSC) ;Update RxNorm subsets
;
;Save Subsets
;
;Clear out existing entries
NEW SB
S SB=0 F S SB=$O(^BSTS(9002318.4,CONCDA,4,SB)) Q:'SB D
. NEW DA,DIK
. S DA(1)=CONCDA,DA=SB
. S DIK="^BSTS(9002318.4,"_DA(1)_",4," D ^DIK
;
I $D(@GL@("SUB"))>1 D
. ;
. NEW SB
. S SB="" F S SB=$O(@GL@("SUB",SB)) Q:SB="" D
.. ;
.. NEW DIC,X,Y,DA,X,Y,IENS,DLAYGO
.. S DA(1)=CONCDA
.. S DIC(0)="LX",DIC="^BSTS(9002318.4,"_DA(1)_",4,"
.. S X=$P($G(@GL@("SUB",SB)),U) Q:X=""
.. ;BSTS*1.0*8;Log ALL SNOMED
.. ;I X="IHS PROBLEM ALL SNOMED" S BSTSC(9002318.4,CONCDA_",",.15)="Y"
.. S DLAYGO=9002318.44 D ^DIC
.. I +Y<0 Q
.. S DA=+Y
.. S IENS=$$IENS^DILF(.DA)
.. S BSTSC(9002318.44,IENS,".02")=$$DTS2FMDT^BSTSUTIL($P($G(@GL@("SUB",SB)),U,2))
;
;Save NDC
;
;Clear out existing entries
D
. NEW NDC
. S NDC=0 F S NDC=$O(^BSTS(9002318.4,CONCDA,7,NDC)) Q:'NDC D
.. NEW DA,DIK
.. S DA(1)=CONCDA,DA=NDC
.. S DIK="^BSTS(9002318.4,"_DA(1)_",7," D ^DIK
I $D(@GL@("NDC"))>1 D
. ;
. NEW NDC
. S NDC="" F S NDC=$O(@GL@("NDC",NDC)) Q:NDC="" D
.. ;
.. NEW DIC,X,Y,DA,X,Y,IENS,DLAYGO
.. S DA(1)=CONCDA
.. S DIC(0)="L",DIC="^BSTS(9002318.4,"_DA(1)_",7,"
.. S X=$P($G(@GL@("NDC",NDC)),U) Q:X=""
.. S DLAYGO=9002318.47 D ^DIC
.. I +Y<0 Q
.. S DA=+Y
.. S IENS=$$IENS^DILF(.DA)
.. S BSTSC(9002318.47,IENS,".02")=$$DTS2FMDT^BSTSUTIL($P($G(@GL@("NDC",NDC)),U,2))
.. S BSTSC(9002318.47,IENS,".03")=$$DTS2FMDT^BSTSUTIL($P($G(@GL@("NDC",NDC)),U,3))
;
;Save VUID
;
;Clear out existing entries
D
. NEW VD
. S VD=0 F S VD=$O(^BSTS(9002318.4,CONCDA,8,VD)) Q:'VD D
.. NEW DA,DIK
.. S DA(1)=CONCDA,DA=VD
.. S DIK="^BSTS(9002318.4,"_DA(1)_",8," D ^DIK
I $D(@GL@("VUID"))>1 D
. ;
. NEW VD
. S VD="" F S VD=$O(@GL@("VUID",VD)) Q:VD="" D
.. ;
.. NEW DIC,X,Y,DA,X,Y,IENS,DLAYGO
.. S DA(1)=CONCDA
.. S DIC(0)="L",DIC="^BSTS(9002318.4,"_DA(1)_",8,"
.. S X=$P($G(@GL@("VUID",VD)),U) Q:X=""
.. S DLAYGO=9002318.48 D ^DIC
.. I +Y<0 Q
.. S DA=+Y
.. S IENS=$$IENS^DILF(.DA)
.. S BSTSC(9002318.48,IENS,".02")=$$DTS2FMDT^BSTSUTIL($P($G(@GL@("VUID",VD)),U,2))
.. S BSTSC(9002318.48,IENS,".03")=$$DTS2FMDT^BSTSUTIL($P($G(@GL@("VUID",VD)),U,3))
;
;Save TTY
;
;Clear out existing entries
D
. NEW TTY
. S TTY=0 F S NDC=$O(^BSTS(9002318.4,CONCDA,12,TTY)) Q:'TTY D
.. NEW DA,DIK
.. S DA(1)=CONCDA,DA=TTY
.. S DIK="^BSTS(9002318.4,"_DA(1)_",12," D ^DIK
I $D(@GL@("TTY"))>1 D
. ;
. NEW TTY
. S TTY="" F S TTY=$O(@GL@("TTY",TTY)) Q:TTY="" D
.. ;
.. NEW DIC,X,Y,DA,X,Y,IENS,DLAYGO
.. S DA(1)=CONCDA
.. S DIC(0)="L",DIC="^BSTS(9002318.4,"_DA(1)_",12,"
.. S X=$P($G(@GL@("TTY",TTY)),U) Q:X=""
.. S DLAYGO=9002318.412 D ^DIC
.. I +Y<0 Q
.. S DA=+Y
.. S IENS=$$IENS^DILF(.DA)
.. S BSTSC(9002318.412,IENS,".02")=$$DTS2FMDT^BSTSUTIL($P($G(@GL@("TTY",TTY)),U,2))
.. S BSTSC(9002318.412,IENS,".03")=$$DTS2FMDT^BSTSUTIL($P($G(@GL@("TTY",TTY)),U,3))
;
Q
BSTSDTS5 ;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 ;
CDST ;EP - Update IHS Standard Terminology Codeset
+1 ;
+2 ;Tasked by BSTSVRSC, tab CCHK. Var NMIEN should be set
+3 ;
+4 SET NMIEN=$GET(NMIEN)
IF NMIEN=""
QUIT
+5 ;
+6 ;Lock
+7 LOCK +^BSTS(9002318.1,0):0
IF '$TEST
QUIT
+8 ;
+9 NEW BSTSWS,RESULT,NMID,STS,VRSN,BSTS,ICONC,CIEN,X1,X2,X,NVIEN,NVLCL,MFAIL,FWAIT,TRY,FCNT,ABORT,TRY
+10 ;
+11 ;Get ext codeset Id
+12 SET NMID=$$GET1^DIQ(9002318.1,NMIEN_",",.01,"I")
IF NMID=""
GOTO XCDST
+13 ;
+14 ;Update LAST VERSION CHECK so proc won't keep getting called
+15 SET BSTS(9002318.1,NMIEN_",",.05)=DT
+16 DO FILE^DIE("","BSTS","ERROR")
+17 ;
+18 ;Online?
+19 SET STS=""
FOR TRY=1:1:60
Begin DoDot:1
+20 ;Reset the DTS link to on
DO RESET^BSTSWSV1
+21 ;Try
SET STS=$$VERSIONS^BSTSAPI("VRSN")
+22 IF +STS'=2
HANG TRY
End DoDot:1
IF +STS=2
QUIT
+23 IF +STS'=2
GOTO XCDST
+24 ;
+25 ;Reset Monitoring GBL
+26 KILL ^XTMP("BSTSLCMP")
+27 ;
+28 ;Get later date
+29 SET X1=DT
SET X2=60
DO C^%DTC
+30 ;
+31 ;Set Monitoring GBL
+32 SET ^XTMP("BSTSLCMP",0)=X_U_DT_U_"Cache refresh running for "_NMID
+33 ;
+34 ;Mark as OOD
+35 SET ^XTMP("BSTSLCMP","STS")="Marking entries as out of date"
+36 SET ICONC=""
FOR
SET ICONC=$ORDER(^BSTS(9002318.4,"C",NMID,ICONC))
IF ICONC=""
QUIT
SET CIEN=""
FOR
SET CIEN=$ORDER(^BSTS(9002318.4,"C",NMID,ICONC,CIEN))
IF CIEN=""
QUIT
Begin DoDot:1
+37 NEW BSTS,ERR,LMOD
+38 ;
+39 ;Mark OOD
+40 SET BSTS(9002318.4,CIEN_",",".12")=""
+41 DO FILE^DIE("","BSTS","ERR")
End DoDot:1
+42 ;
+43 ;Make call to proc
+44 SET ^XTMP("BSTSLCMP","STS")="Performing Refresh from DTS"
+45 SET BSTSWS("NAMESPACEID")=NMID
+46 SET BSTSWS("REVIN")=$$FMTE^XLFDT(DT,"7")
+47 SET STS=$$CSTMCDST^BSTSWSV1("RESULT",.BSTSWS)
+48 ;Quit if update failed
IF +STS=0
GOTO XCDST
+49 IF $DATA(^XTMP("BSTSLCMP","QUIT"))
GOTO XCDST
+50 ;
+51 ;Now refresh entries for codeset that have not been updated (to handle deletes)
+52 SET ICONC=""
FOR
SET ICONC=$ORDER(^BSTS(9002318.4,"C",NMID,ICONC))
IF ICONC=""
QUIT
Begin DoDot:1
+53 SET CIEN=""
FOR
SET CIEN=$ORDER(^BSTS(9002318.4,"C",NMID,ICONC,CIEN))
IF CIEN=""
QUIT
Begin DoDot:2
+54 NEW BSTS,ERR,TIEN,DA,DIK
+55 ;
+56 ;Quit if updated
+57 IF $$GET1^DIQ(9002318.4,CIEN_",",".12","I")]""
QUIT
+58 ;
+59 ;Update monitor
+60 SET ^XTMP("BSTSLCMP","STS")="Removing retired mapping "_CIEN
+61 ;
+62 ;First remove terms
+63 SET TIEN=""
FOR
SET TIEN=$ORDER(^BSTS(9002318.3,"C",NMID,CIEN,TIEN))
IF TIEN=""
QUIT
Begin DoDot:3
+64 NEW DA,DIK
+65 SET DA=TIEN
SET DIK="^BSTS(9002318.3,"
DO ^DIK
End DoDot:3
+66 ;
+67 ;Remove concept
+68 SET DA=CIEN
SET DIK="^BSTS(9002318.4,"
DO ^DIK
End DoDot:2
IF $DATA(^XTMP("BSTSLCMP","QUIT"))
QUIT
End DoDot:1
IF $DATA(^XTMP("BSTSLCMP","QUIT"))
QUIT
+69 ;
+70 ;Retrieve Failover Vars
+71 SET MFAIL=$$FPARMS^BSTSVOFL()
+72 SET FWAIT=$PIECE(MFAIL,U,2)
+73 SET MFAIL=$PIECE(MFAIL,U)
+74 ;
+75 ;Loop through, grab concept that mappings linked to
+76 SET ABORT=0
SET ICONC=""
FOR
SET ICONC=$ORDER(^BSTS(9002318.4,"C",NMID,ICONC))
IF ICONC=""
QUIT
Begin DoDot:1
+77 NEW IEN
+78 SET IEN=""
FOR
SET IEN=$ORDER(^BSTS(9002318.4,"C",NMID,ICONC,IEN))
IF IEN=""
QUIT
Begin DoDot:2
+79 NEW AS
+80 SET AS=0
FOR
SET AS=$ORDER(^BSTS(9002318.4,IEN,9,AS))
IF 'AS
QUIT
Begin DoDot:3
+81 NEW NODE,NM,DTS,VAR,FCNT,TRY
+82 SET NODE=$GET(^BSTS(9002318.4,IEN,9,AS,0))
+83 SET ^XTMP("BSTSLCMP","STS")="Getting Association details for entry: "_ICONC
+84 SET NM=$PIECE(NODE,U,2)
IF NM=""
QUIT
+85 SET DTS=$PIECE(NODE,U,3)
IF DTS=""
QUIT
+86 ;
+87 ;Update entry-Hang max of 12 times
+88 SET (FCNT,STS)=0
FOR TRY=1:1:(12*MFAIL)
Begin DoDot:4
+89 ;Reset the DTS link to on
DO RESET^BSTSWSV1
+90 SET STS=$$DTSLKP^BSTSAPI("VAR",DTS_"^"_NM)
IF +STS=2!(STS="0^")
QUIT
+91 ;Fail handling
SET FCNT=FCNT+1
IF FCNT'<MFAIL
Begin DoDot:5
+92 SET ABORT=$$FAIL^BSTSVOFL(MFAIL,FWAIT,TRY,"CDST^BSTSVRSC - Getting Assoc for entry: "_DTS)
+93 IF ABORT=1
SET ^XTMP("BSTSLCMP","QUIT")=1
DO ELOG^BSTSVOFL("CUSTOM CODESET REFRESH FAILED ON DETAIL ENTRY: "_DTS)
+94 SET FCNT=0
End DoDot:5
End DoDot:4
IF +STS=2!(STS="0^")
QUIT
End DoDot:3
End DoDot:2
IF $DATA(^XTMP("BSTSLCMP","QUIT"))
QUIT
End DoDot:1
IF $DATA(^XTMP("BSTSLCMP","QUIT"))
QUIT
+95 ;
+96 ;Check for failure
+97 IF +STS=0
GOTO XCDST
+98 IF $DATA(^XTMP("BSTSLCMP","QUIT"))
GOTO XCDST
+99 ;
+100 ;Get current version from mult
+101 SET NVIEN=$ORDER(^BSTS(9002318.1,NMIEN,1,"A"),-1)
+102 SET NVLCL=""
IF +NVIEN>0
Begin DoDot:1
+103 NEW DA,IENS
+104 SET DA(1)=NMIEN
SET DA=+NVIEN
SET IENS=$$IENS^DILF(.DA)
+105 SET NVLCL=$$GET1^DIQ(9002318.11,IENS,".01","I")
End DoDot:1
+106 ;
+107 ;Save CURRENT VERSION
+108 IF NVLCL]""
Begin DoDot:1
+109 NEW BSTS,ERROR
+110 SET BSTS(9002318.1,NMIEN_",",.04)=NVLCL
+111 DO FILE^DIE("","BSTS","ERROR")
End DoDot:1
+112 ;
+113 ;Reset Monitoring GBL
XCDST NEW FAIL
+1 SET FAIL=$SELECT($DATA(^XTMP("BSTSLCMP","QUIT")):1,1:0)
+2 KILL ^XTMP("BSTSLCMP")
+3 IF FAIL
SET ^XTMP("BSTSLCMP","QUIT")=1
+4 ;
+5 ;Unlock
+6 LOCK -^BSTS(9002318.1,0)
+7 ;
+8 QUIT
+9 ;
CSTMCDST(RET,BSTSWS) ;Get list of custom codeset entries
+1 ;
+2 NEW SLIST,DLIST,CNT,NMID,MFAIL,FWAIT,TRY,FCNT,STS,ABORT,ERSLT,LENTRY,TR,NMIEN
+3 ;
+4 SET NMID=$GET(BSTSWS("NAMESPACEID"))
IF NMID=""
QUIT 0
+5 ;
+6 ;Returned List
SET SLIST=$NAME(^XTMP("BSTSLCMP"))
+7 SET DLIST=$NAME(^TMP("BSTSCMCL",$JOB))
+8 KILL @DLIST
+9 ;
+10 ;Retrieve Failover Variables
+11 SET MFAIL=$$FPARMS^BSTSVOFL()
+12 SET FWAIT=$PIECE(MFAIL,U,2)
+13 SET MFAIL=$PIECE(MFAIL,U)
+14 ;
+15 FOR TR=1:1:60
Begin DoDot:1
+16 SET (ABORT,FCNT,STS)=0
FOR TRY=1:1:(12*MFAIL)
Begin DoDot:2
+17 ;Reset the DTS link to on
DO RESET^BSTSWSV1
+18 SET STS=$$CSTMCDST^BSTSCMCL(.BSTSWS,.ERSLT)
IF +STS!(STS="0^")
QUIT
+19 ;Fail handling
SET FCNT=FCNT+1
IF FCNT'<MFAIL
Begin DoDot:3
+20 SET ABORT=$$FAIL^BSTSVOFL(MFAIL,FWAIT,TRY,"CSTMCDST^BSTSDTS3 - Calling CSTMCDST^BSTSCMCL")
+21 IF ABORT=1
SET STS="0^"
SET ^XTMP("BSTSLCMP","QUIT")=1
DO ELOG^BSTSVOFL("CUSTOM CODESET "_NMID_" MAPPING LOOKUP FAILED")
+22 SET FCNT=0
End DoDot:3
End DoDot:2
IF +STS!(STS="0^")
QUIT
+23 IF '+STS
HANG TR
End DoDot:1
IF +STS
QUIT
+24 ;
+25 ;Quit on failure
+26 IF +STS=0
QUIT 0
+27 ;
+28 ;Get last entry
+29 SET LENTRY=$ORDER(@DLIST@(""),-1)
+30 ;
+31 ;Move results to second scratch global
+32 SET CNT=0
FOR
SET CNT=$ORDER(@DLIST@(CNT))
IF 'CNT
QUIT
SET @SLIST@(CNT)=@DLIST@(CNT)
+33 ;
+34 ;Now loop through and process each entry
+35 SET (ABORT,CNT)=0
FOR
SET CNT=$ORDER(@SLIST@(CNT))
IF 'CNT
QUIT
Begin DoDot:1
+36 NEW DTSID,VAR,TRY,FCNT,DTSNODE
+37 ;
+38 ;Get the DTSId
+39 SET DTSNODE=$GET(@SLIST@(CNT))
+40 SET DTSID=$PIECE(DTSNODE,U)
IF DTSID=""
QUIT
+41 ;
+42 SET ^XTMP("BSTSLCMP","STS")="Getting mapping details for DTSID: "_DTSID_" (Entry "_CNT_" of "_LENTRY_")"
+43 ;
+44 ;Pull detail from DTS - Hang max of 12 times
+45 SET FCNT=0
FOR TRY=1:1:(12*MFAIL)
Begin DoDot:2
+46 ;Reset the DTS link to on
DO RESET^BSTSWSV1
+47 ;Clear existing entry
DO CLEAR^BSTSDTSC(DTSNODE,NMID)
+48 SET STS=$$DTSLKP^BSTSAPI("VAR",DTSID_"^"_NMID_"^^^^1")
IF +STS=2!(STS="0^")
QUIT
+49 ;Fail handling
SET FCNT=FCNT+1
IF FCNT'<MFAIL
Begin DoDot:3
+50 SET ABORT=$$FAIL^BSTSVOFL(MFAIL,FWAIT,TRY,"CSTMCDST^BSTSDTS3 - Getting Update for entry: "_DTSID)
+51 IF ABORT=1
SET ^XTMP("BSTSLCMP","QUIT")=1
DO ELOG^BSTSVOFL("CUSTOM CODESET "_NMID_" MAPPING FAILED ON DETAIL LOOKUP: "_DTSID)
+52 SET FCNT=0
End DoDot:3
End DoDot:2
IF +STS=2!(STS="0^")
QUIT
+53 ;
+54 ;Remove entry
+55 KILL @SLIST@(CNT)
End DoDot:1
IF $DATA(^XTMP("BSTSLCMP","QUIT"))
QUIT
+56 ;
+57 QUIT STS
+58 ;
RCODE(BSTSWS,ACODE) ;Retrieve list of concepts in RxNorm 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_"RxNorm 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=$$RCODE^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,"RCODE^BSTSDTS5 - Call to $$RCODE^BSTSCMCL")
+45 IF ABORT=1
SET STS="0^"
SET ^XTMP("BSTSLCMP","QUIT")=1
DO ELOG^BSTSVOFL("RXNORM 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 SET LMOD=$$GET1^DIQ(9002318.4,CIEN_",",.12,"I")
IF LMOD'<RUNSTRT
SET SKIP=1
+82 IF SKIP=1
SET $PIECE(@SLIST@(SBCNT),U,2)="Skipped"
End DoDot:2
+83 IF SKIP
QUIT
+84 ;
+85 SET ^XTMP("BSTSLCMP","STS")="Getting concept details for DTSID: "_DTSID_" (Entry "_SBCNT_" of "_LENTRY_")"
+86 ;
+87 ;Pull detail from DTS - Hang max of 12 times
+88 SET (ABORT,FCNT)=0
FOR TRY=1:1:(12*MFAIL)
Begin DoDot:2
+89 ;Reset the DTS link to on
DO RESET^BSTSWSV1
+90 SET STS=$$DTSLKP^BSTSAPI("VAR",DTSID_"^1552^^^^1")
IF +STS=2!(STS="0^")
QUIT
+91 ;Fail handling
SET FCNT=FCNT+1
IF FCNT'<MFAIL
Begin DoDot:3
+92 SET ABORT=$$FAIL^BSTSVOFL(MFAIL,FWAIT,TRY,"RCODE^BSTSDTS5 - Getting Update for entry: "_DTSID)
+93 IF ABORT=1
SET ^XTMP("BSTSLCMP","QUIT")=1
DO ELOG^BSTSVOFL("RXNORM SUBSET REFRESH FAILED ON DETAIL LOOKUP: "_DTSID)
+94 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
+95 ;
+96 ;Clear status
+97 KILL ^XTMP("BSTSLCMP","STS")
+98 ;
+99 IF 'STS
QUIT 0
+100 QUIT 1
+101 ;
+102 ;BSTS*1.0*8;Update RxNorm Subsets
UPRSUB(GL,CONCDA,BSTSC) ;Update RxNorm subsets
+1 ;
+2 ;Save Subsets
+3 ;
+4 ;Clear out existing entries
+5 NEW SB
+6 SET SB=0
FOR
SET SB=$ORDER(^BSTS(9002318.4,CONCDA,4,SB))
IF 'SB
QUIT
Begin DoDot:1
+7 NEW DA,DIK
+8 SET DA(1)=CONCDA
SET DA=SB
+9 SET DIK="^BSTS(9002318.4,"_DA(1)_",4,"
DO ^DIK
End DoDot:1
+10 ;
+11 IF $DATA(@GL@("SUB"))>1
Begin DoDot:1
+12 ;
+13 NEW SB
+14 SET SB=""
FOR
SET SB=$ORDER(@GL@("SUB",SB))
IF SB=""
QUIT
Begin DoDot:2
+15 ;
+16 NEW DIC,X,Y,DA,X,Y,IENS,DLAYGO
+17 SET DA(1)=CONCDA
+18 SET DIC(0)="LX"
SET DIC="^BSTS(9002318.4,"_DA(1)_",4,"
+19 SET X=$PIECE($GET(@GL@("SUB",SB)),U)
IF X=""
QUIT
+20 ;BSTS*1.0*8;Log ALL SNOMED
+21 ;I X="IHS PROBLEM ALL SNOMED" S BSTSC(9002318.4,CONCDA_",",.15)="Y"
+22 SET DLAYGO=9002318.44
DO ^DIC
+23 IF +Y<0
QUIT
+24 SET DA=+Y
+25 SET IENS=$$IENS^DILF(.DA)
+26 SET BSTSC(9002318.44,IENS,".02")=$$DTS2FMDT^BSTSUTIL($PIECE($GET(@GL@("SUB",SB)),U,2))
End DoDot:2
End DoDot:1
+27 ;
+28 ;Save NDC
+29 ;
+30 ;Clear out existing entries
+31 Begin DoDot:1
+32 NEW NDC
+33 SET NDC=0
FOR
SET NDC=$ORDER(^BSTS(9002318.4,CONCDA,7,NDC))
IF 'NDC
QUIT
Begin DoDot:2
+34 NEW DA,DIK
+35 SET DA(1)=CONCDA
SET DA=NDC
+36 SET DIK="^BSTS(9002318.4,"_DA(1)_",7,"
DO ^DIK
End DoDot:2
End DoDot:1
+37 IF $DATA(@GL@("NDC"))>1
Begin DoDot:1
+38 ;
+39 NEW NDC
+40 SET NDC=""
FOR
SET NDC=$ORDER(@GL@("NDC",NDC))
IF NDC=""
QUIT
Begin DoDot:2
+41 ;
+42 NEW DIC,X,Y,DA,X,Y,IENS,DLAYGO
+43 SET DA(1)=CONCDA
+44 SET DIC(0)="L"
SET DIC="^BSTS(9002318.4,"_DA(1)_",7,"
+45 SET X=$PIECE($GET(@GL@("NDC",NDC)),U)
IF X=""
QUIT
+46 SET DLAYGO=9002318.47
DO ^DIC
+47 IF +Y<0
QUIT
+48 SET DA=+Y
+49 SET IENS=$$IENS^DILF(.DA)
+50 SET BSTSC(9002318.47,IENS,".02")=$$DTS2FMDT^BSTSUTIL($PIECE($GET(@GL@("NDC",NDC)),U,2))
+51 SET BSTSC(9002318.47,IENS,".03")=$$DTS2FMDT^BSTSUTIL($PIECE($GET(@GL@("NDC",NDC)),U,3))
End DoDot:2
End DoDot:1
+52 ;
+53 ;Save VUID
+54 ;
+55 ;Clear out existing entries
+56 Begin DoDot:1
+57 NEW VD
+58 SET VD=0
FOR
SET VD=$ORDER(^BSTS(9002318.4,CONCDA,8,VD))
IF 'VD
QUIT
Begin DoDot:2
+59 NEW DA,DIK
+60 SET DA(1)=CONCDA
SET DA=VD
+61 SET DIK="^BSTS(9002318.4,"_DA(1)_",8,"
DO ^DIK
End DoDot:2
End DoDot:1
+62 IF $DATA(@GL@("VUID"))>1
Begin DoDot:1
+63 ;
+64 NEW VD
+65 SET VD=""
FOR
SET VD=$ORDER(@GL@("VUID",VD))
IF VD=""
QUIT
Begin DoDot:2
+66 ;
+67 NEW DIC,X,Y,DA,X,Y,IENS,DLAYGO
+68 SET DA(1)=CONCDA
+69 SET DIC(0)="L"
SET DIC="^BSTS(9002318.4,"_DA(1)_",8,"
+70 SET X=$PIECE($GET(@GL@("VUID",VD)),U)
IF X=""
QUIT
+71 SET DLAYGO=9002318.48
DO ^DIC
+72 IF +Y<0
QUIT
+73 SET DA=+Y
+74 SET IENS=$$IENS^DILF(.DA)
+75 SET BSTSC(9002318.48,IENS,".02")=$$DTS2FMDT^BSTSUTIL($PIECE($GET(@GL@("VUID",VD)),U,2))
+76 SET BSTSC(9002318.48,IENS,".03")=$$DTS2FMDT^BSTSUTIL($PIECE($GET(@GL@("VUID",VD)),U,3))
End DoDot:2
End DoDot:1
+77 ;
+78 ;Save TTY
+79 ;
+80 ;Clear out existing entries
+81 Begin DoDot:1
+82 NEW TTY
+83 SET TTY=0
FOR
SET NDC=$ORDER(^BSTS(9002318.4,CONCDA,12,TTY))
IF 'TTY
QUIT
Begin DoDot:2
+84 NEW DA,DIK
+85 SET DA(1)=CONCDA
SET DA=TTY
+86 SET DIK="^BSTS(9002318.4,"_DA(1)_",12,"
DO ^DIK
End DoDot:2
End DoDot:1
+87 IF $DATA(@GL@("TTY"))>1
Begin DoDot:1
+88 ;
+89 NEW TTY
+90 SET TTY=""
FOR
SET TTY=$ORDER(@GL@("TTY",TTY))
IF TTY=""
QUIT
Begin DoDot:2
+91 ;
+92 NEW DIC,X,Y,DA,X,Y,IENS,DLAYGO
+93 SET DA(1)=CONCDA
+94 SET DIC(0)="L"
SET DIC="^BSTS(9002318.4,"_DA(1)_",12,"
+95 SET X=$PIECE($GET(@GL@("TTY",TTY)),U)
IF X=""
QUIT
+96 SET DLAYGO=9002318.412
DO ^DIC
+97 IF +Y<0
QUIT
+98 SET DA=+Y
+99 SET IENS=$$IENS^DILF(.DA)
+100 SET BSTSC(9002318.412,IENS,".02")=$$DTS2FMDT^BSTSUTIL($PIECE($GET(@GL@("TTY",TTY)),U,2))
+101 SET BSTSC(9002318.412,IENS,".03")=$$DTS2FMDT^BSTSUTIL($PIECE($GET(@GL@("TTY",TTY)),U,3))
End DoDot:2
End DoDot:1
+102 ;
+103 QUIT
