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

HMPDJFS.m

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