- 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 Feb 18, 2025@23:36:55 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:"")