MAGVRS81 ;WOIFO/MLH - RPC calls for DICOM file processing ; 12 Apr 2010 5:45 PM
;;3.0;IMAGING;**118**;Mar 19, 2002;Build 4525;May 01, 2013
;; Per VHA Directive 2004-038, this routine should not be modified.
;; +---------------------------------------------------------------+
;; | Property of the US Government. |
;; | No permission to copy or redistribute this software is given. |
;; | Use of unreleased versions of this software requires the user |
;; | to execute a written test agreement with the VistA Imaging |
;; | Development Office of the Department of Veterans Affairs, |
;; | telephone (301) 734-0100. |
;; | The Food and Drug Administration classifies this software as |
;; | a medical device. As such, it may not be changed in any way. |
;; | Modifications to this software may result in an adulterated |
;; | medical device under 21CFR820, the use of which is considered |
;; | to be a violation of US Federal Statutes. |
;; +---------------------------------------------------------------+
;;
Q
GETRPROC(OUT,ACCNUM) ; Call from GETPINFO^MAGVRS08 - get radiology procedure information
N RPTIX,RPTREC,EXAMDT,MAGD0,MAGD1,V,MAGD2,EXAMREC,OUTIX
N EXAMCODE,EXAMCODEREC,EXAMDESC,EXAMCODECPT,CPTREC,CPTCODE,CPTDESC,REFPHY,TERMGY
S RPTIX=$O(^RARPT("B",ACCNUM,"")) ; ICR 3323
I RPTIX="" S OUT(1)="-21"_SSEP_SSEP_"Accession number doesn't point to Radiology report" Q
S RPTREC=$G(^RARPT(RPTIX,0))
I RPTREC="" S OUT(1)="-22"_SSEP_SSEP_"Radiology report record not found" Q
S EXAMDT=$P(RPTREC,"^",3)
S MAGD0=$P(RPTREC,"^",2)
S MAGD1=9999999.9999-EXAMDT
S V=$P(RPTREC,"^",4)
I $L(MAGD0)*$L(MAGD1)*$L(V)=0 D Q
. S OUT(1)="-23"_SSEP_SSEP_"Radiology exam reference pointers not found" Q
. Q
S MAGD2=$O(^RADPT(MAGD0,"DT",MAGD1,"P","B",V,"")) ; ICR 65
I MAGD2="" S OUT(1)="-24"_SSEP_SSEP_"Radiology exam record pointer not found" Q
S EXAMREC=$G(^RADPT(MAGD0,"DT",MAGD1,"P",MAGD2,0))
I EXAMREC="" S OUT(1)="-25"_SSEP_SSEP_"Radiology exam record not found" Q
;
; EXAM FOUND - populate attributes to return
S EXAMCODE=$P(EXAMREC,"^",2),TERMGY="LOCAL"
D:EXAMCODE
. S EXAMCODEREC=$G(^RAMIS(71,EXAMCODE,0))
. S EXAMDESC=$P(EXAMCODEREC,"^",1)
. S EXAMCODECPT=$P(EXAMCODEREC,"^",9)
. D:EXAMCODECPT'=""
. . S CPTREC=$$CPT^ICPTCOD(EXAMCODECPT,EXAMDT) ; ICR 1995
. . S CPTCODE=$P(CPTREC,"^",2)
. . S CPTDESC=$P(CPTREC,"^",3)
. . D:$L(CPTCODE)*$L(CPTDESC)
. . . S EXAMCODE=CPTCODE
. . . S EXAMDESC=CPTDESC
. . . S TERMGY=$P(CPTREC,"^",5)
. . . S TERMGY=$S(TERMGY="C":"CPT",TERMGY="H":"HCPCS",TERMGY="L":"LOCAL",1:"")
. . . Q
. . Q
. Q
S REFPHY=$$GET1^DIQ(200,(+$P(EXAMREC,"^",14))_",",.01)
S OUTIX=0
D:$G(EXAMDESC)'="" POP(.OUT,"DESCRIPTION",EXAMDESC)
D:$G(EXAMDT)'="" POP(.OUT,"DATE/TIME",$$CVTDT(EXAMDT))
D:$G(EXAMCODE)'="" POP(.OUT,"PROCEDURE CODE",EXAMCODE)
D:$G(TERMGY)'="" POP(.OUT,"TERMINOLOGY",TERMGY)
D POP(.OUT,"CODING AUTHORITY","USDVA")
D:$G(REFPHY)'="" POP(.OUT,"REFERRING PHYSICIAN",REFPHY)
Q
GETRRPT(OUT,ACCNUM) ; Call from GETPINFO^MAGVRS08 - get a radiology report
N RPTIX,RPTIEN,TEXT,RET,ERR,TXTIX,OSEP,ISEP,SSEP
S OSEP=$$OUTSEP^MAGVRS41,ISEP=$$INPUTSEP^MAGVRS41,SSEP=$$STATSEP^MAGVRS41
I ACCNUM="" S OUT(1)="-51"_SSEP_SSEP_"No accession number provided" Q
; look up reports for this accession number - ICR 2479
K ^TMP("DILIST",$J)
D LIST^DIC(74,,"6I;7I",,,,ACCNUM,"B")
; did Lister encounter an exception?
I $D(^TMP("DIERR",$J)) D Q ; yes, exception encountered; report and terminate
. S OUT(1)="-53"_SSEP_SSEP_$G(^TMP("DIERR",$J,1,"TEXT",1))
. Q
I '$D(^TMP("DILIST",$J,1)) D Q ; no, but no report on file; bail
. S OUT(1)="-52"_SSEP_SSEP_"No report on file for this exam"
. Q
; no exception encountered, report results
S RPTIX=0
F S RPTIX=$O(^TMP("DILIST",$J,2,RPTIX)) Q:'RPTIX D
. S RPTIEN=^TMP("DILIST",$J,2,RPTIX) Q:'RPTIEN
. S RET=$$GET1^DIQ(74,RPTIEN_",",200,,"TEXT") Q:'$D(TEXT) ; no report text, plow on
. D POP(.OUT,"REPORT INDEX",RPTIEN)
. D POP(.OUT,"DATE REPORT ENTERED",$$CVTDT($G(^TMP("DILIST",$J,"ID",RPTIX,6))))
. D POP(.OUT,"VERIFIED DATE",$$CVTDT($G(^TMP("DILIST",$J,"ID",RPTIX,7))))
. D POP(.OUT,"REPORT TEXT",.TEXT)
. Q
K ^TMP("DILIST",$J),^TMP("DIERR",$J)
Q
;
POP(ARY,NAME,VALUE) ; populate an array with a name value pair
N IX
S:$D(VALUE)#10 ARY($O(ARY(" "),-1)+1)=NAME_OSEP_VALUE_SSEP
S IX=0
F S IX=$O(VALUE(IX)) Q:'IX S ARY($O(ARY(" "),-1)+1)=NAME_OSEP_VALUE(IX)_SSEP
Q
CVTDT(FMDT) ; convert from FM to ISO date
Q $S(FMDT:(17000000+$P(FMDT,".",1))_"."_$P($J(FMDT#1,0,6),".",2),1:"")
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HMAGVRS81 4712 printed Dec 13, 2024@02:10:27 Page 2
MAGVRS81 ;WOIFO/MLH - RPC calls for DICOM file processing ; 12 Apr 2010 5:45 PM
+1 ;;3.0;IMAGING;**118**;Mar 19, 2002;Build 4525;May 01, 2013
+2 ;; Per VHA Directive 2004-038, this routine should not be modified.
+3 ;; +---------------------------------------------------------------+
+4 ;; | Property of the US Government. |
+5 ;; | No permission to copy or redistribute this software is given. |
+6 ;; | Use of unreleased versions of this software requires the user |
+7 ;; | to execute a written test agreement with the VistA Imaging |
+8 ;; | Development Office of the Department of Veterans Affairs, |
+9 ;; | telephone (301) 734-0100. |
+10 ;; | The Food and Drug Administration classifies this software as |
+11 ;; | a medical device. As such, it may not be changed in any way. |
+12 ;; | Modifications to this software may result in an adulterated |
+13 ;; | medical device under 21CFR820, the use of which is considered |
+14 ;; | to be a violation of US Federal Statutes. |
+15 ;; +---------------------------------------------------------------+
+16 ;;
+17 QUIT
GETRPROC(OUT,ACCNUM) ; Call from GETPINFO^MAGVRS08 - get radiology procedure information
+1 NEW RPTIX,RPTREC,EXAMDT,MAGD0,MAGD1,V,MAGD2,EXAMREC,OUTIX
+2 NEW EXAMCODE,EXAMCODEREC,EXAMDESC,EXAMCODECPT,CPTREC,CPTCODE,CPTDESC,REFPHY,TERMGY
+3 ; ICR 3323
SET RPTIX=$ORDER(^RARPT("B",ACCNUM,""))
+4 IF RPTIX=""
SET OUT(1)="-21"_SSEP_SSEP_"Accession number doesn't point to Radiology report"
QUIT
+5 SET RPTREC=$GET(^RARPT(RPTIX,0))
+6 IF RPTREC=""
SET OUT(1)="-22"_SSEP_SSEP_"Radiology report record not found"
QUIT
+7 SET EXAMDT=$PIECE(RPTREC,"^",3)
+8 SET MAGD0=$PIECE(RPTREC,"^",2)
+9 SET MAGD1=9999999.9999-EXAMDT
+10 SET V=$PIECE(RPTREC,"^",4)
+11 IF $LENGTH(MAGD0)*$LENGTH(MAGD1)*$LENGTH(V)=0
Begin DoDot:1
+12 SET OUT(1)="-23"_SSEP_SSEP_"Radiology exam reference pointers not found"
QUIT
+13 QUIT
End DoDot:1
QUIT
+14 ; ICR 65
SET MAGD2=$ORDER(^RADPT(MAGD0,"DT",MAGD1,"P","B",V,""))
+15 IF MAGD2=""
SET OUT(1)="-24"_SSEP_SSEP_"Radiology exam record pointer not found"
QUIT
+16 SET EXAMREC=$GET(^RADPT(MAGD0,"DT",MAGD1,"P",MAGD2,0))
+17 IF EXAMREC=""
SET OUT(1)="-25"_SSEP_SSEP_"Radiology exam record not found"
QUIT
+18 ;
+19 ; EXAM FOUND - populate attributes to return
+20 SET EXAMCODE=$PIECE(EXAMREC,"^",2)
SET TERMGY="LOCAL"
+21 if EXAMCODE
Begin DoDot:1
+22 SET EXAMCODEREC=$GET(^RAMIS(71,EXAMCODE,0))
+23 SET EXAMDESC=$PIECE(EXAMCODEREC,"^",1)
+24 SET EXAMCODECPT=$PIECE(EXAMCODEREC,"^",9)
+25 if EXAMCODECPT'=""
Begin DoDot:2
+26 ; ICR 1995
SET CPTREC=$$CPT^ICPTCOD(EXAMCODECPT,EXAMDT)
+27 SET CPTCODE=$PIECE(CPTREC,"^",2)
+28 SET CPTDESC=$PIECE(CPTREC,"^",3)
+29 if $LENGTH(CPTCODE)*$LENGTH(CPTDESC)
Begin DoDot:3
+30 SET EXAMCODE=CPTCODE
+31 SET EXAMDESC=CPTDESC
+32 SET TERMGY=$PIECE(CPTREC,"^",5)
+33 SET TERMGY=$SELECT(TERMGY="C":"CPT",TERMGY="H":"HCPCS",TERMGY="L":"LOCAL",1:"")
+34 QUIT
End DoDot:3
+35 QUIT
End DoDot:2
+36 QUIT
End DoDot:1
+37 SET REFPHY=$$GET1^DIQ(200,(+$PIECE(EXAMREC,"^",14))_",",.01)
+38 SET OUTIX=0
+39 if $GET(EXAMDESC)'=""
DO POP(.OUT,"DESCRIPTION",EXAMDESC)
+40 if $GET(EXAMDT)'=""
DO POP(.OUT,"DATE/TIME",$$CVTDT(EXAMDT))
+41 if $GET(EXAMCODE)'=""
DO POP(.OUT,"PROCEDURE CODE",EXAMCODE)
+42 if $GET(TERMGY)'=""
DO POP(.OUT,"TERMINOLOGY",TERMGY)
+43 DO POP(.OUT,"CODING AUTHORITY","USDVA")
+44 if $GET(REFPHY)'=""
DO POP(.OUT,"REFERRING PHYSICIAN",REFPHY)
+45 QUIT
GETRRPT(OUT,ACCNUM) ; Call from GETPINFO^MAGVRS08 - get a radiology report
+1 NEW RPTIX,RPTIEN,TEXT,RET,ERR,TXTIX,OSEP,ISEP,SSEP
+2 SET OSEP=$$OUTSEP^MAGVRS41
SET ISEP=$$INPUTSEP^MAGVRS41
SET SSEP=$$STATSEP^MAGVRS41
+3 IF ACCNUM=""
SET OUT(1)="-51"_SSEP_SSEP_"No accession number provided"
QUIT
+4 ; look up reports for this accession number - ICR 2479
+5 KILL ^TMP("DILIST",$JOB)
+6 DO LIST^DIC(74,,"6I;7I",,,,ACCNUM,"B")
+7 ; did Lister encounter an exception?
+8 ; yes, exception encountered; report and terminate
IF $DATA(^TMP("DIERR",$JOB))
Begin DoDot:1
+9 SET OUT(1)="-53"_SSEP_SSEP_$GET(^TMP("DIERR",$JOB,1,"TEXT",1))
+10 QUIT
End DoDot:1
QUIT
+11 ; no, but no report on file; bail
IF '$DATA(^TMP("DILIST",$JOB,1))
Begin DoDot:1
+12 SET OUT(1)="-52"_SSEP_SSEP_"No report on file for this exam"
+13 QUIT
End DoDot:1
QUIT
+14 ; no exception encountered, report results
+15 SET RPTIX=0
+16 FOR
SET RPTIX=$ORDER(^TMP("DILIST",$JOB,2,RPTIX))
if 'RPTIX
QUIT
Begin DoDot:1
+17 SET RPTIEN=^TMP("DILIST",$JOB,2,RPTIX)
if 'RPTIEN
QUIT
+18 ; no report text, plow on
SET RET=$$GET1^DIQ(74,RPTIEN_",",200,,"TEXT")
if '$DATA(TEXT)
QUIT
+19 DO POP(.OUT,"REPORT INDEX",RPTIEN)
+20 DO POP(.OUT,"DATE REPORT ENTERED",$$CVTDT($GET(^TMP("DILIST",$JOB,"ID",RPTIX,6))))
+21 DO POP(.OUT,"VERIFIED DATE",$$CVTDT($GET(^TMP("DILIST",$JOB,"ID",RPTIX,7))))
+22 DO POP(.OUT,"REPORT TEXT",.TEXT)
+23 QUIT
End DoDot:1
+24 KILL ^TMP("DILIST",$JOB),^TMP("DIERR",$JOB)
+25 QUIT
+26 ;
POP(ARY,NAME,VALUE) ; populate an array with a name value pair
+1 NEW IX
+2 if $DATA(VALUE)#10
SET ARY($ORDER(ARY(" "),-1)+1)=NAME_OSEP_VALUE_SSEP
+3 SET IX=0
+4 FOR
SET IX=$ORDER(VALUE(IX))
if 'IX
QUIT
SET ARY($ORDER(ARY(" "),-1)+1)=NAME_OSEP_VALUE(IX)_SSEP
+5 QUIT
CVTDT(FMDT) ; convert from FM to ISO date
+1 QUIT $SELECT(FMDT:(17000000+$PIECE(FMDT,".",1))_"."_$PIECE($JUSTIFY(FMDT#1,0,6),".",2),1:"")
