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

BSTSVOFL.m

Go to the documentation of this file. 
  1. BSTSVOFL ;GDIT/HS/BEE-Standard Terminology Version/Update Overflow Routine ; 5 Nov 2012  9:53 AM
  1.  ;;2.0;IHS STANDARD TERMINOLOGY;**1**;Dec 01, 2016;Build 36
  1.  ;
  1.  Q
  1.  ;
  1. FPARMS() ;Return the version/update failover parameters
  1.  ;
  1.  ;This tag returns failover parameter values for the web service call
  1.  ;with the highest priority in BSTS SITE PARAMETERS file
  1.  ;
  1.  NEW SITE,SIEN,MFAIL,FWAIT,FOUND,BSTSWS
  1.  ;
  1.  ;Start with default values
  1.  S MFAIL=10,FWAIT=7200
  1.  S (FOUND,SITE)=0 F  S SITE=$O(^BSTS(9002318,SITE)) Q:'SITE  S SIEN=0 F  S SIEN=$O(^BSTS(9002318,SITE,1,SIEN)) Q:'SIEN  D  I FOUND Q
  1.  . NEW WIEN,IENS,DA
  1.  . ;
  1.  . ;Get pointer to web service entry
  1.  . S DA(1)=SITE,DA=SIEN,IENS=$$IENS^DILF(.DA)
  1.  . S WIEN=$$GET1^DIQ(9002318.01,IENS,".01","I") Q:WIEN=""
  1.  . ;
  1.  . ;Pull parameter values
  1.  . S MFAIL=$$GET1^DIQ(9002318.2,WIEN_",","4.02","E") S:MFAIL="" MFAIL=10
  1.  . S FWAIT=$$GET1^DIQ(9002318.2,WIEN_",","4.03","E") S:FWAIT="" FWAIT=7200
  1.  . S FOUND=1
  1.  ;
  1.  Q MFAIL_U_FWAIT
  1.  ;
  1. NVLKP(MFAIL,FWAIT) ;Process NDC and VUID lookups - called by BSTSVRSN
  1.  ;
  1.  NEW ITEM,STS,ABORT
  1.  ;
  1.  S STS=0
  1.  ;
  1.  ;ReLoad VUID
  1.  S (ABORT,ITEM)=0 F  S ITEM=$O(^PSNDF(50.68,ITEM)) Q:'ITEM  D  Q:$D(^XTMP("BSTSLCMP","QUIT"))
  1.  . NEW VUID,VAR,FCNT,TRY
  1.  . S VUID=$P($G(^PSNDF(50.68,ITEM,"VUID")),U) Q:VUID=""
  1.  . S ^XTMP("BSTSLCMP","STS")="Refreshing VUID entry: "_VUID
  1.  . ;
  1.  . ;Retrieve from server - Hang max of 12 times
  1.  . S (FCNT,STS)=0 F TRY=1:1:(12*MFAIL) D  I +STS=2!(STS="0^") Q
  1.  .. D RESET^BSTSWSV1 ;Make sure link is on
  1.  .. S STS=$$DILKP^BSTSAPI("VAR",VUID_"^V^2^^1") I +STS=2!(STS="0^") Q
  1.  .. S FCNT=FCNT+1 I FCNT'<MFAIL D  ;Fail handling
  1.  ... S ABORT=$$FAIL(MFAIL,FWAIT,TRY,"NVLKP^BSTSVOFL - VUID: "_VUID)
  1.  ... I ABORT=1 S ^XTMP("BSTSLCMP","QUIT")=1 D ELOG^BSTSVOFL("SUBSET REFRESH FAILED ON VUID LOOKUP: "_VUID)
  1.  ... S FCNT=0
  1.  ;
  1.  ;Check for failure
  1.  I $D(^XTMP("BSTSLCMP","QUIT")) Q 0
  1.  ;
  1.  ;Load NDC values
  1.  I $D(^XTMP("BSTSLCMP","QUIT")) Q 0
  1.  S ITEM=0 F  S ITEM=$O(^PSNDF(50.68,ITEM)) Q:'ITEM  D  Q:$D(^XTMP("BSTSLCMP","QUIT"))
  1.  . NEW NDC,VAR,FCNT,TRY
  1.  . S NDC=$P($G(^PSNDF(50.68,ITEM,1)),U,7) Q:NDC=""
  1.  . I $L(NDC)>11,$E(NDC,1)="0" S NDC=$E(NDC,2,99)
  1.  . S ^XTMP("BSTSLCMP","STS")="Refreshing NDC entry: "_NDC
  1.  . ;
  1.  . ;Retrieve from server - Hang max of 12 times
  1.  . S (FCNT,STS)=0 F TRY=1:1:(12*MFAIL) D  I +STS=2!(STS="0^") Q
  1.  .. D RESET^BSTSWSV1 ;Make sure link is on
  1.  .. S STS=$$DILKP^BSTSAPI("VAR",NDC_"^N^2^^1") I +STS=2!(STS="0^") Q
  1.  .. S FCNT=FCNT+1 I FCNT'<MFAIL D  ;Fail handling
  1.  ... S ABORT=$$FAIL(MFAIL,FWAIT,TRY,"NVLKP^BSTSVOFL - NDC: "_NDC)
  1.  ... S ABORT=1 S ^XTMP("BSTSLCMP","QUIT")=1 D ELOG^BSTSVOFL("SUBSET REFRESH FAILED ON NDC LOOKUP: "_NDC)
  1.  ... S FCNT=0 ;Fail handling
  1.  ;
  1.  Q +STS
  1.  ;
  1. SBRSET ;EP - BSTS REFRESH SUBSETS option
  1.  ;
  1.  ;Called from BSTSVRSN
  1.  ;
  1.  NEW II,NMID,NMIEN,BSTS,ERR,DIR,X,Y,DIC,CONC,CNT,DLAYGO,DTOUT,DUOUT,DIROUT,DIRUT,SBNAME
  1.  ;
  1.  W !!,"This option allows sites to manually refresh IHS Standard Terminology (BSTS)"
  1.  W !,"information cached locally at the site. Using this option, the subsets"
  1.  W !,"associated with the 'SNOMED with US Extensions' codeset can be refreshed with"
  1.  W !,"up to date information retrieved from the Apelon DTS server. This option also"
  1.  W !,"allows custom codeset mappings to be refreshed with current mappings available"
  1.  W !,"through DTS."
  1.  ;
  1.  W !
  1.  S DIR("A")="Are you sure you want to do this"
  1.  S DIR("B")="NO"
  1.  S DIR(0)="Y"
  1.  D ^DIR I $D(DIRUT) Q
  1.  I '+Y Q
  1.  ;
  1.  S DIR("A")="Select the subset/mapping to refresh"
  1.  S DIR(0)="SO^"
  1.  S DIR(0)=DIR(0)_"36:SNOMED CT US Extension Subsets"
  1.  S DIR(0)=DIR(0)_";1552:RxNorm Subsets"
  1.  S DIR(0)=DIR(0)_";32771:IHS VANDF"
  1.  S DIR(0)=DIR(0)_";32772:GMRA Signs Symptoms"
  1.  S DIR(0)=DIR(0)_";32773:GMRA Allergies with Maps"
  1.  S DIR(0)=DIR(0)_";32774:IHS Med Route"
  1.  S DIR(0)=DIR(0)_";32775:CPT Meds with Maps"
  1.  S DIR(0)=DIR(0)_";32777:SNOMED CT ICD-10 Auto and Conditional Mappings and Equivalencies"
  1.  S DIR(0)=DIR(0)_";32778:SNOMED CT to ICD-9-CM Auto-Codeables"
  1.  ;
  1.  S DIR("B")="SNOMED CT US Extension Subsets"
  1.  ;
  1.  D ^DIR I $D(DIRUT) Q
  1.  S NMID=+Y
  1.  ;
  1.  ;Retrieve codeset
  1.  S NMIEN=$O(^BSTS(9002318.1,"B",NMID,"")) Q:NMIEN=""
  1.  ;
  1.  ;Only one SNOMED background process can be running at a time
  1.  L +^BSTS(9002318.1,0):0 E  W !!,"A Local Cache Refresh is Already Running. Please Try Later" H 3 Q
  1.  L -^BSTS(9002318.1,0)
  1.  ;
  1.  ;Make sure ICD9 to SNOMED background process isn't running
  1.  L +^TMP("BSTSICD2SMD"):0 E  W !!,"An ICD9 to SNOMED Background Process is Already Running. Please Try Later" H 3 Q
  1.  L -^TMP("BSTSICD2SMD")
  1.  ;
  1.  S SBNAME=""
  1.  I NMID=36 S SBNAME=$$ASKSB^BSTSVOF1() I SBNAME="-1" W !!,"Process aborted!" H 3 Q
  1.  ;
  1.  S DIR("A")="Start the process"
  1.  S DIR("B")="NO"
  1.  S DIR(0)="Y"
  1.  D ^DIR I $D(DIRUT) Q
  1.  I '+Y Q
  1.  ;
  1.  ;Remove the LAST SUBSET CHECK date or LAST VERSION CHECK date
  1. CALL I (NMID=1552)!(NMID=36) S:((SBNAME="")!(SBNAME="ALL")) BSTS(9002318.1,NMIEN_",",.1)="@" I 1
  1.  E  S BSTS(9002318.1,NMIEN_",",.05)="@"
  1.  I $D(BSTS)'<10 D FILE^DIE("","BSTS","ERR")
  1.  ;
  1.  W !!,"Kicking off background process to refresh local cache subsets/mappings"
  1.  I NMID=36 D  I 1  ;Subsets
  1.  . I SBNAME="ALL" D SCHK^BSTSVRSN(NMID) Q  ;Process all
  1.  . D ISCHK^BSTSVOF1(SBNAME) ;Process one subset
  1.  E  I NMID=1552 D SCHK^BSTSVRXN(NMID) I 1
  1.  E  I NMID=32777 D ACHK^BSTSVRSC(NMID) I 1 ;'36' Auto-codeable ICD-10s
  1.  E  I NMID=32778 D A9CHK^BSTSVRSC(NMID) I 1 ;'36' Auto-codeable ICD-9s
  1.  E  D CCHK^BSTSVRSC(NMID) ;Custom codesets
  1.  H 2
  1.  ;
  1.  ;Log call
  1.  NEW QUEUE,%
  1.  D NOW^%DTC
  1.  L +^XTMP("BSTSPROCQ","M"):1 E  Q
  1.  S (QUEUE,^XTMP("BSTSPROCQ","M"))=$G(^XTMP("BSTSPROCQ","M"))+1
  1.  S ^XTMP("BSTSPROCQ","M",QUEUE)=%_U_$$GET1^DIQ(200,DUZ_",",.01,"E")_U_"Kicked off manual refresh of: "_NMID
  1.  S ^XTMP("BSTSPROCQ","M","B",NMID,QUEUE)=""
  1.  S ^XTMP("BSTSPROCQ","M","D",%,QUEUE)=""
  1.  L -^XTMP("BSTSPROCQ","M")
  1.  Q
  1.  ;
  1. FAIL(MFAIL,FWAIT,TRY,MESSAGE) ;DTS Connection/Error Handling
  1.  ;
  1.  I $G(TRY)<1 Q 0
  1.  I +$G(MFAIL)=0 S MFAIL=10
  1.  I +$G(FWAIT)=0 S FWAIT=7200
  1.  S MESSAGE=$G(MESSAGE)
  1.  ;
  1.  NEW HFATMPT,EXEC
  1.  ;
  1.  S HFATMPT=TRY\MFAIL
  1.  ;
  1.  ;If reached maximum log error in error trap
  1.  I HFATMPT'<12 D  Q 1
  1.  . NEW %ERROR,%MESSAGE,IEN,IENS,DA
  1.  . S EXEC="S $"_"ZE=""<DTS CONNECTION ERROR - Contact BSTS Support>""" X EXEC
  1.  . S %ERROR="Your DTS Connection is not working properly. Please log a HEAT ticket with the BSTS Support Group"
  1.  . S %MESSAGE=MESSAGE
  1.  . D ^ZTER
  1.  ;
  1.  ;Log entry
  1.  D ELOG(MESSAGE)
  1.  ;
  1.  ;For first 6 tries - only hang for 5 minutes
  1.  I HFATMPT<7 H 300
  1.  E  H FWAIT
  1.  ;
  1.  Q 0
  1.  ;
  1. ELOG(MSG) ;Log entry in web service log
  1.  ;
  1.  ;Input: MSG
  1.  ;       BSTSWS Array may also be defined
  1.  ;
  1.  S MSG=$G(MSG)
  1.  ;
  1.  NEW IEN,DA,X,BSTSUP,ERROR,Y,DLAYGO,DIC,%
  1.  ;
  1.  ;Get IEN of web service entry
  1.  S IEN=$G(BSTSWS("IEN"))
  1.  I IEN="" D
  1.  . NEW SITE,SIEN
  1.  . S SITE=0 F  S SITE=$O(^BSTS(9002318,SITE)) Q:'SITE  S SIEN=0 F  S SIEN=$O(^BSTS(9002318,SITE,1,SIEN)) Q:'SIEN  D  Q:IEN
  1.  .. NEW IENS,DA
  1.  .. ;
  1.  .. ;Get pointer to web service entry
  1.  .. S DA(1)=SITE,DA=SIEN,IENS=$$IENS^DILF(.DA)
  1.  .. S IEN=$$GET1^DIQ(9002318.01,IENS,".01","I")
  1.  I IEN="" Q
  1.  ;
  1.  ;Create new entry
  1.  D NOW^%DTC
  1.  S DIC(0)="L",DA(1)=IEN
  1.  S DIC="^BSTS(9002318.2,"_DA(1)_",5,"
  1.  L +^BSTS(9002318.2,IEN,5,0):1 E  Q
  1.  S X=%
  1.  S DLAYGO=9002318.25
  1.  K DO,DD D FILE^DICN
  1.  L -^BSTS(9002318.2,IEN,5,0)
  1.  I +Y<0 Q
  1.  ;
  1.  ;File message
  1.  I MSG="" Q
  1.  S MSG=$TR(MSG,"^","~")
  1.  S DA=+Y,IENS=$$IENS^DILF(.DA)
  1.  S BSTSUP(9002318.25,IENS,".02")=$E(MSG,1,229)
  1.  D FILE^DIE("","BSTSUP","ERROR")
  1.  ;
  1.  Q
  1.  ;
  1. JBTIME(TOM) ;Calculate job time
  1.  ;
  1.  ;TOM - (1) If after 6 PM already schedule for tomorrow
  1.  S TOM=$G(TOM)
  1.  ;
  1.  NEW %,TIME
  1.  ;
  1.  D NOW^%DTC
  1.  ;
  1.  ;After 6 PM
  1.  I +$E($P(%,".",2),1,2)'<18 D  Q TIME
  1.  . I 'TOM S TIME=$$FMADD^XLFDT($$NOW^XLFDT(),,,2) Q
  1.  . NEW X1,X2,X
  1.  . S X1=$P(%,"."),X2=1 D C^%DTC
  1.  . S TIME=X_".180200"
  1.  ;
  1.  ;Return 6:02 PM
  1.  Q DT_".180200"
  1.  Q
  1.  ;
  1.  ;Background processing
  1. QUEUE(TYPE) ;Schedule Background process
  1.  ;
  1.  NEW TAGRTN,NMIEN,NMID,ZTSK,FIELD,ONMIEN
  1.  ;
  1.  ;BSTS*1.0*8;Added S1552 subsets
  1.  ;Determine process
  1.  S ONMIEN=""
  1.  I TYPE=32778 S TAGRTN="A9CODE^BSTSVRSC",NMID=32778
  1.  E  I TYPE=32777 S TAGRTN="ACODE^BSTSVRSC",NMID=32777
  1.  E  I TYPE=32779 S TAGRTN="ACODE^BSTSVRSC",NMID=32777,ONMIEN=32779  ;BSTS*1.0*6;Added conditionals
  1.  E  I TYPE=32780 S TAGRTN="ACODE^BSTSVRSC",NMID=32777,ONMIEN=32780  ;BSTS*1.0*7;Added equivalents
  1.  E  I TYPE="S36" S TAGRTN="SUB^BSTSVRSN",NMID=36
  1.  E  I TYPE="S1552" S TAGRTN="SUB^BSTSVRXN",NMID=1552
  1.  E  I TYPE=36 S TAGRTN="RES^BSTSVRSN:"_TYPE,NMID=36
  1.  E  I TYPE=5180 S TAGRTN="RES^BSTSVRSN:"_TYPE,NMID=5180
  1.  E  I TYPE=1552 S TAGRTN="RES^BSTSVRSN:"_TYPE,NMID=1552
  1.  E  I TYPE="ICD" S TAGRTN="JOB^BSTSUTIL",NMID=36
  1.  E  I TYPE="PRG" S TAGRTN="EPURGE^BSTSVOFL",NMID=36
  1.  E  I TYPE="STS" S TAGRTN="STATUS^BSTSAPIL",NMID=36
  1.  E  I TYPE'="PRG",TYPE'="S36",TYPE'="S1552",TYPE'="ICD",TYPE'=32779,TYPE'=32780,TYPE'=32778,TYPE'=32777,TYPE'=36,TYPE'=5180,TYPE'=1552 S TAGRTN="CDST^BSTSVRSC:"_TYPE,NMID=TYPE
  1.  E  Q
  1.  ;
  1.  ;Get NMIEN,ONMIEN
  1.  S NMIEN=$O(^BSTS(9002318.1,"B",NMID,"")) Q:NMIEN=""
  1.  I ONMIEN]"" S ONMIEN=$O(^BSTS(9002318.1,"B",ONMIEN,"")) Q:ONMIEN=""
  1.  ;
  1.  ;Update LAST VERSION CHECK now so process won't keep getting called
  1.  S FIELD=$S(TYPE="S1552":".06",TYPE="S36":".06",TYPE="PRG":"",TYPE="ICD":"",1:".05") I FIELD]"" D
  1.  . NEW BSTS,ERROR
  1.  . S ONMIEN=$S(ONMIEN]"":ONMIEN,1:NMIEN)
  1.  . S BSTS(9002318.1,ONMIEN_",",FIELD)=DT
  1.  . D FILE^DIE("","BSTS","ERROR")
  1.  ;
  1.  ;Quit if already scheduled
  1.  I $D(^XTMP("BSTSPROCQ","B",TAGRTN)) Q
  1.  ;
  1.  ;Put entry in queue
  1.  D QENTRY(TAGRTN,NMIEN,TYPE)
  1.  ;
  1.  ;Job off process (if not already scheduled)
  1.  I '$$PSCHD^BSTSVOF1("BSTSVOFL") S ZTSK=$$JOB()
  1.  ;
  1.  ;Update SMD2ICD9 with task
  1.  I TYPE="ICD",+$G(ZTSK)>0 D
  1.  . NEW BSTS,ERROR
  1.  . S BSTS(9002318.1,NMIEN_",",".09")=$G(ZTSK)
  1.  . D FILE^DIE("","BSTS","ERROR")
  1.  ;
  1.  Q
  1.  ;
  1. QENTRY(TAGRTN,NMIEN,TYPE) ;Put entry in queue
  1.  ;
  1.  NEW NEXT,X1,X2,X,%
  1.  ;
  1.  ;Get future date for ^XTMP
  1.  S X1=DT,X2=60 D C^%DTC
  1.  ;
  1.  ;Update top level
  1.  S ^XTMP("BSTSPROCQ",0)=X_U_DT_U_"BSTS Background Process Queue"
  1.  ;
  1.  D NOW^%DTC
  1.  ;
  1.  ;Get next pointer
  1.  L +^XTMP("BSTSPROCQ","CTR"):1 E  Q
  1.  S (NEXT,^XTMP("BSTSPROCQ","CTR"))=$G(^XTMP("BSTSPROCQ","CTR"))+1
  1.  S ^XTMP("BSTSPROCQ",NEXT,"RTN")=TAGRTN
  1.  S ^XTMP("BSTSPROCQ",NEXT,"NMIEN")=NMIEN
  1.  S ^XTMP("BSTSPROCQ",NEXT,"TYPE")=TYPE
  1.  S ^XTMP("BSTSPROCQ",NEXT,"SCHED")=%
  1.  S ^XTMP("BSTSPROCQ","B",TAGRTN,NEXT)=""
  1.  L -^XTMP("BSTSPROCQ","CTR")
  1.  Q
  1.  ;
  1. JOB(DTIME,OVR) ;Job off background process
  1.  NEW ZTDTH,ZTDESC,ZTRTN,ZTIO,ZTSAVE,ZTSK,BSTSOVR
  1.  ;
  1.  ;Handle start override
  1.  I +$G(OVR) S BSTSOVR=1,ZTSAVE("BSTSOVR")=""
  1.  ;
  1.  S ZTIO=""
  1.  S ZTRTN="PROC^BSTSVOFL",ZTDESC="BSTS - Background Process Handling"
  1.  I $G(DTIME)]"" S ZTDTH=DTIME
  1.  I $G(DTIME)="" D
  1.  . S ZTDTH=$$JBTIME^BSTSVOFL()  ;Job after 6 PM
  1.  D ^%ZTLOAD
  1.  ;
  1.  Q $G(ZTSK)
  1.  ;
  1. JOBNOW ;Job off background process now
  1.  NEW ZTSK
  1.  S ZTSK=$$JOB($$FMADD^XLFDT($$NOW^XLFDT(),,,1),1)
  1.  Q
  1.  ;
  1. PROC ;BSTS Background Process Front End
  1.  ;
  1.  ;Perform lock
  1.  L +^XTMP("BSTSPROCQ",1):1 E  Q
  1.  ;
  1.  ;Reset quit flags
  1.  K ^XTMP("BSTSPROCQ","QUIT")
  1.  K ^XTMP("BSTSLCMP","QUIT")
  1.  ;
  1.  NEW QUEUE
  1.  ;
  1.  S QUEUE=0 F  S QUEUE=$O(^XTMP("BSTSPROCQ",QUEUE)) Q:'QUEUE  D  I $D(^XTMP("BSTSLCMP","QUIT"))!$D(^XTMP("BSTSPROCQ","QUIT")) Q
  1.  . ;
  1.  . ;Wait until process is ok to run
  1.  . NEW CANRUN,OTAGRTN,TAGRTN,NMIEN,%,QIEN
  1.  . S CANRUN=0 F  D  Q:CANRUN=1  H 300 Q:$D(^XTMP("BSTSPROCQ","QUIT"))
  1.  .. ;
  1.  .. NEW TIME
  1.  .. ;
  1.  .. ;Check for background processes
  1.  .. L +^BSTS(9002318.1,0):1 E  Q
  1.  .. L -^BSTS(9002318.1,0)
  1.  .. L +^TMP("BSTSICD2SMD"):1 E  Q
  1.  .. L -^TMP("BSTSICD2SMD")
  1.  .. ;
  1.  .. ;Check time, only start between 6 PM and 3 AM
  1.  .. I +$G(BSTSOVR) S CANRUN=1 Q  ;Look for override (defined in job call)
  1.  .. D NOW^%DTC
  1.  .. S TIME=+$E($P(%,".",2),1,2)
  1.  .. I TIME>3,TIME<18 Q
  1.  .. S CANRUN=1
  1.  . ;
  1.  . ;Handle quits
  1.  . Q:$D(^XTMP("BSTSPROCQ","QUIT"))
  1.  . ;
  1.  . ;Get Routine/NMIEN
  1.  . S (OTAGRTN,TAGRTN)=$G(^XTMP("BSTSPROCQ",QUEUE,"RTN"))
  1.  . S TAGRTN=$P(TAGRTN,":")
  1.  . S NMIEN=$G(^XTMP("BSTSPROCQ",QUEUE,"NMIEN"))
  1.  . ;
  1.  . ;Log entries
  1.  . D NOW^%DTC
  1.  . S ^XTMP("BSTSPROCQ",QUEUE,"START")=%
  1.  . S ^XTMP("BSTSPROCQ",QUEUE,"TASK")=$G(ZTSK)
  1.  . K ^XTMP("BSTSPROCQ",QUEUE,"ABORT")  ;Reset abort flag
  1.  . ;
  1.  . ;Make call
  1.  . D DT^DICRW ;Refresh DT since could be run overnight
  1.  . D EN^XBNEW(TAGRTN,"NMIEN")
  1.  . D NOW^%DTC
  1.  . L -^BSTS(9002318.1,0) ;Make sure locks released
  1.  . L -^TMP("BSTSICD2SMD")
  1.  . ;
  1.  . ;Check for failure
  1.  . I $D(^XTMP("BSTSLCMP","QUIT")) D  Q
  1.  .. NEW ZTSK,X1,X2,X
  1.  .. S ^XTMP("BSTSPROCQ",QUEUE,"ABORT")=%
  1.  .. S X1=DT,X2=1 D C^%DTC
  1.  .. S ZTSK=$$JOB($$JBTIME(1))  ;On fail reschedule
  1.  . ;
  1.  . ;Log success
  1.  . D NOW^%DTC
  1.  . S ^XTMP("BSTSPROCQ",QUEUE,"END")=%
  1.  . S ^XTMP("BSTSPROCQ","PD",%,QUEUE)=""
  1.  . S ^XTMP("BSTSPROCQ","PP",OTAGRTN,QUEUE)=""
  1.  . M ^XTMP("BSTSPROCQ","P",QUEUE)=^XTMP("BSTSPROCQ",QUEUE)
  1.  . S QIEN="" F  S QIEN=$O(^XTMP("BSTSPROCQ","B",OTAGRTN,QIEN)) Q:QIEN=""  K ^XTMP("BSTSPROCQ",QIEN)
  1.  . K ^XTMP("BSTSPROCQ","B",OTAGRTN)
  1.  ;
  1.  ;Look for concepts that need updated
  1.  I '$D(^XTMP("BSTSLCMP","QUIT")),'$D(^XTMP("BSTSPROCQ","QUIT")),$O(^XTMP("BSTSPROCQ","C",""))]"" D UPCNC^BSTSVOF1
  1.  ;
  1.  ;Perform daily logging
  1.  I '$D(^XTMP("BSTSLCMP","QUIT")),'$D(^XTMP("BSTSPROCQ","QUIT")),$O(^XTMP("BSTSPROCQ","L",""))]"" D PLOG^BSTSAPIL()
  1.  ;
  1.  ;Clear out quit flags
  1.  K ^XTMP("BSTSLCMP","QUIT")
  1.  K ^XTMP("BSTSPROCQ","QUIT")
  1.  ;
  1.  ;Release lock
  1.  L -^XTMP("BSTSPROCQ",1)
  1.  ;
  1.  Q
  1.  ;
  1. EPURGE ;Purge BSTS WEB SERVICE ENDPOINT Error Responses
  1.  ;
  1.  NEW SITE,SIEN
  1.  ;
  1.  S SITE=0 F  S SITE=$O(^BSTS(9002318,SITE)) Q:'SITE  S SIEN=0 F  S SIEN=$O(^BSTS(9002318,SITE,1,SIEN)) Q:'SIEN  D
  1.  . NEW WIEN,IENS,DA,EDATE,QUIT,KPDATE,X1,X2,X,DAYS
  1.  . ;
  1.  . ;Get the pointer to the web service entry
  1.  . S DA(1)=SITE,DA=SIEN,IENS=$$IENS^DILF(.DA)
  1.  . S WIEN=$$GET1^DIQ(9002318.01,IENS,".01","I") Q:WIEN=""
  1.  . ;
  1.  . ;Get the days to keep on file
  1.  . S DAYS=$$GET1^DIQ(9002318.01,IENS,".03","I") S:DAYS="" DAYS=14
  1.  . S X1=DT,X2=-DAYS D C^%DTC S KPDATE=X
  1.  . ;
  1.  . ;Loop through response errors
  1.  . S QUIT=0,EDATE="" F  S EDATE=$O(^BSTS(9002318.2,WIEN,5,"B",EDATE)) Q:'EDATE!QUIT  D
  1.  .. ;
  1.  .. NEW PIEN,DA,DIK
  1.  .. ;
  1.  .. ;Check date
  1.  .. I EDATE>KPDATE S QUIT=1 Q
  1.  .. ;
  1.  .. ;Purge
  1.  .. S PIEN="" F  S PIEN=$O(^BSTS(9002318.2,WIEN,5,"B",EDATE,PIEN)) Q:PIEN=""  D
  1.  ... S DA(1)=WIEN,DA=PIEN,DIK="^BSTS(9002318.2,"_DA(1)_",5," D ^DIK
  1.  . ;
  1.  . ;Also clean out these calls from background log
  1.  . S IENS="" F  S IENS=$O(^XTMP("BSTSPROCQ","PP","EPURGE^BSTSVOFL",IENS)) Q:IENS=""  D
  1.  .. NEW END
  1.  .. S END=$G(^XTMP("BSTSPROCQ","P",IENS,"START")) Q:END=""
  1.  .. I END>KPDATE Q
  1.  .. ;
  1.  .. ;Purge
  1.  .. K ^XTMP("BSTSPROCQ","PP","EPURGE^BSTSVOFL",IENS)
  1.  .. K ^XTMP("BSTSPROCQ","PD",END,IENS)
  1.  .. K ^XTMP("BSTSPROCQ","P",IENS)
  1.  ;
  1.  Q