VPRDPXAM ;SLC/MKB -- PCE V Exams ;8/2/11 15:29
;;1.0;VIRTUAL PATIENT RECORD;**1**;Sep 01, 2011;Build 38
;;Per VHA Directive 2004-038, this routine should not be modified.
;
; External References DBIA#
; ------------------- -----
; ^AUPNVSIT 2028
; ^PXRMINDX 4290
; DILFD 2055
; PXPXRM 4250
; XUAF4 2171
;
; ------------ Get data from VistA ------------
;
EN(DFN,BEG,END,MAX,IFN) ; -- find a patient's exams
S DFN=+$G(DFN) Q:DFN<1 ;invalid patient
S BEG=$G(BEG,1410101),END=$G(END,4141015),MAX=$G(MAX,9999)
N VPRIDT,VPRN,VPRITM,VPRCNT
;
; get one exam
I $G(IFN) D Q
. N ITM,DATE K ^TMP("VPRPX",$J)
. S ITM=0 F S ITM=$O(^PXRMINDX(9000010.13,"PI",+$G(DFN),ITM)) Q:ITM<1 D Q:$D(VPRITM)
.. S DATE=0 F S DATE=$O(^PXRMINDX(9000010.13,"PI",+$G(DFN),ITM,DATE)) Q:DATE<1 I $D(^(DATE,IFN)) D Q
... S VPRIDT=9999999-DATE,^TMP("VPRPX",$J,VPRIDT,IFN)=ITM_U_DATE
... D EN1(IFN,.VPRITM),XML(.VPRITM)
;
; get all exams
D SORT(DFN,BEG,END) S VPRCNT=0
S VPRIDT=0 F S VPRIDT=$O(^TMP("VPRPX",$J,VPRIDT)) Q:VPRIDT<1 D Q:VPRCNT'<MAX
. S VPRN=0 F S VPRN=$O(^TMP("VPRPX",$J,VPRIDT,VPRN)) Q:VPRN<1 D Q:VPRCNT'<MAX
.. K VPRITM D EN1(VPRN,.VPRITM) Q:'$D(VPRITM)
.. D XML(.VPRITM) S VPRCNT=VPRCNT+1
K ^TMP("VPRPX",$J)
Q
;
SORT(DFN,START,STOP) ; -- build ^TMP("VPRPX",$J,9999999-DATE,DA)=ITM^DATE in range
; from ^PXRMINDX(9000010.13,"PI",DFN,ITM,DATE,DA)
N ITM,DATE,DA,IDT K ^TMP("VPRPX",$J)
S ITM=0 F S ITM=$O(^PXRMINDX(9000010.13,"PI",+$G(DFN),ITM)) Q:ITM<1 D
. S DATE=0 F S DATE=$O(^PXRMINDX(9000010.13,"PI",+$G(DFN),ITM,DATE)) Q:DATE<1 D
.. Q:DATE<START Q:DATE>STOP S IDT=9999999-DATE
.. S DA=0 F S DA=$O(^PXRMINDX(9000010.13,"PI",+$G(DFN),ITM,DATE,DA)) Q:DA<1 S ^TMP("VPRPX",$J,IDT,DA)=ITM_U_DATE
Q
;
EN1(IEN,PCE) ; -- return an exam in PCE("attribute")=value
; from EN: expects ^TMP("VPRPX",$J,VPRIDT,IEN)=ITM^DATE
N VPRF,TMP,VISIT,X0,FAC,LOC,X K PCE
D VXAM^PXPXRM(IEN,.VPRF)
S PCE("id")=IEN,X=$G(VPRF("VALUE"))
S PCE("result")=$$EXTERNAL^DILFD(9000010.13,.04,,X)
S TMP=$G(^TMP("VPRPX",$J,VPRIDT,IEN)),PCE("dateTime")=$P(TMP,U,2)
S PCE("name")=$$EXTERNAL^DILFD(9000010.13,.01,,+TMP)
S PCE("comment")=$G(VPRF("COMMENTS"))
S VISIT=$G(VPRF("VISIT")),PCE("encounter")=VISIT
S X0=$G(^AUPNVSIT(+VISIT,0))
S FAC=+$P(X0,U,6),LOC=+$P(X0,U,22)
S:FAC PCE("facility")=$$STA^XUAF4(FAC)_U_$P($$NS^XUAF4(FAC),U)
S:'FAC PCE("facility")=$$FAC^VPRD(LOC)
Q
;
; ------------ Return data to middle tier ------------
;
XML(PCE) ; -- Return patient data as XML in @VPR@(n)
; as <element code='123' displayName='ABC' />
N ATT,X,Y,I,ID
D ADD("<exam>") S VPRTOTL=$G(VPRTOTL)+1
S ATT="" F S ATT=$O(PCE(ATT)) Q:ATT="" D D:$L(Y) ADD(Y)
. S X=$G(PCE(ATT)),Y="" Q:'$L(X)
. 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("</exam>")
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[HVPRDPXAM 3141 printed Sep 23, 2025@20:21:20 Page 2
VPRDPXAM ;SLC/MKB -- PCE V Exams ;8/2/11 15:29
+1 ;;1.0;VIRTUAL PATIENT RECORD;**1**;Sep 01, 2011;Build 38
+2 ;;Per VHA Directive 2004-038, this routine should not be modified.
+3 ;
+4 ; External References DBIA#
+5 ; ------------------- -----
+6 ; ^AUPNVSIT 2028
+7 ; ^PXRMINDX 4290
+8 ; DILFD 2055
+9 ; PXPXRM 4250
+10 ; XUAF4 2171
+11 ;
+12 ; ------------ Get data from VistA ------------
+13 ;
EN(DFN,BEG,END,MAX,IFN) ; -- find a patient's exams
+1 ;invalid patient
SET DFN=+$GET(DFN)
if DFN<1
QUIT
+2 SET BEG=$GET(BEG,1410101)
SET END=$GET(END,4141015)
SET MAX=$GET(MAX,9999)
+3 NEW VPRIDT,VPRN,VPRITM,VPRCNT
+4 ;
+5 ; get one exam
+6 IF $GET(IFN)
Begin DoDot:1
+7 NEW ITM,DATE
KILL ^TMP("VPRPX",$JOB)
+8 SET ITM=0
FOR
SET ITM=$ORDER(^PXRMINDX(9000010.13,"PI",+$GET(DFN),ITM))
if ITM<1
QUIT
Begin DoDot:2
+9 SET DATE=0
FOR
SET DATE=$ORDER(^PXRMINDX(9000010.13,"PI",+$GET(DFN),ITM,DATE))
if DATE<1
QUIT
IF $DATA(^(DATE,IFN))
Begin DoDot:3
+10 SET VPRIDT=9999999-DATE
SET ^TMP("VPRPX",$JOB,VPRIDT,IFN)=ITM_U_DATE
+11 DO EN1(IFN,.VPRITM)
DO XML(.VPRITM)
End DoDot:3
QUIT
End DoDot:2
if $DATA(VPRITM)
QUIT
End DoDot:1
QUIT
+12 ;
+13 ; get all exams
+14 DO SORT(DFN,BEG,END)
SET VPRCNT=0
+15 SET VPRIDT=0
FOR
SET VPRIDT=$ORDER(^TMP("VPRPX",$JOB,VPRIDT))
if VPRIDT<1
QUIT
Begin DoDot:1
+16 SET VPRN=0
FOR
SET VPRN=$ORDER(^TMP("VPRPX",$JOB,VPRIDT,VPRN))
if VPRN<1
QUIT
Begin DoDot:2
+17 KILL VPRITM
DO EN1(VPRN,.VPRITM)
if '$DATA(VPRITM)
QUIT
+18 DO XML(.VPRITM)
SET VPRCNT=VPRCNT+1
End DoDot:2
if VPRCNT'<MAX
QUIT
End DoDot:1
if VPRCNT'<MAX
QUIT
+19 KILL ^TMP("VPRPX",$JOB)
+20 QUIT
+21 ;
SORT(DFN,START,STOP) ; -- build ^TMP("VPRPX",$J,9999999-DATE,DA)=ITM^DATE in range
+1 ; from ^PXRMINDX(9000010.13,"PI",DFN,ITM,DATE,DA)
+2 NEW ITM,DATE,DA,IDT
KILL ^TMP("VPRPX",$JOB)
+3 SET ITM=0
FOR
SET ITM=$ORDER(^PXRMINDX(9000010.13,"PI",+$GET(DFN),ITM))
if ITM<1
QUIT
Begin DoDot:1
+4 SET DATE=0
FOR
SET DATE=$ORDER(^PXRMINDX(9000010.13,"PI",+$GET(DFN),ITM,DATE))
if DATE<1
QUIT
Begin DoDot:2
+5 if DATE<START
QUIT
if DATE>STOP
QUIT
SET IDT=9999999-DATE
+6 SET DA=0
FOR
SET DA=$ORDER(^PXRMINDX(9000010.13,"PI",+$GET(DFN),ITM,DATE,DA))
if DA<1
QUIT
SET ^TMP("VPRPX",$JOB,IDT,DA)=ITM_U_DATE
End DoDot:2
End DoDot:1
+7 QUIT
+8 ;
EN1(IEN,PCE) ; -- return an exam in PCE("attribute")=value
+1 ; from EN: expects ^TMP("VPRPX",$J,VPRIDT,IEN)=ITM^DATE
+2 NEW VPRF,TMP,VISIT,X0,FAC,LOC,X
KILL PCE
+3 DO VXAM^PXPXRM(IEN,.VPRF)
+4 SET PCE("id")=IEN
SET X=$GET(VPRF("VALUE"))
+5 SET PCE("result")=$$EXTERNAL^DILFD(9000010.13,.04,,X)
+6 SET TMP=$GET(^TMP("VPRPX",$JOB,VPRIDT,IEN))
SET PCE("dateTime")=$PIECE(TMP,U,2)
+7 SET PCE("name")=$$EXTERNAL^DILFD(9000010.13,.01,,+TMP)
+8 SET PCE("comment")=$GET(VPRF("COMMENTS"))
+9 SET VISIT=$GET(VPRF("VISIT"))
SET PCE("encounter")=VISIT
+10 SET X0=$GET(^AUPNVSIT(+VISIT,0))
+11 SET FAC=+$PIECE(X0,U,6)
SET LOC=+$PIECE(X0,U,22)
+12 if FAC
SET PCE("facility")=$$STA^XUAF4(FAC)_U_$PIECE($$NS^XUAF4(FAC),U)
+13 if 'FAC
SET PCE("facility")=$$FAC^VPRD(LOC)
+14 QUIT
+15 ;
+16 ; ------------ Return data to middle tier ------------
+17 ;
XML(PCE) ; -- 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("<exam>")
SET VPRTOTL=$GET(VPRTOTL)+1
+4 SET ATT=""
FOR
SET ATT=$ORDER(PCE(ATT))
if ATT=""
QUIT
Begin DoDot:1
+5 SET X=$GET(PCE(ATT))
SET Y=""
if '$LENGTH(X)
QUIT
+6 IF X'["^"
SET Y="<"_ATT_" value='"_$$ESC^VPRD(X)_"' />"
QUIT
+7 SET Y="<"_ATT_" code='"_$PIECE(X,U)_"' name='"_$$ESC^VPRD($PIECE(X,U,2))_"' />"
End DoDot:1
if $LENGTH(Y)
DO ADD(Y)
+8 DO ADD("</exam>")
+9 QUIT
+10 ;
ADD(X) ; Add a line @VPR@(n)=X
+1 SET VPRI=$GET(VPRI)+1
+2 SET @VPR@(VPRI)=X
+3 QUIT
