- 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 Jan 18, 2025@02:54:43 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 ;