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
;
N ARRAY,CNT,ERR,HMPERR,UID,DA,X,I,DFN,HMPSYS
;M JSON=INPUT(0)
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
;M ^XTMP("AGPARRAY")=ARRAY
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.1,"B",UID,0)) I DA<1 S ERR=$$ERR(3,UID) G PTQ
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.1,DA,1) S ^(1,0)="^800000.101^^",CNT=0
S I="" F S I=$O(JSON(I)) Q:I="" S 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(ERR) S HMP="{""apiVersion"":""1.01"",""error"":{""message"":"""_ERR_"""},""success"":false}" Q
S HMP="{""apiVersion"":""1.01"",""data"":{""updated"":"_""""_$$HL7NOW_""""_",""uid"":"""_UID_"""},""success"":true}"
S DFN=+$P(UID,":",5)
D POST^HMPEVNT(DFN,TYPE,DA) ;UID)
Q
;
NEW ; -- create new entry in ^HMP(800000.1) from PAT,TYPE,HMPSYS
; Return UID & DA, or ERR
N DFN,ICN
S DFN=+$G(PAT),ICN="",TYPE=$G(TYPE)
I 'DFN,DFN[";" S ICN=+$P($G(DFN),";",2),DFN=+$G(DFN)
I 'DFN,ICN S DFN=+$$GETDFN^MPIF001(ICN)
I 'DFN!'$L($G(^DPT(DFN,0))) S ERR=$$ERR(1,DFN) Q ; IA 10035, DE2818
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_":"_DFN_":"_DA
S ^HMP(800000.1,DA,0)=UID_U_DFN_U_TYPE
S ^HMP(800000.1,"B",UID,DA)=""
S ^HMP(800000.1,"C",DFN,TYPE,DA)=""
Q
;
NEXTIFN() ; -- Returns next available IFN
N I,HDR,TOTAL,DA
L +^HMP(800000.1,0):$S($G(DILOCKTM)>0:DILOCKTM,1:5)
I '$T Q "^"
S HDR=$G(^HMP(800000.1,0)),TOTAL=+$P(HDR,U,4),I=$O(^HMP(800000.1,"?"),-1)
F I=(I+1):1 Q:'$D(^HMP(800000.1,I,0))
S DA=I,$P(HDR,U,3,4)=DA_U_(TOTAL+1) S ^HMP(800000.1,0)=HDR
L -^HMP(800000.1,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
;
CONV ; -- convert uid format
N DA,X0,UID,HMPSYS,DFN,COLL,NEW,I,JSON,HMPY,ERR,CNT
S HMPSYS=$$SYS^HMPUTILS
S DA=0 F S DA=$O(^HMP(800000.1,DA)) Q:DA<1 D
. S X0=$G(^HMP(800000.1,DA,0)),UID=$P(X0,U)
. K ^HMP(800000.1,"B",UID,DA),JSON
. S DFN=$P(X0,"^",2),COLL=$P(X0,"^",3)
. S 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
. S I=0 F S I=$O(^HMP(800000.1,DA,1,I)) Q:I<1 S JSON(I)=$G(^(I,0))
. Q:'$D(JSON) K HMPY,ERR
. D DECODE^HMPJSON("JSON","HMPY","ERR") I $D(ERR) W !,DA Q
. S HMPY("uid")=NEW K JSON
. D ENCODE^HMPJSON("HMPY","JSON","ERR") I $D(ERR) W !,DA Q
. K ^HMP(800000.1,DA,1) S ^(1,0)="^800000.101^^",CNT=0
. S I="" F S I=$O(JSON(I)) Q:I="" S 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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HHMPDJ1 4318 printed Nov 22, 2024@17:03:39 Page 2
HMPDJ1 ;SLC/MKB,ASMR/RRB,CK - HMP Patient 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 ;
PUT(HMP,PAT,TYPE,JSON) ; -- Save/update JSON OBJECT in ^HMP(800000.1), return UID if successful
+1 ; RPC = HMP PUT PATIENT DATA
+2 ;
+3 NEW ARRAY,CNT,ERR,HMPERR,UID,DA,X,I,DFN,HMPSYS
+4 ;M JSON=INPUT(0)
+5 DO DECODE^HMPJSON("JSON","ARRAY","HMPERR")
+6 ;N XCNT S XCNT=$O(^XTMP("AGPARRAY",""),-1),XCNT=XCNT+1
+7 ;M ^XTMP("AGPARRAY",XCNT,"DATA")=ARRAY
+8 ;S ^XTMP("AGPARRAY",XCNT,"TYPE")=TYPE
+9 ;M ^XTMP("AGPARRAY")=ARRAY
+10 ;S X=$G(ERR(1)) K ERR S ERR=X G PTQ
IF $DATA(HMPERR)
Begin DoDot:1
+11 KILL ARRAY
NEW HMPTMP,HMPTXT
+12 SET HMPTXT(1)="Problem decoding json input."
+13 DO SETERROR^HMPUTILS(.HMPTMP,.HMPERR,.HMPTXT,.JSON)
+14 KILL HMPERR
DO ENCODE^HMPJSON("HMPTMP","ARRAY","HMPERR")
+15 SET HMP(.5)="{""apiVersion"":""1.01"",""error"":{"
+16 MERGE HMP(1)=ARRAY
+17 SET HMP(2)="}}"
End DoDot:1
QUIT
+18 ;
+19 SET UID=$GET(ARRAY("uid"))
SET HMPSYS=$$SYS^HMPUTILS
+20 IF $LENGTH(UID)
SET DA=+$ORDER(^HMP(800000.1,"B",UID,0))
IF DA<1
SET ERR=$$ERR(3,UID)
GOTO PTQ
+21 IF '$LENGTH(UID)
Begin DoDot:1
+22 DO NEW
if $DATA(ERR)
QUIT
+23 SET ARRAY("uid")=UID
KILL JSON
+24 DO ENCODE^HMPJSON("ARRAY","JSON","HMPERR")
+25 ;S X=$G(ERR(1)) K ERR S ERR=X Q
IF $DATA(HMPERR)
Begin DoDot:2
+26 KILL JSON
NEW HMPTMP,HMPTXT
+27 SET HMPTXT(1)="Problem encoding json output."
+28 DO SETERROR^HMPUTILS(.HMPTMP,.HMPERR,.HMPTXT,.ARRAY)
+29 KILL HMPERR
DO ENCODE^HMPJSON("HMPTMP","JSON","HMPERR")
+30 SET HMP(.5)="{""apiVersion"":""1.01"",""error"":{"
+31 MERGE HMP(1)=JSON
+32 SET HMP(2)="}}"
End DoDot:2
QUIT
End DoDot:1
if $DATA(ERR)
GOTO PTQ
if $DATA(HMPERR)
QUIT
+33 ;
+34 KILL ^HMP(800000.1,DA,1)
SET ^(1,0)="^800000.101^^"
SET CNT=0
+35 SET I=""
FOR
SET I=$ORDER(JSON(I))
if I=""
QUIT
SET CNT=CNT+1
SET ^HMP(800000.1,DA,1,CNT,0)=JSON(I)
+36 if $GET(CNT)
SET ^HMP(800000.1,DA,1,0)="^800000.101^"_CNT_U_CNT
+37 ;
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 SET DFN=+$PIECE(UID,":",5)
+4 ;UID)
DO POST^HMPEVNT(DFN,TYPE,DA)
+5 QUIT
+6 ;
NEW ; -- create new entry in ^HMP(800000.1) from PAT,TYPE,HMPSYS
+1 ; Return UID & DA, or ERR
+2 NEW DFN,ICN
+3 SET DFN=+$GET(PAT)
SET ICN=""
SET TYPE=$GET(TYPE)
+4 IF 'DFN
IF DFN[";"
SET ICN=+$PIECE($GET(DFN),";",2)
SET DFN=+$GET(DFN)
+5 IF 'DFN
IF ICN
SET DFN=+$$GETDFN^MPIF001(ICN)
+6 ; IA 10035, DE2818
IF 'DFN!'$LENGTH($GET(^DPT(DFN,0)))
SET ERR=$$ERR(1,DFN)
QUIT
+7 IF TYPE=""
SET ERR=$$ERR(2,"null")
QUIT
+8 ;
+9 SET DA=$$NEXTIFN
IF DA<1
SET ERR=$$ERR(4)
QUIT
+10 SET UID="urn:va:"_TYPE_":"_HMPSYS_":"_DFN_":"_DA
+11 SET ^HMP(800000.1,DA,0)=UID_U_DFN_U_TYPE
+12 SET ^HMP(800000.1,"B",UID,DA)=""
+13 SET ^HMP(800000.1,"C",DFN,TYPE,DA)=""
+14 QUIT
+15 ;
NEXTIFN() ; -- Returns next available IFN
+1 NEW I,HDR,TOTAL,DA
+2 LOCK +^HMP(800000.1,0):$SELECT($GET(DILOCKTM)>0:DILOCKTM,1:5)
+3 IF '$TEST
QUIT "^"
+4 SET HDR=$GET(^HMP(800000.1,0))
SET TOTAL=+$PIECE(HDR,U,4)
SET I=$ORDER(^HMP(800000.1,"?"),-1)
+5 FOR I=(I+1):1
if '$DATA(^HMP(800000.1,I,0))
QUIT
+6 SET DA=I
SET $PIECE(HDR,U,3,4)=DA_U_(TOTAL+1)
SET ^HMP(800000.1,0)=HDR
+7 LOCK -^HMP(800000.1,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 ;
CONV ; -- convert uid format
+1 NEW DA,X0,UID,HMPSYS,DFN,COLL,NEW,I,JSON,HMPY,ERR,CNT
+2 SET HMPSYS=$$SYS^HMPUTILS
+3 SET DA=0
FOR
SET DA=$ORDER(^HMP(800000.1,DA))
if DA<1
QUIT
Begin DoDot:1
+4 SET X0=$GET(^HMP(800000.1,DA,0))
SET UID=$PIECE(X0,U)
+5 KILL ^HMP(800000.1,"B",UID,DA),JSON
+6 SET DFN=$PIECE(X0,"^",2)
SET COLL=$PIECE(X0,"^",3)
+7 SET NEW="urn:va:"_COLL_":"_HMPSYS_":"_DFN_":"_DA
+8 SET $PIECE(^HMP(800000.1,DA,0),U)=NEW
SET ^HMP(800000.1,"B",NEW,DA)=""
+9 ;decode JSON object, reset uid
+10 SET I=0
FOR
SET I=$ORDER(^HMP(800000.1,DA,1,I))
if I<1
QUIT
SET JSON(I)=$GET(^(I,0))
+11 if '$DATA(JSON)
QUIT
KILL HMPY,ERR
+12 DO DECODE^HMPJSON("JSON","HMPY","ERR")
IF $DATA(ERR)
WRITE !,DA
QUIT
+13 SET HMPY("uid")=NEW
KILL JSON
+14 DO ENCODE^HMPJSON("HMPY","JSON","ERR")
IF $DATA(ERR)
WRITE !,DA
QUIT
+15 KILL ^HMP(800000.1,DA,1)
SET ^(1,0)="^800000.101^^"
SET CNT=0
+16 SET I=""
FOR
SET I=$ORDER(JSON(I))
if I=""
QUIT
SET CNT=CNT+1
SET ^HMP(800000.1,DA,1,CNT,0)=JSON(I)
+17 if $GET(CNT)
SET ^HMP(800000.1,DA,1,0)="^800000.101^"_CNT_U_CNT
End DoDot:1
+18 QUIT
