HMPDJ1 ;SLC/MKB,ASMR/RRB,CK - HMP Patient 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
 
;
PUT(HMP,PAT,TYPE,JSON) ; -- Save/update JSON OBJECT in ^HMP(800000.1), return UID if successful
 ; RPC = HMP PUT PATIENT DATA
 ;
 
ARRAY,CNT,ERR,HMPERR,UID,DA,X,I,DFN,HMPSYS
 
;M JSON=INPUT(0)
 
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
 ;M ^XTMP("AGPARRAY")=ARRAY
 
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.1,"B",UID,0)) DA<1 ERR=$$ERR(3,UIDPTQ
 
'$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.1,DA,1) ^(1,0)="^800000.101^^",CNT=0
 
I="" F  S I=$O(JSON(I)) Q:I=""  CNT=CNT+1,^HMP(800000.1,DA,1,CNT,0)=JSON(I)
 
S:$G(CNT) ^HMP(800000.1,DA,1,0)="^800000.101^"_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}"
 
DFN=+$P(UID,":",5)
 
POST^HMPEVNT(DFN,TYPE,DA;UID)
 
Q
 
;
NEW ; -- create new entry in ^HMP(800000.1) from PAT,TYPE,HMPSYS
 ;  Return UID & DA, or ERR
 
DFN,ICN
 
DFN=+$G(PAT),ICN="",TYPE=$G(TYPE)
 
'DFN,DFN[";" ICN=+$P($G(DFN),";",2),DFN=+$G(DFN)
 
'DFN,ICN DFN=+$$GETDFN^MPIF001(ICN)
 
'DFN!'$L($G(^DPT(DFN,0))) ERR=$$ERR(1,DFNQ  ; IA 10035, DE2818
 
TYPE="" ERR=$$ERR(2,"null"Q
 
;
 
DA=$$NEXTIFN DA<1 ERR=$$ERR(4) Q
 S 
UID="urn:va:"_TYPE_":"_HMPSYS_":"_DFN_":"_DA
 
^HMP(800000.1,DA,0)=UID_U_DFN_U_TYPE
 
^HMP(800000.1,"B",UID,DA)=""
 
^HMP(800000.1,"C",DFN,TYPE,DA)=""
 
Q
 
;
NEXTIFN() ; -- Returns next available IFN
 
I,HDR,TOTAL,DA
 
+^HMP(800000.1,0):$S($G(DILOCKTM)>0:DILOCKTM,1:5)
 
'$T Q "^"
 
HDR=$G(^HMP(800000.1,0)),TOTAL=+$P(HDR,U,4),I=$O(^HMP(800000.1,"?"),-1)
 
I=(I+1):1 Q:'$D(^HMP(800000.1,I,0))
 
DA=I,$P(HDR,U,3,4)=DA_U_(TOTAL+1) ^HMP(800000.1,0)=HDR
 
-^HMP(800000.1,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
 ;
CONV ; -- convert uid format
 
DA,X0,UID,HMPSYS,DFN,COLL,NEW,I,JSON,HMPY,ERR,CNT
 
HMPSYS=$$SYS^HMPUTILS
 
DA=0 F  S DA=$O(^HMP(800000.1,DA)) Q:DA<1  D
 
X0=$G(^HMP(800000.1,DA,0)),UID=$P(X0,U)
 . 
^HMP(800000.1,"B",UID,DA),JSON
 
DFN=$P(X0,"^",2),COLL=$P(X0,"^",3)
 . 
NEW="urn:va:"_COLL_":"_HMPSYS_":"_DFN_":"_DA
 
S $P(^HMP(800000.1,DA,0),U)=NEW,^HMP(800000.1,"B",NEW,DA)=""
 
;decode JSON object, reset uid
 
I=0 F  S I=$O(^HMP(800000.1,DA,1,I)) Q:I<1  JSON(I)=$G(^(I,0))
 . 
Q:'$D(JSON)  HMPY,ERR
 
DECODE^HMPJSON("JSON","HMPY","ERR"I $D(ERR!,DA Q
 
HMPY("uid")=NEW JSON
 
ENCODE^HMPJSON("HMPY","JSON","ERR"I $D(ERR!,DA Q
 
^HMP(800000.1,DA,1) ^(1,0)="^800000.101^^",CNT=0
 . 
I="" F  S I=$O(JSON(I)) Q:I=""  CNT=CNT+1,^HMP(800000.1,DA,1,CNT,0)=JSON(I)
 . 
S:$G(CNT) ^HMP(800000.1,DA,1,0)="^800000.101^"_CNT_U_CNT
 
Q