BSTSVRXN ;GDIT/HS/BEE-Standard Terminology - RxNorm Subset Updates ; 5 Nov 2012 9:53 AM
;;2.0;IHS STANDARD TERMINOLOGY;;Dec 01, 2016;Build 62
;
Q
;
SCHK(NMID,BKGND) ;EP - Check for periodic RxNorm subset updates
;
NEW LMDT,STS,BSTS,ERROR,ZTRTN,ZTSAVE,ZTDESC,ZTDTH,NMIEN
NEW VAR,SITE,SDAYS,ZTIO,SUBLST,X1,X2,X,%H,TR
NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BSTSVRXN D UNWIND^%ZTER" ; SAC 2009 2.2.3.17
;
;Only one SNOMED background process can be running at a time
I '$G(BKGND) L +^BSTS(9002318.1,0):0 E W !!,"A Local Cache Refresh is Already Running. Please Try Later" H 3 Q
L -^BSTS(9002318.1,0)
;
;Make sure ICD9 to SNOMED background process isn't running
I '$G(BKGND) L +^TMP("BSTSICD2SMD"):0 E W !!,"An ICD9 to SNOMED Background Process is Already Running. Please Try Later" H 3 Q
L -^TMP("BSTSICD2SMD")
;
S NMID=$G(NMID,"") S:NMID="" NMID=1552
;
;Only run it for codeset 1552
I NMID'=1552 Q
;
;Get Site Parameter IEN
S SITE=$O(^BSTS(9002318,0)) Q:'SITE
;
;Get subset update days
S SDAYS=$$GET1^DIQ(9002318,SITE_",",.02,"I") S:SDAYS="" SDAYS=60
;
;Make sure we have a codeset (namespace)
S NMIEN=$O(^BSTS(9002318.1,"B",NMID,"")) Q:NMIEN=""
;
;Update LAST SUBSET CHECK as completed today
D
. NEW BSTS,ERROR
. S BSTS(9002318.1,NMIEN_",",.06)=DT
. D FILE^DIE("","BSTS","ERROR")
;
;Check if refresh needs run
S LMDT=$$GET1^DIQ(9002318.1,NMIEN,".1","I")
I LMDT>0 S X1=LMDT,X2=SDAYS D C^%DTC S LMDT=X
I LMDT>DT Q
;
;Only run if server set up
S STS="" F TR=1:1:60 D I +STS=2 Q
. D RESET^BSTSWSV1 ;Reset the DTS link to on
. S STS=$$VERSIONS^BSTSAPI("VAR") ;Try a quick call to see if call works
. I +STS'=2 H TR
I +STS'=2 G XSCHK
;
;Queue the process off in the background
I +$G(BKGND) D QUEUE^BSTSVOFL("S1552") Q ;Daily check - queue
D CDJOB^BSTSUTIL(NMIEN,"S1552","") ;Manual - run now
;
XSCHK Q
;
SUB ;EP - Update IHS Standard Terminology RxNorm Subsets
;
;Perform lock so only one process is allowed
L +^BSTS(9002318.1,0):1 E Q
;
NEW NMID,SDAYS,SITE
;
;Retrieve passed in variable
S NMIEN=$G(NMIEN) I NMIEN="" Q
;
;Get NMID
S NMID=$$GET1^DIQ(9002318.1,NMIEN_",",.01,"I") I NMID="" Q
;
;Get Site Parameter IEN
S SITE=$O(^BSTS(9002318,0)) Q:'SITE
;
;Get subset update days
S SDAYS=$$GET1^DIQ(9002318,SITE_",",.02,"I") S:SDAYS="" SDAYS=60
;
NEW BSTS,ERROR,CIEN,BSTSSB,STS,CNC,SUBLST,SSCIEN,ICONC,X,X1,X2,ITEM,%H
NEW MFAIL,FWAIT,FCNT,ABORT,RUNSTRT,TR
;
;Note the run date
S RUNSTRT=DT
;
;Only run if server up
S STS="" F TR=1:1:60 D I +STS=2 Q
. D RESET^BSTSWSV1 ;Reset DTS to on
. S STS=$$VERSIONS^BSTSAPI("VRSN") ;Try quick call
. I +STS'=2 H TR
I +STS'=2 G XSUB
;
;Reset Monitoring Global
K ^XTMP("BSTSLCMP")
;
;Get a later date
S X1=DT,X2=60 D C^%DTC
;
;Retrieve Failover Variables
S MFAIL=$$FPARMS^BSTSVOFL()
S FWAIT=$P(MFAIL,U,2)
S MFAIL=$P(MFAIL,U)
;
;Update SUBSET TASK NUMBER
I +$G(ZTSK)>0 D
. NEW BSTS,ERROR
. S BSTS(9002318.1,NMIEN_",",.08)=ZTSK
. D FILE^DIE("","BSTS","ERROR")
;
;Set up Monitoring Global
S ^XTMP("BSTSLCMP",0)=X_U_DT_U_"RxNorm Cache subset refresh running for "_NMID
;
;Loop through concepts and clear out modified date for codes in codeset
S ^XTMP("BSTSLCMP","STS")="Marking entries as out of date"
S ICONC="" F S ICONC=$O(^BSTS(9002318.4,"C",NMID,ICONC)) Q:ICONC="" D
. S CIEN="" F S CIEN=$O(^BSTS(9002318.4,"C",NMID,ICONC,CIEN)) Q:CIEN="" D
.. NEW CDSET,BSTS,ERR,LMOD
.. ;
.. ;Skip partial entries
.. I $$GET1^DIQ(9002318.4,CIEN_",",.03,"I")="P" Q
.. ;
.. ;Check last modified - skip if today
.. S LMOD=$$GET1^DIQ(9002318.4,CIEN_",",.12,"I") I LMOD'<RUNSTRT Q
.. ;
.. ;Mark as out of date
.. S BSTS(9002318.4,CIEN_",",".12")="@"
.. D FILE^DIE("","BSTS","ERR")
;
;Make the call to update the subset entries
S STS=$$SCODE^BSTSWSV1(1552)
;
;Quit on failure
I +STS=0 S ^XTMP("BSTSLCMP","QUIT")=1 G XSUB
I $D(^XTMP("BSTSLCMP","QUIT")) G XSUB
;
;Need to loop through list again to catch any deletes
S ^XTMP("BSTSLCMP","STS")="Looking for entries removed from subsets"
S ABORT=0,ICONC="" F S ICONC=$O(^BSTS(9002318.4,"C",NMID,ICONC)) Q:ICONC="" Q:$D(^XTMP("BSTSLCMP","QUIT")) S SSCIEN="" F S SSCIEN=$O(^BSTS(9002318.4,"C",NMID,ICONC,SSCIEN)) Q:SSCIEN="" D Q:$D(^XTMP("BSTSLCMP","QUIT"))
. ;
. NEW LMOD,DTSID,SBVAR,CDSET,X1,X2,X,%H,FCNT,TRY
. ;
. ;Skip partial entries
. I $$GET1^DIQ(9002318.4,SSCIEN_",",.03,"I")="P" Q
. ;
. ;Get last modified date for concept
. S LMOD=$$GET1^DIQ(9002318.4,SSCIEN_",",".12","I")
. ;
. ;Skip if not out of date
. I LMOD'<RUNSTRT Q
. ;
. ;Get DTSId
. S DTSID=$$GET1^DIQ(9002318.4,SSCIEN_",",".08","I") Q:DTSID=""
. S ^XTMP("BSTSLCMP","STS")="Refreshing removed entry: "_SSCIEN_" DTSID: "_DTSID
. ;
. ;If Out of Date, retrieve detail from server - 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 ;Make sure the link is on
.. S STS=$$DTSLKP^BSTSAPI("SBVAR",DTSID_"^1552") I +STS=2!(STS="0^") Q
.. S FCNT=FCNT+1 I FCNT'<MFAIL D ;Fail handling
... S ABORT=$$FAIL^BSTSVOFL(MFAIL,FWAIT,TRY,"SUB^BSTSVRSN - Refreshing entry: "_DTSID)
... I ABORT=1 S ^XTMP("BSTSLCMP","QUIT")=1 D ELOG^BSTSVOFL("SUBSET REFRESH FAILED ON DETAIL ENTRY: "_DTSID)
... S FCNT=0
;
;Check for failure
I $D(^XTMP("BSTSLCMP","QUIT")) G XSUB
;
;Process VUID and NDC
;S STS=$$NVLKP^BSTSVOFL(MFAIL,FWAIT)
;
;Update LAST SUBSET RUN as completed today
D
. NEW BSTS,ERROR
. S BSTS(9002318.1,NMIEN_",",.1)=DT
. D FILE^DIE("","BSTS","ERROR")
;
XSUB NEW FAIL
S FAIL=$S($D(^XTMP("BSTSLCMP","QUIT")):1,1:0)
K ^XTMP("BSTSLCMP")
S:FAIL ^XTMP("BSTSLCMP","QUIT")=1
;
;Unlock entry
L -^BSTS(9002318.1,0)
;
Q
;
SBRSET ;EP - BSTS REFRESH SUBSETS option
;
;Moved to overflow routine because of size issues
D SBRSET^BSTSVOFL Q
;
ERR ;
D ^%ZTER
Q
BSTSVRXN ;GDIT/HS/BEE-Standard Terminology - RxNorm Subset Updates ; 5 Nov 2012 9:53 AM
+1 ;;2.0;IHS STANDARD TERMINOLOGY;;Dec 01, 2016;Build 62
+2 ;
+3 QUIT
+4 ;
SCHK(NMID,BKGND) ;EP - Check for periodic RxNorm subset updates
+1 ;
+2 NEW LMDT,STS,BSTS,ERROR,ZTRTN,ZTSAVE,ZTDESC,ZTDTH,NMIEN
+3 NEW VAR,SITE,SDAYS,ZTIO,SUBLST,X1,X2,X,%H,TR
+4 ; SAC 2009 2.2.3.17
NEW $ESTACK,$ETRAP
SET $ETRAP="D ERR^BSTSVRXN D UNWIND^%ZTER"
+5 ;
+6 ;Only one SNOMED background process can be running at a time
+7 IF '$GET(BKGND)
LOCK +^BSTS(9002318.1,0):0
IF '$TEST
WRITE !!,"A Local Cache Refresh is Already Running. Please Try Later"
HANG 3
QUIT
+8 LOCK -^BSTS(9002318.1,0)
+9 ;
+10 ;Make sure ICD9 to SNOMED background process isn't running
+11 IF '$GET(BKGND)
LOCK +^TMP("BSTSICD2SMD"):0
IF '$TEST
WRITE !!,"An ICD9 to SNOMED Background Process is Already Running. Please Try Later"
HANG 3
QUIT
+12 LOCK -^TMP("BSTSICD2SMD")
+13 ;
+14 SET NMID=$GET(NMID,"")
IF NMID=""
SET NMID=1552
+15 ;
+16 ;Only run it for codeset 1552
+17 IF NMID'=1552
QUIT
+18 ;
+19 ;Get Site Parameter IEN
+20 SET SITE=$ORDER(^BSTS(9002318,0))
IF 'SITE
QUIT
+21 ;
+22 ;Get subset update days
+23 SET SDAYS=$$GET1^DIQ(9002318,SITE_",",.02,"I")
IF SDAYS=""
SET SDAYS=60
+24 ;
+25 ;Make sure we have a codeset (namespace)
+26 SET NMIEN=$ORDER(^BSTS(9002318.1,"B",NMID,""))
IF NMIEN=""
QUIT
+27 ;
+28 ;Update LAST SUBSET CHECK as completed today
+29 Begin DoDot:1
+30 NEW BSTS,ERROR
+31 SET BSTS(9002318.1,NMIEN_",",.06)=DT
+32 DO FILE^DIE("","BSTS","ERROR")
End DoDot:1
+33 ;
+34 ;Check if refresh needs run
+35 SET LMDT=$$GET1^DIQ(9002318.1,NMIEN,".1","I")
+36 IF LMDT>0
SET X1=LMDT
SET X2=SDAYS
DO C^%DTC
SET LMDT=X
+37 IF LMDT>DT
QUIT
+38 ;
+39 ;Only run if server set up
+40 SET STS=""
FOR TR=1:1:60
Begin DoDot:1
+41 ;Reset the DTS link to on
DO RESET^BSTSWSV1
+42 ;Try a quick call to see if call works
SET STS=$$VERSIONS^BSTSAPI("VAR")
+43 IF +STS'=2
HANG TR
End DoDot:1
IF +STS=2
QUIT
+44 IF +STS'=2
GOTO XSCHK
+45 ;
+46 ;Queue the process off in the background
+47 ;Daily check - queue
IF +$GET(BKGND)
DO QUEUE^BSTSVOFL("S1552")
QUIT
+48 ;Manual - run now
DO CDJOB^BSTSUTIL(NMIEN,"S1552","")
+49 ;
XSCHK QUIT
+1 ;
SUB ;EP - Update IHS Standard Terminology RxNorm Subsets
+1 ;
+2 ;Perform lock so only one process is allowed
+3 LOCK +^BSTS(9002318.1,0):1
IF '$TEST
QUIT
+4 ;
+5 NEW NMID,SDAYS,SITE
+6 ;
+7 ;Retrieve passed in variable
+8 SET NMIEN=$GET(NMIEN)
IF NMIEN=""
QUIT
+9 ;
+10 ;Get NMID
+11 SET NMID=$$GET1^DIQ(9002318.1,NMIEN_",",.01,"I")
IF NMID=""
QUIT
+12 ;
+13 ;Get Site Parameter IEN
+14 SET SITE=$ORDER(^BSTS(9002318,0))
IF 'SITE
QUIT
+15 ;
+16 ;Get subset update days
+17 SET SDAYS=$$GET1^DIQ(9002318,SITE_",",.02,"I")
IF SDAYS=""
SET SDAYS=60
+18 ;
+19 NEW BSTS,ERROR,CIEN,BSTSSB,STS,CNC,SUBLST,SSCIEN,ICONC,X,X1,X2,ITEM,%H
+20 NEW MFAIL,FWAIT,FCNT,ABORT,RUNSTRT,TR
+21 ;
+22 ;Note the run date
+23 SET RUNSTRT=DT
+24 ;
+25 ;Only run if server up
+26 SET STS=""
FOR TR=1:1:60
Begin DoDot:1
+27 ;Reset DTS to on
DO RESET^BSTSWSV1
+28 ;Try quick call
SET STS=$$VERSIONS^BSTSAPI("VRSN")
+29 IF +STS'=2
HANG TR
End DoDot:1
IF +STS=2
QUIT
+30 IF +STS'=2
GOTO XSUB
+31 ;
+32 ;Reset Monitoring Global
+33 KILL ^XTMP("BSTSLCMP")
+34 ;
+35 ;Get a later date
+36 SET X1=DT
SET X2=60
DO C^%DTC
+37 ;
+38 ;Retrieve Failover Variables
+39 SET MFAIL=$$FPARMS^BSTSVOFL()
+40 SET FWAIT=$PIECE(MFAIL,U,2)
+41 SET MFAIL=$PIECE(MFAIL,U)
+42 ;
+43 ;Update SUBSET TASK NUMBER
+44 IF +$GET(ZTSK)>0
Begin DoDot:1
+45 NEW BSTS,ERROR
+46 SET BSTS(9002318.1,NMIEN_",",.08)=ZTSK
+47 DO FILE^DIE("","BSTS","ERROR")
End DoDot:1
+48 ;
+49 ;Set up Monitoring Global
+50 SET ^XTMP("BSTSLCMP",0)=X_U_DT_U_"RxNorm Cache subset refresh running for "_NMID
+51 ;
+52 ;Loop through concepts and clear out modified date for codes in codeset
+53 SET ^XTMP("BSTSLCMP","STS")="Marking entries as out of date"
+54 SET ICONC=""
FOR
SET ICONC=$ORDER(^BSTS(9002318.4,"C",NMID,ICONC))
IF ICONC=""
QUIT
Begin DoDot:1
+55 SET CIEN=""
FOR
SET CIEN=$ORDER(^BSTS(9002318.4,"C",NMID,ICONC,CIEN))
IF CIEN=""
QUIT
Begin DoDot:2
+56 NEW CDSET,BSTS,ERR,LMOD
+57 ;
+58 ;Skip partial entries
+59 IF $$GET1^DIQ(9002318.4,CIEN_",",.03,"I")="P"
QUIT
+60 ;
+61 ;Check last modified - skip if today
+62 SET LMOD=$$GET1^DIQ(9002318.4,CIEN_",",.12,"I")
IF LMOD'<RUNSTRT
QUIT
+63 ;
+64 ;Mark as out of date
+65 SET BSTS(9002318.4,CIEN_",",".12")="@"
+66 DO FILE^DIE("","BSTS","ERR")
End DoDot:2
End DoDot:1
+67 ;
+68 ;Make the call to update the subset entries
+69 SET STS=$$SCODE^BSTSWSV1(1552)
+70 ;
+71 ;Quit on failure
+72 IF +STS=0
SET ^XTMP("BSTSLCMP","QUIT")=1
GOTO XSUB
+73 IF $DATA(^XTMP("BSTSLCMP","QUIT"))
GOTO XSUB
+74 ;
+75 ;Need to loop through list again to catch any deletes
+76 SET ^XTMP("BSTSLCMP","STS")="Looking for entries removed from subsets"
+77 SET ABORT=0
SET ICONC=""
FOR
SET ICONC=$ORDER(^BSTS(9002318.4,"C",NMID,ICONC))
IF ICONC=""
QUIT
IF $DATA(^XTMP("BSTSLCMP","QUIT"))
QUIT
SET SSCIEN=""
FOR
SET SSCIEN=$ORDER(^BSTS(9002318.4,"C",NMID,ICONC,SSCIEN))
IF SSCIEN=""
QUIT
Begin DoDot:1
+78 ;
+79 NEW LMOD,DTSID,SBVAR,CDSET,X1,X2,X,%H,FCNT,TRY
+80 ;
+81 ;Skip partial entries
+82 IF $$GET1^DIQ(9002318.4,SSCIEN_",",.03,"I")="P"
QUIT
+83 ;
+84 ;Get last modified date for concept
+85 SET LMOD=$$GET1^DIQ(9002318.4,SSCIEN_",",".12","I")
+86 ;
+87 ;Skip if not out of date
+88 IF LMOD'<RUNSTRT
QUIT
+89 ;
+90 ;Get DTSId
+91 SET DTSID=$$GET1^DIQ(9002318.4,SSCIEN_",",".08","I")
IF DTSID=""
QUIT
+92 SET ^XTMP("BSTSLCMP","STS")="Refreshing removed entry: "_SSCIEN_" DTSID: "_DTSID
+93 ;
+94 ;If Out of Date, retrieve detail from server - Hang max of 12 times
+95 SET (FCNT,STS)=0
FOR TRY=1:1:(12*MFAIL)
Begin DoDot:2
+96 ;Make sure the link is on
DO RESET^BSTSWSV1
+97 SET STS=$$DTSLKP^BSTSAPI("SBVAR",DTSID_"^1552")
IF +STS=2!(STS="0^")
QUIT
+98 ;Fail handling
SET FCNT=FCNT+1
IF FCNT'<MFAIL
Begin DoDot:3
+99 SET ABORT=$$FAIL^BSTSVOFL(MFAIL,FWAIT,TRY,"SUB^BSTSVRSN - Refreshing entry: "_DTSID)
+100 IF ABORT=1
SET ^XTMP("BSTSLCMP","QUIT")=1
DO ELOG^BSTSVOFL("SUBSET REFRESH FAILED ON DETAIL ENTRY: "_DTSID)
+101 SET FCNT=0
End DoDot:3
End DoDot:2
IF +STS=2!(STS="0^")
QUIT
End DoDot:1
IF $DATA(^XTMP("BSTSLCMP","QUIT"))
QUIT
+102 ;
+103 ;Check for failure
+104 IF $DATA(^XTMP("BSTSLCMP","QUIT"))
GOTO XSUB
+105 ;
+106 ;Process VUID and NDC
+107 ;S STS=$$NVLKP^BSTSVOFL(MFAIL,FWAIT)
+108 ;
+109 ;Update LAST SUBSET RUN as completed today
+110 Begin DoDot:1
+111 NEW BSTS,ERROR
+112 SET BSTS(9002318.1,NMIEN_",",.1)=DT
+113 DO FILE^DIE("","BSTS","ERROR")
End DoDot:1
+114 ;
XSUB 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 entry
+6 LOCK -^BSTS(9002318.1,0)
+7 ;
+8 QUIT
+9 ;
SBRSET ;EP - BSTS REFRESH SUBSETS option
+1 ;
+2 ;Moved to overflow routine because of size issues
+3 DO SBRSET^BSTSVOFL
QUIT
+4 ;
ERR ;
+1 DO ^%ZTER
+2 QUIT
