VPRDGPF ;SLC/MKB -- Patient Record Flags ;8/2/11 15:29
;;1.0;VIRTUAL PATIENT RECORD;;Sep 01, 2011;Build 12
;;Per VHA Directive 2004-038, this routine should not be modified.
;
; External References DBIA#
; ------------------- -----
; DGPFAPI 3860
; XUAF4 2171
;
; ------------ Get data from VistA ------------
;
EN(DFN,BEG,END,MAX,ID) ; -- find active flags
; [BEG,END,MAX not currently used]
S DFN=+$G(DFN) Q:DFN<1 ;invalid patient
N NUM,VPRF,VPRN,X,TEXT,VPRITM
S NUM=$$GETACT^DGPFAPI(DFN,"VPRF")
;
S VPRN=0 F S VPRN=$O(VPRF(VPRN)) Q:VPRN<1 D D:$D(VPRITM) XML(.VPRITM)
. K VPRITM S X=$G(VPRF(VPRN,"FLAG"))
. I $G(ID),$P(ID,"~",2)'=$P(X,U) Q
. S VPRITM("id")=DFN_"~"_$P(X,U),VPRITM("name")=$P(X,U,2)
. S VPRITM("approvedBy")=$G(VPRF(VPRN,"APPRVBY"))
. S VPRITM("assigned")=$P($G(VPRF(VPRN,"ASSIGNDT")),U)
. S VPRITM("reviewDue")=$P($G(VPRF(VPRN,"REVIEWDT")),U)
. S VPRITM("type")=$P($G(VPRF(VPRN,"FLAGTYPE")),U,2)
. S VPRITM("category")=$P($G(VPRF(VPRN,"CATEGORY")),U,2)
. S X=$G(VPRF(VPRN,"ORIGSITE"))
. S:X VPRITM("origSite")=$$STA^XUAF4(+X)_U_$P(X,U,2)
. S X=$G(VPRF(VPRN,"OWNER"))
. S:X VPRITM("ownSite")=$$STA^XUAF4(+X)_U_$P(X,U,2)
. S X=$G(VPRF(VPRN,"TIULINK")) S:X VPRITM("document")=X
. M TEXT=VPRF(VPRN,"NARR") S VPRITM("content")=$$STRING^VPRD(.TEXT)
I $G(ID),'$D(VPRITM) D INACT(ID)
Q
;
; ------------ Return data to middle tier ------------
;
XML(FLAG) ; -- Return patient data as XML in @VPR@(n)
; as <element code='123' displayName='ABC' />
N ATT,X,Y,I,ID
D ADD("<flag>") S VPRTOTL=$G(VPRTOTL)+1
S ATT="" F S ATT=$O(FLAG(ATT)) Q:ATT="" D D:$L(Y) ADD(Y)
. S X=$G(FLAG(ATT)),Y="" Q:'$L(X)
. I ATT="content" S Y="<"_ATT_" xml:space='preserve'>"_$$ESC^VPRD(X)_"</"_ATT_">" Q
. I X'["^" S Y="<"_ATT_" value='"_$$ESC^VPRD(X)_"' />" Q
. S Y="<"_ATT_" code='"_$P(X,U)_"' name='"_$$ESC^VPRD($P(X,U,2))_"' />"
D ADD("</flag>")
Q
;
INACT(ID) ; -- inactivated flag
D ADD("<flag id='"_ID_"' inactivated='1' />")
Q
;
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[HVPRDGPF 2165 printed Sep 23, 2025@20:20:51 Page 2
VPRDGPF ;SLC/MKB -- Patient Record Flags ;8/2/11 15:29
+1 ;;1.0;VIRTUAL PATIENT RECORD;;Sep 01, 2011;Build 12
+2 ;;Per VHA Directive 2004-038, this routine should not be modified.
+3 ;
+4 ; External References DBIA#
+5 ; ------------------- -----
+6 ; DGPFAPI 3860
+7 ; XUAF4 2171
+8 ;
+9 ; ------------ Get data from VistA ------------
+10 ;
EN(DFN,BEG,END,MAX,ID) ; -- find active flags
+1 ; [BEG,END,MAX not currently used]
+2 ;invalid patient
SET DFN=+$GET(DFN)
if DFN<1
QUIT
+3 NEW NUM,VPRF,VPRN,X,TEXT,VPRITM
+4 SET NUM=$$GETACT^DGPFAPI(DFN,"VPRF")
+5 ;
+6 SET VPRN=0
FOR
SET VPRN=$ORDER(VPRF(VPRN))
if VPRN<1
QUIT
Begin DoDot:1
+7 KILL VPRITM
SET X=$GET(VPRF(VPRN,"FLAG"))
+8 IF $GET(ID)
IF $PIECE(ID,"~",2)'=$PIECE(X,U)
QUIT
+9 SET VPRITM("id")=DFN_"~"_$PIECE(X,U)
SET VPRITM("name")=$PIECE(X,U,2)
+10 SET VPRITM("approvedBy")=$GET(VPRF(VPRN,"APPRVBY"))
+11 SET VPRITM("assigned")=$PIECE($GET(VPRF(VPRN,"ASSIGNDT")),U)
+12 SET VPRITM("reviewDue")=$PIECE($GET(VPRF(VPRN,"REVIEWDT")),U)
+13 SET VPRITM("type")=$PIECE($GET(VPRF(VPRN,"FLAGTYPE")),U,2)
+14 SET VPRITM("category")=$PIECE($GET(VPRF(VPRN,"CATEGORY")),U,2)
+15 SET X=$GET(VPRF(VPRN,"ORIGSITE"))
+16 if X
SET VPRITM("origSite")=$$STA^XUAF4(+X)_U_$PIECE(X,U,2)
+17 SET X=$GET(VPRF(VPRN,"OWNER"))
+18 if X
SET VPRITM("ownSite")=$$STA^XUAF4(+X)_U_$PIECE(X,U,2)
+19 SET X=$GET(VPRF(VPRN,"TIULINK"))
if X
SET VPRITM("document")=X
+20 MERGE TEXT=VPRF(VPRN,"NARR")
SET VPRITM("content")=$$STRING^VPRD(.TEXT)
End DoDot:1
if $DATA(VPRITM)
DO XML(.VPRITM)
+21 IF $GET(ID)
IF '$DATA(VPRITM)
DO INACT(ID)
+22 QUIT
+23 ;
+24 ; ------------ Return data to middle tier ------------
+25 ;
XML(FLAG) ; -- Return patient data as XML in @VPR@(n)
+1 ; as <element code='123' displayName='ABC' />
+2 NEW ATT,X,Y,I,ID
+3 DO ADD("<flag>")
SET VPRTOTL=$GET(VPRTOTL)+1
+4 SET ATT=""
FOR
SET ATT=$ORDER(FLAG(ATT))
if ATT=""
QUIT
Begin DoDot:1
+5 SET X=$GET(FLAG(ATT))
SET Y=""
if '$LENGTH(X)
QUIT
+6 IF ATT="content"
SET Y="<"_ATT_" xml:space='preserve'>"_$$ESC^VPRD(X)_"</"_ATT_">"
QUIT
+7 IF X'["^"
SET Y="<"_ATT_" value='"_$$ESC^VPRD(X)_"' />"
QUIT
+8 SET Y="<"_ATT_" code='"_$PIECE(X,U)_"' name='"_$$ESC^VPRD($PIECE(X,U,2))_"' />"
End DoDot:1
if $LENGTH(Y)
DO ADD(Y)
+9 DO ADD("</flag>")
+10 QUIT
+11 ;
INACT(ID) ; -- inactivated flag
+1 DO ADD("<flag id='"_ID_"' inactivated='1' />")
+2 QUIT
+3 ;
ADD(X) ; Add a line @VPR@(n)=X
+1 SET VPRI=$GET(VPRI)+1
+2 SET @VPR@(VPRI)=X
+3 QUIT
