- 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 Feb 19, 2025@00:11:31 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