VPRDPXRM ;SLC/MKB -- Reminders extract ;8/2/11 15:29
;;1.0;VIRTUAL PATIENT RECORD;**5**;Sep 01, 2011;Build 21
;;Per VHA Directive 2004-038, this routine should not be modified.
;
; External References DBIA#
; ------------------- -----
; ^DPT 10035
; ^VA(200 10060
; %DT 10003
; DIQ 2056
; PXRMMHV 4811
;(returns ^TMP("PXRMMHVC",$J) and ^TMP("PXRMMHVL,$J))
; XLFDT 10103
; XUAF4 2171
;
; ------------ Get reminders from VistA ------------
;
EN(DFN,BEG,END,MAX,IFN) ; -- find patient's reminders
; [BEG,END,IFN not currently used]
N VPRPROB,VPRN,VPRITM,VPRCNT,X
D PREMLIST^PXRMMHV
;
; get one reminder
I $G(IFN) D EN1(IFN,.VPRITM),XML(.VPRITM) G ENQ
;
; get all patient reminders
S DFN=+$G(DFN) Q:DFN<1
S MAX=$G(MAX,9999),VPRCNT=0
D MHVC^PXRMMHV(DFN)
S VPRN=0 F S VPRN=$O(^TMP("PXRMMHVC",$J,VPRN)) Q:(VPRN<1)!(VPRCNT'<MAX) D
. S X=$G(^TMP("PXRMMHVC",$J,VPRN,"STATUS")) Q:$P(X,U)="N/A"
. K VPRITM D EN1(VPRN,.VPRITM) Q:'$D(VPRITM)
. D XML(.VPRITM) S VPRCNT=VPRCNT+1
ENQ K ^TMP("PXRMMHVC",$J),^TMP("PXRMMHVL",$J)
Q
;
EN1(ID,REM) ; -- return a reminder in REM("attribute")=value
N VPRM,X,I,J K REM
S ID=+$G(ID) Q:ID<1 ;invalid ien
S VPRM=$G(^TMP("PXRMMHVL",$J,ID)) Q:$P(VPRM,U,3)'="N" ;nat'l only
S REM("id")=ID,REM("name")=$P(VPRM,U,2),X=$P(VPRM,U,3)
S REM("class")=X_U_$S(X="N":"NATIONAL",X="V":"VISN",X="L":"LOCAL",1:X)
S X=$G(^TMP("PXRMMHVC",$J,ID,"STATUS"))
S REM("status")=$P(X,U)
S:$L($P(X,U,2)) REM("due")=$P(X,U,2) ;string or FM date
S:$L($P(X,U,3)) REM("lastDone")=$P(X,U,3) ;string or FM date
S REM("facility")=$$FAC^VPRD ;local stn#^name
I $O(^TMP("PXRMMHVC",$J,ID,"DETAIL",0)) M REM("detail")=^TMP("PXRMMHVC",$J,ID,"DETAIL")
I $O(^TMP("PXRMMHVC",$J,ID,"SUMMARY",0)) M REM("summary")=^TMP("PXRMMHVC",$J,ID,"SUMMARY")
Q
;
; ------------ Return data to middle tier ------------
;
XML(REM) ; -- Return patient reminder as XML in @VPR@(I)
N ATT,I,X,Y,NAMES
D ADD("<reminder>") S VPRTOTL=$G(VPRTOTL)+1
S ATT="" F S ATT=$O(REM(ATT)) Q:ATT="" D D:$L(Y) ADD(Y)
. I ATT="detail"!(ATT="summary") D S Y="" Q ;text
.. S Y="<"_ATT_" xml:space='preserve'>" D ADD(Y)
.. S I=0 F S I=$O(REM(ATT,I)) Q:I<1 S X=$G(REM(ATT,I)),Y=$$ESC^VPRD(X) D ADD(Y)
.. D ADD("</"_ATT_">")
. S X=$G(REM(ATT)),Y="" Q:'$L(X)
. I X'["^" S Y="<"_ATT_" value='"_$$ESC^VPRD(X)_"' />" Q
. I $L(X)>1 S NAMES="code^name^Z",Y="<"_ATT_" "_$$LOOP_"/>"
D ADD("</reminder>")
Q
;
LOOP() ; -- build sub-items string from NAMES and X
N STR,P,TAG S STR=""
F P=1:1 S TAG=$P(NAMES,U,P) Q:TAG="Z" I $L($P(X,U,P)) S STR=STR_TAG_"='"_$$ESC^VPRD($P(X,U,P))_"' "
Q STR
;
ADD(X) ; Add a line @VPR@(n)=X
S VPRI=$G(VPRI)+1
S @VPR@(VPRI)=X
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HVPRDPXRM 2926 printed Sep 23, 2025@20:21:24 Page 2
VPRDPXRM ;SLC/MKB -- Reminders extract ;8/2/11 15:29
+1 ;;1.0;VIRTUAL PATIENT RECORD;**5**;Sep 01, 2011;Build 21
+2 ;;Per VHA Directive 2004-038, this routine should not be modified.
+3 ;
+4 ; External References DBIA#
+5 ; ------------------- -----
+6 ; ^DPT 10035
+7 ; ^VA(200 10060
+8 ; %DT 10003
+9 ; DIQ 2056
+10 ; PXRMMHV 4811
+11 ;(returns ^TMP("PXRMMHVC",$J) and ^TMP("PXRMMHVL,$J))
+12 ; XLFDT 10103
+13 ; XUAF4 2171
+14 ;
+15 ; ------------ Get reminders from VistA ------------
+16 ;
EN(DFN,BEG,END,MAX,IFN) ; -- find patient's reminders
+1 ; [BEG,END,IFN not currently used]
+2 NEW VPRPROB,VPRN,VPRITM,VPRCNT,X
+3 DO PREMLIST^PXRMMHV
+4 ;
+5 ; get one reminder
+6 IF $GET(IFN)
DO EN1(IFN,.VPRITM)
DO XML(.VPRITM)
GOTO ENQ
+7 ;
+8 ; get all patient reminders
+9 SET DFN=+$GET(DFN)
if DFN<1
QUIT
+10 SET MAX=$GET(MAX,9999)
SET VPRCNT=0
+11 DO MHVC^PXRMMHV(DFN)
+12 SET VPRN=0
FOR
SET VPRN=$ORDER(^TMP("PXRMMHVC",$JOB,VPRN))
if (VPRN<1)!(VPRCNT'<MAX)
QUIT
Begin DoDot:1
+13 SET X=$GET(^TMP("PXRMMHVC",$JOB,VPRN,"STATUS"))
if $PIECE(X,U)="N/A"
QUIT
+14 KILL VPRITM
DO EN1(VPRN,.VPRITM)
if '$DATA(VPRITM)
QUIT
+15 DO XML(.VPRITM)
SET VPRCNT=VPRCNT+1
End DoDot:1
ENQ KILL ^TMP("PXRMMHVC",$JOB),^TMP("PXRMMHVL",$JOB)
+1 QUIT
+2 ;
EN1(ID,REM) ; -- return a reminder in REM("attribute")=value
+1 NEW VPRM,X,I,J
KILL REM
+2 ;invalid ien
SET ID=+$GET(ID)
if ID<1
QUIT
+3 ;nat'l only
SET VPRM=$GET(^TMP("PXRMMHVL",$JOB,ID))
if $PIECE(VPRM,U,3)'="N"
QUIT
+4 SET REM("id")=ID
SET REM("name")=$PIECE(VPRM,U,2)
SET X=$PIECE(VPRM,U,3)
+5 SET REM("class")=X_U_$SELECT(X="N":"NATIONAL",X="V":"VISN",X="L":"LOCAL",1:X)
+6 SET X=$GET(^TMP("PXRMMHVC",$JOB,ID,"STATUS"))
+7 SET REM("status")=$PIECE(X,U)
+8 ;string or FM date
if $LENGTH($PIECE(X,U,2))
SET REM("due")=$PIECE(X,U,2)
+9 ;string or FM date
if $LENGTH($PIECE(X,U,3))
SET REM("lastDone")=$PIECE(X,U,3)
+10 ;local stn#^name
SET REM("facility")=$$FAC^VPRD
+11 IF $ORDER(^TMP("PXRMMHVC",$JOB,ID,"DETAIL",0))
MERGE REM("detail")=^TMP("PXRMMHVC",$JOB,ID,"DETAIL")
+12 IF $ORDER(^TMP("PXRMMHVC",$JOB,ID,"SUMMARY",0))
MERGE REM("summary")=^TMP("PXRMMHVC",$JOB,ID,"SUMMARY")
+13 QUIT
+14 ;
+15 ; ------------ Return data to middle tier ------------
+16 ;
XML(REM) ; -- Return patient reminder as XML in @VPR@(I)
+1 NEW ATT,I,X,Y,NAMES
+2 DO ADD("<reminder>")
SET VPRTOTL=$GET(VPRTOTL)+1
+3 SET ATT=""
FOR
SET ATT=$ORDER(REM(ATT))
if ATT=""
QUIT
Begin DoDot:1
+4 ;text
IF ATT="detail"!(ATT="summary")
Begin DoDot:2
+5 SET Y="<"_ATT_" xml:space='preserve'>"
DO ADD(Y)
+6 SET I=0
FOR
SET I=$ORDER(REM(ATT,I))
if I<1
QUIT
SET X=$GET(REM(ATT,I))
SET Y=$$ESC^VPRD(X)
DO ADD(Y)
+7 DO ADD("</"_ATT_">")
End DoDot:2
SET Y=""
QUIT
+8 SET X=$GET(REM(ATT))
SET Y=""
if '$LENGTH(X)
QUIT
+9 IF X'["^"
SET Y="<"_ATT_" value='"_$$ESC^VPRD(X)_"' />"
QUIT
+10 IF $LENGTH(X)>1
SET NAMES="code^name^Z"
SET Y="<"_ATT_" "_$$LOOP_"/>"
End DoDot:1
if $LENGTH(Y)
DO ADD(Y)
+11 DO ADD("</reminder>")
+12 QUIT
+13 ;
LOOP() ; -- build sub-items string from NAMES and X
+1 NEW STR,P,TAG
SET STR=""
+2 FOR P=1:1
SET TAG=$PIECE(NAMES,U,P)
if TAG="Z"
QUIT
IF $LENGTH($PIECE(X,U,P))
SET STR=STR_TAG_"='"_$$ESC^VPRD($PIECE(X,U,P))_"' "
+3 QUIT STR
+4 ;
ADD(X) ; Add a line @VPR@(n)=X
+1 SET VPRI=$GET(VPRI)+1
+2 SET @VPR@(VPRI)=X
+3 QUIT
