VPRDRA ;SLC/MKB -- Radiology extract ;8/2/11 15:29
;;1.0;VIRTUAL PATIENT RECORD;**1,5,30**;Sep 01, 2011;Build 9
;;Per VHA Directive 2004-038, this routine should not be modified.
;
; External References DBIA#
; ------------------- -----
; ^RADPT 2480
; ^RARPT 5605
; ^OR(100 5771
; ^SC( 10040
; ^VA(200 10060
; DIQ 2056
; ICPTCOD 1995
; ORX8 2467
; RAO7PC1 2043,2265
; RAO7PC3 2877
;
; ------------ Get exam(s) from VistA ------------
;
EN(DFN,BEG,END,MAX,ID) ; -- find patient's radiology exams
N VPRITM,VPRXID
S DFN=+$G(DFN) Q:DFN<1
S BEG=$G(BEG,1410101),END=$G(END,4141015),MAX=$G(MAX,9999)_"P"
K ^TMP($J,"RAE1") D EN1^RAO7PC1(DFN,BEG,END,MAX)
;
; get exam(s) by single case or RA order#
I $G(ID) D G ENQ
. I ID["-" D EN1(ID,.VPRITM),XML(.VPRITM) Q
. N IDT,CN S IDT=+$O(^RADPT("AO",ID,DFN,0)) Q:'IDT
. S CN=0 F S CN=$O(^RADPT("AO",ID,DFN,IDT,CN)) Q:CN<1 D
.. K VPRITM D EN1(IDT_"-"_CN,.VPRITM) Q:'$D(VPRITM)
.. D XML(.VPRITM)
;
; get all exams
S VPRXID="" F S VPRXID=$O(^TMP($J,"RAE1",DFN,VPRXID)) Q:VPRXID="" D
. K VPRITM D EN1(VPRXID,.VPRITM) Q:'$D(VPRITM)
. D XML(.VPRITM)
ENQ ; end
K ^TMP($J,"RAE1"),^TMP("VPRTEXT",$J)
Q
;
EN1(ID,EXAM) ; -- return an exam in EXAM("attribute")=value
; Expects ^TMP($J,"RAE1",DFN,ID) from EN1^RAO7PC1
N X0,SET,PROC,DATE,LOC,X,Y,IENS
K EXAM,^TMP("VPRTEXT",$J)
S X0=$G(^TMP($J,"RAE1",DFN,ID)),SET=$G(^(ID,"CPRS")),PROC=$P(X0,U)
S EXAM("id")=ID,EXAM("name")=PROC,EXAM("case")=$P(X0,U,2)
S DATE=9999999.9999-+ID,EXAM("dateTime")=DATE
I $P(X0,U,5) D ;report exists
. S X=$P(X0,U,3) Q:X="No Report"!(X="Deleted")!(X["Draft") ;Rpt sts
. N NM S NM=$S(+SET=2:$P(SET,U,2),1:PROC) ;2 = shared report
. S EXAM("document",1)=ID_U_NM_"^RADIOLOGY REPORT^4695068^"_X
. ; id^localTitle^nationalTitle^vuid^status
. S:$G(VPRTEXT) EXAM("document",1,"content")=$$TEXT(DFN,ID)
S:$L($P(X0,U,6)) EXAM("status")=$P($P(X0,U,6),"~",2) ;Exam sts
S X=$P(X0,U,7),LOC="" I $L(X) D
. S LOC=+$O(^SC("B",X,0)),EXAM("location")=LOC_U_X
S EXAM("facility")=$$FAC^VPRD(LOC)
I $L($P(X0,U,8)) S X=$TR($P(X0,U,8),"~","^"),EXAM("imagingType")=X
S IENS=$P(ID,"-",2)_","_+ID_","_DFN_","
S X=$P(X0,U,10) I X D
. S EXAM("type")=$$CPT(X)
. I $D(^TMP($J,"RAE1",DFN,ID,"CMOD")) M EXAM("modifier")=^("CMOD")
I $P(X0,U,11) D
. S EXAM("order")=+$P(X0,U,11)_U_$S($L(SET):$P(SET,U,2),1:PROC)
. S EXAM("radOrderID")=$G(^OR(100,+$P(X0,U,11),4))
. S EXAM("urgency")=$$VALUE^ORX8(+$P(X0,U,11),"URGENCY",1,"E")
S EXAM("hasImages")=$S($P(X0,U,12)="Y":1,1:0)
I $P(X0,U,4)="Y" S EXAM("interpretation")="ABNORMAL" ;!($P(X0,U,9)="Y")
S EXAM("encounter")=$$GET1^DIQ(70.03,IENS,27,"I")
S ID=DFN_U_$TR(ID,"-","^") D EN3^RAO7PC1(ID) D ;get additional values
. S X=+$G(^TMP($J,"RAE2",DFN,+$P(ID,U,3),PROC,"P"))
. I X S EXAM("provider")=X_U_$P($G(^VA(200,X,0)),U)_U_$$PROVSPC^VPRD(X)
S EXAM("category")="RA"
Q
;
CPT(IEN) ; -- return code^description for CPT code, or "^" if error
N X0,VPRX,N,I,X,Y S IEN=+$G(IEN)
S X0=$$CPT^ICPTCOD(IEN) I X0<0 Q "^"
S Y=$P(X0,U,2,3) ;CPT Code^Short Name
S N=$$CPTD^ICPTCOD($P(Y,U),"VPRX") ;CPT Description
I N>0,$L($G(VPRX(1))) D
. S X=$G(VPRX(1)),I=1
. F S I=$O(VPRX(I)) Q:I<1 Q:VPRX(I)=" " S X=X_" "_VPRX(I)
. S $P(Y,U,2)=X
Q Y
;
TEXT(PAT,ID) ; -- Get report text, return temp array name
S PAT=+$G(PAT),ID=$G(ID) I PAT<1!(ID<1) Q ""
N DFN,EXAM,CASE,PROC,I,X,Y
S EXAM=PAT_U_$TR(ID,"-","^") D EN3^RAO7PC3(EXAM)
S Y=$NA(^TMP("VPRTEXT",$J,ID)) K @Y
S CASE=$O(^TMP($J,"RAE3",PAT,0)),PROC=$O(^(CASE,""))
S I=0 F S I=$O(^TMP($J,"RAE3",PAT,CASE,PROC,I)) Q:I<1 S X=^(I),@Y@(I)=X
K ^TMP($J,"RAE3",PAT)
Q Y
;
; ------------ Get report(s) [via VPRDTIU] ------------
;
RPTS(DFN,BEG,END,MAX) ; -- find patient's radiology reports
N VPRITM,VPRXID,STS,PSET
S DFN=+$G(DFN) Q:DFN<1
S BEG=$G(BEG,1410101),END=$G(END,4141015),MAX=$G(MAX,9999)_"P"
K ^TMP($J,"RAE1") D EN1^RAO7PC1(DFN,BEG,END,MAX)
S VPRXID="" F S VPRXID=$O(^TMP($J,"RAE1",DFN,VPRXID)) Q:VPRXID="" D
. S STS=$P($G(^TMP($J,"RAE1",DFN,VPRXID)),U,3),PSET=$G(^(VPRXID,"CPRS"))
. Q:STS="No Report"!(STS="Deleted")!(STS["Draft")
. I +PSET=2,$G(PSET(+VPRXID,$P(PSET,U,2))) Q ;already have report
. K VPRITM D RPT1(DFN,VPRXID,.VPRITM) D:$D(VPRITM) XML^VPRDTIU(.VPRITM)
. I +PSET=2 S PSET(+VPRXID,$P(PSET,U,2))=$P(VPRXID,"-",2) ;parent
K ^TMP($J,"RAE1"),^TMP("VPRTEXT",$J)
Q
;
RPT1(DFN,ID,RPT) ; -- return report as a TIU document
S DFN=+$G(DFN),ID=$G(ID) Q:DFN<1 Q:ID<1
N EXAM,CASE,PROC,RAE3,RAE1,I,X,Y,IENS,LOC
K RPT,^TMP("VPRTEXT",$J)
S EXAM=DFN_U_$TR(ID,"-","^") D
. N DFN D EN3^RAO7PC3(EXAM) ;report
. D EN3^RAO7PC1(EXAM) ;add'l values
S CASE=$O(^TMP($J,"RAE3",DFN,0)),PROC=$O(^(CASE,"")),RAE3=$G(^(PROC))
S RAE1=$G(^TMP($J,"RAE1",DFN,ID))
I $G(VPRTEXT) D
. S Y=$NA(^TMP("VPRTEXT",$J,ID))
. S I=0 F S I=$O(^TMP($J,"RAE3",DFN,CASE,PROC,I)) Q:I<1 S X=^(I),@Y@(I)=X
. S RPT("content")=Y
S RPT("id")=ID,RPT("status")=$P(RAE3,U)
S X=9999999.9999-(+ID),RPT("referenceDateTime")=X
S X=+$G(^TMP($J,"RAE2",DFN,CASE,PROC,"P"))
I X S RPT("clinician",1)=X_U_$P($G(^VA(200,X,0)),U)_"^A^^^"_$$PROVSPC^VPRD(X)
S X=$G(^TMP($J,"RAE2",DFN,CASE,PROC,"V")) I X D
. N Y S Y=$$GET1^DIQ(74,+$P(RAE1,U,5)_",",7,"I")
. S RPT("clinician",2)=+X_U_$P($G(^VA(200,+X,0)),U)_"^S^"_Y_U_$P(X,U,2)_U_$$PROVSPC^VPRD(+X)
I $D(^TMP($J,"RAE3",DFN,"PRINT_SET")) S PROC=$G(^("ORD")) ;use parent, if printset
S RPT("localTitle")=PROC,RPT("category")="RA"
S RPT("nationalTitle")="4695068^RADIOLOGY REPORT"
S RPT("nationalTitleSubject")="4693357^RADIOLOGY"
S RPT("nationalTitleType")="4696123^REPORT"
S X=$P(RAE1,U,7),LOC="" I $L(X) D
. S LOC=+$O(^SC("B",X,0)) ;,EXAM("location")=LOC_U_X
S RPT("facility")=$$FAC^VPRD(LOC)
S IENS=$P(ID,"-",2)_","_+ID_","_DFN_","
S RPT("encounter")=$$GET1^DIQ(70.03,IENS,27,"I")
S:$G(FILTER("loinc")) RPT("loinc")=$P(FILTER("loinc"),U)
K ^TMP($J,"RAE3",DFN),^TMP($J,"RAE2",DFN)
Q
;
; ------------ Return data to middle tier ------------
;
XML(EXAM) ; -- Return exams as XML
N ATT,X,Y,NAMES,I,J
D ADD("<radiology>") S VPRTOTL=$G(VPRTOTL)+1
S ATT="" F S ATT=$O(EXAM(ATT)) Q:ATT="" D D:$L(Y) ADD(Y)
. S NAMES=$S(ATT="document":"id^localTitle^nationalTitle^vuid^status",ATT="provider":"code^name^"_$$PROVTAGS^VPRD,1:"code^name")_"^Z"
. I $O(EXAM(ATT,0)) D S Y="" Q ;multiples
.. D ADD("<"_ATT_"s>")
.. S I=0 F S I=$O(EXAM(ATT,I)) Q:I<1 D
... S X=$G(EXAM(ATT,I))
... S Y="<"_ATT_" "_$$LOOP ;_"/>" D ADD(Y)
... S X=$G(EXAM(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(EXAM(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("</radiology>")
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[HVPRDRA 7563 printed Dec 13, 2024@02:45:04 Page 2
VPRDRA ;SLC/MKB -- Radiology extract ;8/2/11 15:29
+1 ;;1.0;VIRTUAL PATIENT RECORD;**1,5,30**;Sep 01, 2011;Build 9
+2 ;;Per VHA Directive 2004-038, this routine should not be modified.
+3 ;
+4 ; External References DBIA#
+5 ; ------------------- -----
+6 ; ^RADPT 2480
+7 ; ^RARPT 5605
+8 ; ^OR(100 5771
+9 ; ^SC( 10040
+10 ; ^VA(200 10060
+11 ; DIQ 2056
+12 ; ICPTCOD 1995
+13 ; ORX8 2467
+14 ; RAO7PC1 2043,2265
+15 ; RAO7PC3 2877
+16 ;
+17 ; ------------ Get exam(s) from VistA ------------
+18 ;
EN(DFN,BEG,END,MAX,ID) ; -- find patient's radiology exams
+1 NEW VPRITM,VPRXID
+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)_"P"
+4 KILL ^TMP($JOB,"RAE1")
DO EN1^RAO7PC1(DFN,BEG,END,MAX)
+5 ;
+6 ; get exam(s) by single case or RA order#
+7 IF $GET(ID)
Begin DoDot:1
+8 IF ID["-"
DO EN1(ID,.VPRITM)
DO XML(.VPRITM)
QUIT
+9 NEW IDT,CN
SET IDT=+$ORDER(^RADPT("AO",ID,DFN,0))
if 'IDT
QUIT
+10 SET CN=0
FOR
SET CN=$ORDER(^RADPT("AO",ID,DFN,IDT,CN))
if CN<1
QUIT
Begin DoDot:2
+11 KILL VPRITM
DO EN1(IDT_"-"_CN,.VPRITM)
if '$DATA(VPRITM)
QUIT
+12 DO XML(.VPRITM)
End DoDot:2
End DoDot:1
GOTO ENQ
+13 ;
+14 ; get all exams
+15 SET VPRXID=""
FOR
SET VPRXID=$ORDER(^TMP($JOB,"RAE1",DFN,VPRXID))
if VPRXID=""
QUIT
Begin DoDot:1
+16 KILL VPRITM
DO EN1(VPRXID,.VPRITM)
if '$DATA(VPRITM)
QUIT
+17 DO XML(.VPRITM)
End DoDot:1
ENQ ; end
+1 KILL ^TMP($JOB,"RAE1"),^TMP("VPRTEXT",$JOB)
+2 QUIT
+3 ;
EN1(ID,EXAM) ; -- return an exam in EXAM("attribute")=value
+1 ; Expects ^TMP($J,"RAE1",DFN,ID) from EN1^RAO7PC1
+2 NEW X0,SET,PROC,DATE,LOC,X,Y,IENS
+3 KILL EXAM,^TMP("VPRTEXT",$JOB)
+4 SET X0=$GET(^TMP($JOB,"RAE1",DFN,ID))
SET SET=$GET(^(ID,"CPRS"))
SET PROC=$PIECE(X0,U)
+5 SET EXAM("id")=ID
SET EXAM("name")=PROC
SET EXAM("case")=$PIECE(X0,U,2)
+6 SET DATE=9999999.9999-+ID
SET EXAM("dateTime")=DATE
+7 ;report exists
IF $PIECE(X0,U,5)
Begin DoDot:1
+8 ;Rpt sts
SET X=$PIECE(X0,U,3)
if X="No Report"!(X="Deleted")!(X["Draft")
QUIT
+9 ;2 = shared report
NEW NM
SET NM=$SELECT(+SET=2:$PIECE(SET,U,2),1:PROC)
+10 SET EXAM("document",1)=ID_U_NM_"^RADIOLOGY REPORT^4695068^"_X
+11 ; id^localTitle^nationalTitle^vuid^status
+12 if $GET(VPRTEXT)
SET EXAM("document",1,"content")=$$TEXT(DFN,ID)
End DoDot:1
+13 ;Exam sts
if $LENGTH($PIECE(X0,U,6))
SET EXAM("status")=$PIECE($PIECE(X0,U,6),"~",2)
+14 SET X=$PIECE(X0,U,7)
SET LOC=""
IF $LENGTH(X)
Begin DoDot:1
+15 SET LOC=+$ORDER(^SC("B",X,0))
SET EXAM("location")=LOC_U_X
End DoDot:1
+16 SET EXAM("facility")=$$FAC^VPRD(LOC)
+17 IF $LENGTH($PIECE(X0,U,8))
SET X=$TRANSLATE($PIECE(X0,U,8),"~","^")
SET EXAM("imagingType")=X
+18 SET IENS=$PIECE(ID,"-",2)_","_+ID_","_DFN_","
+19 SET X=$PIECE(X0,U,10)
IF X
Begin DoDot:1
+20 SET EXAM("type")=$$CPT(X)
+21 IF $DATA(^TMP($JOB,"RAE1",DFN,ID,"CMOD"))
MERGE EXAM("modifier")=^("CMOD")
End DoDot:1
+22 IF $PIECE(X0,U,11)
Begin DoDot:1
+23 SET EXAM("order")=+$PIECE(X0,U,11)_U_$SELECT($LENGTH(SET):$PIECE(SET,U,2),1:PROC)
+24 SET EXAM("radOrderID")=$GET(^OR(100,+$PIECE(X0,U,11),4))
+25 SET EXAM("urgency")=$$VALUE^ORX8(+$PIECE(X0,U,11),"URGENCY",1,"E")
End DoDot:1
+26 SET EXAM("hasImages")=$SELECT($PIECE(X0,U,12)="Y":1,1:0)
+27 ;!($P(X0,U,9)="Y")
IF $PIECE(X0,U,4)="Y"
SET EXAM("interpretation")="ABNORMAL"
+28 SET EXAM("encounter")=$$GET1^DIQ(70.03,IENS,27,"I")
+29 ;get additional values
SET ID=DFN_U_$TRANSLATE(ID,"-","^")
DO EN3^RAO7PC1(ID)
Begin DoDot:1
+30 SET X=+$GET(^TMP($JOB,"RAE2",DFN,+$PIECE(ID,U,3),PROC,"P"))
+31 IF X
SET EXAM("provider")=X_U_$PIECE($GET(^VA(200,X,0)),U)_U_$$PROVSPC^VPRD(X)
End DoDot:1
+32 SET EXAM("category")="RA"
+33 QUIT
+34 ;
CPT(IEN) ; -- return code^description for CPT code, or "^" if error
+1 NEW X0,VPRX,N,I,X,Y
SET IEN=+$GET(IEN)
+2 SET X0=$$CPT^ICPTCOD(IEN)
IF X0<0
QUIT "^"
+3 ;CPT Code^Short Name
SET Y=$PIECE(X0,U,2,3)
+4 ;CPT Description
SET N=$$CPTD^ICPTCOD($PIECE(Y,U),"VPRX")
+5 IF N>0
IF $LENGTH($GET(VPRX(1)))
Begin DoDot:1
+6 SET X=$GET(VPRX(1))
SET I=1
+7 FOR
SET I=$ORDER(VPRX(I))
if I<1
QUIT
if VPRX(I)=" "
QUIT
SET X=X_" "_VPRX(I)
+8 SET $PIECE(Y,U,2)=X
End DoDot:1
+9 QUIT Y
+10 ;
TEXT(PAT,ID) ; -- Get report text, return temp array name
+1 SET PAT=+$GET(PAT)
SET ID=$GET(ID)
IF PAT<1!(ID<1)
QUIT ""
+2 NEW DFN,EXAM,CASE,PROC,I,X,Y
+3 SET EXAM=PAT_U_$TRANSLATE(ID,"-","^")
DO EN3^RAO7PC3(EXAM)
+4 SET Y=$NAME(^TMP("VPRTEXT",$JOB,ID))
KILL @Y
+5 SET CASE=$ORDER(^TMP($JOB,"RAE3",PAT,0))
SET PROC=$ORDER(^(CASE,""))
+6 SET I=0
FOR
SET I=$ORDER(^TMP($JOB,"RAE3",PAT,CASE,PROC,I))
if I<1
QUIT
SET X=^(I)
SET @Y@(I)=X
+7 KILL ^TMP($JOB,"RAE3",PAT)
+8 QUIT Y
+9 ;
+10 ; ------------ Get report(s) [via VPRDTIU] ------------
+11 ;
RPTS(DFN,BEG,END,MAX) ; -- find patient's radiology reports
+1 NEW VPRITM,VPRXID,STS,PSET
+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)_"P"
+4 KILL ^TMP($JOB,"RAE1")
DO EN1^RAO7PC1(DFN,BEG,END,MAX)
+5 SET VPRXID=""
FOR
SET VPRXID=$ORDER(^TMP($JOB,"RAE1",DFN,VPRXID))
if VPRXID=""
QUIT
Begin DoDot:1
+6 SET STS=$PIECE($GET(^TMP($JOB,"RAE1",DFN,VPRXID)),U,3)
SET PSET=$GET(^(VPRXID,"CPRS"))
+7 if STS="No Report"!(STS="Deleted")!(STS["Draft")
QUIT
+8 ;already have report
IF +PSET=2
IF $GET(PSET(+VPRXID,$PIECE(PSET,U,2)))
QUIT
+9 KILL VPRITM
DO RPT1(DFN,VPRXID,.VPRITM)
if $DATA(VPRITM)
DO XML^VPRDTIU(.VPRITM)
+10 ;parent
IF +PSET=2
SET PSET(+VPRXID,$PIECE(PSET,U,2))=$PIECE(VPRXID,"-",2)
End DoDot:1
+11 KILL ^TMP($JOB,"RAE1"),^TMP("VPRTEXT",$JOB)
+12 QUIT
+13 ;
RPT1(DFN,ID,RPT) ; -- return report as a TIU document
+1 SET DFN=+$GET(DFN)
SET ID=$GET(ID)
if DFN<1
QUIT
if ID<1
QUIT
+2 NEW EXAM,CASE,PROC,RAE3,RAE1,I,X,Y,IENS,LOC
+3 KILL RPT,^TMP("VPRTEXT",$JOB)
+4 SET EXAM=DFN_U_$TRANSLATE(ID,"-","^")
Begin DoDot:1
+5 ;report
NEW DFN
DO EN3^RAO7PC3(EXAM)
+6 ;add'l values
DO EN3^RAO7PC1(EXAM)
End DoDot:1
+7 SET CASE=$ORDER(^TMP($JOB,"RAE3",DFN,0))
SET PROC=$ORDER(^(CASE,""))
SET RAE3=$GET(^(PROC))
+8 SET RAE1=$GET(^TMP($JOB,"RAE1",DFN,ID))
+9 IF $GET(VPRTEXT)
Begin DoDot:1
+10 SET Y=$NAME(^TMP("VPRTEXT",$JOB,ID))
+11 SET I=0
FOR
SET I=$ORDER(^TMP($JOB,"RAE3",DFN,CASE,PROC,I))
if I<1
QUIT
SET X=^(I)
SET @Y@(I)=X
+12 SET RPT("content")=Y
End DoDot:1
+13 SET RPT("id")=ID
SET RPT("status")=$PIECE(RAE3,U)
+14 SET X=9999999.9999-(+ID)
SET RPT("referenceDateTime")=X
+15 SET X=+$GET(^TMP($JOB,"RAE2",DFN,CASE,PROC,"P"))
+16 IF X
SET RPT("clinician",1)=X_U_$PIECE($GET(^VA(200,X,0)),U)_"^A^^^"_$$PROVSPC^VPRD(X)
+17 SET X=$GET(^TMP($JOB,"RAE2",DFN,CASE,PROC,"V"))
IF X
Begin DoDot:1
+18 NEW Y
SET Y=$$GET1^DIQ(74,+$PIECE(RAE1,U,5)_",",7,"I")
+19 SET RPT("clinician",2)=+X_U_$PIECE($GET(^VA(200,+X,0)),U)_"^S^"_Y_U_$PIECE(X,U,2)_U_$$PROVSPC^VPRD(+X)
End DoDot:1
+20 ;use parent, if printset
IF $DATA(^TMP($JOB,"RAE3",DFN,"PRINT_SET"))
SET PROC=$GET(^("ORD"))
+21 SET RPT("localTitle")=PROC
SET RPT("category")="RA"
+22 SET RPT("nationalTitle")="4695068^RADIOLOGY REPORT"
+23 SET RPT("nationalTitleSubject")="4693357^RADIOLOGY"
+24 SET RPT("nationalTitleType")="4696123^REPORT"
+25 SET X=$PIECE(RAE1,U,7)
SET LOC=""
IF $LENGTH(X)
Begin DoDot:1
+26 ;,EXAM("location")=LOC_U_X
SET LOC=+$ORDER(^SC("B",X,0))
End DoDot:1
+27 SET RPT("facility")=$$FAC^VPRD(LOC)
+28 SET IENS=$PIECE(ID,"-",2)_","_+ID_","_DFN_","
+29 SET RPT("encounter")=$$GET1^DIQ(70.03,IENS,27,"I")
+30 if $GET(FILTER("loinc"))
SET RPT("loinc")=$PIECE(FILTER("loinc"),U)
+31 KILL ^TMP($JOB,"RAE3",DFN),^TMP($JOB,"RAE2",DFN)
+32 QUIT
+33 ;
+34 ; ------------ Return data to middle tier ------------
+35 ;
XML(EXAM) ; -- Return exams as XML
+1 NEW ATT,X,Y,NAMES,I,J
+2 DO ADD("<radiology>")
SET VPRTOTL=$GET(VPRTOTL)+1
+3 SET ATT=""
FOR
SET ATT=$ORDER(EXAM(ATT))
if ATT=""
QUIT
Begin DoDot:1
+4 SET NAMES=$SELECT(ATT="document":"id^localTitle^nationalTitle^vuid^status",ATT="provider":"code^name^"_$$PROVTAGS^VPRD,1:"code^name")_"^Z"
+5 ;multiples
IF $ORDER(EXAM(ATT,0))
Begin DoDot:2
+6 DO ADD("<"_ATT_"s>")
+7 SET I=0
FOR
SET I=$ORDER(EXAM(ATT,I))
if I<1
QUIT
Begin DoDot:3
+8 SET X=$GET(EXAM(ATT,I))
+9 ;_"/>" D ADD(Y)
SET Y="<"_ATT_" "_$$LOOP
+10 SET X=$GET(EXAM(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(EXAM(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("</radiology>")
+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
