HMPDJFSP ;SLC/KCM.ASMR/RRB,CPC-PUT/POST for extract & freshness ;Jan 20, 2017 17:18:18
;;2.0;ENTERPRISE HEALTH MANAGEMENT PLATFORM;**1,2,3**;Sep 01, 2011;Build 15
;Per VA Directive 6402, this routine should not be modified.
;
Q ; no entry at top
;
;
; --- create a new patient subscription
;
PUTSUB(ARGS) ; return location after creating a new subscription
; called by:
; API^HMPDJFS
; falls through to:
; QREJOIN
; calls:
; $$TM^%ZTLOAD
; SETERR^HMPDJFS
; $$GETDFN^MPIF001
; SETERR^HMPDJFS
; OPDOMS^HMPDJFSD
; PTDOMS^HMPDJFSD
; SETPAT
; NEWXTMP^HMPDJFS
; SETMARK
; INIT^HMPMETA
; $$HTFM^XLFDT
; SAVETASK^HMPDJFSQ
; $$PID^HMPDJFS
; output:
; fn returns : /hmp/subscription/{hmpSrvId}/patient/{sysId;dfn}
; : "" if error, errors in ^TMP("HMPFERR",$J)
; .ARGS("server") : name of HMP server
; .ARGS("localId") : dfn for patient to subscribe or "OPD" (operational data)
; .ARGS("icn") : icn for patient to subscribe
; .ARGS("domains") : optional array of domains to initialize (deprecated)
;
I '$$TM^%ZTLOAD D SETERR^HMPDJFS("Taskman not running") Q ""
;
N HMPSRV,HMPFDFN,HMPBATCH,HMPFERR,I,NEWSUB,DOMAINS,HMPSVERS,HMPSTMP,HMPPRITY,HMPQBTCH ;US13442
;
; make sure we can identify the patient ("OPD" signals sync operational)
S HMPFDFN=$G(ARGS("localId"))
S HMPSVERS=+$G(ARGS("HMPSVERS")) ;US11019 get sync version
I HMPFDFN'="OPD" D Q:$G(HMPFERR) ""
. I '$L(HMPFDFN),$L(ARGS("icn")) S HMPFDFN=+$$GETDFN^MPIF001(ARGS("icn"))
. I 'HMPFDFN D SETERR^HMPDJFS("No patient specified") Q
. I '$D(^DPT(HMPFDFN)) D SETERR^HMPDJFS("Patient not found") ; IA 10035, DE2818
;
; make sure server is known and create batch id
S HMPSRV=HMPFHMP ; TODO: switch to HMPFHMP as server ien
I '$L(HMPSRV) D SETERR^HMPDJFS("Missing HMP Server ID") Q ""
S HMPSRV("ien")=$O(^HMP(800000,"B",HMPSRV,0))
I 'HMPSRV("ien") D SETERR^HMPDJFS("HMP Server not registered") Q ""
S HMPBATCH="HMPFX~"_HMPSRV_"~"_HMPFDFN
S HMPQBTCH="HMPFS~"_HMPSRV_"~queue"
;
; set up domains to extract
D @($S(HMPFDFN="OPD":"OPDOMS",1:"PTDOMS")_"^HMPDJFSD(.DOMAINS)")
;
; ejk US5647
; code below restores selective domain functionality.
; once the complete list of domains is returned from HMPDJFSD,
; if ARGS("domains") is passed in, anything not in that parameter
; will be excluded from the ODS extract.
I $G(ARGS("domains"))'="" D
.F I=1:1 Q:'$D(DOMAINS(I)) I ARGS("domains")'[DOMAINS(I) K DOMAINS(I)
;
; see if this is new subscription and task extract if new
D SETPAT(HMPFDFN,HMPSRV,.NEWSUB) Q:$G(HMPFERR) ""
;For operational data set stamptime as time subscription placed US6734
S HMPSTMP=$$EN^HMPSTMP("NOW") ;DE3377
;
;cpc US11019 following chunk of code moved out of QUINIT as was being called multiple times
;US11019 get array of job ids by domain
; only done once when beginning the batch, no matter how many tasked jobs
L +^XTMP(HMPBATCH):5 E D SETERR^HMPDJFS("Cannot lock batch:"_HMPBATCH) QUIT
I '$D(^XTMP(HMPBATCH)) D
. D NEWXTMP^HMPDJFS(HMPBATCH,2,"HMP Patient Extract")
. ;US11019 - store domain specific job ids
. N EMPB S EMPB="jobDomainId-" ;US11019
. F S EMPB=$O(ARGS(EMPB)) Q:EMPB="" Q:EMPB'["jobDomainId-" S:'HMPSVERS HMPSVERS=1 S ^XTMP(HMPBATCH,"JOBID",$P(EMPB,"jobDomainId-",2))=ARGS(EMPB) ; US11019 3rd version
. S ^XTMP(HMPBATCH,"HMPSVERS")=HMPSVERS ;US11019 store sync version
. I $G(ARGS("jobId"))]"" S ^XTMP(HMPBATCH,"JOBID")=ARGS("jobId") ;US3907 /US11019
. I $G(ARGS("rootJobId"))]"" S ^XTMP(HMPBATCH,"ROOTJOBID")=ARGS("rootJobId") ;US3907
. S ^XTMP(HMPBATCH,0,"time")=$H
. ; US6734 - setting of syncStart for OPD only
. I HMPFDFN="OPD" D SETMARK("Start",HMPFDFN,HMPBATCH),INIT^HMPMETA(HMPBATCH,HMPFDFN,.ARGS) ; US6734
L -^XTMP(HMPBATCH)
;cpc US11019 end moved code
;US13442
S HMPPRITY=1 S:+$G(ARGS("HMPPriority")) HMPPRITY=+ARGS("HMPPriority")
I '$D(^XTMP(HMPQBTCH,0)) D ;check basic controls exist
. S ^XTMP(HMPQBTCH,0)=$$HTFM^XLFDT(+$H+5)_U_$$HTFM^XLFDT(+$H)_U_"HMP task queue"
. S ^XTMP(HMPQBTCH,0,0)=2 ;default concurrent patients
;put task onto task queue if new subscription for patient
I NEWSUB,+HMPFDFN D SAVETASK^HMPDJFSQ Q "/hmp/subscription/"_HMPSRV_"/patient/"_$$PID^HMPDJFS(HMPFDFN)
;
QREJOIN ; task And come back in from queue
; falls through from:
; PUTSUB
; called by:
; NEWTASK^HMPDJFSQ: ZTRTN="QREJOIN^HMPDJFSP"
; calls:
; UPDSTS
; QUINIT^HMPDJFSQ
; SETMARK
; $$PID^HMPDJFS
;
;Every Domain in it's own task (unless running in original mode)
I NEWSUB D Q:$G(HMPFERR) ""
. ; if patient's extracts are held (version mismatch), put DFN on wait list
. I +HMPFDFN,$G(^XTMP("HMPFS~"_HMPSRV("ien"),"waiting")) S ^XTMP("HMPFS~"_HMPSRV("ien"),"waiting",HMPFDFN)="" QUIT
. D UPDSTS(HMPFDFN,$P(HMPBATCH,"~",2),1) ;moved from background job to once in foreground 12/17/2015
. I 'HMPSVERS N HMPFDOM M HMPFDOM=DOMAINS D QUINIT^HMPDJFSQ(HMPBATCH,HMPFDFN,.HMPFDOM) Q ;US11019 Enable previous behavior
. S I="" F S I=$O(DOMAINS(I)) Q:'I D
.. N HMPFDOM
.. S HMPFDOM(1)=DOMAINS(I)
.. D QUINIT^HMPDJFSQ(HMPBATCH,HMPFDFN,.HMPFDOM)
;===JD START===
; For patient resubscribes, need to send demographics ONLY
I 'NEWSUB,HMPFDFN'="OPD",'$D(^XTMP(HMPBATCH,0,"status")) D ;DE3331 check expanded to ensure not current
. N HMPFDOM,HMPDSAVE ;DE3331
. M HMPDSAVE=DOMAINS ;DE3331
. K DOMAINS S DOMAINS(1)="patient"
. M HMPFDOM=DOMAINS
. D QUINIT^HMPDJFSQ(HMPBATCH,HMPFDFN,.HMPFDOM)
. I $G(HMPSVERS) S I="" F S I=$O(HMPDSAVE(I)) Q:'I D ;DE3331 create empty metastamp entries for remaining domains
.. I HMPDSAVE(I)'="patient" D SETMARK("Meta",HMPFDFN,HMPDSAVE(I))
;===JD END===
Q "/hmp/subscription/"_HMPSRV_"/patient/"_$$PID^HMPDJFS(HMPFDFN)
;
;
QUINIT(HMPBATCH,HMPFDFN,HMPFDOM) ; Queue the initial extracts for a patient
; called by:
; VERMATCH^HMPDJFSG
; CVTSEL^HMPP3I
; calls:
; QUINIT^HMPDJFSQ
;
do QUINIT^HMPDJFSQ(HMPBATCH,HMPFDFN,.HMPFDOM)
;
quit ; end of QUINIT
;
;
SETDOM(ATTRIB,DOMAIN,VALUE,HMPMETA) ; Set value for a domain ; cpc TA41760
; called by:
; QUINIT^HMPDJFSQ
; QUINIT^HMPMETA
; DQINIT^HMPDJFSQ
; DOMPT
; MOD4STRM
; calls: none
; input:
; ATTRIB: "status" or "count" attribute
; VALUE:
; for status, VALUE: 0=waiting, 1=ready
; for count, VALUE: count of items
; don't update to finished value if just tracking metastamp
;
I $G(HMPMETA)'="" S ^XTMP(HMPBATCH,0,ATTRIB,DOMAIN,$S(HMPMETA=1:"MetaStamp",HMPMETA=2:"Combined",1:"Staging"),$S(VALUE:"Stop",1:"Start"))=$H Q:(HMPMETA=1&VALUE) ;cpc TA41760 10/7/2015 add time logging
S ^XTMP(HMPBATCH,0,ATTRIB,DOMAIN)=VALUE
Q
;
;
SETMARK(TYPE,HMPFDFN,HMPBATCH) ; Post markers for begin and end of initial synch
; called by:
; PUTSUB
; PUTSUB-QREJOIN
; QUINIT^HMPMETA
; DQINIT^HMPDJFSQ
; calls:
; POST^HMPDJFS
; SETTIDY
;
; ^XTMP("HMPFP","tidy",hmpServer,fmDate,sequence)=batch
Q:$G(HMPENVIR("converting")) ; don't set markers during conversion
N HMPSRV,NODES,X
S HMPSRV=$P(HMPBATCH,"~",2)
D POST^HMPDJFS(HMPFDFN,"sync"_TYPE,HMPBATCH,"",HMPSRV,.NODES)
Q:TYPE="Start"!(TYPE="Meta") ; US11019
D SETTIDY("<done>",.NODES)
Q
;
;
DQINIT ; task Dequeue initial extracts
; called by: none
; calls:
; DQINIT^HMPDJFSQ
;
do DQINIT^HMPDJFSQ
;
quit ; end of DQINIT
;
;
DOMPT(HMPFADOM) ; Load a patient domain
; called by:
; DQBACKDM^HMPDJFS1
; DQINIT^HMPDJFSQ
; calls:
; $$CHNKCNT
; GET^HMPDJ
; SETDOM
; CHNKFIN
;
N FILTER,RSLT,HMPFEST,HMPCHNK ; *S68-JCH*
S FILTER("noHead")=1
S FILTER("domain")=HMPFADOM
S FILTER("patientId")=HMPFDFN
; -- domain var used for chunking patient objects using <domain>#<number> construct *BEGIN*S68-JCH*
S HMPCHNK=HMPFADOM
S HMPCHNK("trigger count")=$$CHNKCNT(HMPFADOM) ; *END*S68-JCH*
D GET^HMPDJ(.RSLT,.FILTER) ;US11019 I $G(HMPMETA) D SETDOM("status",HMPFADOM,1,1) Q ;US11019/US6734 - do not update stream if compiling metastamp ; CPC TA41760
I $G(HMPMETA)=1 D SETDOM("status",HMPFADOM,1,1) Q ;US11019/US6734 - do not update stream if compiling metastamp ; CPC TA41760
; add to HMPFS queue if total>0 OR this is the first chunck (#0) section *S68-JCH*
I ($G(@RSLT@("total"),0)>0)!($P(HMPCHNK,"#",2)=0) D CHNKFIN ; *S68-JCH*
Q
;
;
DOMOPD(HMPFADOM) ; Load an operational domain in smaller batches
; called by: none
; calls:
; DOMOPD^HMPDJFSQ
;
D DOMOPD^HMPDJFSQ(HMPFADOM) Q
;
;
CHNKCNT(DOMAIN) ; -- get patient object chunk count trigger *BEGIN*S68-JCH*
; called by:
; DOMPT
; calls:
; $$GET^XPAR
; input:
; DOMAIN := current domain name being processed
;
Q $S(+$$GET^XPAR("PKG","HMP DOMAIN SIZES",$P($G(DOMAIN),"#"),"Q")>3000:500,1:1000) ; *END*S68-JCH*
;
;
CHNKINIT(HMP,HMPI) ; -- init chunk section callback *BEGIN*S68-JCH*
; called by:
; GET^HMPDJ
; DQINIT^HMPDJFSQ
; CHNKCHK
; calls: none
; input by ref:
; HMP := $NA of location for chunk of objects
; HMPI := number of objects in @HMP
;
; -- quit if not in chunking mode
Q:'$D(HMPCHNK)
;
S $P(HMPCHNK,"#",2)=$S(HMPCHNK["#":$P(HMPCHNK,"#",2)+1,1:0)
S HMP=$NA(^XTMP(HMPBATCH,HMPFZTSK,HMPCHNK))
K @HMP
S HMPI=0
Q ; *END*S68-JCH*
;
;
CHNKCHK(HMP,HMPI) ; -- check if chunk should be queued callback *BEGIN*S68-JCH*
; called by:
; ADD^HMPDJ
; HMP1^HMPDJ02
; calls:
; GTQ^HMPDJ
; CHNKFIN
; CHKXTMP
; CHNKINIT
; input by ref:
; HMP := $NA of location for chunk of objects
; HMPI := number of objects in @HMP
;
; quit if not in chunking mode
Q:'$D(HMPCHNK)
;
; execute 'whether to chunk' criteria
Q:HMPI<HMPCHNK("trigger count")
; -- add tail to json to section
D GTQ^HMPDJ
; -- finish section and put on HMPFS~ queue
D CHNKFIN
; -- check ^XTMP size before continuing; may have to HANG if too big
D CHKXTMP(HMPBATCH,HMPFZTSK) ; US5074 disable loopback
; -- initialize for next section
D CHNKINIT(.HMP,.HMPI)
Q ; *END*S68-JCH*
;
;
CHNKFIN ; -- finish chunk section callback *BEGIN*S68-JCH*
; called by:
; DOMPT
; CHNKCHK
; calls:
; MOD4STRM
; POSTSEC
;
; -- quit if not in chunking mode
Q:'$D(HMPCHNK)
;
D MOD4STRM(HMPCHNK)
; -- domain#number, <no estimated do> , chunk trigger count for domain
D POSTSEC(HMPCHNK,,HMPCHNK("trigger count"))
Q ; *END*S68-JCH*
;
;
MOD4STRM(DOMAIN) ; modify extract to be ready for stream
; called by:
; DOMOPD^HMPDJFSQ
; CHNKFIN
; calls:
; SETDOM
; expects:
; HMPBATCH, HMPFSYS, HMPFZTSK
; results are in:
; ^XTMP("HMPFX~hmpsrv~dfn",DFN,DOMAIN,...)
;
; syncError: {uid,collection,error} uid=urn:va:syncError:sysId:dfn:extract
N DFN,HMPSRV,COUNT,DOMONLY
S DOMONLY=$P(DOMAIN,"#")
S DFN=$P(HMPBATCH,"~",3),HMPSRV=$P(HMPBATCH,"~",2)
S COUNT=+$G(^XTMP(HMPBATCH,HMPFZTSK,DOMAIN,"total"),0)
I COUNT=0 S ^XTMP(HMPBATCH,HMPFZTSK,DOMAIN,1,1)="null"
;
S ^XTMP(HMPBATCH,HMPFZTSK,DOMAIN,"total")=COUNT ; include errors and/or empty
D SETDOM("count",DOMONLY,$G(^XTMP(HMPBATCH,0,"count",DOMONLY),0)+COUNT)
Q
;
;
POSTSEC(DOMAIN,ETOTAL,SECSIZE) ; post domain section to stream and set tidy nodes
; called by:
; DOMOPD^HMPDJFSQ
; CHNKFIN
; calls:
; POST^HMPDJFS
; SETTIDY
;
N DFN,HMPSRV,COUNT,X,NODES
S COUNT=^XTMP(HMPBATCH,HMPFZTSK,DOMAIN,"total")
S ETOTAL=$G(ETOTAL,COUNT)
s SECSIZE=$G(SECSIZE,0)
S DFN=$P(HMPBATCH,"~",3)
S HMPSRV=$P(HMPBATCH,"~",2)
D POST^HMPDJFS(DFN,"syncDomain",DOMAIN_":"_HMPFZTSK_":"_COUNT_":"_ETOTAL_":"_SECSIZE,"",HMPSRV,.NODES)
D SETTIDY(DOMAIN,.NODES)
I $G(HMPQREF)'="" S @HMPQREF=$P($H,",",2) ;update heartbeat US13442
Q
;
;
SETTIDY(DOMAIN,NODES) ; Set tidy nodes for clean-up of the extracts in ^XTMP
; called by:
; SETMARK
; POSTSEC
; calls: none
; expects:
; HMPBATCH,HMPFZTSK
;
N X,STREAM,SEQ
S X="" F S X=$O(NODES(X)) Q:X="" D ; iterate hmp servers
. S STREAM="HMPFS~"_X_"~"_$P(NODES(X),U) ; HMPFS~hmpSrv~fmDate
. S SEQ=$P(NODES(X),U,2)
. S ^XTMP(STREAM,"tidy",SEQ,"batch")=HMPBATCH
. S ^XTMP(STREAM,"tidy",SEQ,"domain")=DOMAIN
. S ^XTMP(STREAM,"tidy",SEQ,"task")=HMPFZTSK
Q
;
;
MVFRUPD(HMPBATCH,HMPFDFN) ; Move freshness updates over active stream
; called by: none
; calls:
; MVFRUPD^HMPDJFSQ
;
do MVFRUPD^HMPDJFSQ(HMPBATCH,HMPFDFN)
;
quit ; end of MVFRUPD
;
;
BLDSERR(DFN,DOMAIN,ERRJSON) ; Create syncError object in ERRJSON
; called by: none
; calls:
; DECODE^HMPJSON
; ENCODE^HMPJSON
; expects:
; HMPBATCH, HMPFSYS, HMPFZTSK
;
N COUNT,ERRVAL,ERROBJ,ERR,ERRMSG,SYNCERR
M ERRVAL=^XTMP(HMPBATCH,HMPFZTSK,DOMAIN,"error")
I $G(ERRVAL)="" Q
S ERRVAL="{"_ERRVAL_"}"
D DECODE^HMPJSON("ERRVAL","ERROBJ","ERR")
I $D(ERR) S $EC=",UJSON decode error,"
K ^XTMP(HMPBATCH,HMPFZTSK,DOMAIN,"error")
S ERRMSG=ERROBJ("error","message")
Q:'$L(ERRMSG)
S SYNCERR("uid")="urn:va:syncError:"_HMPFSYS_":"_DFN_":"_DOMAIN
S SYNCERR("collection")=DOMAIN
S SYNCERR("error")=ERRMSG
D ENCODE^HMPJSON("SYNCERR","ERRJSON","ERR") I $D(ERR) S $EC=",UJSON encode error," Q
S COUNT=$O(^TMP("HMPERR",$J,""),-1)+1
M ^TMP("HMPERR",$J,COUNT)=ERRJSON
Q
;
;
POSTERR(COUNT,DFN) ; put error into ^XTMP(batch)
; called by:
; DQINIT^HMPDJFSQ
; calls:
; POST^HMPDJFS
;
N CNT,NODE,HMPSRV
S HMPSRV=$P(HMPBATCH,"~",2)
S CNT=0 F S CNT=$O(^TMP("HMPERR",$J,CNT)) Q:CNT'>0 D
.S NODE=$G(^TMP("HMPERR",$J,CNT,1))
.S ^XTMP(HMPBATCH,HMPFZTSK,"error",CNT,1)=NODE
.I CNT>1 S ^XTMP(HMPBATCH,HMPFZTSK,"error",CNT,.3)=","
D POST^HMPDJFS(DFN,"syncError","error:"_HMPFZTSK_":"_COUNT_":"_COUNT,"",HMPSRV)
Q
;
;
INITDONE(HMPBATCH) ; Return 1 if all domains are done
; called by:
; DQINIT^HMPDJFSQ
; calls: none
;
N X,DONE
S X="",DONE=1
F S X=$O(^XTMP(HMPBATCH,0,"status",X)) Q:'$L(X) I '^(X) S DONE=0
Q DONE
;
;
SETPAT(DFN,SRV,NEWSUB) ; Add patient to 800000 if not there
; called by:
; EN^HMPMETA
; PUTSUB
; calls:
; SETERR^HMPDJFS
; UPDOPD
; ADDPAT
;
N ERR,FDA,IEN,IENROOT
S IEN=$O(^HMP(800000,"B",SRV,0))
I 'IEN D SETERR^HMPDJFS("Unable to find server: "_SRV) QUIT
; for operational, only start sync if not yet subscribed
I DFN="OPD" D QUIT
. L +^HMP(800000,IEN):5 E D SETERR^HMPDJFS("Unable to lock server: "_SRV) Q
. ; status is empty string (not 0) when unsubscribed
. S NEWSUB='$L($P($G(^HMP(800000,IEN,0)),U,3))
. I NEWSUB D UPDOPD(IEN,1) ; set to subscribed
. L -^HMP(800000,IEN)
;
; for patient, check subscribed and get the PID
L +^HMP(800000,IEN,1,DFN):5 E D SETERR^HMPDJFS("Unable to lock patient: "_DFN) Q
S NEWSUB='$D(^HMP(800000,IEN,1,DFN))
I NEWSUB D ADDPAT(DFN,IEN)
L -^HMP(800000,IEN,1,DFN)
Q
;
;
UPDOPD(SRV,STS) ; Update status of operational synch
; called by:
; UNSUB^HMPMETA
; UPDSTS
; SETPAT
; calls:
; FILE^DIE
; SETERR^HMPDJFS
; CLEAN^DILF
;
N FDA,ERR,DIERR
S FDA(800000,SRV_",",.03)=STS
D FILE^DIE("","FDA","ERR")
I $D(ERR) D SETERR^HMPDJFS("Error changing operational status")
D CLEAN^DILF
Q
;
;
ADDPAT(DFN,SRV) ; Add a patient as subscribed for server
; called by:
; SETPAT
; calls:
; $$NOW^XLFDT
; UPDATE^DIE
; SETERR^HMPDJFS
; CLEAN^DILF
;
N FDA,FDAIEN,DIERR,ERR,IENS
S IENS="?+"_DFN_","_SRV_","
S FDAIEN(DFN)=DFN ; help DINUM to work
S FDA(800000.01,IENS,.01)=DFN
S FDA(800000.01,IENS,2)=0
S FDA(800000.01,IENS,3)=$$NOW^XLFDT
D UPDATE^DIE("","FDA","FDAIEN","ERR")
I $D(ERR) D SETERR^HMPDJFS("Error adding patient subscription")
D CLEAN^DILF
Q
;
;
UPDSTS(DFN,SRVNM,STS) ; Update the sync status
; called by:
; PUTSUB-QREJOIN
; MVFRUPD^HMPDJFSQ
; calls:
; SETERR^HMPDJFS
; UPDOPD
; $$NOW^XLFDT
; FILE^DIE
; CLEAN^DILF
;
N SRV,ERR ;US11019
S SRV=$O(^HMP(800000,"B",SRVNM,0)) I 'SRV D SETERR^HMPDJFS("Missing Server") Q
I DFN="OPD" D UPDOPD(SRV,STS) QUIT
;
S FDA(800000.01,DFN_","_SRV_",",2)=STS
S FDA(800000.01,DFN_","_SRV_",",3)=$$NOW^XLFDT
D FILE^DIE("","FDA","ERR")
I $D(ERR) D SETERR^HMPDJFS("Error updating patient sync status")
D CLEAN^DILF
Q
;
CHKXTMP(HMPBATCH,HMPFZTSK) ; -- ^XTMP check at end each domain loop iteration ; if too big HANG
; called by:
; DQINIT^HMPDJFSQ
; CHNKCHK
;
N HMPOK S HMPOK=0 ; OK to run flag
F D Q:HMPOK
. ; if max disk size > estimated size then done with HANG
. I $$GETMAX^HMPUTILS>$$GETSIZE^HMPUTILS("estimate") K ^XTMP(HMPBATCH,0,"task",HMPFZTSK,"hanging") S HMPOK=1 Q
. S ^("hanging")=$G(^XTMP(HMPBATCH,0,"task",HMPFZTSK,"hanging"))+1 ; increment
. I $G(HMPQREF)'="" S @HMPQREF=$P($H,",",2) ;update heartbeat US13442
. H $$GETSECS
Q
;
GETSECS() ; return default # of seconds to requeue in future or hang when processing domains
; called by:
; CHKSP^HMPUTILS
; CHKXTMP
;
N SECS S SECS=+$$GET^XPAR("SYS","HMP EXTRACT TASK REQUEUE SECS")
Q $S(SECS>0:SECS,1:10) ; if not set, wait 10 seconds
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HHMPDJFSP 17231 printed Sep 02, 2024@18:38:50 Page 2
HMPDJFSP ;SLC/KCM.ASMR/RRB,CPC-PUT/POST for extract & freshness ;Jan 20, 2017 17:18:18
+1 ;;2.0;ENTERPRISE HEALTH MANAGEMENT PLATFORM;**1,2,3**;Sep 01, 2011;Build 15
+2 ;Per VA Directive 6402, this routine should not be modified.
+3 ;
+4 ; no entry at top
QUIT
+5 ;
+6 ;
+7 ; --- create a new patient subscription
+8 ;
PUTSUB(ARGS) ; return location after creating a new subscription
+1 ; called by:
+2 ; API^HMPDJFS
+3 ; falls through to:
+4 ; QREJOIN
+5 ; calls:
+6 ; $$TM^%ZTLOAD
+7 ; SETERR^HMPDJFS
+8 ; $$GETDFN^MPIF001
+9 ; SETERR^HMPDJFS
+10 ; OPDOMS^HMPDJFSD
+11 ; PTDOMS^HMPDJFSD
+12 ; SETPAT
+13 ; NEWXTMP^HMPDJFS
+14 ; SETMARK
+15 ; INIT^HMPMETA
+16 ; $$HTFM^XLFDT
+17 ; SAVETASK^HMPDJFSQ
+18 ; $$PID^HMPDJFS
+19 ; output:
+20 ; fn returns : /hmp/subscription/{hmpSrvId}/patient/{sysId;dfn}
+21 ; : "" if error, errors in ^TMP("HMPFERR",$J)
+22 ; .ARGS("server") : name of HMP server
+23 ; .ARGS("localId") : dfn for patient to subscribe or "OPD" (operational data)
+24 ; .ARGS("icn") : icn for patient to subscribe
+25 ; .ARGS("domains") : optional array of domains to initialize (deprecated)
+26 ;
+27 IF '$$TM^%ZTLOAD
DO SETERR^HMPDJFS("Taskman not running")
QUIT ""
+28 ;
+29 ;US13442
NEW HMPSRV,HMPFDFN,HMPBATCH,HMPFERR,I,NEWSUB,DOMAINS,HMPSVERS,HMPSTMP,HMPPRITY,HMPQBTCH
+30 ;
+31 ; make sure we can identify the patient ("OPD" signals sync operational)
+32 SET HMPFDFN=$GET(ARGS("localId"))
+33 ;US11019 get sync version
SET HMPSVERS=+$GET(ARGS("HMPSVERS"))
+34 IF HMPFDFN'="OPD"
Begin DoDot:1
+35 IF '$LENGTH(HMPFDFN)
IF $LENGTH(ARGS("icn"))
SET HMPFDFN=+$$GETDFN^MPIF001(ARGS("icn"))
+36 IF 'HMPFDFN
DO SETERR^HMPDJFS("No patient specified")
QUIT
+37 ; IA 10035, DE2818
IF '$DATA(^DPT(HMPFDFN))
DO SETERR^HMPDJFS("Patient not found")
End DoDot:1
if $GET(HMPFERR)
QUIT ""
+38 ;
+39 ; make sure server is known and create batch id
+40 ; TODO: switch to HMPFHMP as server ien
SET HMPSRV=HMPFHMP
+41 IF '$LENGTH(HMPSRV)
DO SETERR^HMPDJFS("Missing HMP Server ID")
QUIT ""
+42 SET HMPSRV("ien")=$ORDER(^HMP(800000,"B",HMPSRV,0))
+43 IF 'HMPSRV("ien")
DO SETERR^HMPDJFS("HMP Server not registered")
QUIT ""
+44 SET HMPBATCH="HMPFX~"_HMPSRV_"~"_HMPFDFN
+45 SET HMPQBTCH="HMPFS~"_HMPSRV_"~queue"
+46 ;
+47 ; set up domains to extract
+48 DO @($SELECT(HMPFDFN="OPD":"OPDOMS",1:"PTDOMS")_"^HMPDJFSD(.DOMAINS)")
+49 ;
+50 ; ejk US5647
+51 ; code below restores selective domain functionality.
+52 ; once the complete list of domains is returned from HMPDJFSD,
+53 ; if ARGS("domains") is passed in, anything not in that parameter
+54 ; will be excluded from the ODS extract.
+55 IF $GET(ARGS("domains"))'=""
Begin DoDot:1
+56 FOR I=1:1
if '$DATA(DOMAINS(I))
QUIT
IF ARGS("domains")'[DOMAINS(I)
KILL DOMAINS(I)
End DoDot:1
+57 ;
+58 ; see if this is new subscription and task extract if new
+59 DO SETPAT(HMPFDFN,HMPSRV,.NEWSUB)
if $GET(HMPFERR)
QUIT ""
+60 ;For operational data set stamptime as time subscription placed US6734
+61 ;DE3377
SET HMPSTMP=$$EN^HMPSTMP("NOW")
+62 ;
+63 ;cpc US11019 following chunk of code moved out of QUINIT as was being called multiple times
+64 ;US11019 get array of job ids by domain
+65 ; only done once when beginning the batch, no matter how many tasked jobs
+66 LOCK +^XTMP(HMPBATCH):5
IF '$TEST
DO SETERR^HMPDJFS("Cannot lock batch:"_HMPBATCH)
QUIT
+67 IF '$DATA(^XTMP(HMPBATCH))
Begin DoDot:1
+68 DO NEWXTMP^HMPDJFS(HMPBATCH,2,"HMP Patient Extract")
+69 ;US11019 - store domain specific job ids
+70 ;US11019
NEW EMPB
SET EMPB="jobDomainId-"
+71 ; US11019 3rd version
FOR
SET EMPB=$ORDER(ARGS(EMPB))
if EMPB=""
QUIT
if EMPB'["jobDomainId-"
QUIT
if 'HMPSVERS
SET HMPSVERS=1
SET ^XTMP(HMPBATCH,"JOBID",$PIECE(EMPB,"jobDomainId-",2))=ARGS(EMPB)
+72 ;US11019 store sync version
SET ^XTMP(HMPBATCH,"HMPSVERS")=HMPSVERS
+73 ;US3907 /US11019
IF $GET(ARGS("jobId"))]""
SET ^XTMP(HMPBATCH,"JOBID")=ARGS("jobId")
+74 ;US3907
IF $GET(ARGS("rootJobId"))]""
SET ^XTMP(HMPBATCH,"ROOTJOBID")=ARGS("rootJobId")
+75 SET ^XTMP(HMPBATCH,0,"time")=$HOROLOG
+76 ; US6734 - setting of syncStart for OPD only
+77 ; US6734
IF HMPFDFN="OPD"
DO SETMARK("Start",HMPFDFN,HMPBATCH)
DO INIT^HMPMETA(HMPBATCH,HMPFDFN,.ARGS)
End DoDot:1
+78 LOCK -^XTMP(HMPBATCH)
+79 ;cpc US11019 end moved code
+80 ;US13442
+81 SET HMPPRITY=1
if +$GET(ARGS("HMPPriority"))
SET HMPPRITY=+ARGS("HMPPriority")
+82 ;check basic controls exist
IF '$DATA(^XTMP(HMPQBTCH,0))
Begin DoDot:1
+83 SET ^XTMP(HMPQBTCH,0)=$$HTFM^XLFDT(+$HOROLOG+5)_U_$$HTFM^XLFDT(+$HOROLOG)_U_"HMP task queue"
+84 ;default concurrent patients
SET ^XTMP(HMPQBTCH,0,0)=2
End DoDot:1
+85 ;put task onto task queue if new subscription for patient
+86 IF NEWSUB
IF +HMPFDFN
DO SAVETASK^HMPDJFSQ
QUIT "/hmp/subscription/"_HMPSRV_"/patient/"_$$PID^HMPDJFS(HMPFDFN)
+87 ;
QREJOIN ; task And come back in from queue
+1 ; falls through from:
+2 ; PUTSUB
+3 ; called by:
+4 ; NEWTASK^HMPDJFSQ: ZTRTN="QREJOIN^HMPDJFSP"
+5 ; calls:
+6 ; UPDSTS
+7 ; QUINIT^HMPDJFSQ
+8 ; SETMARK
+9 ; $$PID^HMPDJFS
+10 ;
+11 ;Every Domain in it's own task (unless running in original mode)
+12 IF NEWSUB
Begin DoDot:1
+13 ; if patient's extracts are held (version mismatch), put DFN on wait list
+14 IF +HMPFDFN
IF $GET(^XTMP("HMPFS~"_HMPSRV("ien"),"waiting"))
SET ^XTMP("HMPFS~"_HMPSRV("ien"),"waiting",HMPFDFN)=""
QUIT
+15 ;moved from background job to once in foreground 12/17/2015
DO UPDSTS(HMPFDFN,$PIECE(HMPBATCH,"~",2),1)
+16 ;US11019 Enable previous behavior
IF 'HMPSVERS
NEW HMPFDOM
MERGE HMPFDOM=DOMAINS
DO QUINIT^HMPDJFSQ(HMPBATCH,HMPFDFN,.HMPFDOM)
QUIT
+17 SET I=""
FOR
SET I=$ORDER(DOMAINS(I))
if 'I
QUIT
Begin DoDot:2
+18 NEW HMPFDOM
+19 SET HMPFDOM(1)=DOMAINS(I)
+20 DO QUINIT^HMPDJFSQ(HMPBATCH,HMPFDFN,.HMPFDOM)
End DoDot:2
End DoDot:1
if $GET(HMPFERR)
QUIT ""
+21 ;===JD START===
+22 ; For patient resubscribes, need to send demographics ONLY
+23 ;DE3331 check expanded to ensure not current
IF 'NEWSUB
IF HMPFDFN'="OPD"
IF '$DATA(^XTMP(HMPBATCH,0,"status"))
Begin DoDot:1
+24 ;DE3331
NEW HMPFDOM,HMPDSAVE
+25 ;DE3331
MERGE HMPDSAVE=DOMAINS
+26 KILL DOMAINS
SET DOMAINS(1)="patient"
+27 MERGE HMPFDOM=DOMAINS
+28 DO QUINIT^HMPDJFSQ(HMPBATCH,HMPFDFN,.HMPFDOM)
+29 ;DE3331 create empty metastamp entries for remaining domains
IF $GET(HMPSVERS)
SET I=""
FOR
SET I=$ORDER(HMPDSAVE(I))
if 'I
QUIT
Begin DoDot:2
+30 IF HMPDSAVE(I)'="patient"
DO SETMARK("Meta",HMPFDFN,HMPDSAVE(I))
End DoDot:2
End DoDot:1
+31 ;===JD END===
+32 QUIT "/hmp/subscription/"_HMPSRV_"/patient/"_$$PID^HMPDJFS(HMPFDFN)
+33 ;
+34 ;
QUINIT(HMPBATCH,HMPFDFN,HMPFDOM) ; Queue the initial extracts for a patient
+1 ; called by:
+2 ; VERMATCH^HMPDJFSG
+3 ; CVTSEL^HMPP3I
+4 ; calls:
+5 ; QUINIT^HMPDJFSQ
+6 ;
+7 DO QUINIT^HMPDJFSQ(HMPBATCH,HMPFDFN,.HMPFDOM)
+8 ;
+9 ; end of QUINIT
QUIT
+10 ;
+11 ;
SETDOM(ATTRIB,DOMAIN,VALUE,HMPMETA) ; Set value for a domain ; cpc TA41760
+1 ; called by:
+2 ; QUINIT^HMPDJFSQ
+3 ; QUINIT^HMPMETA
+4 ; DQINIT^HMPDJFSQ
+5 ; DOMPT
+6 ; MOD4STRM
+7 ; calls: none
+8 ; input:
+9 ; ATTRIB: "status" or "count" attribute
+10 ; VALUE:
+11 ; for status, VALUE: 0=waiting, 1=ready
+12 ; for count, VALUE: count of items
+13 ; don't update to finished value if just tracking metastamp
+14 ;
+15 ;cpc TA41760 10/7/2015 add time logging
IF $GET(HMPMETA)'=""
SET ^XTMP(HMPBATCH,0,ATTRIB,DOMAIN,$SELECT(HMPMETA=1:"MetaStamp",HMPMETA=2:"Combined",1:"Staging"),$SELECT(VALUE:"Stop",1:"Start"))=$HOROLOG
if (HMPMETA=1&VALUE)
QUIT
+16 SET ^XTMP(HMPBATCH,0,ATTRIB,DOMAIN)=VALUE
+17 QUIT
+18 ;
+19 ;
SETMARK(TYPE,HMPFDFN,HMPBATCH) ; Post markers for begin and end of initial synch
+1 ; called by:
+2 ; PUTSUB
+3 ; PUTSUB-QREJOIN
+4 ; QUINIT^HMPMETA
+5 ; DQINIT^HMPDJFSQ
+6 ; calls:
+7 ; POST^HMPDJFS
+8 ; SETTIDY
+9 ;
+10 ; ^XTMP("HMPFP","tidy",hmpServer,fmDate,sequence)=batch
+11 ; don't set markers during conversion
if $GET(HMPENVIR("converting"))
QUIT
+12 NEW HMPSRV,NODES,X
+13 SET HMPSRV=$PIECE(HMPBATCH,"~",2)
+14 DO POST^HMPDJFS(HMPFDFN,"sync"_TYPE,HMPBATCH,"",HMPSRV,.NODES)
+15 ; US11019
if TYPE="Start"!(TYPE="Meta")
QUIT
+16 DO SETTIDY("<done>",.NODES)
+17 QUIT
+18 ;
+19 ;
DQINIT ; task Dequeue initial extracts
+1 ; called by: none
+2 ; calls:
+3 ; DQINIT^HMPDJFSQ
+4 ;
+5 DO DQINIT^HMPDJFSQ
+6 ;
+7 ; end of DQINIT
QUIT
+8 ;
+9 ;
DOMPT(HMPFADOM) ; Load a patient domain
+1 ; called by:
+2 ; DQBACKDM^HMPDJFS1
+3 ; DQINIT^HMPDJFSQ
+4 ; calls:
+5 ; $$CHNKCNT
+6 ; GET^HMPDJ
+7 ; SETDOM
+8 ; CHNKFIN
+9 ;
+10 ; *S68-JCH*
NEW FILTER,RSLT,HMPFEST,HMPCHNK
+11 SET FILTER("noHead")=1
+12 SET FILTER("domain")=HMPFADOM
+13 SET FILTER("patientId")=HMPFDFN
+14 ; -- domain var used for chunking patient objects using <domain>#<number> construct *BEGIN*S68-JCH*
+15 SET HMPCHNK=HMPFADOM
+16 ; *END*S68-JCH*
SET HMPCHNK("trigger count")=$$CHNKCNT(HMPFADOM)
+17 ;US11019 I $G(HMPMETA) D SETDOM("status",HMPFADOM,1,1) Q ;US11019/US6734 - do not update stream if compiling metastamp ; CPC TA41760
DO GET^HMPDJ(.RSLT,.FILTER)
+18 ;US11019/US6734 - do not update stream if compiling metastamp ; CPC TA41760
IF $GET(HMPMETA)=1
DO SETDOM("status",HMPFADOM,1,1)
QUIT
+19 ; add to HMPFS queue if total>0 OR this is the first chunck (#0) section *S68-JCH*
+20 ; *S68-JCH*
IF ($GET(@RSLT@("total"),0)>0)!($PIECE(HMPCHNK,"#",2)=0)
DO CHNKFIN
+21 QUIT
+22 ;
+23 ;
DOMOPD(HMPFADOM) ; Load an operational domain in smaller batches
+1 ; called by: none
+2 ; calls:
+3 ; DOMOPD^HMPDJFSQ
+4 ;
+5 DO DOMOPD^HMPDJFSQ(HMPFADOM)
QUIT
+6 ;
+7 ;
CHNKCNT(DOMAIN) ; -- get patient object chunk count trigger *BEGIN*S68-JCH*
+1 ; called by:
+2 ; DOMPT
+3 ; calls:
+4 ; $$GET^XPAR
+5 ; input:
+6 ; DOMAIN := current domain name being processed
+7 ;
+8 ; *END*S68-JCH*
QUIT $SELECT(+$$GET^XPAR("PKG","HMP DOMAIN SIZES",$PIECE($GET(DOMAIN),"#"),"Q")>3000:500,1:1000)
+9 ;
+10 ;
CHNKINIT(HMP,HMPI) ; -- init chunk section callback *BEGIN*S68-JCH*
+1 ; called by:
+2 ; GET^HMPDJ
+3 ; DQINIT^HMPDJFSQ
+4 ; CHNKCHK
+5 ; calls: none
+6 ; input by ref:
+7 ; HMP := $NA of location for chunk of objects
+8 ; HMPI := number of objects in @HMP
+9 ;
+10 ; -- quit if not in chunking mode
+11 if '$DATA(HMPCHNK)
QUIT
+12 ;
+13 SET $PIECE(HMPCHNK,"#",2)=$SELECT(HMPCHNK["#":$PIECE(HMPCHNK,"#",2)+1,1:0)
+14 SET HMP=$NAME(^XTMP(HMPBATCH,HMPFZTSK,HMPCHNK))
+15 KILL @HMP
+16 SET HMPI=0
+17 ; *END*S68-JCH*
QUIT
+18 ;
+19 ;
CHNKCHK(HMP,HMPI) ; -- check if chunk should be queued callback *BEGIN*S68-JCH*
+1 ; called by:
+2 ; ADD^HMPDJ
+3 ; HMP1^HMPDJ02
+4 ; calls:
+5 ; GTQ^HMPDJ
+6 ; CHNKFIN
+7 ; CHKXTMP
+8 ; CHNKINIT
+9 ; input by ref:
+10 ; HMP := $NA of location for chunk of objects
+11 ; HMPI := number of objects in @HMP
+12 ;
+13 ; quit if not in chunking mode
+14 if '$DATA(HMPCHNK)
QUIT
+15 ;
+16 ; execute 'whether to chunk' criteria
+17 if HMPI<HMPCHNK("trigger count")
QUIT
+18 ; -- add tail to json to section
+19 DO GTQ^HMPDJ
+20 ; -- finish section and put on HMPFS~ queue
+21 DO CHNKFIN
+22 ; -- check ^XTMP size before continuing; may have to HANG if too big
+23 ; US5074 disable loopback
DO CHKXTMP(HMPBATCH,HMPFZTSK)
+24 ; -- initialize for next section
+25 DO CHNKINIT(.HMP,.HMPI)
+26 ; *END*S68-JCH*
QUIT
+27 ;
+28 ;
CHNKFIN ; -- finish chunk section callback *BEGIN*S68-JCH*
+1 ; called by:
+2 ; DOMPT
+3 ; CHNKCHK
+4 ; calls:
+5 ; MOD4STRM
+6 ; POSTSEC
+7 ;
+8 ; -- quit if not in chunking mode
+9 if '$DATA(HMPCHNK)
QUIT
+10 ;
+11 DO MOD4STRM(HMPCHNK)
+12 ; -- domain#number, <no estimated do> , chunk trigger count for domain
+13 DO POSTSEC(HMPCHNK,,HMPCHNK("trigger count"))
+14 ; *END*S68-JCH*
QUIT
+15 ;
+16 ;
MOD4STRM(DOMAIN) ; modify extract to be ready for stream
+1 ; called by:
+2 ; DOMOPD^HMPDJFSQ
+3 ; CHNKFIN
+4 ; calls:
+5 ; SETDOM
+6 ; expects:
+7 ; HMPBATCH, HMPFSYS, HMPFZTSK
+8 ; results are in:
+9 ; ^XTMP("HMPFX~hmpsrv~dfn",DFN,DOMAIN,...)
+10 ;
+11 ; syncError: {uid,collection,error} uid=urn:va:syncError:sysId:dfn:extract
+12 NEW DFN,HMPSRV,COUNT,DOMONLY
+13 SET DOMONLY=$PIECE(DOMAIN,"#")
+14 SET DFN=$PIECE(HMPBATCH,"~",3)
SET HMPSRV=$PIECE(HMPBATCH,"~",2)
+15 SET COUNT=+$GET(^XTMP(HMPBATCH,HMPFZTSK,DOMAIN,"total"),0)
+16 IF COUNT=0
SET ^XTMP(HMPBATCH,HMPFZTSK,DOMAIN,1,1)="null"
+17 ;
+18 ; include errors and/or empty
SET ^XTMP(HMPBATCH,HMPFZTSK,DOMAIN,"total")=COUNT
+19 DO SETDOM("count",DOMONLY,$GET(^XTMP(HMPBATCH,0,"count",DOMONLY),0)+COUNT)
+20 QUIT
+21 ;
+22 ;
POSTSEC(DOMAIN,ETOTAL,SECSIZE) ; post domain section to stream and set tidy nodes
+1 ; called by:
+2 ; DOMOPD^HMPDJFSQ
+3 ; CHNKFIN
+4 ; calls:
+5 ; POST^HMPDJFS
+6 ; SETTIDY
+7 ;
+8 NEW DFN,HMPSRV,COUNT,X,NODES
+9 SET COUNT=^XTMP(HMPBATCH,HMPFZTSK,DOMAIN,"total")
+10 SET ETOTAL=$GET(ETOTAL,COUNT)
+11 SET SECSIZE=$GET(SECSIZE,0)
+12 SET DFN=$PIECE(HMPBATCH,"~",3)
+13 SET HMPSRV=$PIECE(HMPBATCH,"~",2)
+14 DO POST^HMPDJFS(DFN,"syncDomain",DOMAIN_":"_HMPFZTSK_":"_COUNT_":"_ETOTAL_":"_SECSIZE,"",HMPSRV,.NODES)
+15 DO SETTIDY(DOMAIN,.NODES)
+16 ;update heartbeat US13442
IF $GET(HMPQREF)'=""
SET @HMPQREF=$PIECE($HOROLOG,",",2)
+17 QUIT
+18 ;
+19 ;
SETTIDY(DOMAIN,NODES) ; Set tidy nodes for clean-up of the extracts in ^XTMP
+1 ; called by:
+2 ; SETMARK
+3 ; POSTSEC
+4 ; calls: none
+5 ; expects:
+6 ; HMPBATCH,HMPFZTSK
+7 ;
+8 NEW X,STREAM,SEQ
+9 ; iterate hmp servers
SET X=""
FOR
SET X=$ORDER(NODES(X))
if X=""
QUIT
Begin DoDot:1
+10 ; HMPFS~hmpSrv~fmDate
SET STREAM="HMPFS~"_X_"~"_$PIECE(NODES(X),U)
+11 SET SEQ=$PIECE(NODES(X),U,2)
+12 SET ^XTMP(STREAM,"tidy",SEQ,"batch")=HMPBATCH
+13 SET ^XTMP(STREAM,"tidy",SEQ,"domain")=DOMAIN
+14 SET ^XTMP(STREAM,"tidy",SEQ,"task")=HMPFZTSK
End DoDot:1
+15 QUIT
+16 ;
+17 ;
MVFRUPD(HMPBATCH,HMPFDFN) ; Move freshness updates over active stream
+1 ; called by: none
+2 ; calls:
+3 ; MVFRUPD^HMPDJFSQ
+4 ;
+5 DO MVFRUPD^HMPDJFSQ(HMPBATCH,HMPFDFN)
+6 ;
+7 ; end of MVFRUPD
QUIT
+8 ;
+9 ;
BLDSERR(DFN,DOMAIN,ERRJSON) ; Create syncError object in ERRJSON
+1 ; called by: none
+2 ; calls:
+3 ; DECODE^HMPJSON
+4 ; ENCODE^HMPJSON
+5 ; expects:
+6 ; HMPBATCH, HMPFSYS, HMPFZTSK
+7 ;
+8 NEW COUNT,ERRVAL,ERROBJ,ERR,ERRMSG,SYNCERR
+9 MERGE ERRVAL=^XTMP(HMPBATCH,HMPFZTSK,DOMAIN,"error")
+10 IF $GET(ERRVAL)=""
QUIT
+11 SET ERRVAL="{"_ERRVAL_"}"
+12 DO DECODE^HMPJSON("ERRVAL","ERROBJ","ERR")
+13 IF $DATA(ERR)
SET $ECODE=",UJSON decode error,"
+14 KILL ^XTMP(HMPBATCH,HMPFZTSK,DOMAIN,"error")
+15 SET ERRMSG=ERROBJ("error","message")
+16 if '$LENGTH(ERRMSG)
QUIT
+17 SET SYNCERR("uid")="urn:va:syncError:"_HMPFSYS_":"_DFN_":"_DOMAIN
+18 SET SYNCERR("collection")=DOMAIN
+19 SET SYNCERR("error")=ERRMSG
+20 DO ENCODE^HMPJSON("SYNCERR","ERRJSON","ERR")
IF $DATA(ERR)
SET $ECODE=",UJSON encode error,"
QUIT
+21 SET COUNT=$ORDER(^TMP("HMPERR",$JOB,""),-1)+1
+22 MERGE ^TMP("HMPERR",$JOB,COUNT)=ERRJSON
+23 QUIT
+24 ;
+25 ;
POSTERR(COUNT,DFN) ; put error into ^XTMP(batch)
+1 ; called by:
+2 ; DQINIT^HMPDJFSQ
+3 ; calls:
+4 ; POST^HMPDJFS
+5 ;
+6 NEW CNT,NODE,HMPSRV
+7 SET HMPSRV=$PIECE(HMPBATCH,"~",2)
+8 SET CNT=0
FOR
SET CNT=$ORDER(^TMP("HMPERR",$JOB,CNT))
if CNT'>0
QUIT
Begin DoDot:1
+9 SET NODE=$GET(^TMP("HMPERR",$JOB,CNT,1))
+10 SET ^XTMP(HMPBATCH,HMPFZTSK,"error",CNT,1)=NODE
+11 IF CNT>1
SET ^XTMP(HMPBATCH,HMPFZTSK,"error",CNT,.3)=","
End DoDot:1
+12 DO POST^HMPDJFS(DFN,"syncError","error:"_HMPFZTSK_":"_COUNT_":"_COUNT,"",HMPSRV)
+13 QUIT
+14 ;
+15 ;
INITDONE(HMPBATCH) ; Return 1 if all domains are done
+1 ; called by:
+2 ; DQINIT^HMPDJFSQ
+3 ; calls: none
+4 ;
+5 NEW X,DONE
+6 SET X=""
SET DONE=1
+7 FOR
SET X=$ORDER(^XTMP(HMPBATCH,0,"status",X))
if '$LENGTH(X)
QUIT
IF '^(X)
SET DONE=0
+8 QUIT DONE
+9 ;
+10 ;
SETPAT(DFN,SRV,NEWSUB) ; Add patient to 800000 if not there
+1 ; called by:
+2 ; EN^HMPMETA
+3 ; PUTSUB
+4 ; calls:
+5 ; SETERR^HMPDJFS
+6 ; UPDOPD
+7 ; ADDPAT
+8 ;
+9 NEW ERR,FDA,IEN,IENROOT
+10 SET IEN=$ORDER(^HMP(800000,"B",SRV,0))
+11 IF 'IEN
DO SETERR^HMPDJFS("Unable to find server: "_SRV)
QUIT
+12 ; for operational, only start sync if not yet subscribed
+13 IF DFN="OPD"
Begin DoDot:1
+14 LOCK +^HMP(800000,IEN):5
IF '$TEST
DO SETERR^HMPDJFS("Unable to lock server: "_SRV)
QUIT
+15 ; status is empty string (not 0) when unsubscribed
+16 SET NEWSUB='$LENGTH($PIECE($GET(^HMP(800000,IEN,0)),U,3))
+17 ; set to subscribed
IF NEWSUB
DO UPDOPD(IEN,1)
+18 LOCK -^HMP(800000,IEN)
End DoDot:1
QUIT
+19 ;
+20 ; for patient, check subscribed and get the PID
+21 LOCK +^HMP(800000,IEN,1,DFN):5
IF '$TEST
DO SETERR^HMPDJFS("Unable to lock patient: "_DFN)
QUIT
+22 SET NEWSUB='$DATA(^HMP(800000,IEN,1,DFN))
+23 IF NEWSUB
DO ADDPAT(DFN,IEN)
+24 LOCK -^HMP(800000,IEN,1,DFN)
+25 QUIT
+26 ;
+27 ;
UPDOPD(SRV,STS) ; Update status of operational synch
+1 ; called by:
+2 ; UNSUB^HMPMETA
+3 ; UPDSTS
+4 ; SETPAT
+5 ; calls:
+6 ; FILE^DIE
+7 ; SETERR^HMPDJFS
+8 ; CLEAN^DILF
+9 ;
+10 NEW FDA,ERR,DIERR
+11 SET FDA(800000,SRV_",",.03)=STS
+12 DO FILE^DIE("","FDA","ERR")
+13 IF $DATA(ERR)
DO SETERR^HMPDJFS("Error changing operational status")
+14 DO CLEAN^DILF
+15 QUIT
+16 ;
+17 ;
ADDPAT(DFN,SRV) ; Add a patient as subscribed for server
+1 ; called by:
+2 ; SETPAT
+3 ; calls:
+4 ; $$NOW^XLFDT
+5 ; UPDATE^DIE
+6 ; SETERR^HMPDJFS
+7 ; CLEAN^DILF
+8 ;
+9 NEW FDA,FDAIEN,DIERR,ERR,IENS
+10 SET IENS="?+"_DFN_","_SRV_","
+11 ; help DINUM to work
SET FDAIEN(DFN)=DFN
+12 SET FDA(800000.01,IENS,.01)=DFN
+13 SET FDA(800000.01,IENS,2)=0
+14 SET FDA(800000.01,IENS,3)=$$NOW^XLFDT
+15 DO UPDATE^DIE("","FDA","FDAIEN","ERR")
+16 IF $DATA(ERR)
DO SETERR^HMPDJFS("Error adding patient subscription")
+17 DO CLEAN^DILF
+18 QUIT
+19 ;
+20 ;
UPDSTS(DFN,SRVNM,STS) ; Update the sync status
+1 ; called by:
+2 ; PUTSUB-QREJOIN
+3 ; MVFRUPD^HMPDJFSQ
+4 ; calls:
+5 ; SETERR^HMPDJFS
+6 ; UPDOPD
+7 ; $$NOW^XLFDT
+8 ; FILE^DIE
+9 ; CLEAN^DILF
+10 ;
+11 ;US11019
NEW SRV,ERR
+12 SET SRV=$ORDER(^HMP(800000,"B",SRVNM,0))
IF 'SRV
DO SETERR^HMPDJFS("Missing Server")
QUIT
+13 IF DFN="OPD"
DO UPDOPD(SRV,STS)
QUIT
+14 ;
+15 SET FDA(800000.01,DFN_","_SRV_",",2)=STS
+16 SET FDA(800000.01,DFN_","_SRV_",",3)=$$NOW^XLFDT
+17 DO FILE^DIE("","FDA","ERR")
+18 IF $DATA(ERR)
DO SETERR^HMPDJFS("Error updating patient sync status")
+19 DO CLEAN^DILF
+20 QUIT
+21 ;
CHKXTMP(HMPBATCH,HMPFZTSK) ; -- ^XTMP check at end each domain loop iteration ; if too big HANG
+1 ; called by:
+2 ; DQINIT^HMPDJFSQ
+3 ; CHNKCHK
+4 ;
+5 ; OK to run flag
NEW HMPOK
SET HMPOK=0
+6 FOR
Begin DoDot:1
+7 ; if max disk size > estimated size then done with HANG
+8 IF $$GETMAX^HMPUTILS>$$GETSIZE^HMPUTILS("estimate")
KILL ^XTMP(HMPBATCH,0,"task",HMPFZTSK,"hanging")
SET HMPOK=1
QUIT
+9 ; increment
SET ^("hanging")=$GET(^XTMP(HMPBATCH,0,"task",HMPFZTSK,"hanging"))+1
+10 ;update heartbeat US13442
IF $GET(HMPQREF)'=""
SET @HMPQREF=$PIECE($HOROLOG,",",2)
+11 HANG $$GETSECS
End DoDot:1
if HMPOK
QUIT
+12 QUIT
+13 ;
GETSECS() ; return default # of seconds to requeue in future or hang when processing domains
+1 ; called by:
+2 ; CHKSP^HMPUTILS
+3 ; CHKXTMP
+4 ;
+5 NEW SECS
SET SECS=+$$GET^XPAR("SYS","HMP EXTRACT TASK REQUEUE SECS")
+6 ; if not set, wait 10 seconds
QUIT $SELECT(SECS>0:SECS,1:10)
+7 ;