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