Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: VPRDRA

VPRDRA.m

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