HMPDJ2 ;SLC/MKB,ASMR/RRB,CK - HMP Object RPCs;May 15, 2016 14:15
;;2.0;ENTERPRISE HEALTH MANAGEMENT PLATFORM;**1,2**;May 15, 2016;Build 28
;Per VA Directive 6402, this routine should not be modified.
;
Q
;
GET(HMP,FILTER) ; -- Return search results as JSON in @HMP@(n)
; RPC = HMP GET OBJECT
N TYPE,HMPMAX,HMPI,HMPID,HMPERR,IEN
S HMP=$NA(^TMP("HMP",$J)),HMPI=0 K @HMP
;
; parse & validate input parameters
S TYPE=$G(FILTER("collection")),TYPE=$$LOW^XLFSTR(TYPE)
S HMPMAX=+$G(FILTER("max"),9999) ;??
S HMPID=$G(FILTER("id"))
;
;set error trap
N $ES,$ET,ERRARRY,ERRDOM,ERRPAT,ERRMSG
;S $ET="D ERRHDLR^HMPDERRH G ERRQ^HMPDJ0"
S ERRDOM="hmp",ERRMSG=$G(TYPE)
K ^TMP($J,"HMP ERROR")
;
; extract data
I $L(HMPID) D G GQ
. S IEN=+HMPID I 'IEN S IEN=+$O(^HMP(800000.11,"B",HMPID,0)) ;IEN or UID
. D:IEN HMP1^HMPDJ02(800000.11,IEN)
I TYPE="" S HMPERR="Missing or invalid collection type" G GQ
S IEN=0 F S IEN=$O(^HMP(800000.11,"C",TYPE,IEN)) Q:IEN<1 D HMP1^HMPDJ02(800000.11,IEN)
;
GQ ;build return JSON
D GTQ^HMPDJ
Q
;
DEL(HMP,HMPID) ; -- Delete object HMPID from ^HMP(800000.11)
; RPC = HMP DELETE OBJECT
;
N ACTION,ERR,UID,DA,DIK,TYPE
S UID=$G(HMPID) I '$L(UID) S ERR=$$ERR(3,"null") G PTQ
S DA=+$O(^HMP(800000.11,"B",UID,0)) I DA<1 S ERR=$$ERR(3,UID) G PTQ
S DIK="^HMP(800000.11," D ^DIK
S ACTION="@",TYPE=$P(UID,":",3)
G PTQ
Q
;
PUT(HMP,TYPE,JSON) ; -- Save/update JSON OBJECT in ^HMP(800000.11), return UID if successful
; RPC = HMP PUT OBJECT
;
N ACTION,ARRAY,CNT,ERR,HMPERR,UID,DA,X,I,HMPSYS
D DECODE^HMPJSON("JSON","ARRAY","HMPERR")
;N XCNT S XCNT=$O(^XTMP("AGPARRAY",""),-1),XCNT=XCNT+1
;M ^XTMP("AGPARRAY",XCNT,"DATA")=ARRAY
;S ^XTMP("AGPARRAY",XCNT,"TYPE")=TYPE
I $D(HMPERR) D Q ;S X=$G(ERR(1)) K ERR S ERR=X G PTQ
. K ARRAY N HMPTMP,HMPTXT
. S HMPTXT(1)="Problem decoding json input."
. D SETERROR^HMPUTILS(.HMPTMP,.HMPERR,.HMPTXT,.JSON)
. K HMPERR D ENCODE^HMPJSON("HMPTMP","ARRAY","HMPERR")
. S HMP(.5)="{""apiVersion"":""1.01"",""error"":{"
. M HMP(1)=ARRAY
. S HMP(2)="}}"
;
S UID=$G(ARRAY("uid")),HMPSYS=$$SYS^HMPUTILS
I $L(UID) S DA=+$O(^HMP(800000.11,"B",UID,0)) I DA<1 S ERR=$$ERR(3,UID) G PTQ
;I $L(UID) S DA=+$O(^HMP(800000.11,"B",UID,0)) I DA<1 D NEW1(UID)
I '$L(UID) D G:$D(ERR) PTQ Q:$D(HMPERR)
. D NEW Q:$D(ERR)
. S ARRAY("uid")=UID K JSON
. D ENCODE^HMPJSON("ARRAY","JSON","HMPERR")
. I $D(HMPERR) D Q ;S X=$G(ERR(1)) K ERR S ERR=X Q
.. K JSON N HMPTMP,HMPTXT
.. S HMPTXT(1)="Problem encoding json output."
.. D SETERROR^HMPUTILS(.HMPTMP,.HMPERR,.HMPTXT,.ARRAY)
.. K HMPERR D ENCODE^HMPJSON("HMPTMP","JSON","HMPERR")
.. S HMP(.5)="{""apiVersion"":""1.01"",""error"":{"
.. M HMP(1)=JSON
.. S HMP(2)="}}"
;
K ^HMP(800000.11,DA,1) S ^(1,0)="^800000.111^^",CNT=0
S I="" F S I=$O(JSON(I)) Q:I="" S CNT=CNT+1,^HMP(800000.11,DA,1,CNT,0)=JSON(I)
S:$G(CNT) ^HMP(800000.11,DA,1,0)="^800000.111^"_CNT_U_CNT
;
PTQ ; add item count and terminating characters
I $D(ERR) S HMP="{""apiVersion"":""1.01"",""error"":{""message"":"""_ERR_"""},""success"":false}" Q
S HMP="{""apiVersion"":""1.01"",""data"":{""updated"":"_""""_$$HL7NOW_""""_",""uid"":"""_UID_"""},""success"":true}"
D POSTX^HMPEVNT(TYPE,DA,$G(ACTION)) ;UID)
Q
;
NEW1(UID) ; -- create new entry in ^HMP(800000.11) from PAT,TYPE,HMPSYS
; Return UID & DA, or ERR
S TYPE=$G(TYPE)
I TYPE="" S ERR=$$ERR(2,"null") Q
;
S DA=$$NEXTIFN I DA<1 S ERR=$$ERR(4) Q
S UID="urn:va:"_TYPE_":"_HMPSYS_":"_DA
S ^HMP(800000.11,DA,0)=UID_U_U_TYPE
S ^HMP(800000.11,"B",UID,DA)=""
S ^HMP(800000.11,"C",TYPE,DA)=""
Q
;
NEW ; -- create new entry in ^HMP(800000.11) from PAT,TYPE,HMPSYS
; Return UID & DA, or ERR
S TYPE=$G(TYPE)
I TYPE="" S ERR=$$ERR(2,"null") Q
;
S DA=$$NEXTIFN I DA<1 S ERR=$$ERR(4) Q
S UID="urn:va:"_TYPE_":"_HMPSYS_":"_DA
S ^HMP(800000.11,DA,0)=UID_U_U_TYPE
S ^HMP(800000.11,"B",UID,DA)=""
S ^HMP(800000.11,"C",TYPE,DA)=""
Q
;
NEXTIFN() ; -- Returns next available IFN
N I,HDR,TOTAL,DA
L +^HMP(800000.11,0):$S($G(DILOCKTM)>0:DILOCKTM,1:5)
I '$T Q "^"
S HDR=$G(^HMP(800000.11,0)),TOTAL=+$P(HDR,U,4),I=$O(^HMP(800000.11,"?"),-1)
F I=(I+1):1 Q:'$D(^HMP(800000.11,I,0))
S DA=I,$P(HDR,U,3,4)=DA_U_(TOTAL+1) S ^HMP(800000.11,0)=HDR
L -^HMP(800000.11,0)
Q DA
;
ERR(X,VAL) ; -- return error message
N MSG S MSG="Error"
I X=1 S MSG="Patient with dfn '"_$G(VAL)_"' not found"
I X=2 S MSG="Domain type '"_$G(VAL)_"' not recognized"
I X=3 S MSG="UID '"_$G(VAL)_"' not found"
I X=4 S MSG="Unable to create new object"
I X=99 S MSG="Unknown request"
Q MSG
;
HL7NOW() ; -- Return current time in HL7 format
Q $$FMTHL7^HMPSTMP($$NOW^XLFDT) ; DE5016
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HHMPDJ2 4768 printed Sep 23, 2025@19:29:32 Page 2
HMPDJ2 ;SLC/MKB,ASMR/RRB,CK - HMP Object RPCs;May 15, 2016 14:15
+1 ;;2.0;ENTERPRISE HEALTH MANAGEMENT PLATFORM;**1,2**;May 15, 2016;Build 28
+2 ;Per VA Directive 6402, this routine should not be modified.
+3 ;
+4 QUIT
+5 ;
GET(HMP,FILTER) ; -- Return search results as JSON in @HMP@(n)
+1 ; RPC = HMP GET OBJECT
+2 NEW TYPE,HMPMAX,HMPI,HMPID,HMPERR,IEN
+3 SET HMP=$NAME(^TMP("HMP",$JOB))
SET HMPI=0
KILL @HMP
+4 ;
+5 ; parse & validate input parameters
+6 SET TYPE=$GET(FILTER("collection"))
SET TYPE=$$LOW^XLFSTR(TYPE)
+7 ;??
SET HMPMAX=+$GET(FILTER("max"),9999)
+8 SET HMPID=$GET(FILTER("id"))
+9 ;
+10 ;set error trap
+11 NEW $ESTACK,$ETRAP,ERRARRY,ERRDOM,ERRPAT,ERRMSG
+12 ;S $ET="D ERRHDLR^HMPDERRH G ERRQ^HMPDJ0"
+13 SET ERRDOM="hmp"
SET ERRMSG=$GET(TYPE)
+14 KILL ^TMP($JOB,"HMP ERROR")
+15 ;
+16 ; extract data
+17 IF $LENGTH(HMPID)
Begin DoDot:1
+18 ;IEN or UID
SET IEN=+HMPID
IF 'IEN
SET IEN=+$ORDER(^HMP(800000.11,"B",HMPID,0))
+19 if IEN
DO HMP1^HMPDJ02(800000.11,IEN)
End DoDot:1
GOTO GQ
+20 IF TYPE=""
SET HMPERR="Missing or invalid collection type"
GOTO GQ
+21 SET IEN=0
FOR
SET IEN=$ORDER(^HMP(800000.11,"C",TYPE,IEN))
if IEN<1
QUIT
DO HMP1^HMPDJ02(800000.11,IEN)
+22 ;
GQ ;build return JSON
+1 DO GTQ^HMPDJ
+2 QUIT
+3 ;
DEL(HMP,HMPID) ; -- Delete object HMPID from ^HMP(800000.11)
+1 ; RPC = HMP DELETE OBJECT
+2 ;
+3 NEW ACTION,ERR,UID,DA,DIK,TYPE
+4 SET UID=$GET(HMPID)
IF '$LENGTH(UID)
SET ERR=$$ERR(3,"null")
GOTO PTQ
+5 SET DA=+$ORDER(^HMP(800000.11,"B",UID,0))
IF DA<1
SET ERR=$$ERR(3,UID)
GOTO PTQ
+6 SET DIK="^HMP(800000.11,"
DO ^DIK
+7 SET ACTION="@"
SET TYPE=$PIECE(UID,":",3)
+8 GOTO PTQ
+9 QUIT
+10 ;
PUT(HMP,TYPE,JSON) ; -- Save/update JSON OBJECT in ^HMP(800000.11), return UID if successful
+1 ; RPC = HMP PUT OBJECT
+2 ;
+3 NEW ACTION,ARRAY,CNT,ERR,HMPERR,UID,DA,X,I,HMPSYS
+4 DO DECODE^HMPJSON("JSON","ARRAY","HMPERR")
+5 ;N XCNT S XCNT=$O(^XTMP("AGPARRAY",""),-1),XCNT=XCNT+1
+6 ;M ^XTMP("AGPARRAY",XCNT,"DATA")=ARRAY
+7 ;S ^XTMP("AGPARRAY",XCNT,"TYPE")=TYPE
+8 ;S X=$G(ERR(1)) K ERR S ERR=X G PTQ
IF $DATA(HMPERR)
Begin DoDot:1
+9 KILL ARRAY
NEW HMPTMP,HMPTXT
+10 SET HMPTXT(1)="Problem decoding json input."
+11 DO SETERROR^HMPUTILS(.HMPTMP,.HMPERR,.HMPTXT,.JSON)
+12 KILL HMPERR
DO ENCODE^HMPJSON("HMPTMP","ARRAY","HMPERR")
+13 SET HMP(.5)="{""apiVersion"":""1.01"",""error"":{"
+14 MERGE HMP(1)=ARRAY
+15 SET HMP(2)="}}"
End DoDot:1
QUIT
+16 ;
+17 SET UID=$GET(ARRAY("uid"))
SET HMPSYS=$$SYS^HMPUTILS
+18 IF $LENGTH(UID)
SET DA=+$ORDER(^HMP(800000.11,"B",UID,0))
IF DA<1
SET ERR=$$ERR(3,UID)
GOTO PTQ
+19 ;I $L(UID) S DA=+$O(^HMP(800000.11,"B",UID,0)) I DA<1 D NEW1(UID)
+20 IF '$LENGTH(UID)
Begin DoDot:1
+21 DO NEW
if $DATA(ERR)
QUIT
+22 SET ARRAY("uid")=UID
KILL JSON
+23 DO ENCODE^HMPJSON("ARRAY","JSON","HMPERR")
+24 ;S X=$G(ERR(1)) K ERR S ERR=X Q
IF $DATA(HMPERR)
Begin DoDot:2
+25 KILL JSON
NEW HMPTMP,HMPTXT
+26 SET HMPTXT(1)="Problem encoding json output."
+27 DO SETERROR^HMPUTILS(.HMPTMP,.HMPERR,.HMPTXT,.ARRAY)
+28 KILL HMPERR
DO ENCODE^HMPJSON("HMPTMP","JSON","HMPERR")
+29 SET HMP(.5)="{""apiVersion"":""1.01"",""error"":{"
+30 MERGE HMP(1)=JSON
+31 SET HMP(2)="}}"
End DoDot:2
QUIT
End DoDot:1
if $DATA(ERR)
GOTO PTQ
if $DATA(HMPERR)
QUIT
+32 ;
+33 KILL ^HMP(800000.11,DA,1)
SET ^(1,0)="^800000.111^^"
SET CNT=0
+34 SET I=""
FOR
SET I=$ORDER(JSON(I))
if I=""
QUIT
SET CNT=CNT+1
SET ^HMP(800000.11,DA,1,CNT,0)=JSON(I)
+35 if $GET(CNT)
SET ^HMP(800000.11,DA,1,0)="^800000.111^"_CNT_U_CNT
+36 ;
PTQ ; add item count and terminating characters
+1 IF $DATA(ERR)
SET HMP="{""apiVersion"":""1.01"",""error"":{""message"":"""_ERR_"""},""success"":false}"
QUIT
+2 SET HMP="{""apiVersion"":""1.01"",""data"":{""updated"":"_""""_$$HL7NOW_""""_",""uid"":"""_UID_"""},""success"":true}"
+3 ;UID)
DO POSTX^HMPEVNT(TYPE,DA,$GET(ACTION))
+4 QUIT
+5 ;
NEW1(UID) ; -- create new entry in ^HMP(800000.11) from PAT,TYPE,HMPSYS
+1 ; Return UID & DA, or ERR
+2 SET TYPE=$GET(TYPE)
+3 IF TYPE=""
SET ERR=$$ERR(2,"null")
QUIT
+4 ;
+5 SET DA=$$NEXTIFN
IF DA<1
SET ERR=$$ERR(4)
QUIT
+6 SET UID="urn:va:"_TYPE_":"_HMPSYS_":"_DA
+7 SET ^HMP(800000.11,DA,0)=UID_U_U_TYPE
+8 SET ^HMP(800000.11,"B",UID,DA)=""
+9 SET ^HMP(800000.11,"C",TYPE,DA)=""
+10 QUIT
+11 ;
NEW ; -- create new entry in ^HMP(800000.11) from PAT,TYPE,HMPSYS
+1 ; Return UID & DA, or ERR
+2 SET TYPE=$GET(TYPE)
+3 IF TYPE=""
SET ERR=$$ERR(2,"null")
QUIT
+4 ;
+5 SET DA=$$NEXTIFN
IF DA<1
SET ERR=$$ERR(4)
QUIT
+6 SET UID="urn:va:"_TYPE_":"_HMPSYS_":"_DA
+7 SET ^HMP(800000.11,DA,0)=UID_U_U_TYPE
+8 SET ^HMP(800000.11,"B",UID,DA)=""
+9 SET ^HMP(800000.11,"C",TYPE,DA)=""
+10 QUIT
+11 ;
NEXTIFN() ; -- Returns next available IFN
+1 NEW I,HDR,TOTAL,DA
+2 LOCK +^HMP(800000.11,0):$SELECT($GET(DILOCKTM)>0:DILOCKTM,1:5)
+3 IF '$TEST
QUIT "^"
+4 SET HDR=$GET(^HMP(800000.11,0))
SET TOTAL=+$PIECE(HDR,U,4)
SET I=$ORDER(^HMP(800000.11,"?"),-1)
+5 FOR I=(I+1):1
if '$DATA(^HMP(800000.11,I,0))
QUIT
+6 SET DA=I
SET $PIECE(HDR,U,3,4)=DA_U_(TOTAL+1)
SET ^HMP(800000.11,0)=HDR
+7 LOCK -^HMP(800000.11,0)
+8 QUIT DA
+9 ;
ERR(X,VAL) ; -- return error message
+1 NEW MSG
SET MSG="Error"
+2 IF X=1
SET MSG="Patient with dfn '"_$GET(VAL)_"' not found"
+3 IF X=2
SET MSG="Domain type '"_$GET(VAL)_"' not recognized"
+4 IF X=3
SET MSG="UID '"_$GET(VAL)_"' not found"
+5 IF X=4
SET MSG="Unable to create new object"
+6 IF X=99
SET MSG="Unknown request"
+7 QUIT MSG
+8 ;
HL7NOW() ; -- Return current time in HL7 format
+1 ; DE5016
QUIT $$FMTHL7^HMPSTMP($$NOW^XLFDT)
+2 ;
