VPRDPROC ;SLC/MKB -- Procedure extract ;8/2/11 15:29
;;1.0;VIRTUAL PATIENT RECORD;**1,5**;Sep 01, 2011;Build 21
;;Per VHA Directive 2004-038, this routine should not be modified.
;
; External References DBIA#
; ------------------- -----
; RAO7PC1 2043
; SROESTV 3533
;
; ------------ Get procedure(s) from VistA ------------
;
EN(DFN,BEG,END,MAX,ID) ; -- find patient's procedures
S DFN=+$G(DFN) Q:DFN<1
S BEG=$G(BEG,1410101),END=$G(END,4141015),MAX=$G(MAX,9999)
;
N VPRN,VPRCNT,VPRITM,VPRY,VPRCATG
S VPRCATG=$G(FILTER("category"),"SR;RA") ;NwHIN default
;
; get one procedure
I $G(ID),ID'[";" D D:$D(VPRITM) XML(.VPRITM) Q
. I ID'["-" D EN1^VPRDSR(ID,.VPRITM) Q ;Surgery
. S (BEG,END)=9999999.9999=+ID D EN1^RAO7PC1(DFN,BEG,END,"1P")
. D EN1^VPRDRA(ID,.VPRITM) ;Radiology
. K ^TMP($J,"RAE1")
I $G(ID),ID[";" D EN^VPRDMC(DFN,,,,ID) Q ;CP/Medicine
;
SR ; get all surgeries
I VPRCATG'["SR" G RA
N SHOWADD S SHOWADD=1 ;to omit leading '+' with note titles
D LIST^SROESTV(.VPRY,DFN,BEG,END,MAX,1)
S VPRN=0 F S VPRN=$O(@VPRY@(VPRN)) Q:VPRN<1 D
. K VPRITM D ONE^VPRDSR(VPRN,.VPRITM) Q:'$D(VPRITM)
. ;Q:$G(VPRITM("status"))'?1"COMP".E
. D XML(.VPRITM)
K @VPRY
;
RA ; get all radiology exams
I VPRCATG'["RA" G CP
K ^TMP($J,"RAE1") D EN1^RAO7PC1(DFN,BEG,END,MAX)
S VPRCNT=+$G(VPRTOTL),VPRN=""
F S VPRN=$O(^TMP($J,"RAE1",DFN,VPRN)) Q:VPRN="" D Q:VPRCNT'<MAX ;I $P($P($G(^(VPRN)),U,6),"~",2)?1"COMP".E
. K VPRITM D EN1^VPRDRA(VPRN,.VPRITM) Q:'$D(VPRITM)
. D XML(.VPRITM) S VPRCNT=VPRCNT+1
K ^TMP($J,"RAE1")
;
CP ; get CP procedures
D:VPRCATG["CP" EN^VPRDMC(DFN,BEG,END,MAX)
;
; V-CPT
;
Q
;
; ------------ Return data to middle tier ------------
;
XML(PROC) ; -- Return procedures as XML
N ATT,X,Y,I,J,NAMES
D ADD("<procedure>") S VPRTOTL=$G(VPRTOTL)+1
S ATT="" F S ATT=$O(PROC(ATT)) Q:ATT="" D D:$L(Y) ADD(Y)
. S NAMES=$S(ATT="document"!(ATT="opReport"):"id^localTitle^nationalTitle^vuid^status^Z",1:"code^name^Z")
. I $O(PROC(ATT,0)) D S Y="" Q ;multiples
.. D ADD("<"_ATT_"s>")
.. S I=0 F S I=$O(PROC(ATT,I)) Q:I<1 D
... S X=$G(PROC(ATT,I))
... S Y="<"_ATT_" "_$$LOOP ;_"/>" D ADD(Y)
... S X=$G(PROC(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(PROC(ATT)),Y="" Q:'$L(X)
. I X'["^" S Y="<"_ATT_" value='"_$$ESC^VPRD(X)_"' />" Q
. I $L(X)>1 S Y="<"_ATT_" "_$$LOOP_"/>"
D ADD("</procedure>")
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[HVPRDPROC 3014 printed Apr 09, 2024@21:47 Page 2
VPRDPROC ;SLC/MKB -- Procedure extract ;8/2/11 15:29
+1 ;;1.0;VIRTUAL PATIENT RECORD;**1,5**;Sep 01, 2011;Build 21
+2 ;;Per VHA Directive 2004-038, this routine should not be modified.
+3 ;
+4 ; External References DBIA#
+5 ; ------------------- -----
+6 ; RAO7PC1 2043
+7 ; SROESTV 3533
+8 ;
+9 ; ------------ Get procedure(s) from VistA ------------
+10 ;
EN(DFN,BEG,END,MAX,ID) ; -- find patient's procedures
+1 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 ;
+4 NEW VPRN,VPRCNT,VPRITM,VPRY,VPRCATG
+5 ;NwHIN default
SET VPRCATG=$GET(FILTER("category"),"SR;RA")
+6 ;
+7 ; get one procedure
+8 IF $GET(ID)
IF ID'[";"
Begin DoDot:1
+9 ;Surgery
IF ID'["-"
DO EN1^VPRDSR(ID,.VPRITM)
QUIT
+10 SET (BEG,END)=9999999.9999=+ID
DO EN1^RAO7PC1(DFN,BEG,END,"1P")
+11 ;Radiology
DO EN1^VPRDRA(ID,.VPRITM)
+12 KILL ^TMP($JOB,"RAE1")
End DoDot:1
if $DATA(VPRITM)
DO XML(.VPRITM)
QUIT
+13 ;CP/Medicine
IF $GET(ID)
IF ID[";"
DO EN^VPRDMC(DFN,,,,ID)
QUIT
+14 ;
SR ; get all surgeries
+1 IF VPRCATG'["SR"
GOTO RA
+2 ;to omit leading '+' with note titles
NEW SHOWADD
SET SHOWADD=1
+3 DO LIST^SROESTV(.VPRY,DFN,BEG,END,MAX,1)
+4 SET VPRN=0
FOR
SET VPRN=$ORDER(@VPRY@(VPRN))
if VPRN<1
QUIT
Begin DoDot:1
+5 KILL VPRITM
DO ONE^VPRDSR(VPRN,.VPRITM)
if '$DATA(VPRITM)
QUIT
+6 ;Q:$G(VPRITM("status"))'?1"COMP".E
+7 DO XML(.VPRITM)
End DoDot:1
+8 KILL @VPRY
+9 ;
RA ; get all radiology exams
+1 IF VPRCATG'["RA"
GOTO CP
+2 KILL ^TMP($JOB,"RAE1")
DO EN1^RAO7PC1(DFN,BEG,END,MAX)
+3 SET VPRCNT=+$GET(VPRTOTL)
SET VPRN=""
+4 ;I $P($P($G(^(VPRN)),U,6),"~",2)?1"COMP".E
FOR
SET VPRN=$ORDER(^TMP($JOB,"RAE1",DFN,VPRN))
if VPRN=""
QUIT
Begin DoDot:1
+5 KILL VPRITM
DO EN1^VPRDRA(VPRN,.VPRITM)
if '$DATA(VPRITM)
QUIT
+6 DO XML(.VPRITM)
SET VPRCNT=VPRCNT+1
End DoDot:1
if VPRCNT'<MAX
QUIT
+7 KILL ^TMP($JOB,"RAE1")
+8 ;
CP ; get CP procedures
+1 if VPRCATG["CP"
DO EN^VPRDMC(DFN,BEG,END,MAX)
+2 ;
+3 ; V-CPT
+4 ;
+5 QUIT
+6 ;
+7 ; ------------ Return data to middle tier ------------
+8 ;
XML(PROC) ; -- Return procedures as XML
+1 NEW ATT,X,Y,I,J,NAMES
+2 DO ADD("<procedure>")
SET VPRTOTL=$GET(VPRTOTL)+1
+3 SET ATT=""
FOR
SET ATT=$ORDER(PROC(ATT))
if ATT=""
QUIT
Begin DoDot:1
+4 SET NAMES=$SELECT(ATT="document"!(ATT="opReport"):"id^localTitle^nationalTitle^vuid^status^Z",1:"code^name^Z")
+5 ;multiples
IF $ORDER(PROC(ATT,0))
Begin DoDot:2
+6 DO ADD("<"_ATT_"s>")
+7 SET I=0
FOR
SET I=$ORDER(PROC(ATT,I))
if I<1
QUIT
Begin DoDot:3
+8 SET X=$GET(PROC(ATT,I))
+9 ;_"/>" D ADD(Y)
SET Y="<"_ATT_" "_$$LOOP
+10 SET X=$GET(PROC(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(PROC(ATT))
SET Y=""
if '$LENGTH(X)
QUIT
+17 IF X'["^"
SET Y="<"_ATT_" value='"_$$ESC^VPRD(X)_"' />"
QUIT
+18 IF $LENGTH(X)>1
SET Y="<"_ATT_" "_$$LOOP_"/>"
End DoDot:1
if $LENGTH(Y)
DO ADD(Y)
+19 DO ADD("</procedure>")
+20 QUIT
+21 ;
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
