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
 
TYPE,HMPMAX,HMPI,HMPID,HMPERR,IEN
 
HMP=$NA(^TMP("HMP",$J)),HMPI=0 @HMP
 
;
 ; parse & validate input parameters
 
TYPE=$G(FILTER("collection")),TYPE=$$LOW^XLFSTR(TYPE)
 
HMPMAX=+$G(FILTER("max"),9999) ;??
 
HMPID=$G(FILTER("id"))
 
;
 ;set error trap
 
N $ES,$ET,ERRARRY,ERRDOM,ERRPAT,ERRMSG
 
;S $ET="D ERRHDLR^HMPDERRH G ERRQ^HMPDJ0"
 
ERRDOM="hmp",ERRMSG=$G(TYPE)
 
^TMP($J,"HMP ERROR")
 
;
 ; extract data
 
I $L(HMPIDD  G GQ
 
IEN=+HMPID 'IEN IEN=+$O(^HMP(800000.11,"B",HMPID,0)) ;IEN or UID
 
D:IEN HMP1^HMPDJ02(800000.11,IEN)
 
TYPE="" HMPERR="Missing or invalid collection type" GQ
 
IEN=0 F  S IEN=$O(^HMP(800000.11,"C",TYPE,IEN)) Q:IEN<1  HMP1^HMPDJ02(800000.11,IEN)
 
;
GQ ;build return JSON
 
GTQ^HMPDJ
 
Q
 
;
DEL(HMP,HMPID) ; -- Delete object HMPID from ^HMP(800000.11)
 ; RPC = HMP DELETE OBJECT
 ;
 
ACTION,ERR,UID,DA,DIK,TYPE
 
UID=$G(HMPID'$L(UIDERR=$$ERR(3,"null"PTQ
 
DA=+$O(^HMP(800000.11,"B",UID,0)) DA<1 ERR=$$ERR(3,UIDPTQ
 
DIK="^HMP(800000.11," ^DIK
 
ACTION="@",TYPE=$P(UID,":",3)
 
PTQ
 
Q
 
;
PUT(HMP,TYPE,JSON) ; -- Save/update JSON OBJECT in ^HMP(800000.11), return UID if successful
 ; RPC = HMP PUT OBJECT
 ;
 
ACTION,ARRAY,CNT,ERR,HMPERR,UID,DA,X,I,HMPSYS
 
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(HMPERRD  Q  ;S X=$G(ERR(1)) K ERR S ERR=X G PTQ
 
ARRAY HMPTMP,HMPTXT
 
HMPTXT(1)="Problem decoding json input."
 
SETERROR^HMPUTILS(.HMPTMP,.HMPERR,.HMPTXT,.JSON)
 . 
HMPERR ENCODE^HMPJSON("HMPTMP","ARRAY","HMPERR")
 . 
HMP(.5)="{""apiVersion"":""1.01"",""error"":{"
 
HMP(1)=ARRAY
 
HMP(2)="}}"
 ;
 
UID=$G(ARRAY("uid")),HMPSYS=$$SYS^HMPUTILS
 
I $L(UIDDA=+$O(^HMP(800000.11,"B",UID,0)) DA<1 ERR=$$ERR(3,UIDPTQ
 
;I $L(UID) S DA=+$O(^HMP(800000.11,"B",UID,0)) I DA<1 D NEW1(UID)
 
'$L(UIDD  G:$D(ERRPTQ Q:$D(HMPERR)
 . 
NEW Q:$D(ERR)
 . 
ARRAY("uid")=UID JSON
 
ENCODE^HMPJSON("ARRAY","JSON","HMPERR")
 . 
I $D(HMPERRD  Q  ;S X=$G(ERR(1)) K ERR S ERR=X Q
 
.. JSON HMPTMP,HMPTXT
 
.. HMPTXT(1)="Problem encoding json output."
 
.. SETERROR^HMPUTILS(.HMPTMP,.HMPERR,.HMPTXT,.ARRAY)
 .. 
HMPERR ENCODE^HMPJSON("HMPTMP","JSON","HMPERR")
 .. 
HMP(.5)="{""apiVersion"":""1.01"",""error"":{"
 
.. HMP(1)=JSON
 
.. HMP(2)="}}"
 ;
 
^HMP(800000.11,DA,1) ^(1,0)="^800000.111^^",CNT=0
 
I="" F  S I=$O(JSON(I)) Q:I=""  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(ERRHMP="{""apiVersion"":""1.01"",""error"":{""message"":"""_ERR_"""},""success"":false}" Q
 S 
HMP="{""apiVersion"":""1.01"",""data"":{""updated"":"_""""_$$HL7NOW_""""_",""uid"":"""_UID_"""},""success"":true}"
 
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
 
TYPE=$G(TYPE)
 
TYPE="" ERR=$$ERR(2,"null"Q
 
;
 
DA=$$NEXTIFN DA<1 ERR=$$ERR(4) Q
 S 
UID="urn:va:"_TYPE_":"_HMPSYS_":"_DA
 
^HMP(800000.11,DA,0)=UID_U_U_TYPE
 
^HMP(800000.11,"B",UID,DA)=""
 
^HMP(800000.11,"C",TYPE,DA)=""
 
Q
 
;
NEW ; -- create new entry in ^HMP(800000.11) from PAT,TYPE,HMPSYS
 ;  Return UID & DA, or ERR
 
TYPE=$G(TYPE)
 
TYPE="" ERR=$$ERR(2,"null"Q
 
;
 
DA=$$NEXTIFN DA<1 ERR=$$ERR(4) Q
 S 
UID="urn:va:"_TYPE_":"_HMPSYS_":"_DA
 
^HMP(800000.11,DA,0)=UID_U_U_TYPE
 
^HMP(800000.11,"B",UID,DA)=""
 
^HMP(800000.11,"C",TYPE,DA)=""
 
Q
 
;
NEXTIFN() ; -- Returns next available IFN
 
I,HDR,TOTAL,DA
 
+^HMP(800000.11,0):$S($G(DILOCKTM)>0:DILOCKTM,1:5)
 
'$T Q "^"
 
HDR=$G(^HMP(800000.11,0)),TOTAL=+$P(HDR,U,4),I=$O(^HMP(800000.11,"?"),-1)
 
I=(I+1):1 Q:'$D(^HMP(800000.11,I,0))
 
DA=I,$P(HDR,U,3,4)=DA_U_(TOTAL+1) ^HMP(800000.11,0)=HDR
 
-^HMP(800000.11,0)
 
DA
 
;
ERR(X,VAL) ; -- return error message
 
MSG  MSG="Error"
 
X=1  MSG="Patient with dfn '"_$G(VAL)_"' not found"
 
X=2  MSG="Domain type '"_$G(VAL)_"' not recognized"
 
X=3  MSG="UID '"_$G(VAL)_"' not found"
 
X=4  MSG="Unable to create new object"
 
X=99 MSG="Unknown request"
 
MSG
 
;
HL7NOW() ; -- Return current time in HL7 format
 
Q $$FMTHL7^HMPSTMP($$NOW^XLFDT)  ; DE5016
 ;