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) ;
 
HMPFERR,HMPFHMP,HMPFLOG,CNT,ACNT
 
^TMP("HMPF",$J)
 
HMPFHMP=$TR($G(ARGS("server")),"~","=")
 
HMPFRSP=$NA(^TMP("HMPF",$J))
 
HMPFLOG=+$$GET^XPAR("ALL","HMP LOG LEVEL")
 
HMPFLOG LOGREQ(HMPFHMP,.ARGS)
 
HMPSYS=$$SYS^HMPUTILS
 
'$L(HMPFHMPSETERR("Missing HMP Server ID"QUIT
 I 
'$O(^HMP(800000,"B",HMPFHMP,0)) SETERR("HMP Server not registered"QUIT
 
;
 ; begin select case
 
ARGS("command")="putPtSubscription" D  G XAPI
 
LOC
 
LOC=$$PUTSUB^HMPDJFSP(.ARGS; Added ELSE for US4304
 
I $L(LOC^TMP("HMPF",$J,1)="{""apiVersion"":""1.0"",""location"":"""_LOC_""""_$$PROGRESS_"}"
 
ARGS("command")="startOperationalDataExtract" D  G XAPI
 
HMPX2,LOC
 
ARGS("localId")="OPD"  ; use OPD to indicate "sync operational"
 
; Next 2 lines added for US4304
 
HMPX2="HMPFX~"_$G(HMPFHMP)_"~OPD"
 
D  ;DE5181 submit ODS only if not already run or running
 
..  HMPUID
 
..  I $D(^XTMP(HMPX2)) LOC="/hmp/subscription/operational data/" Q
 
..  HMPUID=$O(^HMP(800000,"B",HMPFHMP,0))
 ..  
HMPUID,$P($G(^HMP(800000,HMPUID,0)),U,3)=2 LOC="/hmp/subscription/operational data/" Q
 
..  LOC=$$PUTSUB^HMPDJFSP(.ARGS)
 . 
I $L(LOC^TMP("HMPF",$J,1)="{""apiVersion"":""1.0"",""location"":"""_LOC_"""}"
 
ARGS("command")="getPtUpdates" D  G XAPI
 
+^XTMP("HMPDJFSG "_$G(HMPFHMP)):2 E  D SETERR^HMPDJFS("Only one extract can run for a single server"Q  ;DE3411
 
GETSUB^HMPDJFSG(HMPFRSP,.ARGS)
 . 
-^XTMP("HMPDJFSG "_$G(HMPFHMP)) ;DE3411
 
ARGS("command")="resetAllSubscriptions" D  G XAPI
 
RESETSVR(.ARGS)
 . 
^TMP("HMPF",$J,1)="{""apiVersion"":""1.0"",""removed"":""true""}"
 
ARGS("command")="checkHealth" D  G XAPI
 
HLTHCHK^HMPDJFSM(.ARGS)
 
; else
 
SETERR("command not recognized")  ; should not get this far
 ;
XAPI ; end select case
 ;
 
HMPFLOG=2 LOGRSP(HMPFHMP)
 
Q
 
;
LOGREQ(SRV,ARGS) ; Log the request
 
I $D(^XTMP("HMPFLOG",0,"start")) D  Q:'$$GET^XPAR("ALL","HMP LOG LEVEL")
 . 
ELAPSED ELAPSED=$$HDIFF^XLFDT($H,^XTMP("HMPFLOG",0,"start"),2)
 . 
ELAPSED>$$GET^XPAR("ALL","HMP LOG LIMIT"PUT^XPAR("SYS","HMP LOG LEVEL",1,0)
 
E  D
 
NEWXTMP("HMPFLOG",1,"HMP Freshness Logging")
 . 
^XTMP("HMPFLOG",0,"start")=$H
 S 
^XTMP("HMPFLOG",0,"total")=$G(^XTMP("HMPFLOG",0,"total"))+1
 
S:'$L(SRVSRV="unknown"
 
SEQ
 
SEQ=+$G(^XTMP("HMPFLOG",SRV))+1,^XTMP("HMPFLOG",SRV)=SEQ
 
^XTMP("HMPFLOG",SRV,SEQ,"request")=ARGS
 
HMPFLOG("seq")=SEQ
 
Q
LOGRSP(SRV) ; Log the response
 
^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
 
DFN,HMPSRV,BATCH,HMPSRVID
 
^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"
 
DFN=$$DFN(ARGS("pid")) Q:$D(HMPFERR)
 
HMPSRV=ARGS("hmpSrvId")
 
BATCH="HMPFX~"_HMPSRV_"~"_DFN
 
+^XTMP("HMPFP",DFN,HMPSRV):20 E  D SETERR("unable to get lock"Q
 
; if extract still running, it should remove itself when it finishes
 
^XTMP("HMPFX~"_HMPSRV_"~"_DFN; kill extract nodes
 
^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
 
^XTMP("HMPFP",DFN,HMPSRV)      ; kill subscription
 
DELPT(DFN,HMPSRV)
 
-^XTMP("HMPFP",DFN,HMPSRV)
 
RSP="{""apiVersion"":""1.0"",""success"":""true""}" ; if successful
 
Q
DELPT(DFN,SRV) ; delete patient DFN for server SRV
 
DIK,DA
 
DA(1)=$O(^HMP(800000,"B",SRV,"")) Q:'DA(1)
 
DA=DFN Q:'DA
 
DIK="^HMP(800000,"_DA(1)_",1,"
 
^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
 
HMPSRV,INIT,STREAM,DATE,SEQ,CNT
 
DATE=$$DT^XLFDT
 
HMPSRV="" F  S HMPSRV=$O(^HMP(800000,"AITEM",DFN,HMPSRV)) Q:'$L(HMPSRV)  D
 
SERVER'="",HMPSRV'=SERVER Q
 
'$D(^HMP(800000,"AITEM",DFN,HMPSRV)) Q          ; patient not subscribed
 
INIT=(^HMP(800000,"AITEM",DFN,HMPSRV)=2),CNT=1  ; 2 means patient initialized
 
I $E(TYPE,1,4)="sync" INIT=1                 ; sync* goes to main stream
 
TYPE="syncDomain" CNT=+$P(ID,":",3) S:CNT<1 CNT=1 ; CNT must be >0
 
STREAM=$S(INIT:"HMPFS~",1:"HMPFH~")_HMPSRV_"~"_$S(INIT:DATE,1:DFN)
 . 
'$D(^XTMP(STREAM)) NEWXTMP(STREAM,8,"HMP Freshness Stream")
 . 
+^XTMP(STREAM):5 E  S $EC=",Uno lock obtained," Q  ; throw error
 
SEQ=$G(^XTMP(STREAM,"last"),0)+CNT
 
^XTMP(STREAM,SEQ)=DFN_U_TYPE_U_ID_U_$G(ACT)_U_$P($H,",",2)
 . 
^XTMP(STREAM,"last")=SEQ
 
-^XTMP(STREAM)
 . 
; NODES(hmpserverid)=streamDate^sequence -- optionally returned
 
NODES($P(STREAM,"~",2))=$S(INIT:DATE,1:0)_U_SEQ
 
Q
 
;
NEWXTMP(NODE,DAYS,DESC) ; Set a new node in ^XTMP
 
^XTMP(NODE)
 
^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 ""
 ;
 
X
 
X=",""pid"":"""_$$PID(DFN)_""""
 
X=X_",""systemId"":"""_HMPSYS_""""
 
X=X_",""localId"":"""_DFN_""""
 
X=X_",""icn"":"""_$$GETICN^MPIF001(DFN)_"""" ; US4194
 
X
 
;
PID(DFN) ; return most likely PID (ICN or SYS;DFN)
 
Q:'DFN ""
 
'$D(HMPSYSHMPSYS=$$SYS^HMPUTILS
 
HMPSYS_";"_DFN            ; otherwise use SysId;DFN
 ;
DFN(PID) ; return the DFN given the PID (ICN or SYS;DFN)
 
DFN
 
PID=$TR(PID,":",";")
 
PID'[";" D  Q DFN  ; treat as ICN
 
DFN=$$GETDFN^MPIF001(PID)
 . 
DFN<0 SETERR($P(DFN,"^",2))
 
; otherwise
 
I $P(PID,";")'=$$SYS^HMPUTILS SETERR("DFN unknown to this system"0
 
Q $P(PID,";",2)
 
;
PROGRESS(LASTITM) ; set the node in REF with progress properties
 ; expects HMPFHMP,HMPSYS
 
RSLT,HMPIEN,CNT,STS,TS,DFN,FIRST
 
HMPIEN=$O(^HMP(800000,"B",HMPFHMP,0)) Q:'HMPIEN ""
 
CNT=0,RSLT=""
 
STS=0,1 D  ; 0=uninitialized, 1=initializing
 
FIRST=1
 . 
RSLT=$S(STS=0:",""waitingPids"":[",1:RSLT_"],""processingPids"":[")
 . 
TS=0 F  S TS=$O(^HMP(800000,HMPIEN,1,"AP",STS,TS)) Q:'TS  D  Q:CNT>99
 . . 
DFN=0 F  S DFN=$O(^HMP(800000,HMPIEN,1,"AP",STS,TS,DFN)) Q:'DFN  D
 
. . . CNT=CNT+1
 . . . 
RSLT=RSLT_$S(FIRST=1:"",1:",")_""""_HMPSYS_";"_DFN_""""
 
. . . FIRST=0
 
RSLT=RSLT_"]"
 ;
 
STRM,STRMDT,CURRDT
 
I $G(LASTITM)="" LASTITM=$P(^HMP(800000,HMPIEN,0),U,2)
 
I $L(LASTITM,"-")<2 LASTITM=$$DT^XLFDT_"-"_+LASTITM
 
STRMDT=$P(LASTITM,"-"),CURRDT=$$DT^XLFDT,SEQ=$P(LASTITM,"-",2)
 
CNT=0 F  D  Q:$$FMDIFF^XLFDT(STRMDT,CURRDT,1)'<0
 . 
STRM="HMPFS~"_HMPFHMP_"~"_STRMDT
 
CNT=CNT+$G(^XTMP(STRM,"last"))-SEQ
 
STRMDT=$$FMADD^XLFDT(STRMDT,1),SEQ=0
 
RSLT=RSLT_",""remainingObjects"":"_CNT
 
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
 
@HMPFRSP@(1)="{""apiVersion"":""1.0"",""error"":{""message"":"""_MSG_"""}}"
 
^TMP("HMPFERR",$J,$H)=MSG
 
HMPFERR=1
 
Q
 
;
DEBUG(MSG) ;
 
^TMP("HMPDEBUG",$J,0)=$G(^TMP("HMPDEBUG",$J,0),0)+1
 
I $D(MSG)'=1 ^TMP("HMPDEBUG",$J,^TMP("HMPDEBUG",$J,0))=MSG Q
 S 
^TMP("HMPDEBUG",$J,^TMP("HMPDEBUG",$J,0))=MSG
 
Q
RESETSVR(ARGS) ;
 
DA,DIE,DIK,DR,IEN,SRV,SRVIEN,X
 
SRV=$G(ARGS("server")) SRV="" Q
 S 
DA=$O(^HMP(800000,"B",SRV,"")) DA'>0 Q
 S 
SRVIEN=DA
 
+^HMP(800000,SRVIEN):5 E  S $EC=",Uno lock obtained," Q
 
;delete operational data field
 
DIE="^HMP(800000,",DR=".03///@" ^DIE
 
DA(1)=DA,DA=0
 
;delete patient multiple values
 
DIK="^HMP(800000,"_DA(1)_",1,"
 
F  S DA=$O(^HMP(800000,DA(1),1,DA)) Q:DA'>0  ^DIK
 
;kill server ^XTMP
 
X="HMPF" F  S X=$O(^XTMP(X)) Q:$E(X,1,4)'="HMPF"  D
 
X[SRV ^XTMP(X1
 
;kill tidy node
 
^XTMP("HMPFP","tidy",SRV)
 
-^HMP(800000,SRVIEN)
 
Q
 
;
CLEARDOM(SVR,PAT) ;
 
Q
 
;
CLEARPAT(SVR,PAT) ;
 
'$D(^XTMP("HMPFP",PAT,SVR)) Q
 
;do we need a check for patient initialized?
 
^XTMP("HMPFP",PAT,SVR)
 
Q
 
;
HMPSET(DA,NEW) ;
 
IEN,NAME
 
IEN=0 F  S IEN=$O(^HMP(800000,IEN)) Q:IEN'>0  D
 
.NAME=$P(^HMP(800000,IEN,0),U)
 .
I $D(^HMP(800000,IEN,1,NEW(1)))>0 ^HMP(800000,"AITEM",NEW(1),NAME)=NEW(2)
 
Q
 
;
HMPKILL(DA,OLD) ;
 
NAME
 
NAME=$P($G(^HMP(800000,DA(1),0)),UNAME="" Q
 K 
^HMP(800000,"AITEM",OLD(1),NAME)
 
Q
 
;
HMPOSET(DA,NEW) ;
 
IEN,NAME
 
IEN=0 F  S IEN=$O(^HMP(800000,IEN)) Q:IEN'>0  D
 
.NAME=$P(^HMP(800000,IEN,0),U)
 .
^HMP(800000,"AITEM","OPD",NAME)=NEW
 
Q
 
;
HMPOKILL(DA) ;
 
NAME
 
NAME=$P($G(^HMP(800000,DA,0)),UNAME="" Q
 K 
^HMP(800000,"AITEM","OPD",NAME)
 
Q
KILL ; clear out all ^XTMP nodes
 
X
 
X="HMPF" F  S X=$O(^XTMP(X)) Q:$E(X,1,4)'="HMPF"  !,X  ^XTMP(X)
 
Q
KILLSVR(SVR) ; clear out for specific machine
 
X
 
X="HMPF" F  S X=$O(^XTMP(X)) Q:$E(X,1,4)'="HMPF"  D
 
X[SVR !,X  ^XTMP(X1
 
X="" F  S X=$O(^XTMP("HMPFP",X)) Q:X=""  D
 
I $D(^XTMP("HMPFP",X,SVR)) ^XTMP("HMPFP",X,SVR)
 
Q