Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: HMPDJ2

HMPDJ2.m

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