VPRDGPF.m

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 ---VPRDGPF   2165     printed  Feb 19, 2025@00:10:56                                                                                                                                                                                                     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