MAGDSTD2 ; OITCLIN/DWM,WOIFO/PMK - rad exams w/o VI images; Jul 06, 2021@08:21:46
;;3.0;IMAGING;**231,306,375**;Mar 19, 2002;Build 3
;; Per VA Directive 6402, 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. |
;; +---------------------------------------------------------------+
;
; Supported IA #10026 reference ^DIR subroutine call
; Controlled Subscription IA #10035 for Fileman reads of ^DPT
; Controlled Subscription IA #1171 to read RAD/NUC MED REPORTS file (#74)
; Supported IA #1519 reference EN^XUTMDEVQ subroutine call
; Private IA #7111 reference ^RARTFLDS subroutine call
; Supported IA #10035 to read PATIENT file (#2)
; Supported IA #10103 reference $$FMTE^XLFDT function call
; Supported IA #10103 reference $$NOW^XLFDT function call
;
; Original: MAGWOVI by Dave Massey
;
DATES ; enter date range to search
N DIR,DTFR,DTTO,Y,X
;
N $ETRAP,$ESTACK S $ETRAP="D ERROR^MAGDSTA"
;
W !!!,"Search for Radiology Exams Lacking Images"
W !,"------------------------------------------"
D BEGDATE^MAGDSTA2
S DTFR=$G(^TMP("MAG",$J,"BATCH Q/R","BEGIN DATE"))
I DTFR="" G EXIT
D ENDDATE^MAGDSTA2
S DTTO=$G(^TMP("MAG",$J,"BATCH Q/R","END DATE"))
I DTTO="" G EXIT
;
QUE ; queue to run report
W !!,"Recommend report output of 132 columns",!!
;
N %ZIS,ZTDESC,ZTSAVE
S ZTDESC="Radiology Exams w/o VI Images"
S ZTSAVE("DTFR")=""
S ZTSAVE("DTTO")=""
D EN^XUTMDEVQ("EN^"_$T(+0),ZTDESC,.ZTSAVE,.%ZIS)
G EXIT
Q
;
EN ;entry point
N $ETRAP,$ESTACK S $ETRAP="D ERROR^MAGDSTA"
;
S X=132 X ^%ZOSF("RM") ; set right margin to 132
;
K ^TMP("MAG",$J)
;
D COUNTS(DTFR,DTTO)
;
; display results
I '$D(^TMP("MAG",$J)) W !!,"No data for display!",!! G EXIT
D DISPLAY
W !!,"RUN COMPLETED at ",$$FMTE^XLFDT($$NOW^XLFDT,1)
D CONTINUE^MAGDSTQ
;
EXIT ;
K ^TMP("MAG",$J)
Q
;
COUNTS(DTFR,DTTO) ; build list of exams w/o images
; ^TMP("MAG",$J,LOC,RPTDATE,ACNUMB)=PNAME_"^"_SSN_"^"_PROC
N RARPT,REVDATE,RPTDATE,XDTFR,XDTTO
;
S XDTFR=DTFR-.0001,XDTTO=DTTO+.9999
S XDTFR=9999999.9999-XDTFR ; reverse date & time
S XDTTO=9999999.9999-XDTTO ; reverse date & time
;
S REVDATE=XDTFR
;F S REVDATE=$O(^RARPT("AA",REVDATE),-1) Q:REVDATE="" Q:REVDATE<DTTO D - p375: report ignoring end date
F S REVDATE=$O(^RARPT("AA",REVDATE),-1) Q:REVDATE="" Q:REVDATE<XDTTO D
. S RPTDATE=9999999.9999-REVDATE ; get regular FM date/time from reverse date/time
. S RARPT=""
. F S RARPT=$O(^RARPT("AA",REVDATE,RARPT)) Q:RARPT="" D
. . D LOOKUP(RARPT)
. . Q
. Q
Q
;
LOOKUP(RARPT) ;
N ACNUMB,DFN,EXAMDATE,FOUND,LOC,RARPT0,OUT,PNAME,PROC,RARPT0,SSN
S RARPT0=$G(^RARPT(RARPT,0)) I RARPT0="" Q ; no zero-node
S ACNUMB=$P(RARPT0,"^",1) I ACNUMB="" Q ; null accession number
I $P(RARPT0,"^",5)="X" Q ; deleted report
S EXAMDATE=$P(RARPT0,"^",3) ; exam date/time
; -- patient demographics --
S DFN=$P(RARPT0,"^",2) I DFN="" Q ; null patient field
S PNAME=$$GET1^DIQ(2,DFN,.01,"E") Q:PNAME=""
S SSN=$$GET1^DIQ(2,DFN,.09,"E") Q:SSN=""
; -- check for #74 file 2005 node --
; if not present, check new sop database
S FOUND=$$LEGACY(RARPT)
I 'FOUND D
. S FOUND=$$NEWSOP(ACNUMB)
. Q
I 'FOUND D
. ; -- lookup report's procedure & imaging location --
. D PROLOC(.OUT,RARPT) S PROC=$P(OUT,"^",1),LOC=$P(OUT,"^",2)
. I PROC="" Q ; no report procedure
. I LOC="" Q ; no imaging location
. S ^TMP("MAG",$J,LOC,EXAMDATE,ACNUMB)=PNAME_"^"_SSN_"^"_PROC
. Q
Q
;
LEGACY(RARPT) ; check for "2005" node
N FOUND,J,MAGIEN
S (FOUND,J)=0
; -- loop #74 "2005" node to validate images --
F S J=$O(^RARPT(RARPT,"2005",J)) Q:'J D
. S MAGIEN=$G(^RARPT(RARPT,"2005",J,0)) Q:'MAGIEN
. S FOUND=FOUND+$$CHECKMAG(MAGIEN,RARPT)
. Q
Q FOUND
;
CHECKMAG(MAGIEN,RARPT) ;
; -- ensure #2005 entry exists --
I '$D(^MAG(2005,MAGIEN,0)) Q 0 ; no entry in file #2005
; -- check if image valid --
I '$$MAG(MAGIEN) Q 0 ; invalid patient or child entry
; -- check #2005 pointer back to #74 --
I '$$PARENT(MAGIEN,RARPT) Q 0 ; bad pointer
Q 1
;
MAG(MAGIEN) ; validate parent or child image
; called by ^MAGDSTD3 for consults
N CHECK,CHILDIEN,J
S CHECK=0
; -- parent #2005 entry --
I $D(^MAG(2005,MAGIEN,1)) D
. S J=0 F S J=$O(^MAG(2005,MAGIEN,1,J)) Q:'J Q:CHECK D
. . S CHILDIEN=$P(^MAG(2005,MAGIEN,1,J,0),"^",1)
. . Q:'$D(^MAG(2005,CHILDIEN,0))
. . S CHECK=$$IMAGE(CHILDIEN)
. . Q
. Q
E D ; -- child #2005 entry --
. S CHILDIEN=MAGIEN,CHECK=$$IMAGE(CHILDIEN)
. Q
Q CHECK
;
IMAGE(CHILDIEN) ; called from within 'MAG' subroutine
N MAG0,REF,OBJ,TYPE
S MAG0=$G(^MAG(2005,CHILDIEN,0)) Q:MAG0="" 0
; -- file reference and object type
S REF=$P(MAG0,"^",2),OBJ=$P(MAG0,"^",6)
Q:REF="" 0 Q:OBJ="" 0
S TYPE=$P(^MAG(2005.02,OBJ,0),"^",1)
; .dcm, .pdf, & .tga files
I TYPE="DICOM IMAGE" Q 1
I TYPE="ADOBE" Q 1 ; for consults
I TYPE="XRAY" Q 1 ; for old pre-DICOM TGA's
Q 0
;
PARENT(MAGIEN,RARPT) ; check #2005 pointer back to #74
N REPORT
I '$D(^MAG(2005,MAGIEN,"PACS")) Q 0
S REPORT=$P(^MAG(2005,MAGIEN,"PACS"),"^",2)
I REPORT'=RARPT Q 0
Q 1
;
NEWSOP(GMRCACN) ; lookup in new sop class database
; called by ^MAGDSTD3 for consults
N FIELD,FOUND,FNUM,IEN,IMAGES,J,OUT,OVERRIDE,STATUS
S FOUND=0
I $G(GMRCACN)="" Q FOUND
S OVERRIDE=1
I '$D(^MAGV(2005.62,"D",GMRCACN)) Q FOUND
S IEN=0 F S IEN=$O(^MAGV(2005.62,"D",GMRCACN,IEN)) Q:'IEN D
. ; RPC - MAGV GET STUDY
. D GETSTUDY^MAGVRS04(.OUT,,IEN,OVERRIDE) Q:'$D(OUT)
. S J=" " F S J=$O(OUT(J),-1) Q:'J Q:FOUND=1 D
. . S FIELD=$P(OUT(J),"|")
. . Q:FIELD'="NUMBER OF SOP INSTANCES"
. . S IMAGES=$P(OUT(J),"|",2)
. . S:IMAGES>0 FOUND=1
. . Q
. Q
Q FOUND
;
PROLOC(OUT,D0) ; return report's procedure & imaging location
N RACN,RAEXFLD,X,LOC,PROC
S OUT="^" I D0="" Q
S RAEXFLD="PROC" D ^RARTFLDS S PROC=X K X Q:PROC=""
S RAEXFLD="LOC" D ^RARTFLDS S LOC=X K X Q:LOC=""
S OUT=PROC_"^"_LOC
Q
;
DISPLAY ;
N ACNUMB,ANS,EXAMDATE,FDATE,LOC,NODE,PNAME,PROC,SSN,STOP,TDATE,X,Y
S STOP=0,Y=DTFR X ^DD("DD") S FDATE=Y,Y=DTTO X ^DD("DD") S TDATE=Y
S LOC="" F S LOC=$O(^TMP("MAG",$J,LOC)) Q:LOC="" D
. D HDR I STOP Q
. S EXAMDATE=0 F S EXAMDATE=$O(^TMP("MAG",$J,LOC,EXAMDATE)) Q:'EXAMDATE!(STOP=1) D
. . S ACNUMB="" F S ACNUMB=$O(^TMP("MAG",$J,LOC,EXAMDATE,ACNUMB)) Q:ACNUMB=""!(STOP=1) D
. . . S NODE=^TMP("MAG",$J,LOC,EXAMDATE,ACNUMB),Y=$P(EXAMDATE,".") X ^DD("DD")
. . . S PNAME=$P(NODE,"^",1),SSN=$P(NODE,"^",2),PROC=$P(NODE,"^",3)
. . . W !,ACNUMB,?20,$E(PNAME,1,30),?53,$E(SSN,6,9),?60,Y,?75,PROC
. . . I $E(IOST,1,2)="C-",$Y+5>IOSL D
. . . . R !!,"Press RETURN to continue or '^' to exit: ",ANS:DTIME E S ANS="^"
. . . . S STOP=$S(ANS="^":1,1:0)
. . . . W @IOF
. . . . Q
. . . Q
. . Q
. ; stop after each imaging location displayed
. I $E(IOST,1,2)="C-" D
. . R !!,"Press RETURN to continue or '^' to exit: ",ANS:DTIME E S ANS="^"
. . S STOP=$S(ANS="^":1,1:0)
. . Q
. ; new page after each imaging location displayed
. W @IOF
. Q
Q
;
HDR ; header
N LN,ANS,I
S LN="-" F I=1:1:131 S LN=LN_"-"
I $E(IOST,1,2)="C-",$Y+10>IOSL D
. R !!,"Press RETURN to continue or '^' to exit: ",ANS:DTIME E S ANS="^"
. S STOP=$S(ANS="^":1,1:0)
. W @IOF
. Q
I STOP Q
I $E(IOST,1,2)="C-",$Y>1 W @IOF
W !,?42,"Radiology Exams without Images in VistA Imaging"
W !,?93,"From "_FDATE_" to "_TDATE
W !!,"Imaging Location: "_LOC,!
W !,"Accession",?20,"Patient Name",?53,"Last4",?60,"Exam Date"
W ?75,"Procedure",!,LN
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HMAGDSTD2 8431 printed Sep 23, 2025@19:38:06 Page 2
MAGDSTD2 ; OITCLIN/DWM,WOIFO/PMK - rad exams w/o VI images; Jul 06, 2021@08:21:46
+1 ;;3.0;IMAGING;**231,306,375**;Mar 19, 2002;Build 3
+2 ;; Per VA Directive 6402, 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 ; Supported IA #10026 reference ^DIR subroutine call
+18 ; Controlled Subscription IA #10035 for Fileman reads of ^DPT
+19 ; Controlled Subscription IA #1171 to read RAD/NUC MED REPORTS file (#74)
+20 ; Supported IA #1519 reference EN^XUTMDEVQ subroutine call
+21 ; Private IA #7111 reference ^RARTFLDS subroutine call
+22 ; Supported IA #10035 to read PATIENT file (#2)
+23 ; Supported IA #10103 reference $$FMTE^XLFDT function call
+24 ; Supported IA #10103 reference $$NOW^XLFDT function call
+25 ;
+26 ; Original: MAGWOVI by Dave Massey
+27 ;
DATES ; enter date range to search
+1 NEW DIR,DTFR,DTTO,Y,X
+2 ;
+3 NEW $ETRAP,$ESTACK
SET $ETRAP="D ERROR^MAGDSTA"
+4 ;
+5 WRITE !!!,"Search for Radiology Exams Lacking Images"
+6 WRITE !,"------------------------------------------"
+7 DO BEGDATE^MAGDSTA2
+8 SET DTFR=$GET(^TMP("MAG",$JOB,"BATCH Q/R","BEGIN DATE"))
+9 IF DTFR=""
GOTO EXIT
+10 DO ENDDATE^MAGDSTA2
+11 SET DTTO=$GET(^TMP("MAG",$JOB,"BATCH Q/R","END DATE"))
+12 IF DTTO=""
GOTO EXIT
+13 ;
QUE ; queue to run report
+1 WRITE !!,"Recommend report output of 132 columns",!!
+2 ;
+3 NEW %ZIS,ZTDESC,ZTSAVE
+4 SET ZTDESC="Radiology Exams w/o VI Images"
+5 SET ZTSAVE("DTFR")=""
+6 SET ZTSAVE("DTTO")=""
+7 DO EN^XUTMDEVQ("EN^"_$TEXT(+0),ZTDESC,.ZTSAVE,.%ZIS)
+8 GOTO EXIT
+9 QUIT
+10 ;
EN ;entry point
+1 NEW $ETRAP,$ESTACK
SET $ETRAP="D ERROR^MAGDSTA"
+2 ;
+3 ; set right margin to 132
SET X=132
XECUTE ^%ZOSF("RM")
+4 ;
+5 KILL ^TMP("MAG",$JOB)
+6 ;
+7 DO COUNTS(DTFR,DTTO)
+8 ;
+9 ; display results
+10 IF '$DATA(^TMP("MAG",$JOB))
WRITE !!,"No data for display!",!!
GOTO EXIT
+11 DO DISPLAY
+12 WRITE !!,"RUN COMPLETED at ",$$FMTE^XLFDT($$NOW^XLFDT,1)
+13 DO CONTINUE^MAGDSTQ
+14 ;
EXIT ;
+1 KILL ^TMP("MAG",$JOB)
+2 QUIT
+3 ;
COUNTS(DTFR,DTTO) ; build list of exams w/o images
+1 ; ^TMP("MAG",$J,LOC,RPTDATE,ACNUMB)=PNAME_"^"_SSN_"^"_PROC
+2 NEW RARPT,REVDATE,RPTDATE,XDTFR,XDTTO
+3 ;
+4 SET XDTFR=DTFR-.0001
SET XDTTO=DTTO+.9999
+5 ; reverse date & time
SET XDTFR=9999999.9999-XDTFR
+6 ; reverse date & time
SET XDTTO=9999999.9999-XDTTO
+7 ;
+8 SET REVDATE=XDTFR
+9 ;F S REVDATE=$O(^RARPT("AA",REVDATE),-1) Q:REVDATE="" Q:REVDATE<DTTO D - p375: report ignoring end date
+10 FOR
SET REVDATE=$ORDER(^RARPT("AA",REVDATE),-1)
if REVDATE=""
QUIT
if REVDATE<XDTTO
QUIT
Begin DoDot:1
+11 ; get regular FM date/time from reverse date/time
SET RPTDATE=9999999.9999-REVDATE
+12 SET RARPT=""
+13 FOR
SET RARPT=$ORDER(^RARPT("AA",REVDATE,RARPT))
if RARPT=""
QUIT
Begin DoDot:2
+14 DO LOOKUP(RARPT)
+15 QUIT
End DoDot:2
+16 QUIT
End DoDot:1
+17 QUIT
+18 ;
LOOKUP(RARPT) ;
+1 NEW ACNUMB,DFN,EXAMDATE,FOUND,LOC,RARPT0,OUT,PNAME,PROC,RARPT0,SSN
+2 ; no zero-node
SET RARPT0=$GET(^RARPT(RARPT,0))
IF RARPT0=""
QUIT
+3 ; null accession number
SET ACNUMB=$PIECE(RARPT0,"^",1)
IF ACNUMB=""
QUIT
+4 ; deleted report
IF $PIECE(RARPT0,"^",5)="X"
QUIT
+5 ; exam date/time
SET EXAMDATE=$PIECE(RARPT0,"^",3)
+6 ; -- patient demographics --
+7 ; null patient field
SET DFN=$PIECE(RARPT0,"^",2)
IF DFN=""
QUIT
+8 SET PNAME=$$GET1^DIQ(2,DFN,.01,"E")
if PNAME=""
QUIT
+9 SET SSN=$$GET1^DIQ(2,DFN,.09,"E")
if SSN=""
QUIT
+10 ; -- check for #74 file 2005 node --
+11 ; if not present, check new sop database
+12 SET FOUND=$$LEGACY(RARPT)
+13 IF 'FOUND
Begin DoDot:1
+14 SET FOUND=$$NEWSOP(ACNUMB)
+15 QUIT
End DoDot:1
+16 IF 'FOUND
Begin DoDot:1
+17 ; -- lookup report's procedure & imaging location --
+18 DO PROLOC(.OUT,RARPT)
SET PROC=$PIECE(OUT,"^",1)
SET LOC=$PIECE(OUT,"^",2)
+19 ; no report procedure
IF PROC=""
QUIT
+20 ; no imaging location
IF LOC=""
QUIT
+21 SET ^TMP("MAG",$JOB,LOC,EXAMDATE,ACNUMB)=PNAME_"^"_SSN_"^"_PROC
+22 QUIT
End DoDot:1
+23 QUIT
+24 ;
LEGACY(RARPT) ; check for "2005" node
+1 NEW FOUND,J,MAGIEN
+2 SET (FOUND,J)=0
+3 ; -- loop #74 "2005" node to validate images --
+4 FOR
SET J=$ORDER(^RARPT(RARPT,"2005",J))
if 'J
QUIT
Begin DoDot:1
+5 SET MAGIEN=$GET(^RARPT(RARPT,"2005",J,0))
if 'MAGIEN
QUIT
+6 SET FOUND=FOUND+$$CHECKMAG(MAGIEN,RARPT)
+7 QUIT
End DoDot:1
+8 QUIT FOUND
+9 ;
CHECKMAG(MAGIEN,RARPT) ;
+1 ; -- ensure #2005 entry exists --
+2 ; no entry in file #2005
IF '$DATA(^MAG(2005,MAGIEN,0))
QUIT 0
+3 ; -- check if image valid --
+4 ; invalid patient or child entry
IF '$$MAG(MAGIEN)
QUIT 0
+5 ; -- check #2005 pointer back to #74 --
+6 ; bad pointer
IF '$$PARENT(MAGIEN,RARPT)
QUIT 0
+7 QUIT 1
+8 ;
MAG(MAGIEN) ; validate parent or child image
+1 ; called by ^MAGDSTD3 for consults
+2 NEW CHECK,CHILDIEN,J
+3 SET CHECK=0
+4 ; -- parent #2005 entry --
+5 IF $DATA(^MAG(2005,MAGIEN,1))
Begin DoDot:1
+6 SET J=0
FOR
SET J=$ORDER(^MAG(2005,MAGIEN,1,J))
if 'J
QUIT
if CHECK
QUIT
Begin DoDot:2
+7 SET CHILDIEN=$PIECE(^MAG(2005,MAGIEN,1,J,0),"^",1)
+8 if '$DATA(^MAG(2005,CHILDIEN,0))
QUIT
+9 SET CHECK=$$IMAGE(CHILDIEN)
+10 QUIT
End DoDot:2
+11 QUIT
End DoDot:1
+12 ; -- child #2005 entry --
IF '$TEST
Begin DoDot:1
+13 SET CHILDIEN=MAGIEN
SET CHECK=$$IMAGE(CHILDIEN)
+14 QUIT
End DoDot:1
+15 QUIT CHECK
+16 ;
IMAGE(CHILDIEN) ; called from within 'MAG' subroutine
+1 NEW MAG0,REF,OBJ,TYPE
+2 SET MAG0=$GET(^MAG(2005,CHILDIEN,0))
if MAG0=""
QUIT 0
+3 ; -- file reference and object type
+4 SET REF=$PIECE(MAG0,"^",2)
SET OBJ=$PIECE(MAG0,"^",6)
+5 if REF=""
QUIT 0
if OBJ=""
QUIT 0
+6 SET TYPE=$PIECE(^MAG(2005.02,OBJ,0),"^",1)
+7 ; .dcm, .pdf, & .tga files
+8 IF TYPE="DICOM IMAGE"
QUIT 1
+9 ; for consults
IF TYPE="ADOBE"
QUIT 1
+10 ; for old pre-DICOM TGA's
IF TYPE="XRAY"
QUIT 1
+11 QUIT 0
+12 ;
PARENT(MAGIEN,RARPT) ; check #2005 pointer back to #74
+1 NEW REPORT
+2 IF '$DATA(^MAG(2005,MAGIEN,"PACS"))
QUIT 0
+3 SET REPORT=$PIECE(^MAG(2005,MAGIEN,"PACS"),"^",2)
+4 IF REPORT'=RARPT
QUIT 0
+5 QUIT 1
+6 ;
NEWSOP(GMRCACN) ; lookup in new sop class database
+1 ; called by ^MAGDSTD3 for consults
+2 NEW FIELD,FOUND,FNUM,IEN,IMAGES,J,OUT,OVERRIDE,STATUS
+3 SET FOUND=0
+4 IF $GET(GMRCACN)=""
QUIT FOUND
+5 SET OVERRIDE=1
+6 IF '$DATA(^MAGV(2005.62,"D",GMRCACN))
QUIT FOUND
+7 SET IEN=0
FOR
SET IEN=$ORDER(^MAGV(2005.62,"D",GMRCACN,IEN))
if 'IEN
QUIT
Begin DoDot:1
+8 ; RPC - MAGV GET STUDY
+9 DO GETSTUDY^MAGVRS04(.OUT,,IEN,OVERRIDE)
if '$DATA(OUT)
QUIT
+10 SET J=" "
FOR
SET J=$ORDER(OUT(J),-1)
if 'J
QUIT
if FOUND=1
QUIT
Begin DoDot:2
+11 SET FIELD=$PIECE(OUT(J),"|")
+12 if FIELD'="NUMBER OF SOP INSTANCES"
QUIT
+13 SET IMAGES=$PIECE(OUT(J),"|",2)
+14 if IMAGES>0
SET FOUND=1
+15 QUIT
End DoDot:2
+16 QUIT
End DoDot:1
+17 QUIT FOUND
+18 ;
PROLOC(OUT,D0) ; return report's procedure & imaging location
+1 NEW RACN,RAEXFLD,X,LOC,PROC
+2 SET OUT="^"
IF D0=""
QUIT
+3 SET RAEXFLD="PROC"
DO ^RARTFLDS
SET PROC=X
KILL X
if PROC=""
QUIT
+4 SET RAEXFLD="LOC"
DO ^RARTFLDS
SET LOC=X
KILL X
if LOC=""
QUIT
+5 SET OUT=PROC_"^"_LOC
+6 QUIT
+7 ;
DISPLAY ;
+1 NEW ACNUMB,ANS,EXAMDATE,FDATE,LOC,NODE,PNAME,PROC,SSN,STOP,TDATE,X,Y
+2 SET STOP=0
SET Y=DTFR
XECUTE ^DD("DD")
SET FDATE=Y
SET Y=DTTO
XECUTE ^DD("DD")
SET TDATE=Y
+3 SET LOC=""
FOR
SET LOC=$ORDER(^TMP("MAG",$JOB,LOC))
if LOC=""
QUIT
Begin DoDot:1
+4 DO HDR
IF STOP
QUIT
+5 SET EXAMDATE=0
FOR
SET EXAMDATE=$ORDER(^TMP("MAG",$JOB,LOC,EXAMDATE))
if 'EXAMDATE!(STOP=1)
QUIT
Begin DoDot:2
+6 SET ACNUMB=""
FOR
SET ACNUMB=$ORDER(^TMP("MAG",$JOB,LOC,EXAMDATE,ACNUMB))
if ACNUMB=""!(STOP=1)
QUIT
Begin DoDot:3
+7 SET NODE=^TMP("MAG",$JOB,LOC,EXAMDATE,ACNUMB)
SET Y=$PIECE(EXAMDATE,".")
XECUTE ^DD("DD")
+8 SET PNAME=$PIECE(NODE,"^",1)
SET SSN=$PIECE(NODE,"^",2)
SET PROC=$PIECE(NODE,"^",3)
+9 WRITE !,ACNUMB,?20,$EXTRACT(PNAME,1,30),?53,$EXTRACT(SSN,6,9),?60,Y,?75,PROC
+10 IF $EXTRACT(IOST,1,2)="C-"
IF $Y+5>IOSL
Begin DoDot:4
+11 READ !!,"Press RETURN to continue or '^' to exit: ",ANS:DTIME
IF '$TEST
SET ANS="^"
+12 SET STOP=$SELECT(ANS="^":1,1:0)
+13 WRITE @IOF
+14 QUIT
End DoDot:4
+15 QUIT
End DoDot:3
+16 QUIT
End DoDot:2
+17 ; stop after each imaging location displayed
+18 IF $EXTRACT(IOST,1,2)="C-"
Begin DoDot:2
+19 READ !!,"Press RETURN to continue or '^' to exit: ",ANS:DTIME
IF '$TEST
SET ANS="^"
+20 SET STOP=$SELECT(ANS="^":1,1:0)
+21 QUIT
End DoDot:2
+22 ; new page after each imaging location displayed
+23 WRITE @IOF
+24 QUIT
End DoDot:1
+25 QUIT
+26 ;
HDR ; header
+1 NEW LN,ANS,I
+2 SET LN="-"
FOR I=1:1:131
SET LN=LN_"-"
+3 IF $EXTRACT(IOST,1,2)="C-"
IF $Y+10>IOSL
Begin DoDot:1
+4 READ !!,"Press RETURN to continue or '^' to exit: ",ANS:DTIME
IF '$TEST
SET ANS="^"
+5 SET STOP=$SELECT(ANS="^":1,1:0)
+6 WRITE @IOF
+7 QUIT
End DoDot:1
+8 IF STOP
QUIT
+9 IF $EXTRACT(IOST,1,2)="C-"
IF $Y>1
WRITE @IOF
+10 WRITE !,?42,"Radiology Exams without Images in VistA Imaging"
+11 WRITE !,?93,"From "_FDATE_" to "_TDATE
+12 WRITE !!,"Imaging Location: "_LOC,!
+13 WRITE !,"Accession",?20,"Patient Name",?53,"Last4",?60,"Exam Date"
+14 WRITE ?75,"Procedure",!,LN
+15 QUIT
