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)
Q
;
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)
Q
;
; ------------ 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>")
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[HVPRDGMRC 3845 printed Sep 23, 2025@20:20:49 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
