- 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 Jan 18, 2025@02:54:44 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