VPRDJ ;SLC/MKB -- Serve VistA data as JSON via RPC ;10/18/12 6:26pm
;;1.0;VIRTUAL PATIENT RECORD;**2,32**;Sep 01, 2011;Build 6
;;Per VHA Directive 2004-038, this routine should not be modified.
;
; External References DBIA#
; ------------------- -----
; ^DPT 10035
; MPIF001 2701
; XLFDT 10103
; XLFSTR 10104
; XUPARAM 2541
;
GET(VPR,FILTER) ; -- Return search results as JSON in @VPR@(n)
; RPC = VPR GET PATIENT DATA JSON
; where FILTER("patientId") = DFN or DFN;ICN
; FILTER("domain") = name of desired data type (see VPRDJ0)
; 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("nowrap") = include line breaks in comments [opt]
;
N ICN,DFN,VPRSYS,VPRTYPE,VPRSTART,VPRSTOP,VPRMAX,VPRI,VPRID,VPRTEXT,VPRP,VPRTN,VPRERR
S VPR=$NA(^TMP("VPR",$J)),VPRI=0 K @VPR
S VPRSYS=$$GET^XPAR("SYS","VPR SYSTEM NAME")
S DT=$$DT^XLFDT ;for crossing midnight boundary
;
I $G(FILTER("uid"))'="" D SEPUID(.FILTER)
; parse & validate input parameters
S DFN=$G(FILTER("patientId"))
S ICN=+$P($G(DFN),";",2),DFN=+$G(DFN)
I DFN<1,ICN S DFN=+$$GETDFN^MPIF001(ICN)
;
S VPRTYPE=$G(FILTER("domain")) S:VPRTYPE="" VPRTYPE=$$ALL
I $D(ZTQUEUED) S VPR=$NA(^XTMP(VPRBATCH,DFN,VPRTYPE)) K @VPR
I VPRTYPE'="new",DFN<1!'$D(^DPT(DFN)) S VPRERR=$$ERR(1,DFN) G GTQ
;
S VPRSTART=+$G(FILTER("start"),1410102)
S VPRSTOP=+$G(FILTER("stop"),4141015)
S VPRMAX=+$G(FILTER("max"),9999)
I VPRSTART,VPRSTOP,VPRSTOP<VPRSTART D
. N X S X=VPRSTART,VPRSTART=VPRSTOP,VPRSTOP=X
I VPRSTOP,$L(VPRSTOP,".")<2 S VPRSTOP=VPRSTOP_".24"
;
S VPRID=$G(FILTER("id"))
S VPRTEXT=+$G(FILTER("text"),1) ;default = true/text
;
; extract data
;I VPRTYPE="new",$L($T(EN^VPRDJX)) D EN^VPRDJX(VPRID,VPRMAX) Q ;HMP
F VPRP=1:1:$L(VPRTYPE,";") S TYPE=$P(VPRTYPE,";",VPRP) I $L(TYPE) D
. S VPRTN=$$TAG(TYPE)_"^VPRDJ0" Q:'$L($T(@VPRTN))
. D @VPRTN
;
GTQ ; add item count and terminating characters
S @VPR@(.5)="{""apiVersion"":""1.01"",""params"":{"_$$SYS_"},"
I $D(VPRERR) S @VPR@(.7)="""error"":{""message"":"""_VPRERR_"""}}" Q
I '$D(@VPR)!'$G(VPRI) S @VPR@(.6)="""data"":{""totalItems"":0,""items"":[]}}" Q
;
S @VPR@(.6)="""data"":{""updated"":"""_$$HL7NOW_""",""totalItems"":"_VPRI_",""items"":["
S VPRI=VPRI+1,@VPR@(VPRI)="]}}"
K ^TMP("VPRTEXT",$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)'=VPRSYS 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"":"""_VPRSYS_""""
;
TAG(X) ; -- Return linetag in VPRDJ0 routine for clinical domain X
N Y S X=$G(X,"Z")
S Y=$E($$UP^XLFSTR(X),1,8)
S:'$L($T(@(Y_"^VPRDJ0"))) Y="VPR"
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"
;
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 $P($$FMTHL7^XLFDT($$NOW^XLFDT),"-")
;
ADD(ITEM,COLL) ; -- add ITEM to results
I $D(VPRCRC),$D(COLL) D ONE^VPRDCRC(ITEM,COLL) Q ;checksum
; -- add ITEM to @VPR@(VPRI) to return JSON
N VPRY,VPRERR
D ENCODE^VPRJSON(ITEM,"VPRY","VPRERR")
I $D(VPRERR) D ;return ERRor instead of ITEM
. N VPRTMP,VPRTXT,VPRITM
. M VPRITM=@ITEM K VPRY
. S VPRTXT(1)="Problem encoding json output."
. D SETERROR^VPRUTILS(.VPRTMP,.VPRERR,.VPRTXT,.VPRITM)
. K VPRERR D ENCODE^VPRJSON("VPRTMP","VPRY","VPRERR")
I $D(VPRY) D
. S VPRI=VPRI+1 S:VPRI>1 @VPR@(VPRI,.3)=","
. M @VPR@(VPRI)=VPRY
Q
;
TEST(DFN,TYPE,ID,TEXT,IN) ; -- test GET, write results to screen
N OUT,IDX
S U="^"
S:'$D(IN("systemID")) IN("systemID")=$$GET^XPAR("SYS","VPR SYSTEM NAME")
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(""VPR"","1.N.E Q:+$P(IDX,",",2)'=$J W !,@IDX
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HVPRDJ 4972 printed Sep 23, 2025@20:20:53 Page 2
VPRDJ ;SLC/MKB -- Serve VistA data as JSON via RPC ;10/18/12 6:26pm
+1 ;;1.0;VIRTUAL PATIENT RECORD;**2,32**;Sep 01, 2011;Build 6
+2 ;;Per VHA Directive 2004-038, 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 ;
GET(VPR,FILTER) ; -- Return search results as JSON in @VPR@(n)
+1 ; RPC = VPR GET PATIENT DATA JSON
+2 ; where FILTER("patientId") = DFN or DFN;ICN
+3 ; FILTER("domain") = name of desired data type (see VPRDJ0)
+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("nowrap") = include line breaks in comments [opt]
+11 ;
+12 NEW ICN,DFN,VPRSYS,VPRTYPE,VPRSTART,VPRSTOP,VPRMAX,VPRI,VPRID,VPRTEXT,VPRP,VPRTN,VPRERR
+13 SET VPR=$NAME(^TMP("VPR",$JOB))
SET VPRI=0
KILL @VPR
+14 SET VPRSYS=$$GET^XPAR("SYS","VPR SYSTEM NAME")
+15 ;for crossing midnight boundary
SET DT=$$DT^XLFDT
+16 ;
+17 IF $GET(FILTER("uid"))'=""
DO SEPUID(.FILTER)
+18 ; parse & validate input parameters
+19 SET DFN=$GET(FILTER("patientId"))
+20 SET ICN=+$PIECE($GET(DFN),";",2)
SET DFN=+$GET(DFN)
+21 IF DFN<1
IF ICN
SET DFN=+$$GETDFN^MPIF001(ICN)
+22 ;
+23 SET VPRTYPE=$GET(FILTER("domain"))
if VPRTYPE=""
SET VPRTYPE=$$ALL
+24 IF $DATA(ZTQUEUED)
SET VPR=$NAME(^XTMP(VPRBATCH,DFN,VPRTYPE))
KILL @VPR
+25 IF VPRTYPE'="new"
IF DFN<1!'$DATA(^DPT(DFN))
SET VPRERR=$$ERR(1,DFN)
GOTO GTQ
+26 ;
+27 SET VPRSTART=+$GET(FILTER("start"),1410102)
+28 SET VPRSTOP=+$GET(FILTER("stop"),4141015)
+29 SET VPRMAX=+$GET(FILTER("max"),9999)
+30 IF VPRSTART
IF VPRSTOP
IF VPRSTOP<VPRSTART
Begin DoDot:1
+31 NEW X
SET X=VPRSTART
SET VPRSTART=VPRSTOP
SET VPRSTOP=X
End DoDot:1
+32 IF VPRSTOP
IF $LENGTH(VPRSTOP,".")<2
SET VPRSTOP=VPRSTOP_".24"
+33 ;
+34 SET VPRID=$GET(FILTER("id"))
+35 ;default = true/text
SET VPRTEXT=+$GET(FILTER("text"),1)
+36 ;
+37 ; extract data
+38 ;I VPRTYPE="new",$L($T(EN^VPRDJX)) D EN^VPRDJX(VPRID,VPRMAX) Q ;HMP
+39 FOR VPRP=1:1:$LENGTH(VPRTYPE,";")
SET TYPE=$PIECE(VPRTYPE,";",VPRP)
IF $LENGTH(TYPE)
Begin DoDot:1
+40 SET VPRTN=$$TAG(TYPE)_"^VPRDJ0"
if '$LENGTH($TEXT(@VPRTN))
QUIT
+41 DO @VPRTN
End DoDot:1
+42 ;
GTQ ; add item count and terminating characters
+1 SET @VPR@(.5)="{""apiVersion"":""1.01"",""params"":{"_$$SYS_"},"
+2 IF $DATA(VPRERR)
SET @VPR@(.7)="""error"":{""message"":"""_VPRERR_"""}}"
QUIT
+3 IF '$DATA(@VPR)!'$GET(VPRI)
SET @VPR@(.6)="""data"":{""totalItems"":0,""items"":[]}}"
QUIT
+4 ;
+5 SET @VPR@(.6)="""data"":{""updated"":"""_$$HL7NOW_""",""totalItems"":"_VPRI_",""items"":["
+6 SET VPRI=VPRI+1
SET @VPR@(VPRI)="]}}"
+7 KILL ^TMP("VPRTEXT",$JOB)
+8 QUIT
+9 ;
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)'=VPRSYS
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"":"""_VPRSYS_""""
+2 ;
TAG(X) ; -- Return linetag in VPRDJ0 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_"^VPRDJ0")))
SET Y="VPR"
+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"
+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 QUIT $PIECE($$FMTHL7^XLFDT($$NOW^XLFDT),"-")
+2 ;
ADD(ITEM,COLL) ; -- add ITEM to results
+1 ;checksum
IF $DATA(VPRCRC)
IF $DATA(COLL)
DO ONE^VPRDCRC(ITEM,COLL)
QUIT
+2 ; -- add ITEM to @VPR@(VPRI) to return JSON
+3 NEW VPRY,VPRERR
+4 DO ENCODE^VPRJSON(ITEM,"VPRY","VPRERR")
+5 ;return ERRor instead of ITEM
IF $DATA(VPRERR)
Begin DoDot:1
+6 NEW VPRTMP,VPRTXT,VPRITM
+7 MERGE VPRITM=@ITEM
KILL VPRY
+8 SET VPRTXT(1)="Problem encoding json output."
+9 DO SETERROR^VPRUTILS(.VPRTMP,.VPRERR,.VPRTXT,.VPRITM)
+10 KILL VPRERR
DO ENCODE^VPRJSON("VPRTMP","VPRY","VPRERR")
End DoDot:1
+11 IF $DATA(VPRY)
Begin DoDot:1
+12 SET VPRI=VPRI+1
if VPRI>1
SET @VPR@(VPRI,.3)=","
+13 MERGE @VPR@(VPRI)=VPRY
End DoDot:1
+14 QUIT
+15 ;
TEST(DFN,TYPE,ID,TEXT,IN) ; -- test GET, write results to screen
+1 NEW OUT,IDX
+2 SET U="^"
+3 if '$DATA(IN("systemID"))
SET IN("systemID")=$$GET^XPAR("SYS","VPR SYSTEM NAME")
+4 SET IN("patientId")=+$GET(DFN)
+5 SET IN("domain")=$GET(TYPE)
+6 if $DATA(ID)
SET IN("id")=ID
+7 if $DATA(TEXT)
SET IN("text")=TEXT
+8 DO GET(.OUT,.IN)
+9 ;
+10 SET IDX=OUT
+11 FOR
SET IDX=$QUERY(@IDX)
if IDX'?1"^TMP(""VPR"","1.N.E
QUIT
if +$PIECE(IDX,",",2)'=$JOB
QUIT
WRITE !,@IDX
+12 QUIT
