HMPDJ ;SLC/MKB,ASMR/RRB,CK -- Serve VistA data as JSON via RPC;Aug 29, 2016 20:06:27
;;2.0;ENTERPRISE HEALTH MANAGEMENT PLATFORM;**1,2,3**;May 15, 2016;Build 15
;Per VA Directive 6402, this routine should not be modified.
;
; External References DBIA#
; ------------------- -----
; ^DPT 10035
; MPIF001 2701
; XLFDT 10103
; XLFSTR 10104
; XUPARAM 2541
;
; DE2818/RRB - SQA findings 1st 3 lines of code.
;
Q
;
GET(HMP,FILTER) ; -- Return search results as JSON in @HMP@(n)
; RPC = HMP GET PATIENT DATA JSON
; where FILTER("patientId") = DFN or DFN;ICN
; FILTER("domain") = name of desired data type (see HMPDJ0)
; FILTER("text") = boolean, to include document text [opt]
; FILTER("start") = start date.time of search [opt]
; FILTER("stop") = stop date.time of search [opt]
; FILTER("max") = maximum number of items to return [opt]
; FILTER("id") = single item id to return [opt]
; FILTER("uid") = single record uid to return [opt]
; FILTER("noHead") = flag, to omit header and commas [opt]
;
N ICN,DFN,HMPI,HMPSYS,HMPTYPE,HMPSTART,HMPSTOP,HMPMAX,HMPID,HMPTEXT,HMPP,TYPE,HMPTN,HMPERR
S HMP=$NA(^TMP("HMP",$J)),HMPI=0 K @HMP
S HMPSYS=$$SYS^HMPUTILS
S DT=$$DT^XLFDT ;for crossing midnight
;
; parse & validate input parameters
I $G(FILTER("uid"))'="" D SEPUID(.FILTER)
;
S DFN=$G(FILTER("patientId"))
;
S ICN=+$P($G(DFN),";",2),DFN=+$G(DFN)
I '(DFN>0),ICN S DFN=+$$GETDFN^MPIF001(ICN) ;DE4496
;
S HMPTYPE=$G(FILTER("domain")) S:HMPTYPE="" HMPTYPE=$$ALL
I $D(ZTQUEUED) S HMP=$NA(^XTMP(HMPBATCH,HMPFZTSK,HMPTYPE)) K @HMP
;ICR 10035 DE2818 ASF 11/2/15, DE4496 August 19, 2016
I HMPTYPE'="new",'(DFN>0)!'$D(^DPT(DFN)) D LOGDPT^HMPLOG(DFN) S HMPERR=$$ERR(1,DFN) G GTQ
;
; -- initialize chunking if from DOMPT^HMPDJFSP ; i.e. HMPCHNK defined *S68-JCH*
D CHNKINIT^HMPDJFSP(.HMP,.HMPI) ; *S68-JCH*
;
S HMPSTART=+$G(FILTER("start"),1410102)
S HMPSTOP=+$G(FILTER("stop"),4141015)
S HMPMAX=+$G(FILTER("max"),999999)
I HMPSTART,HMPSTOP,HMPSTOP<HMPSTART D
. N X S X=HMPSTART,HMPSTART=HMPSTOP,HMPSTOP=X
I HMPSTOP,$L(HMPSTOP,".")<2 S HMPSTOP=HMPSTOP_".24"
;
S HMPID=$G(FILTER("id"))
S HMPTEXT=+$G(FILTER("text"),1) ;default = true/text
;
;set error trap
K ^TMP($J,"HMP ERROR")
;
; extract data
I HMPTYPE="new",$L($T(EN^HMPDJX)),'$G(^XTMP("HMP-off","GET")) D EN^HMPDJX(HMPID,HMPMAX) Q ;data updates
F HMPP=1:1:$L(HMPTYPE,";") S TYPE=$P(HMPTYPE,";",HMPP) I $L(TYPE) D
. S HMPTN=$$TAG(TYPE)_"^HMPDJ0" Q:'$L($T(@HMPTN)) ;D ERR(2) Q
. N $ES,$ET,ERRPAT,ERRMSG
. S $ET="D ERRHDLR^HMPDERRH",ERRMSG="A problem occurred when trying to load patient data from an API."
. D @HMPTN
;
GTQ ; add item count and terminating characters
N ERROR I $D(^TMP($J,"HMP ERROR"))>0 D BUILDERR(.ERROR)
I +$G(FILTER("noHead"))=1 D Q
.S @HMP@("total")=+$G(HMPI)
.I $L($G(ERROR(1)))>1 S @HMP@("error")=ERROR(1)
S @HMP@(.5)="{""apiVersion"":""1.01"",""params"":{"_$$SYS_"},"
I $D(HMPERR) S @HMP@(1)="""error"":{""message"":"""_HMPERR_"""}}" Q
I '$D(@HMP)!'$G(HMPI) D Q
. I '$D(ERROR) S @HMP@(1)="""data"":{""totalItems"":0,""items"":[]}}" Q
. S @HMP@(1)="""data"":{""totalItems"":0,""items"":[]},"
. S @HMP@(2,1)=ERROR(1)_"}"
;
S @HMP@(.6)="""data"":{""updated"":"""_$$HL7NOW_""",""totalItems"":"_HMPI_",""items"":["
S HMPI=HMPI+1,@HMP@(HMPI)=$S($D(ERROR):"]}",1:"]}}")
I $D(ERROR)>0 S HMPI=HMPI+1,@HMP@(HMPI,.3)=",",@HMP@(HMPI,1)=ERROR(1)_"}"
K ^TMP($J,"HMP ERROR"),^TMP("HMPTEXT",$J)
Q
;
SEPUID(FILTER) ; -- separate uid into FILTER pieces
N UID
S UID=$G(FILTER("uid")) K FILTER("uid") Q:UID=""
I $P(UID,":",4)'=HMPSYS Q
S FILTER("patientId")=$P(UID,":",5)
S FILTER("domain")=$P(UID,":",3)
S FILTER("id")=$P(UID,":",6)
Q
;
SYS() ; -- return system info for JSON header
Q """domain"":"""_$$KSP^XUPARAM("WHERE")_""",""systemId"":"""_HMPSYS_""""
;
BUILDERR(RESULT,DFN) ; -- build error array
N COUNT,MESSAGE,MSGCNT
S COUNT=$G(^TMP($J,"HMP ERROR","# of Errors"))
S MESSAGE="A mumps error occurred when extracting patient data. A total of "_COUNT_" occurred.\n\r"
S MSGCNT=0 F S MSGCNT=$O(^TMP($J,"HMP ERROR","ERROR MESSAGE",MSGCNT)) Q:MSGCNT'>0 D
. S MESSAGE=MESSAGE_$G(^TMP($J,"HMP ERROR","ERROR MESSAGE",MSGCNT))_"\n\r"
S RESULT(1)="""error"":{""message"":"""_MESSAGE_"""}"
Q
;
TAG(X) ; -- Return linetag in HMPDJ0 routine for clinical domain X
N Y S X=$G(X,"Z")
S Y=$E($$UP^XLFSTR(X),1,8)
S:'$L($T(@(Y_"^HMPDJ0"))) Y="HMP"
Q Y
;
ALL() ; -- return string for all types of data
Q "patient;problem;allergy;consult;vital;lab;procedure;obs;order;treatment;med;ptf;factor;immunization;exam;cpt;education;pov;skin;image;appointment;surgery;document;visit;mh"
;
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
;
ADD(ITEM,COLL) ; -- add ITEM to results
I $D(HMPCRC),$D(COLL) D ONE^HMPDCRC(ITEM,COLL) Q ;checksum
; -- add ITEM to @HMP@(HMPI) to return JSON
N HMPY,HMPERR
D ENCODE^HMPJSON(ITEM,"HMPY","HMPERR")
I $D(HMPERR) D ;return ERRor instead of ITEM
. N HMPTMP,HMPTXT,HMPITM
. M HMPITM=@ITEM K HMPY
. S HMPTXT(1)="Problem encoding json output."
. D SETERROR^HMPUTILS(.HMPTMP,.HMPERR,.HMPTXT,.HMPITM)
. K HMPERR D ENCODE^HMPJSON("HMPTMP","HMPY","HMPERR")
I $D(HMPY) D
. S HMPI=HMPI+1
. I HMPI>1 S @HMP@(HMPI,.3)=","
. M @HMP@(HMPI)=HMPY
. ;
. ; -- chunk data if from DOMPT^HMPDJFSP ; i.e. HMPCHNK defined ; *S68-JCH*
. D CHNKCHK^HMPDJFSP(.HMP,.HMPI) ; *S68-JCH*
Q
;
TEST(DFN,TYPE,ID,TEXT,IN) ; -- test GET, write results to screen
N OUT,IDX S U="^"
S:'$D(IN("systemID")) IN("systemID")=$$SYS^HMPUTILS
S IN("patientId")=+$G(DFN)
S IN("domain")=$G(TYPE)
S:$D(ID) IN("id")=ID
S:$D(TEXT) IN("text")=TEXT
D GET(.OUT,.IN)
;
S IDX=OUT
F S IDX=$Q(@IDX) Q:IDX'?1"^TMP(""HMP"","1.N.E Q:+$P(IDX,",",2)'=$J W !,@IDX
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HHMPDJ 6469 printed Sep 23, 2025@19:29:14 Page 2
HMPDJ ;SLC/MKB,ASMR/RRB,CK -- Serve VistA data as JSON via RPC;Aug 29, 2016 20:06:27
+1 ;;2.0;ENTERPRISE HEALTH MANAGEMENT PLATFORM;**1,2,3**;May 15, 2016;Build 15
+2 ;Per VA Directive 6402, this routine should not be modified.
+3 ;
+4 ; External References DBIA#
+5 ; ------------------- -----
+6 ; ^DPT 10035
+7 ; MPIF001 2701
+8 ; XLFDT 10103
+9 ; XLFSTR 10104
+10 ; XUPARAM 2541
+11 ;
+12 ; DE2818/RRB - SQA findings 1st 3 lines of code.
+13 ;
+14 QUIT
+15 ;
GET(HMP,FILTER) ; -- Return search results as JSON in @HMP@(n)
+1 ; RPC = HMP GET PATIENT DATA JSON
+2 ; where FILTER("patientId") = DFN or DFN;ICN
+3 ; FILTER("domain") = name of desired data type (see HMPDJ0)
+4 ; FILTER("text") = boolean, to include document text [opt]
+5 ; FILTER("start") = start date.time of search [opt]
+6 ; FILTER("stop") = stop date.time of search [opt]
+7 ; FILTER("max") = maximum number of items to return [opt]
+8 ; FILTER("id") = single item id to return [opt]
+9 ; FILTER("uid") = single record uid to return [opt]
+10 ; FILTER("noHead") = flag, to omit header and commas [opt]
+11 ;
+12 NEW ICN,DFN,HMPI,HMPSYS,HMPTYPE,HMPSTART,HMPSTOP,HMPMAX,HMPID,HMPTEXT,HMPP,TYPE,HMPTN,HMPERR
+13 SET HMP=$NAME(^TMP("HMP",$JOB))
SET HMPI=0
KILL @HMP
+14 SET HMPSYS=$$SYS^HMPUTILS
+15 ;for crossing midnight
SET DT=$$DT^XLFDT
+16 ;
+17 ; parse & validate input parameters
+18 IF $GET(FILTER("uid"))'=""
DO SEPUID(.FILTER)
+19 ;
+20 SET DFN=$GET(FILTER("patientId"))
+21 ;
+22 SET ICN=+$PIECE($GET(DFN),";",2)
SET DFN=+$GET(DFN)
+23 ;DE4496
IF '(DFN>0)
IF ICN
SET DFN=+$$GETDFN^MPIF001(ICN)
+24 ;
+25 SET HMPTYPE=$GET(FILTER("domain"))
if HMPTYPE=""
SET HMPTYPE=$$ALL
+26 IF $DATA(ZTQUEUED)
SET HMP=$NAME(^XTMP(HMPBATCH,HMPFZTSK,HMPTYPE))
KILL @HMP
+27 ;ICR 10035 DE2818 ASF 11/2/15, DE4496 August 19, 2016
+28 IF HMPTYPE'="new"
IF '(DFN>0)!'$DATA(^DPT(DFN))
DO LOGDPT^HMPLOG(DFN)
SET HMPERR=$$ERR(1,DFN)
GOTO GTQ
+29 ;
+30 ; -- initialize chunking if from DOMPT^HMPDJFSP ; i.e. HMPCHNK defined *S68-JCH*
+31 ; *S68-JCH*
DO CHNKINIT^HMPDJFSP(.HMP,.HMPI)
+32 ;
+33 SET HMPSTART=+$GET(FILTER("start"),1410102)
+34 SET HMPSTOP=+$GET(FILTER("stop"),4141015)
+35 SET HMPMAX=+$GET(FILTER("max"),999999)
+36 IF HMPSTART
IF HMPSTOP
IF HMPSTOP<HMPSTART
Begin DoDot:1
+37 NEW X
SET X=HMPSTART
SET HMPSTART=HMPSTOP
SET HMPSTOP=X
End DoDot:1
+38 IF HMPSTOP
IF $LENGTH(HMPSTOP,".")<2
SET HMPSTOP=HMPSTOP_".24"
+39 ;
+40 SET HMPID=$GET(FILTER("id"))
+41 ;default = true/text
SET HMPTEXT=+$GET(FILTER("text"),1)
+42 ;
+43 ;set error trap
+44 KILL ^TMP($JOB,"HMP ERROR")
+45 ;
+46 ; extract data
+47 ;data updates
IF HMPTYPE="new"
IF $LENGTH($TEXT(EN^HMPDJX))
IF '$GET(^XTMP("HMP-off","GET"))
DO EN^HMPDJX(HMPID,HMPMAX)
QUIT
+48 FOR HMPP=1:1:$LENGTH(HMPTYPE,";")
SET TYPE=$PIECE(HMPTYPE,";",HMPP)
IF $LENGTH(TYPE)
Begin DoDot:1
+49 ;D ERR(2) Q
SET HMPTN=$$TAG(TYPE)_"^HMPDJ0"
if '$LENGTH($TEXT(@HMPTN))
QUIT
+50 NEW $ESTACK,$ETRAP,ERRPAT,ERRMSG
+51 SET $ETRAP="D ERRHDLR^HMPDERRH"
SET ERRMSG="A problem occurred when trying to load patient data from an API."
+52 DO @HMPTN
End DoDot:1
+53 ;
GTQ ; add item count and terminating characters
+1 NEW ERROR
IF $DATA(^TMP($JOB,"HMP ERROR"))>0
DO BUILDERR(.ERROR)
+2 IF +$GET(FILTER("noHead"))=1
Begin DoDot:1
+3 SET @HMP@("total")=+$GET(HMPI)
+4 IF $LENGTH($GET(ERROR(1)))>1
SET @HMP@("error")=ERROR(1)
End DoDot:1
QUIT
+5 SET @HMP@(.5)="{""apiVersion"":""1.01"",""params"":{"_$$SYS_"},"
+6 IF $DATA(HMPERR)
SET @HMP@(1)="""error"":{""message"":"""_HMPERR_"""}}"
QUIT
+7 IF '$DATA(@HMP)!'$GET(HMPI)
Begin DoDot:1
+8 IF '$DATA(ERROR)
SET @HMP@(1)="""data"":{""totalItems"":0,""items"":[]}}"
QUIT
+9 SET @HMP@(1)="""data"":{""totalItems"":0,""items"":[]},"
+10 SET @HMP@(2,1)=ERROR(1)_"}"
End DoDot:1
QUIT
+11 ;
+12 SET @HMP@(.6)="""data"":{""updated"":"""_$$HL7NOW_""",""totalItems"":"_HMPI_",""items"":["
+13 SET HMPI=HMPI+1
SET @HMP@(HMPI)=$SELECT($DATA(ERROR):"]}",1:"]}}")
+14 IF $DATA(ERROR)>0
SET HMPI=HMPI+1
SET @HMP@(HMPI,.3)=","
SET @HMP@(HMPI,1)=ERROR(1)_"}"
+15 KILL ^TMP($JOB,"HMP ERROR"),^TMP("HMPTEXT",$JOB)
+16 QUIT
+17 ;
SEPUID(FILTER) ; -- separate uid into FILTER pieces
+1 NEW UID
+2 SET UID=$GET(FILTER("uid"))
KILL FILTER("uid")
if UID=""
QUIT
+3 IF $PIECE(UID,":",4)'=HMPSYS
QUIT
+4 SET FILTER("patientId")=$PIECE(UID,":",5)
+5 SET FILTER("domain")=$PIECE(UID,":",3)
+6 SET FILTER("id")=$PIECE(UID,":",6)
+7 QUIT
+8 ;
SYS() ; -- return system info for JSON header
+1 QUIT """domain"":"""_$$KSP^XUPARAM("WHERE")_""",""systemId"":"""_HMPSYS_""""
+2 ;
BUILDERR(RESULT,DFN) ; -- build error array
+1 NEW COUNT,MESSAGE,MSGCNT
+2 SET COUNT=$GET(^TMP($JOB,"HMP ERROR","# of Errors"))
+3 SET MESSAGE="A mumps error occurred when extracting patient data. A total of "_COUNT_" occurred.\n\r"
+4 SET MSGCNT=0
FOR
SET MSGCNT=$ORDER(^TMP($JOB,"HMP ERROR","ERROR MESSAGE",MSGCNT))
if MSGCNT'>0
QUIT
Begin DoDot:1
+5 SET MESSAGE=MESSAGE_$GET(^TMP($JOB,"HMP ERROR","ERROR MESSAGE",MSGCNT))_"\n\r"
End DoDot:1
+6 SET RESULT(1)="""error"":{""message"":"""_MESSAGE_"""}"
+7 QUIT
+8 ;
TAG(X) ; -- Return linetag in HMPDJ0 routine for clinical domain X
+1 NEW Y
SET X=$GET(X,"Z")
+2 SET Y=$EXTRACT($$UP^XLFSTR(X),1,8)
+3 if '$LENGTH($TEXT(@(Y_"^HMPDJ0")))
SET Y="HMP"
+4 QUIT Y
+5 ;
ALL() ; -- return string for all types of data
+1 QUIT "patient;problem;allergy;consult;vital;lab;procedure;obs;order;treatment;med;ptf;factor;immunization;exam;cpt;education;pov;skin;image;appointment;surgery;document;visit;mh"
+2 ;
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 ;
ADD(ITEM,COLL) ; -- add ITEM to results
+1 ;checksum
IF $DATA(HMPCRC)
IF $DATA(COLL)
DO ONE^HMPDCRC(ITEM,COLL)
QUIT
+2 ; -- add ITEM to @HMP@(HMPI) to return JSON
+3 NEW HMPY,HMPERR
+4 DO ENCODE^HMPJSON(ITEM,"HMPY","HMPERR")
+5 ;return ERRor instead of ITEM
IF $DATA(HMPERR)
Begin DoDot:1
+6 NEW HMPTMP,HMPTXT,HMPITM
+7 MERGE HMPITM=@ITEM
KILL HMPY
+8 SET HMPTXT(1)="Problem encoding json output."
+9 DO SETERROR^HMPUTILS(.HMPTMP,.HMPERR,.HMPTXT,.HMPITM)
+10 KILL HMPERR
DO ENCODE^HMPJSON("HMPTMP","HMPY","HMPERR")
End DoDot:1
+11 IF $DATA(HMPY)
Begin DoDot:1
+12 SET HMPI=HMPI+1
+13 IF HMPI>1
SET @HMP@(HMPI,.3)=","
+14 MERGE @HMP@(HMPI)=HMPY
+15 ;
+16 ; -- chunk data if from DOMPT^HMPDJFSP ; i.e. HMPCHNK defined ; *S68-JCH*
+17 ; *S68-JCH*
DO CHNKCHK^HMPDJFSP(.HMP,.HMPI)
End DoDot:1
+18 QUIT
+19 ;
TEST(DFN,TYPE,ID,TEXT,IN) ; -- test GET, write results to screen
+1 NEW OUT,IDX
SET U="^"
+2 if '$DATA(IN("systemID"))
SET IN("systemID")=$$SYS^HMPUTILS
+3 SET IN("patientId")=+$GET(DFN)
+4 SET IN("domain")=$GET(TYPE)
+5 if $DATA(ID)
SET IN("id")=ID
+6 if $DATA(TEXT)
SET IN("text")=TEXT
+7 DO GET(.OUT,.IN)
+8 ;
+9 SET IDX=OUT
+10 FOR
SET IDX=$QUERY(@IDX)
if IDX'?1"^TMP(""HMP"","1.N.E
QUIT
if +$PIECE(IDX,",",2)'=$JOB
QUIT
WRITE !,@IDX
+11 QUIT
+12 ;
