HMPDRA ;SLC/MKB,ASMR/RRB,BL - Radiology extract;Sep 20, 2016 17:43:20
;;2.0;ENTERPRISE HEALTH MANAGEMENT PLATFORM;**3**;Sep 01, 2011;Build 15
;Per VA Directive 6402, this routine should not be modified.
;
; External References DBIA#
; ------------------- -----
; ^RADPT 2480
; ^RARPT 8000005
; ^SC( 10040
; ^VA(200 10060
; DIQ 2056
; ICPTCOD 1995
; RAO7PC1 2043,2265
; RAO7PC3 2877
Q
; ------------ Get exam(s) from VistA ------------
;
EN(DFN,BEG,END,MAX,ID) ; -- find patient's radiology exams
N HMPITM,HMPXID
S DFN=+$G(DFN) Q:'(DFN>0) ;DE4496 19 August 2016
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)
I $G(ID) D EN1(ID,.HMPITM),XML(.HMPITM) G ENQ
;
; get all exams
S HMPXID="" F S HMPXID=$O(^TMP($J,"RAE1",DFN,HMPXID)) Q:HMPXID="" D
. K HMPITM D EN1(HMPXID,.HMPITM) Q:'$D(HMPITM)
. D XML(.HMPITM)
ENQ ; end
K ^TMP($J,"RAE1"),^TMP("HMPTEXT",$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("HMPTEXT",$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
. N NM S NM=$S(+SET=2:$P(SET,U,2),1:PROC) ;2 = shared report
. S EXAM("document",1)=ID_U_NM_"^^"_$P(X0,U,3) ;id^localTitle^^status
. S:$G(HMPTEXT) EXAM("document",1,"content")=$$TEXT(DFN,ID)
S:$L($P(X0,U,6)) EXAM("status")=$P($P(X0,U,6),"~",2)
S X=$P(X0,U,7),LOC="" I $L(X) D
. S LOC=+$O(^SC("B",X,0)),EXAM("location")=LOC_U_X ;ICR 10040 DE2818 ASF 11/18/15
S EXAM("facility")=$$FAC^HMPD(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) S EXAM("order")=+$P(X0,U,11)_U_$S($L(SET):$P(SET,U,2),1:PROC)
S EXAM("hasImages")=$S($P(X0,U,12)="Y":1,1:0)
I $P(X0,U,4)="Y"!($P(X0,U,9)="Y") S EXAM("interpretation")="ABNORMAL"
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) ;ICR10060 DE2818 ASF 11/18/15
S EXAM("category")="RA"
Q
;
CPT(IEN) ; -- return code^description for CPT code, or "^" if error
N X0,HMPX,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),"HMPX") ;CPT Description
I N>0,$L($G(HMPX(1))) D
. S X=$G(HMPX(1)),I=1
. F S I=$O(HMPX(I)) Q:I<1 Q:HMPX(I)=" " S X=X_" "_HMPX(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("HMPTEXT",$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 HMPDTIU] ------------
;
RPTS(DFN,BEG,END,MAX) ; -- find patient's radiology reports
N HMPITM,HMPXID,STS,PSET
S DFN=+$G(DFN) Q:'(DFN>0) ;DE4496 19 August 2016
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 HMPXID="" F S HMPXID=$O(^TMP($J,"RAE1",DFN,HMPXID)) Q:HMPXID="" D
. S STS=$P($G(^TMP($J,"RAE1",DFN,HMPXID)),U,3),PSET=$G(^(HMPXID,"CPRS"))
. Q:STS="No Report"!(STS="Deleted") ;!(STS["Draft") ??
. I +PSET=2,$G(PSET(+HMPXID,$P(PSET,U,2))) Q ;already have report
. K HMPITM D RPT1(DFN,HMPXID,.HMPITM) D:$D(HMPITM) XML^HMPDTIU(.HMPITM)
. I +PSET=2 S PSET(+HMPXID,$P(PSET,U,2))=$P(HMPXID,"-",2) ;parent
K ^TMP($J,"RAE1"),^TMP("HMPTEXT",$J)
Q
;
RPT1(DFN,ID,RPT) ; -- return report as a TIU document
S DFN=+$G(DFN),ID=$G(ID) Q:'(DFN>0) Q:ID<1 ;DE4496 19 August 2016
N EXAM,CASE,PROC,RAE3,RAE1,I,X,Y,IENS,LOC
K RPT,^TMP("HMPTEXT",$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(HMPTEXT) D
. S Y=$NA(^TMP("HMPTEXT",$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" ;ICR10060 DE2818 ASF 11/18/15
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) ;ICR10060 DE2818 ASF 11/18/15
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 ICR 10040 DE2818 ASF 11/18/15
S RPT("facility")=$$FAC^HMPD(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 HMPTOTL=$G(HMPTOTL)+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^status^Z",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^HMPD(@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^HMPD(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^HMPD($P(X,U,P))_"' "
Q STR
;
ADD(X) ; -- Add a line @HMP@(n)=X
S HMPI=$G(HMPI)+1
S @HMP@(HMPI)=X
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HHMPDRA 7159 printed Oct 16, 2024@17:54:26 Page 2
HMPDRA ;SLC/MKB,ASMR/RRB,BL - Radiology extract;Sep 20, 2016 17:43:20
+1 ;;2.0;ENTERPRISE HEALTH MANAGEMENT PLATFORM;**3**;Sep 01, 2011;Build 15
+2 ;Per VA Directive 6402, this routine should not be modified.
+3 ;
+4 ; External References DBIA#
+5 ; ------------------- -----
+6 ; ^RADPT 2480
+7 ; ^RARPT 8000005
+8 ; ^SC( 10040
+9 ; ^VA(200 10060
+10 ; DIQ 2056
+11 ; ICPTCOD 1995
+12 ; RAO7PC1 2043,2265
+13 ; RAO7PC3 2877
+14 QUIT
+15 ; ------------ Get exam(s) from VistA ------------
+16 ;
EN(DFN,BEG,END,MAX,ID) ; -- find patient's radiology exams
+1 NEW HMPITM,HMPXID
+2 ;DE4496 19 August 2016
SET DFN=+$GET(DFN)
if '(DFN>0)
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)
+7 IF $GET(ID)
DO EN1(ID,.HMPITM)
DO XML(.HMPITM)
GOTO ENQ
+8 ;
+9 ; get all exams
+10 SET HMPXID=""
FOR
SET HMPXID=$ORDER(^TMP($JOB,"RAE1",DFN,HMPXID))
if HMPXID=""
QUIT
Begin DoDot:1
+11 KILL HMPITM
DO EN1(HMPXID,.HMPITM)
if '$DATA(HMPITM)
QUIT
+12 DO XML(.HMPITM)
End DoDot:1
ENQ ; end
+1 KILL ^TMP($JOB,"RAE1"),^TMP("HMPTEXT",$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("HMPTEXT",$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 ;2 = shared report
NEW NM
SET NM=$SELECT(+SET=2:$PIECE(SET,U,2),1:PROC)
+9 ;id^localTitle^^status
SET EXAM("document",1)=ID_U_NM_"^^"_$PIECE(X0,U,3)
+10 if $GET(HMPTEXT)
SET EXAM("document",1,"content")=$$TEXT(DFN,ID)
End DoDot:1
+11 if $LENGTH($PIECE(X0,U,6))
SET EXAM("status")=$PIECE($PIECE(X0,U,6),"~",2)
+12 SET X=$PIECE(X0,U,7)
SET LOC=""
IF $LENGTH(X)
Begin DoDot:1
+13 ;ICR 10040 DE2818 ASF 11/18/15
SET LOC=+$ORDER(^SC("B",X,0))
SET EXAM("location")=LOC_U_X
End DoDot:1
+14 SET EXAM("facility")=$$FAC^HMPD(LOC)
+15 IF $LENGTH($PIECE(X0,U,8))
SET X=$TRANSLATE($PIECE(X0,U,8),"~","^")
SET EXAM("imagingType")=X
+16 SET IENS=$PIECE(ID,"-",2)_","_+ID_","_DFN_","
+17 SET X=$PIECE(X0,U,10)
IF X
Begin DoDot:1
+18 SET EXAM("type")=$$CPT(X)
+19 IF $DATA(^TMP($JOB,"RAE1",DFN,ID,"CMOD"))
MERGE EXAM("modifier")=^("CMOD")
End DoDot:1
+20 IF $PIECE(X0,U,11)
SET EXAM("order")=+$PIECE(X0,U,11)_U_$SELECT($LENGTH(SET):$PIECE(SET,U,2),1:PROC)
+21 SET EXAM("hasImages")=$SELECT($PIECE(X0,U,12)="Y":1,1:0)
+22 IF $PIECE(X0,U,4)="Y"!($PIECE(X0,U,9)="Y")
SET EXAM("interpretation")="ABNORMAL"
+23 SET EXAM("encounter")=$$GET1^DIQ(70.03,IENS,27,"I")
+24 ;get additional values
SET ID=DFN_U_$TRANSLATE(ID,"-","^")
DO EN3^RAO7PC1(ID)
Begin DoDot:1
+25 SET X=+$GET(^TMP($JOB,"RAE2",DFN,+$PIECE(ID,U,3),PROC,"P"))
+26 ;ICR10060 DE2818 ASF 11/18/15
IF X
SET EXAM("provider")=X_U_$PIECE($GET(^VA(200,X,0)),U)
End DoDot:1
+27 SET EXAM("category")="RA"
+28 QUIT
+29 ;
CPT(IEN) ; -- return code^description for CPT code, or "^" if error
+1 NEW X0,HMPX,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),"HMPX")
+5 IF N>0
IF $LENGTH($GET(HMPX(1)))
Begin DoDot:1
+6 SET X=$GET(HMPX(1))
SET I=1
+7 FOR
SET I=$ORDER(HMPX(I))
if I<1
QUIT
if HMPX(I)=" "
QUIT
SET X=X_" "_HMPX(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("HMPTEXT",$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 HMPDTIU] ------------
+11 ;
RPTS(DFN,BEG,END,MAX) ; -- find patient's radiology reports
+1 NEW HMPITM,HMPXID,STS,PSET
+2 ;DE4496 19 August 2016
SET DFN=+$GET(DFN)
if '(DFN>0)
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 HMPXID=""
FOR
SET HMPXID=$ORDER(^TMP($JOB,"RAE1",DFN,HMPXID))
if HMPXID=""
QUIT
Begin DoDot:1
+6 SET STS=$PIECE($GET(^TMP($JOB,"RAE1",DFN,HMPXID)),U,3)
SET PSET=$GET(^(HMPXID,"CPRS"))
+7 ;!(STS["Draft") ??
if STS="No Report"!(STS="Deleted")
QUIT
+8 ;already have report
IF +PSET=2
IF $GET(PSET(+HMPXID,$PIECE(PSET,U,2)))
QUIT
+9 KILL HMPITM
DO RPT1(DFN,HMPXID,.HMPITM)
if $DATA(HMPITM)
DO XML^HMPDTIU(.HMPITM)
+10 ;parent
IF +PSET=2
SET PSET(+HMPXID,$PIECE(PSET,U,2))=$PIECE(HMPXID,"-",2)
End DoDot:1
+11 KILL ^TMP($JOB,"RAE1"),^TMP("HMPTEXT",$JOB)
+12 QUIT
+13 ;
RPT1(DFN,ID,RPT) ; -- return report as a TIU document
+1 ;DE4496 19 August 2016
SET DFN=+$GET(DFN)
SET ID=$GET(ID)
if '(DFN>0)
QUIT
if ID<1
QUIT
+2 NEW EXAM,CASE,PROC,RAE3,RAE1,I,X,Y,IENS,LOC
+3 KILL RPT,^TMP("HMPTEXT",$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(HMPTEXT)
Begin DoDot:1
+10 SET Y=$NAME(^TMP("HMPTEXT",$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 ;ICR10060 DE2818 ASF 11/18/15
IF X
SET RPT("clinician",1)=X_U_$PIECE($GET(^VA(200,X,0)),U)_"^A"
+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 ;ICR10060 DE2818 ASF 11/18/15
SET RPT("clinician",2)=+X_U_$PIECE($GET(^VA(200,+X,0)),U)_"^S^"_Y_U_$PIECE(X,U,2)
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 ICR 10040 DE2818 ASF 11/18/15
SET LOC=+$ORDER(^SC("B",X,0))
End DoDot:1
+27 SET RPT("facility")=$$FAC^HMPD(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 HMPTOTL=$GET(HMPTOTL)+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^status^Z",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^HMPD(@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^HMPD(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^HMPD($PIECE(X,U,P))_"' "
+3 QUIT STR
+4 ;
ADD(X) ; -- Add a line @HMP@(n)=X
+1 SET HMPI=$GET(HMPI)+1
+2 SET @HMP@(HMPI)=X
+3 QUIT
