HMPDJFS ;SLC/KCM,ASMR/BL,JD,CK,CPC,PB -- Asynchronous Extracts and Freshness via stream;Sep 16, 2016 09:45:43
;;2.0;ENTERPRISE HEALTH MANAGEMENT PLATFORM;**1,2,3**;May 15, 2016;Build 15
;Per VA Directive 6402, this routine should not be modified.
;
; JD - 1/14/15 - Removed "+" from "$$GETICN^MPIF001(DFN)" so that the
; full value of icn (<icn>V<checksum>) could be captured. US4194.
; JD - 3/16/15 - Added checks to prevent restaging of data if the data has
; already been staged. US4304
; CPC - 3/4/16 - Prevent dual execution. DE3411
;
; PUT/POST call $$TAG^ROUTINE(.args,.body)
; GET/DELETE call TAG^ROUTINE(.response,.args)
;
Q
;
API(HMPFRSP,ARGS) ;
N HMPFERR,HMPFHMP,HMPFLOG,CNT,ACNT
K ^TMP("HMPF",$J)
S HMPFHMP=$TR($G(ARGS("server")),"~","=")
S HMPFRSP=$NA(^TMP("HMPF",$J))
S HMPFLOG=+$$GET^XPAR("ALL","HMP LOG LEVEL")
I HMPFLOG D LOGREQ(HMPFHMP,.ARGS)
S HMPSYS=$$SYS^HMPUTILS
I '$L(HMPFHMP) D SETERR("Missing HMP Server ID") QUIT
I '$O(^HMP(800000,"B",HMPFHMP,0)) D SETERR("HMP Server not registered") QUIT
;
; begin select case
I ARGS("command")="putPtSubscription" D G XAPI
. N LOC
. S LOC=$$PUTSUB^HMPDJFSP(.ARGS) ; Added ELSE for US4304
. I $L(LOC) S ^TMP("HMPF",$J,1)="{""apiVersion"":""1.0"",""location"":"""_LOC_""""_$$PROGRESS_"}"
I ARGS("command")="startOperationalDataExtract" D G XAPI
. N HMPX2,LOC
. S ARGS("localId")="OPD" ; use OPD to indicate "sync operational"
. ; Next 2 lines added for US4304
. S HMPX2="HMPFX~"_$G(HMPFHMP)_"~OPD"
. D ;DE5181 submit ODS only if not already run or running
.. N HMPUID
.. I $D(^XTMP(HMPX2)) S LOC="/hmp/subscription/operational data/" Q
.. S HMPUID=$O(^HMP(800000,"B",HMPFHMP,0))
.. I HMPUID,$P($G(^HMP(800000,HMPUID,0)),U,3)=2 S LOC="/hmp/subscription/operational data/" Q
.. S LOC=$$PUTSUB^HMPDJFSP(.ARGS)
. I $L(LOC) S ^TMP("HMPF",$J,1)="{""apiVersion"":""1.0"",""location"":"""_LOC_"""}"
I ARGS("command")="getPtUpdates" D G XAPI
. L +^XTMP("HMPDJFSG "_$G(HMPFHMP)):2 E D SETERR^HMPDJFS("Only one extract can run for a single server") Q ;DE3411
. D GETSUB^HMPDJFSG(HMPFRSP,.ARGS)
. L -^XTMP("HMPDJFSG "_$G(HMPFHMP)) ;DE3411
I ARGS("command")="resetAllSubscriptions" D G XAPI
. D RESETSVR(.ARGS)
. S ^TMP("HMPF",$J,1)="{""apiVersion"":""1.0"",""removed"":""true""}"
I ARGS("command")="checkHealth" D G XAPI
. D HLTHCHK^HMPDJFSM(.ARGS)
; else
D SETERR("command not recognized") ; should not get this far
;
XAPI ; end select case
;
I HMPFLOG=2 D LOGRSP(HMPFHMP)
Q
;
LOGREQ(SRV,ARGS) ; Log the request
I $D(^XTMP("HMPFLOG",0,"start")) D Q:'$$GET^XPAR("ALL","HMP LOG LEVEL")
. N ELAPSED S ELAPSED=$$HDIFF^XLFDT($H,^XTMP("HMPFLOG",0,"start"),2)
. I ELAPSED>$$GET^XPAR("ALL","HMP LOG LIMIT") D PUT^XPAR("SYS","HMP LOG LEVEL",1,0)
E D
. D NEWXTMP("HMPFLOG",1,"HMP Freshness Logging")
. S ^XTMP("HMPFLOG",0,"start")=$H
S ^XTMP("HMPFLOG",0,"total")=$G(^XTMP("HMPFLOG",0,"total"))+1
S:'$L(SRV) SRV="unknown"
N SEQ
S SEQ=+$G(^XTMP("HMPFLOG",SRV))+1,^XTMP("HMPFLOG",SRV)=SEQ
M ^XTMP("HMPFLOG",SRV,SEQ,"request")=ARGS
S HMPFLOG("seq")=SEQ
Q
LOGRSP(SRV) ; Log the response
M ^XTMP("HMPFLOG",SRV,HMPFLOG("seq"),"response")=^TMP("HMPF",$J)
Q
;
; delete a patient subscription
DELSUB(RSP,ARGS) ; cancel a subscription
; DELETE with: /hmp/subscription/{hmpSrvId}/patient/{pid}
; remove patient from HMP SUBSCRIPTION file
; remove ^XTMP(HMPX and ^XTMP(HMPH nodes
; look ahead (from lastId) and remove any nodes for the patient
N DFN,HMPSRV,BATCH,HMPSRVID
K ^TMP("HMPF",$J)
; DE6856, initialize HMPFRSP in case of error, use RSP here because of argument in DELSUB line tag, 15 Sept 2016
S:$G(HMPFRSP)="" HMPFRSP="RSP"
S DFN=$$DFN(ARGS("pid")) Q:$D(HMPFERR)
S HMPSRV=ARGS("hmpSrvId")
S BATCH="HMPFX~"_HMPSRV_"~"_DFN
L +^XTMP("HMPFP",DFN,HMPSRV):20 E D SETERR("unable to get lock") Q
; if extract still running, it should remove itself when it finishes
K ^XTMP("HMPFX~"_HMPSRV_"~"_DFN) ; kill extract nodes
K ^XTMP("HMPFH~"_HMPSRV_"~"_DFN) ; kill held freshness updates
; remove all nodes for this patient between "last" and "next"
; loop forward from "last" in ^XTMP("HMPFP",0,hmpSrv) and remove nodes for this DFN
K ^XTMP("HMPFP",DFN,HMPSRV) ; kill subscription
D DELPT(DFN,HMPSRV)
L -^XTMP("HMPFP",DFN,HMPSRV)
S RSP="{""apiVersion"":""1.0"",""success"":""true""}" ; if successful
Q
DELPT(DFN,SRV) ; delete patient DFN for server SRV
N DIK,DA
S DA(1)=$O(^HMP(800000,"B",SRV,"")) Q:'DA(1)
S DA=DFN Q:'DA
S DIK="^HMP(800000,"_DA(1)_",1,"
D ^DIK
Q
;
; --- post freshness updates (internal to VistA)
;
POST(DFN,TYPE,ID,ACT,SERVER,NODES) ; adds new freshness item, return DT-seq
; if initializing use: ^XTMP("HMPFH-hmpserverid-dfn",seq#) -hold
; otherwise use: ^XTMP("HMPFS-hmpserverid-date",seq#) -stream
;
; loop through subscribing streams for this patient
; if patient is initialized for an hmp server send events directly to stream
; otherwise, events go to temporary holding area
; initial extracts always sent directly to stream
N HMPSRV,INIT,STREAM,DATE,SEQ,CNT
S DATE=$$DT^XLFDT
S HMPSRV="" F S HMPSRV=$O(^HMP(800000,"AITEM",DFN,HMPSRV)) Q:'$L(HMPSRV) D
. I SERVER'="",HMPSRV'=SERVER Q
. I '$D(^HMP(800000,"AITEM",DFN,HMPSRV)) Q ; patient not subscribed
. S INIT=(^HMP(800000,"AITEM",DFN,HMPSRV)=2),CNT=1 ; 2 means patient initialized
. I $E(TYPE,1,4)="sync" S INIT=1 ; sync* goes to main stream
. I TYPE="syncDomain" S CNT=+$P(ID,":",3) S:CNT<1 CNT=1 ; CNT must be >0
. S STREAM=$S(INIT:"HMPFS~",1:"HMPFH~")_HMPSRV_"~"_$S(INIT:DATE,1:DFN)
. I '$D(^XTMP(STREAM)) D NEWXTMP(STREAM,8,"HMP Freshness Stream")
. L +^XTMP(STREAM):5 E S $EC=",Uno lock obtained," Q ; throw error
. S SEQ=$G(^XTMP(STREAM,"last"),0)+CNT
. S ^XTMP(STREAM,SEQ)=DFN_U_TYPE_U_ID_U_$G(ACT)_U_$P($H,",",2)
. S ^XTMP(STREAM,"last")=SEQ
. L -^XTMP(STREAM)
. ; NODES(hmpserverid)=streamDate^sequence -- optionally returned
. S NODES($P(STREAM,"~",2))=$S(INIT:DATE,1:0)_U_SEQ
Q
;
NEWXTMP(NODE,DAYS,DESC) ; Set a new node in ^XTMP
K ^XTMP(NODE)
S ^XTMP(NODE,0)=$$HTFM^XLFDT(+$H+DAYS)_U_$$HTFM^XLFDT(+$H)_U_DESC
Q
PIDS(DFN) ; return string containing patient id's ready for JSON
; expects HMPFSYS, HMPFHMP
Q:'DFN ""
;
N X
S X=",""pid"":"""_$$PID(DFN)_""""
S X=X_",""systemId"":"""_HMPSYS_""""
S X=X_",""localId"":"""_DFN_""""
S X=X_",""icn"":"""_$$GETICN^MPIF001(DFN)_"""" ; US4194
Q X
;
PID(DFN) ; return most likely PID (ICN or SYS;DFN)
Q:'DFN ""
I '$D(HMPSYS) S HMPSYS=$$SYS^HMPUTILS
Q HMPSYS_";"_DFN ; otherwise use SysId;DFN
;
DFN(PID) ; return the DFN given the PID (ICN or SYS;DFN)
N DFN
S PID=$TR(PID,":",";")
I PID'[";" D Q DFN ; treat as ICN
. S DFN=$$GETDFN^MPIF001(PID)
. I DFN<0 D SETERR($P(DFN,"^",2))
; otherwise
I $P(PID,";")'=$$SYS^HMPUTILS D SETERR("DFN unknown to this system") Q 0
Q $P(PID,";",2)
;
PROGRESS(LASTITM) ; set the node in REF with progress properties
; expects HMPFHMP,HMPSYS
N RSLT,HMPIEN,CNT,STS,TS,DFN,FIRST
S HMPIEN=$O(^HMP(800000,"B",HMPFHMP,0)) Q:'HMPIEN ""
S CNT=0,RSLT=""
F STS=0,1 D ; 0=uninitialized, 1=initializing
. S FIRST=1
. S RSLT=$S(STS=0:",""waitingPids"":[",1:RSLT_"],""processingPids"":[")
. S TS=0 F S TS=$O(^HMP(800000,HMPIEN,1,"AP",STS,TS)) Q:'TS D Q:CNT>99
. . S DFN=0 F S DFN=$O(^HMP(800000,HMPIEN,1,"AP",STS,TS,DFN)) Q:'DFN D
. . . S CNT=CNT+1
. . . S RSLT=RSLT_$S(FIRST=1:"",1:",")_""""_HMPSYS_";"_DFN_""""
. . . S FIRST=0
S RSLT=RSLT_"]"
;
N STRM,STRMDT,CURRDT
I $G(LASTITM)="" S LASTITM=$P(^HMP(800000,HMPIEN,0),U,2)
I $L(LASTITM,"-")<2 S LASTITM=$$DT^XLFDT_"-"_+LASTITM
S STRMDT=$P(LASTITM,"-"),CURRDT=$$DT^XLFDT,SEQ=$P(LASTITM,"-",2)
S CNT=0 F D Q:$$FMDIFF^XLFDT(STRMDT,CURRDT,1)'<0
. S STRM="HMPFS~"_HMPFHMP_"~"_STRMDT
. S CNT=CNT+$G(^XTMP(STRM,"last"))-SEQ
. S STRMDT=$$FMADD^XLFDT(STRMDT,1),SEQ=0
S RSLT=RSLT_",""remainingObjects"":"_CNT
Q RSLT
;
; --- handle errors
;
SETERR(MSG) ; create error object in ^TMP("HMPFERR",$J) and set HMPFERR
;DE6856, following line is because we may be here before HMPFRSP is SET since it's an error, 15 Sept 2016
S:$G(HMPFRSP)="" HMPFRSP=$NA(^TMP("HMPF",$J))
; TODO: escape MSG for JSON
S @HMPFRSP@(1)="{""apiVersion"":""1.0"",""error"":{""message"":"""_MSG_"""}}"
S ^TMP("HMPFERR",$J,$H)=MSG
S HMPFERR=1
Q
;
DEBUG(MSG) ;
S ^TMP("HMPDEBUG",$J,0)=$G(^TMP("HMPDEBUG",$J,0),0)+1
I $D(MSG)'=1 M ^TMP("HMPDEBUG",$J,^TMP("HMPDEBUG",$J,0))=MSG Q
S ^TMP("HMPDEBUG",$J,^TMP("HMPDEBUG",$J,0))=MSG
Q
RESETSVR(ARGS) ;
N DA,DIE,DIK,DR,IEN,SRV,SRVIEN,X
S SRV=$G(ARGS("server")) I SRV="" Q
S DA=$O(^HMP(800000,"B",SRV,"")) I DA'>0 Q
S SRVIEN=DA
L +^HMP(800000,SRVIEN):5 E S $EC=",Uno lock obtained," Q
;delete operational data field
S DIE="^HMP(800000,",DR=".03///@" D ^DIE
S DA(1)=DA,DA=0
;delete patient multiple values
S DIK="^HMP(800000,"_DA(1)_",1,"
F S DA=$O(^HMP(800000,DA(1),1,DA)) Q:DA'>0 D ^DIK
;kill server ^XTMP
S X="HMPF" F S X=$O(^XTMP(X)) Q:$E(X,1,4)'="HMPF" D
. I X[SRV K ^XTMP(X) I 1
;kill tidy node
K ^XTMP("HMPFP","tidy",SRV)
L -^HMP(800000,SRVIEN)
Q
;
CLEARDOM(SVR,PAT) ;
Q
;
CLEARPAT(SVR,PAT) ;
I '$D(^XTMP("HMPFP",PAT,SVR)) Q
;do we need a check for patient initialized?
K ^XTMP("HMPFP",PAT,SVR)
Q
;
HMPSET(DA,NEW) ;
N IEN,NAME
S IEN=0 F S IEN=$O(^HMP(800000,IEN)) Q:IEN'>0 D
.S NAME=$P(^HMP(800000,IEN,0),U)
.I $D(^HMP(800000,IEN,1,NEW(1)))>0 S ^HMP(800000,"AITEM",NEW(1),NAME)=NEW(2)
Q
;
HMPKILL(DA,OLD) ;
N NAME
S NAME=$P($G(^HMP(800000,DA(1),0)),U) I NAME="" Q
K ^HMP(800000,"AITEM",OLD(1),NAME)
Q
;
HMPOSET(DA,NEW) ;
N IEN,NAME
S IEN=0 F S IEN=$O(^HMP(800000,IEN)) Q:IEN'>0 D
.S NAME=$P(^HMP(800000,IEN,0),U)
.S ^HMP(800000,"AITEM","OPD",NAME)=NEW
Q
;
HMPOKILL(DA) ;
N NAME
S NAME=$P($G(^HMP(800000,DA,0)),U) I NAME="" Q
K ^HMP(800000,"AITEM","OPD",NAME)
Q
KILL ; clear out all ^XTMP nodes
N X
S X="HMPF" F S X=$O(^XTMP(X)) Q:$E(X,1,4)'="HMPF" W !,X K ^XTMP(X)
Q
KILLSVR(SVR) ; clear out for specific machine
N X
S X="HMPF" F S X=$O(^XTMP(X)) Q:$E(X,1,4)'="HMPF" D
. I X[SVR W !,X K ^XTMP(X) I 1
S X="" F S X=$O(^XTMP("HMPFP",X)) Q:X="" D
. I $D(^XTMP("HMPFP",X,SVR)) K ^XTMP("HMPFP",X,SVR)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HHMPDJFS 10480 printed Dec 13, 2024@01:53:32 Page 2
HMPDJFS ;SLC/KCM,ASMR/BL,JD,CK,CPC,PB -- Asynchronous Extracts and Freshness via stream;Sep 16, 2016 09:45:43
+1 ;;2.0;ENTERPRISE HEALTH MANAGEMENT PLATFORM;**1,2,3**;May 15, 2016;Build 15
+2 ;Per VA Directive 6402, this routine should not be modified.
+3 ;
+4 ; JD - 1/14/15 - Removed "+" from "$$GETICN^MPIF001(DFN)" so that the
+5 ; full value of icn (<icn>V<checksum>) could be captured. US4194.
+6 ; JD - 3/16/15 - Added checks to prevent restaging of data if the data has
+7 ; already been staged. US4304
+8 ; CPC - 3/4/16 - Prevent dual execution. DE3411
+9 ;
+10 ; PUT/POST call $$TAG^ROUTINE(.args,.body)
+11 ; GET/DELETE call TAG^ROUTINE(.response,.args)
+12 ;
+13 QUIT
+14 ;
API(HMPFRSP,ARGS) ;
+1 NEW HMPFERR,HMPFHMP,HMPFLOG,CNT,ACNT
+2 KILL ^TMP("HMPF",$JOB)
+3 SET HMPFHMP=$TRANSLATE($GET(ARGS("server")),"~","=")
+4 SET HMPFRSP=$NAME(^TMP("HMPF",$JOB))
+5 SET HMPFLOG=+$$GET^XPAR("ALL","HMP LOG LEVEL")
+6 IF HMPFLOG
DO LOGREQ(HMPFHMP,.ARGS)
+7 SET HMPSYS=$$SYS^HMPUTILS
+8 IF '$LENGTH(HMPFHMP)
DO SETERR("Missing HMP Server ID")
QUIT
+9 IF '$ORDER(^HMP(800000,"B",HMPFHMP,0))
DO SETERR("HMP Server not registered")
QUIT
+10 ;
+11 ; begin select case
+12 IF ARGS("command")="putPtSubscription"
Begin DoDot:1
+13 NEW LOC
+14 ; Added ELSE for US4304
SET LOC=$$PUTSUB^HMPDJFSP(.ARGS)
+15 IF $LENGTH(LOC)
SET ^TMP("HMPF",$JOB,1)="{""apiVersion"":""1.0"",""location"":"""_LOC_""""_$$PROGRESS_"}"
End DoDot:1
GOTO XAPI
+16 IF ARGS("command")="startOperationalDataExtract"
Begin DoDot:1
+17 NEW HMPX2,LOC
+18 ; use OPD to indicate "sync operational"
SET ARGS("localId")="OPD"
+19 ; Next 2 lines added for US4304
+20 SET HMPX2="HMPFX~"_$GET(HMPFHMP)_"~OPD"
+21 ;DE5181 submit ODS only if not already run or running
Begin DoDot:2
+22 NEW HMPUID
+23 IF $DATA(^XTMP(HMPX2))
SET LOC="/hmp/subscription/operational data/"
QUIT
+24 SET HMPUID=$ORDER(^HMP(800000,"B",HMPFHMP,0))
+25 IF HMPUID
IF $PIECE($GET(^HMP(800000,HMPUID,0)),U,3)=2
SET LOC="/hmp/subscription/operational data/"
QUIT
+26 SET LOC=$$PUTSUB^HMPDJFSP(.ARGS)
End DoDot:2
+27 IF $LENGTH(LOC)
SET ^TMP("HMPF",$JOB,1)="{""apiVersion"":""1.0"",""location"":"""_LOC_"""}"
End DoDot:1
GOTO XAPI
+28 IF ARGS("command")="getPtUpdates"
Begin DoDot:1
+29 ;DE3411
LOCK +^XTMP("HMPDJFSG "_$GET(HMPFHMP)):2
IF '$TEST
DO SETERR^HMPDJFS("Only one extract can run for a single server")
QUIT
+30 DO GETSUB^HMPDJFSG(HMPFRSP,.ARGS)
+31 ;DE3411
LOCK -^XTMP("HMPDJFSG "_$GET(HMPFHMP))
End DoDot:1
GOTO XAPI
+32 IF ARGS("command")="resetAllSubscriptions"
Begin DoDot:1
+33 DO RESETSVR(.ARGS)
+34 SET ^TMP("HMPF",$JOB,1)="{""apiVersion"":""1.0"",""removed"":""true""}"
End DoDot:1
GOTO XAPI
+35 IF ARGS("command")="checkHealth"
Begin DoDot:1
+36 DO HLTHCHK^HMPDJFSM(.ARGS)
End DoDot:1
GOTO XAPI
+37 ; else
+38 ; should not get this far
DO SETERR("command not recognized")
+39 ;
XAPI ; end select case
+1 ;
+2 IF HMPFLOG=2
DO LOGRSP(HMPFHMP)
+3 QUIT
+4 ;
LOGREQ(SRV,ARGS) ; Log the request
+1 IF $DATA(^XTMP("HMPFLOG",0,"start"))
Begin DoDot:1
+2 NEW ELAPSED
SET ELAPSED=$$HDIFF^XLFDT($HOROLOG,^XTMP("HMPFLOG",0,"start"),2)
+3 IF ELAPSED>$$GET^XPAR("ALL","HMP LOG LIMIT")
DO PUT^XPAR("SYS","HMP LOG LEVEL",1,0)
End DoDot:1
if '$$GET^XPAR("ALL","HMP LOG LEVEL")
QUIT
+4 IF '$TEST
Begin DoDot:1
+5 DO NEWXTMP("HMPFLOG",1,"HMP Freshness Logging")
+6 SET ^XTMP("HMPFLOG",0,"start")=$HOROLOG
End DoDot:1
+7 SET ^XTMP("HMPFLOG",0,"total")=$GET(^XTMP("HMPFLOG",0,"total"))+1
+8 if '$LENGTH(SRV)
SET SRV="unknown"
+9 NEW SEQ
+10 SET SEQ=+$GET(^XTMP("HMPFLOG",SRV))+1
SET ^XTMP("HMPFLOG",SRV)=SEQ
+11 MERGE ^XTMP("HMPFLOG",SRV,SEQ,"request")=ARGS
+12 SET HMPFLOG("seq")=SEQ
+13 QUIT
LOGRSP(SRV) ; Log the response
+1 MERGE ^XTMP("HMPFLOG",SRV,HMPFLOG("seq"),"response")=^TMP("HMPF",$JOB)
+2 QUIT
+3 ;
+4 ; delete a patient subscription
DELSUB(RSP,ARGS) ; cancel a subscription
+1 ; DELETE with: /hmp/subscription/{hmpSrvId}/patient/{pid}
+2 ; remove patient from HMP SUBSCRIPTION file
+3 ; remove ^XTMP(HMPX and ^XTMP(HMPH nodes
+4 ; look ahead (from lastId) and remove any nodes for the patient
+5 NEW DFN,HMPSRV,BATCH,HMPSRVID
+6 KILL ^TMP("HMPF",$JOB)
+7 ; DE6856, initialize HMPFRSP in case of error, use RSP here because of argument in DELSUB line tag, 15 Sept 2016
+8 if $GET(HMPFRSP)=""
SET HMPFRSP="RSP"
+9 SET DFN=$$DFN(ARGS("pid"))
if $DATA(HMPFERR)
QUIT
+10 SET HMPSRV=ARGS("hmpSrvId")
+11 SET BATCH="HMPFX~"_HMPSRV_"~"_DFN
+12 LOCK +^XTMP("HMPFP",DFN,HMPSRV):20
IF '$TEST
DO SETERR("unable to get lock")
QUIT
+13 ; if extract still running, it should remove itself when it finishes
+14 ; kill extract nodes
KILL ^XTMP("HMPFX~"_HMPSRV_"~"_DFN)
+15 ; kill held freshness updates
KILL ^XTMP("HMPFH~"_HMPSRV_"~"_DFN)
+16 ; remove all nodes for this patient between "last" and "next"
+17 ; loop forward from "last" in ^XTMP("HMPFP",0,hmpSrv) and remove nodes for this DFN
+18 ; kill subscription
KILL ^XTMP("HMPFP",DFN,HMPSRV)
+19 DO DELPT(DFN,HMPSRV)
+20 LOCK -^XTMP("HMPFP",DFN,HMPSRV)
+21 ; if successful
SET RSP="{""apiVersion"":""1.0"",""success"":""true""}"
+22 QUIT
DELPT(DFN,SRV) ; delete patient DFN for server SRV
+1 NEW DIK,DA
+2 SET DA(1)=$ORDER(^HMP(800000,"B",SRV,""))
if 'DA(1)
QUIT
+3 SET DA=DFN
if 'DA
QUIT
+4 SET DIK="^HMP(800000,"_DA(1)_",1,"
+5 DO ^DIK
+6 QUIT
+7 ;
+8 ; --- post freshness updates (internal to VistA)
+9 ;
POST(DFN,TYPE,ID,ACT,SERVER,NODES) ; adds new freshness item, return DT-seq
+1 ; if initializing use: ^XTMP("HMPFH-hmpserverid-dfn",seq#) -hold
+2 ; otherwise use: ^XTMP("HMPFS-hmpserverid-date",seq#) -stream
+3 ;
+4 ; loop through subscribing streams for this patient
+5 ; if patient is initialized for an hmp server send events directly to stream
+6 ; otherwise, events go to temporary holding area
+7 ; initial extracts always sent directly to stream
+8 NEW HMPSRV,INIT,STREAM,DATE,SEQ,CNT
+9 SET DATE=$$DT^XLFDT
+10 SET HMPSRV=""
FOR
SET HMPSRV=$ORDER(^HMP(800000,"AITEM",DFN,HMPSRV))
if '$LENGTH(HMPSRV)
QUIT
Begin DoDot:1
+11 IF SERVER'=""
IF HMPSRV'=SERVER
QUIT
+12 ; patient not subscribed
IF '$DATA(^HMP(800000,"AITEM",DFN,HMPSRV))
QUIT
+13 ; 2 means patient initialized
SET INIT=(^HMP(800000,"AITEM",DFN,HMPSRV)=2)
SET CNT=1
+14 ; sync* goes to main stream
IF $EXTRACT(TYPE,1,4)="sync"
SET INIT=1
+15 ; CNT must be >0
IF TYPE="syncDomain"
SET CNT=+$PIECE(ID,":",3)
if CNT<1
SET CNT=1
+16 SET STREAM=$SELECT(INIT:"HMPFS~",1:"HMPFH~")_HMPSRV_"~"_$SELECT(INIT:DATE,1:DFN)
+17 IF '$DATA(^XTMP(STREAM))
DO NEWXTMP(STREAM,8,"HMP Freshness Stream")
+18 ; throw error
LOCK +^XTMP(STREAM):5
IF '$TEST
SET $ECODE=",Uno lock obtained,"
QUIT
+19 SET SEQ=$GET(^XTMP(STREAM,"last"),0)+CNT
+20 SET ^XTMP(STREAM,SEQ)=DFN_U_TYPE_U_ID_U_$GET(ACT)_U_$PIECE($HOROLOG,",",2)
+21 SET ^XTMP(STREAM,"last")=SEQ
+22 LOCK -^XTMP(STREAM)
+23 ; NODES(hmpserverid)=streamDate^sequence -- optionally returned
+24 SET NODES($PIECE(STREAM,"~",2))=$SELECT(INIT:DATE,1:0)_U_SEQ
End DoDot:1
+25 QUIT
+26 ;
NEWXTMP(NODE,DAYS,DESC) ; Set a new node in ^XTMP
+1 KILL ^XTMP(NODE)
+2 SET ^XTMP(NODE,0)=$$HTFM^XLFDT(+$HOROLOG+DAYS)_U_$$HTFM^XLFDT(+$HOROLOG)_U_DESC
+3 QUIT
PIDS(DFN) ; return string containing patient id's ready for JSON
+1 ; expects HMPFSYS, HMPFHMP
+2 if 'DFN
QUIT ""
+3 ;
+4 NEW X
+5 SET X=",""pid"":"""_$$PID(DFN)_""""
+6 SET X=X_",""systemId"":"""_HMPSYS_""""
+7 SET X=X_",""localId"":"""_DFN_""""
+8 ; US4194
SET X=X_",""icn"":"""_$$GETICN^MPIF001(DFN)_""""
+9 QUIT X
+10 ;
PID(DFN) ; return most likely PID (ICN or SYS;DFN)
+1 if 'DFN
QUIT ""
+2 IF '$DATA(HMPSYS)
SET HMPSYS=$$SYS^HMPUTILS
+3 ; otherwise use SysId;DFN
QUIT HMPSYS_";"_DFN
+4 ;
DFN(PID) ; return the DFN given the PID (ICN or SYS;DFN)
+1 NEW DFN
+2 SET PID=$TRANSLATE(PID,":",";")
+3 ; treat as ICN
IF PID'[";"
Begin DoDot:1
+4 SET DFN=$$GETDFN^MPIF001(PID)
+5 IF DFN<0
DO SETERR($PIECE(DFN,"^",2))
End DoDot:1
QUIT DFN
+6 ; otherwise
+7 IF $PIECE(PID,";")'=$$SYS^HMPUTILS
DO SETERR("DFN unknown to this system")
QUIT 0
+8 QUIT $PIECE(PID,";",2)
+9 ;
PROGRESS(LASTITM) ; set the node in REF with progress properties
+1 ; expects HMPFHMP,HMPSYS
+2 NEW RSLT,HMPIEN,CNT,STS,TS,DFN,FIRST
+3 SET HMPIEN=$ORDER(^HMP(800000,"B",HMPFHMP,0))
if 'HMPIEN
QUIT ""
+4 SET CNT=0
SET RSLT=""
+5 ; 0=uninitialized, 1=initializing
FOR STS=0,1
Begin DoDot:1
+6 SET FIRST=1
+7 SET RSLT=$SELECT(STS=0:",""waitingPids"":[",1:RSLT_"],""processingPids"":[")
+8 SET TS=0
FOR
SET TS=$ORDER(^HMP(800000,HMPIEN,1,"AP",STS,TS))
if 'TS
QUIT
Begin DoDot:2
+9 SET DFN=0
FOR
SET DFN=$ORDER(^HMP(800000,HMPIEN,1,"AP",STS,TS,DFN))
if 'DFN
QUIT
Begin DoDot:3
+10 SET CNT=CNT+1
+11 SET RSLT=RSLT_$SELECT(FIRST=1:"",1:",")_""""_HMPSYS_";"_DFN_""""
+12 SET FIRST=0
End DoDot:3
End DoDot:2
if CNT>99
QUIT
End DoDot:1
+13 SET RSLT=RSLT_"]"
+14 ;
+15 NEW STRM,STRMDT,CURRDT
+16 IF $GET(LASTITM)=""
SET LASTITM=$PIECE(^HMP(800000,HMPIEN,0),U,2)
+17 IF $LENGTH(LASTITM,"-")<2
SET LASTITM=$$DT^XLFDT_"-"_+LASTITM
+18 SET STRMDT=$PIECE(LASTITM,"-")
SET CURRDT=$$DT^XLFDT
SET SEQ=$PIECE(LASTITM,"-",2)
+19 SET CNT=0
FOR
Begin DoDot:1
+20 SET STRM="HMPFS~"_HMPFHMP_"~"_STRMDT
+21 SET CNT=CNT+$GET(^XTMP(STRM,"last"))-SEQ
+22 SET STRMDT=$$FMADD^XLFDT(STRMDT,1)
SET SEQ=0
End DoDot:1
if $$FMDIFF^XLFDT(STRMDT,CURRDT,1)'<0
QUIT
+23 SET RSLT=RSLT_",""remainingObjects"":"_CNT
+24 QUIT RSLT
+25 ;
+26 ; --- handle errors
+27 ;
SETERR(MSG) ; create error object in ^TMP("HMPFERR",$J) and set HMPFERR
+1 ;DE6856, following line is because we may be here before HMPFRSP is SET since it's an error, 15 Sept 2016
+2 if $GET(HMPFRSP)=""
SET HMPFRSP=$NAME(^TMP("HMPF",$JOB))
+3 ; TODO: escape MSG for JSON
+4 SET @HMPFRSP@(1)="{""apiVersion"":""1.0"",""error"":{""message"":"""_MSG_"""}}"
+5 SET ^TMP("HMPFERR",$JOB,$HOROLOG)=MSG
+6 SET HMPFERR=1
+7 QUIT
+8 ;
DEBUG(MSG) ;
+1 SET ^TMP("HMPDEBUG",$JOB,0)=$GET(^TMP("HMPDEBUG",$JOB,0),0)+1
+2 IF $DATA(MSG)'=1
MERGE ^TMP("HMPDEBUG",$JOB,^TMP("HMPDEBUG",$JOB,0))=MSG
QUIT
+3 SET ^TMP("HMPDEBUG",$JOB,^TMP("HMPDEBUG",$JOB,0))=MSG
+4 QUIT
RESETSVR(ARGS) ;
+1 NEW DA,DIE,DIK,DR,IEN,SRV,SRVIEN,X
+2 SET SRV=$GET(ARGS("server"))
IF SRV=""
QUIT
+3 SET DA=$ORDER(^HMP(800000,"B",SRV,""))
IF DA'>0
QUIT
+4 SET SRVIEN=DA
+5 LOCK +^HMP(800000,SRVIEN):5
IF '$TEST
SET $ECODE=",Uno lock obtained,"
QUIT
+6 ;delete operational data field
+7 SET DIE="^HMP(800000,"
SET DR=".03///@"
DO ^DIE
+8 SET DA(1)=DA
SET DA=0
+9 ;delete patient multiple values
+10 SET DIK="^HMP(800000,"_DA(1)_",1,"
+11 FOR
SET DA=$ORDER(^HMP(800000,DA(1),1,DA))
if DA'>0
QUIT
DO ^DIK
+12 ;kill server ^XTMP
+13 SET X="HMPF"
FOR
SET X=$ORDER(^XTMP(X))
if $EXTRACT(X,1,4)'="HMPF"
QUIT
Begin DoDot:1
+14 IF X[SRV
KILL ^XTMP(X)
IF 1
End DoDot:1
+15 ;kill tidy node
+16 KILL ^XTMP("HMPFP","tidy",SRV)
+17 LOCK -^HMP(800000,SRVIEN)
+18 QUIT
+19 ;
CLEARDOM(SVR,PAT) ;
+1 QUIT
+2 ;
CLEARPAT(SVR,PAT) ;
+1 IF '$DATA(^XTMP("HMPFP",PAT,SVR))
QUIT
+2 ;do we need a check for patient initialized?
+3 KILL ^XTMP("HMPFP",PAT,SVR)
+4 QUIT
+5 ;
HMPSET(DA,NEW) ;
+1 NEW IEN,NAME
+2 SET IEN=0
FOR
SET IEN=$ORDER(^HMP(800000,IEN))
if IEN'>0
QUIT
Begin DoDot:1
+3 SET NAME=$PIECE(^HMP(800000,IEN,0),U)
+4 IF $DATA(^HMP(800000,IEN,1,NEW(1)))>0
SET ^HMP(800000,"AITEM",NEW(1),NAME)=NEW(2)
End DoDot:1
+5 QUIT
+6 ;
HMPKILL(DA,OLD) ;
+1 NEW NAME
+2 SET NAME=$PIECE($GET(^HMP(800000,DA(1),0)),U)
IF NAME=""
QUIT
+3 KILL ^HMP(800000,"AITEM",OLD(1),NAME)
+4 QUIT
+5 ;
HMPOSET(DA,NEW) ;
+1 NEW IEN,NAME
+2 SET IEN=0
FOR
SET IEN=$ORDER(^HMP(800000,IEN))
if IEN'>0
QUIT
Begin DoDot:1
+3 SET NAME=$PIECE(^HMP(800000,IEN,0),U)
+4 SET ^HMP(800000,"AITEM","OPD",NAME)=NEW
End DoDot:1
+5 QUIT
+6 ;
HMPOKILL(DA) ;
+1 NEW NAME
+2 SET NAME=$PIECE($GET(^HMP(800000,DA,0)),U)
IF NAME=""
QUIT
+3 KILL ^HMP(800000,"AITEM","OPD",NAME)
+4 QUIT
KILL ; clear out all ^XTMP nodes
+1 NEW X
+2 SET X="HMPF"
FOR
SET X=$ORDER(^XTMP(X))
if $EXTRACT(X,1,4)'="HMPF"
QUIT
WRITE !,X
KILL ^XTMP(X)
+3 QUIT
KILLSVR(SVR) ; clear out for specific machine
+1 NEW X
+2 SET X="HMPF"
FOR
SET X=$ORDER(^XTMP(X))
if $EXTRACT(X,1,4)'="HMPF"
QUIT
Begin DoDot:1
+3 IF X[SVR
WRITE !,X
KILL ^XTMP(X)
IF 1
End DoDot:1
+4 SET X=""
FOR
SET X=$ORDER(^XTMP("HMPFP",X))
if X=""
QUIT
Begin DoDot:1
+5 IF $DATA(^XTMP("HMPFP",X,SVR))
KILL ^XTMP("HMPFP",X,SVR)
End DoDot:1
+6 QUIT
