Routine: VPRDGMRC

VPRDGMRC ;SLC/MKB -- Consult extract ;8/2/11  15:29

 ;;1.0;VIRTUAL PATIENT RECORD;**1,4,5,7**;Sep 01, 2011;Build 3

 ;;Per VHA Directive 2004-038, this routine should not be modified.

 ; External References          DBIA#

 ; -------------------          -----

 ; ^VA(200                      10060

 ; GMRCAPI                       6082

 ; GMRCGUIB                      2980

 ; GMRCSLM1,^TMP("GMRCR",$J)     2740

 ; XUAF4                         2171

 ; ------------ Get consults from VistA ------------

EN(DFN,BEG,END,MAX,IFN) ; -- find patient's consults

 N VPRN,VPRX,VPRITM K ^TMP("GMRCR",$J,"CS")

 S DFN=+$G(DFN) Q:DFN<1

 S BEG=$G(BEG,1410101),END=$G(END,4141015),MAX=$G(MAX,9999)

 D OER^GMRCSLM1(DFN,"",BEG,END,"")

 S VPRN=0 F  S VPRN=$O(^TMP("GMRCR",$J,"CS",VPRN)) Q:VPRN<1!(VPRN>MAX)  S VPRX=$G(^(VPRN,0)) Q:$E(VPRX)="<"  D

 . I $G(IFN),IFN'=+VPRX Q

 . K VPRITM D EN1(+VPRX,.VPRITM),XML(.VPRITM)

 K ^TMP("GMRCR",$J,"CS"),^TMP("VPRTEXT",$J)

EN1(ID,CONS) ; -- return a consult in CONS("attribute")=value

 ;     Expects DFN, VPRX=^TMP("GMRCR",$J,"CS",VPRN,0) [from EN]

 N VPRD,X0,VPRJ,X,VPRTIU

 K CONS,^TMP("VPRTEXT",$J)

 S CONS("id")=ID,CONS("requested")=$P(VPRX,U,2)

 S CONS("status")=$P(VPRX,U,3),CONS("service")=$P(VPRX,U,4)

 S CONS("procedure")=$P(VPRX,U,5),CONS("name")=$P(VPRX,U,7)

 I $P(VPRX,U,6)="*" S CONS("result")="SIGNIFICANT FINDINGS"

 S CONS("orderID")=$P(VPRX,U,8),CONS("type")=$P(VPRX,U,9)

 ;D DOCLIST^GMRCGUIB(.VPRD,ID) S X0=$G(VPRD(0)) ;=^GMR(123,ID,0)

 D GET^GMRCAPI(.VPRD,ID) S X0=$G(VPRD(0)) ;=^GMR(123,ID,0)

 S X=$P(X0,U,9) S:$L(X) CONS("urgency")=X

 S X=$P(X0,U,14) S:X CONS("provider")=X_U_$P($G(^VA(200,X,0)),U)_U_$$PROVSPC^VPRD(X)

 I $O(VPRD(20,0)) D

 . S X=$NA(^TMP("VPRTEXT",$J,"reason"))

 . S VPRJ=0 F  S VPRJ=$O(VPRD(20,VPRJ)) Q:VPRJ<1  S @X@(VPRJ)=$G(VPRD(20,VPRJ,0))

 . S CONS("reason")=X

 I $D(VPRD(30))!$D(VPRD(30.1)) D

 . S X=$G(VPRD(30.1)),$P(X,U,2)=""

 . S:$D(VPRD(30)) $P(X,U,2)=VPRD(30)

 . S:$L(X) CONS("provDx")=X

 S VPRJ=0 F  S VPRJ=$O(VPRD(50,VPRJ)) Q:VPRJ<1  S X=$G(VPRD(50,VPRJ)) D

 . N Y S Y=$$INFO^VPRDTIU(+X) Q:Y<1  ;draft or retracted

 . S CONS("document",VPRJ)=Y

 . S:$G(VPRTEXT) CONS("document",VPRJ,"content")=$$TEXT^VPRDTIU(X)

 S X=$P(X0,U,21),CONS("facility")=$S(X:$$STA^XUAF4(X)_U_$P($$NS^XUAF4(X),U),1:$$FAC^VPRD)

 ; ------------ Return data to middle tier ------------

XML(CONS) ; -- Return patient consult as XML

 ;  as <element code='123' displayName='ABC' />

 N ATT,X,Y,I,J,NAMES

 D ADD("<consult>") S VPRTOTL=$G(VPRTOTL)+1

 S ATT="" F  S ATT=$O(CONS(ATT)) Q:ATT=""  D  D:$L(Y) ADD(Y)

 . S NAMES=$S(ATT="document":"id^localTitle^nationalTitle^vuid",ATT="provider":"code^name^"_$$PROVTAGS^VPRD,ATT="provDx":"code^name^system",1:"code^name")_"^Z"

 . I $O(CONS(ATT,0)) D  S Y="" Q  ;multiples

 .. D ADD("<"_ATT_"s>")

 .. S I=0 F  S I=$O(CONS(ATT,I)) Q:I<1  D

 ... S X=$G(CONS(ATT,I)),Y="<"_ATT_" "_$$LOOP

 ... S X=$G(CONS(ATT,I,"content")) I '$L(X) S Y=Y_"/>" D ADD(Y) Q

 ... S Y=Y_">" D ADD(Y)

 ... S Y="<content xml:space='preserve'>" D ADD(Y)

 ... S J=0 F  S J=$O(@X@(J)) Q:J<1  S Y=$$ESC^VPRD(@X@(J)) D ADD(Y)

 ... D ADD("</content>"),ADD("</"_ATT_">")

 .. D ADD("</"_ATT_"s>")

 . S X=$G(CONS(ATT)),Y="" Q:'$L(X)

 . I ATT="reason" D  S Y="" Q

 .. S Y="<reason xml:space='preserve'>" D ADD(Y)

 .. S J=0 F  S J=$O(@X@(J)) Q:J<1  S Y=$$ESC^VPRD(@X@(J)) D ADD(Y)

 .. D ADD("</reason>")

 . I X'["^" S Y="<"_ATT_" value='"_$$ESC^VPRD(X)_"' />" Q

 . I $L(X)>1 S Y="<"_ATT_" "_$$LOOP_"/>"

 D ADD("</consult>")

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

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HVPRDGMRC   3845     printed  Mar 13, 2025@21:49:30                                                                                                                                                                                                    Page 2

VPRDGMRC  ;SLC/MKB -- Consult extract ;8/2/11  15:29

 +1       ;;1.0;VIRTUAL PATIENT RECORD;**1,4,5,7**;Sep 01, 2011;Build 3

 +2       ;;Per VHA Directive 2004-038, this routine should not be modified.

 +3       ;

 +4       ; External References          DBIA#

 +5       ; -------------------          -----

 +6       ; ^VA(200                      10060

 +7       ; GMRCAPI                       6082

 +8       ; GMRCGUIB                      2980

 +9       ; GMRCSLM1,^TMP("GMRCR",$J)     2740

 +10      ; XUAF4                         2171

 +11      ;

 +12      ; ------------ Get consults from VistA ------------

 +13      ;

EN(DFN,BEG,END,MAX,IFN) ; -- find patient's consults

 +1        NEW VPRN,VPRX,VPRITM

           KILL ^TMP("GMRCR",$JOB,"CS")

 +2        SET DFN=+$GET(DFN)

           if DFN<1

               QUIT

 +3        SET BEG=$GET(BEG,1410101)

           SET END=$GET(END,4141015)

           SET MAX=$GET(MAX,9999)

 +4       ;

 +5        DO OER^GMRCSLM1(DFN,"",BEG,END,"")

 +6        SET VPRN=0

FOR

               SET VPRN=$ORDER(^TMP("GMRCR",$JOB,"CS",VPRN))

               if VPRN<1!(VPRN>MAX)

                   QUIT

               SET VPRX=$GET(^(VPRN,0))

               if $EXTRACT(VPRX)="<"

                   QUIT

               Begin DoDot:1

 +7                IF $GET(IFN)

                       IF IFN'=+VPRX

                           QUIT

 +8                KILL VPRITM

                   DO EN1(+VPRX,.VPRITM)

                   DO XML(.VPRITM)

               End DoDot:1

 +9        KILL ^TMP("GMRCR",$JOB,"CS"),^TMP("VPRTEXT",$JOB)

 +10       QUIT

 +11      ;

EN1(ID,CONS) ; -- return a consult in CONS("attribute")=value

 +1       ;     Expects DFN, VPRX=^TMP("GMRCR",$J,"CS",VPRN,0) [from EN]

 +2        NEW VPRD,X0,VPRJ,X,VPRTIU

 +3        KILL CONS,^TMP("VPRTEXT",$JOB)

 +4        SET CONS("id")=ID

           SET CONS("requested")=$PIECE(VPRX,U,2)

 +5        SET CONS("status")=$PIECE(VPRX,U,3)

           SET CONS("service")=$PIECE(VPRX,U,4)

 +6        SET CONS("procedure")=$PIECE(VPRX,U,5)

           SET CONS("name")=$PIECE(VPRX,U,7)

 +7        IF $PIECE(VPRX,U,6)="*"

               SET CONS("result")="SIGNIFICANT FINDINGS"

 +8        SET CONS("orderID")=$PIECE(VPRX,U,8)

           SET CONS("type")=$PIECE(VPRX,U,9)

 +9       ;D DOCLIST^GMRCGUIB(.VPRD,ID) S X0=$G(VPRD(0)) ;=^GMR(123,ID,0)

 +10      ;=^GMR(123,ID,0)

           DO GET^GMRCAPI(.VPRD,ID)

           SET X0=$GET(VPRD(0))

 +11       SET X=$PIECE(X0,U,9)

           if $LENGTH(X)

               SET CONS("urgency")=X

 +12       SET X=$PIECE(X0,U,14)

           if X

               SET CONS("provider")=X_U_$PIECE($GET(^VA(200,X,0)),U)_U_$$PROVSPC^VPRD(X)

 +13       IF $ORDER(VPRD(20,0))

               Begin DoDot:1

 +14               SET X=$NAME(^TMP("VPRTEXT",$JOB,"reason"))

 +15               SET VPRJ=0

FOR

                       SET VPRJ=$ORDER(VPRD(20,VPRJ))

                       if VPRJ<1

                           QUIT

                       SET @X@(VPRJ)=$GET(VPRD(20,VPRJ,0))

 +16               SET CONS("reason")=X

               End DoDot:1

 +17       IF $DATA(VPRD(30))!$DATA(VPRD(30.1))

               Begin DoDot:1

 +18               SET X=$GET(VPRD(30.1))

                   SET $PIECE(X,U,2)=""

 +19               if $DATA(VPRD(30))

                       SET $PIECE(X,U,2)=VPRD(30)

 +20               if $LENGTH(X)

                       SET CONS("provDx")=X

               End DoDot:1

 +21       SET VPRJ=0

FOR

               SET VPRJ=$ORDER(VPRD(50,VPRJ))

               if VPRJ<1

                   QUIT

               SET X=$GET(VPRD(50,VPRJ))

               Begin DoDot:1

 +22      ;draft or retracted

                   NEW Y

                   SET Y=$$INFO^VPRDTIU(+X)

                   if Y<1

                       QUIT

 +23               SET CONS("document",VPRJ)=Y

 +24               if $GET(VPRTEXT)

                       SET CONS("document",VPRJ,"content")=$$TEXT^VPRDTIU(X)

               End DoDot:1

 +25       SET X=$PIECE(X0,U,21)

           SET CONS("facility")=$SELECT(X:$$STA^XUAF4(X)_U_$PIECE($$NS^XUAF4(X),U),1:$$FAC^VPRD)

 +26       QUIT

 +27      ;

 +28      ; ------------ Return data to middle tier ------------

 +29      ;

XML(CONS) ; -- Return patient consult as XML

 +1       ;  as <element code='123' displayName='ABC' />

 +2        NEW ATT,X,Y,I,J,NAMES

 +3        DO ADD("<consult>")

           SET VPRTOTL=$GET(VPRTOTL)+1

 +4        SET ATT=""

FOR

               SET ATT=$ORDER(CONS(ATT))

               if ATT=""

                   QUIT

               Begin DoDot:1

 +5                SET NAMES=$SELECT(ATT="document":"id^localTitle^nationalTitle^vuid",ATT="provider":"code^name^"_$$PROVTAGS^VPRD,ATT="provDx":"code^name^system",1:"code^name")_"^Z"

 +6       ;multiples

                   IF $ORDER(CONS(ATT,0))

                       Begin DoDot:2

 +7                        DO ADD("<"_ATT_"s>")

 +8                        SET I=0

FOR

                               SET I=$ORDER(CONS(ATT,I))

                               if I<1

                                   QUIT

                               Begin DoDot:3

 +9                                SET X=$GET(CONS(ATT,I))

                                   SET Y="<"_ATT_" "_$$LOOP

 +10                               SET X=$GET(CONS(ATT,I,"content"))

                                   IF '$LENGTH(X)

                                       SET Y=Y_"/>"

                                       DO ADD(Y)

                                       QUIT

 +11                               SET Y=Y_">"

                                   DO ADD(Y)

 +12                               SET Y="<content xml:space='preserve'>"

                                   DO ADD(Y)

 +13                               SET J=0

FOR

                                       SET J=$ORDER(@X@(J))

                                       if J<1

                                           QUIT

                                       SET Y=$$ESC^VPRD(@X@(J))

                                       DO ADD(Y)

 +14                               DO ADD("</content>")

                                   DO ADD("</"_ATT_">")

                               End DoDot:3

 +15                       DO ADD("</"_ATT_"s>")

                       End DoDot:2

                       SET Y=""

                       QUIT

 +16               SET X=$GET(CONS(ATT))

                   SET Y=""

                   if '$LENGTH(X)

                       QUIT

 +17               IF ATT="reason"

                       Begin DoDot:2

 +18                       SET Y="<reason xml:space='preserve'>"

                           DO ADD(Y)

 +19                       SET J=0

FOR

                               SET J=$ORDER(@X@(J))

                               if J<1

                                   QUIT

                               SET Y=$$ESC^VPRD(@X@(J))

                               DO ADD(Y)

 +20                       DO ADD("</reason>")

                       End DoDot:2

                       SET Y=""

                       QUIT

 +21               IF X'["^"

                       SET Y="<"_ATT_" value='"_$$ESC^VPRD(X)_"' />"

                       QUIT

 +22               IF $LENGTH(X)>1

                       SET Y="<"_ATT_" "_$$LOOP_"/>"

               End DoDot:1

               if $LENGTH(Y)

                   DO ADD(Y)

 +23       DO ADD("</consult>")

 +24       QUIT

 +25      ;

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

VPRDGMRC.m