MAGDSTD3 ; OI&T-Clin3/DWM,WOIFO/PMK - rad exams w/o VI images; Jul 06, 2021@08:27:03
;;3.0;Support;**231,306**;11/13/2018;Build 1
;; 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. |
;; +---------------------------------------------------------------+
;
; Supported IA #2056 reference $$GET1^DIQ function call;
; Controlled Subscription IA #10035 for Fileman reads of ^DPT
; Supported IA #10026 reference ^DIR subroutine call
; Supported IA #1519 reference EN^XUTMDEVQ subroutine call
; Controlled IA #4110 to read REQUEST/CONSULTATION file (#123)
; 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
;
; This is the CONSULT version of MAGDSTD2
;
DATES ; enter date range to search
N CONSULTSERVICES,DIR,DTFR,DTTO,SERVICE,Y,X
;
N $ETRAP,$ESTACK S $ETRAP="D ERROR^MAGDSTA"
;
;
W !!!,"Search for Clinical Specialty 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
W ! S X=$$SERVICES^MAGDSTA8(.CONSULTSERVICES)
I X<0 W !,"Exiting" Q
;
QUE ; queue to run report
W !!,"Recommend report output of 132 columns",!!
;
N %ZIS,ZTDESC,ZTSAVE
S ZTDESC="Clinical Specialty Exams w/o VI Images"
S ZTSAVE("DTFR")=""
S ZTSAVE("DTTO")=""
S ZTSAVE("CONSULTSERVICES(")=""
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)
;
S SERVICE="" F S SERVICE=$O(CONSULTSERVICES(SERVICE)) Q:SERVICE="" D
. D COUNTS(DTFR,DTTO,.SERVICE)
. Q
;
; 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,SERVICE) ; build list of exams w/o images
; ^TMP("MAG",$J,SERVICE,EXAMDATE,ACNUMB)=PNAME_"^"_SSN_"^"_PROC
N COMPLETE,EXAMDATE,GMRCIEN,REVDATE,XDTFR,XDTTO
;
S XDTFR=DTFR-.0001,XDTTO=DTTO+.9999
; S XDTFR=9999999.9999-XDTFR ; reverse date & time
S XDTFR=$$GMRCDATE^MAGDSTA7(XDTFR) ; reverse date & time
; S XDTTO=9999999.9999-XDTTO ; reverse date & time
S XDTTO=$$GMRCDATE^MAGDSTA7(XDTTO) ; reverse date & time
;
; search completed consult/procedure request
S COMPLETE=2 ; ORDER STATUS file (#100.01) COMPLETE status
S REVDATE=XDTFR
F S REVDATE=$O(^GMR(123,"AE",SERVICE,COMPLETE,REVDATE),-1) Q:REVDATE="" Q:REVDATE<DTTO D
. S EXAMDATE=9999999.9999-REVDATE ; get regular FM date/time from reverse date/time
. S GMRCIEN=""
. F S GMRCIEN=$O(^GMR(123,"AE",SERVICE,COMPLETE,REVDATE,GMRCIEN)) Q:GMRCIEN="" D
. . D LOOKUP(GMRCIEN)
. . Q
. Q
Q
;
LOOKUP(GMRCIEN) ;
N DFN,GMRCACN,FOUND,PNAME,PROC,SENDIT,SSN
S DFN=$$GET1^DIQ(123,GMRCIEN,.02,"I") Q:DFN=""
S PNAME=$$GET1^DIQ(2,DFN,.01,"E") Q:PNAME=""
S SSN=$$GET1^DIQ(2,DFN,.09,"E") Q:SSN=""
;
; check if the consult is supported by a DICOM modality worklist
I '$$SERVICE^MAGDHOW1(SERVICE,GMRCIEN) Q ; no worklist defined
;
; worklist defined - check if the consult/procedure has images
;
S GMRCACN=$$GMRCACN^MAGDFCNV(GMRCIEN)
S FOUND=$$LEGACY(GMRCIEN) ; lookup in legacy database
I 'FOUND D
. S FOUND=$$NEWSOP^MAGDSTD2(GMRCACN) ; lookup in new sop class database
. Q
I 'FOUND D ; image(s) not found (or maybe incorrect)
. S PROC=$$GET1^DIQ(123,GMRCIEN,4,"E") I PROC="" S PROC="CONSULT"
. S ^TMP("MAG",$J,CONSULTSERVICES(SERVICE),EXAMDATE,GMRCACN)=PNAME_"^"_SSN_"^"_PROC
. Q
Q
;
LEGACY(GMRCIEN) ; lookup in legacy database
N FOUND,I,MAGIEN,TIU892591,TIU91NODE,TIUIEN,TIUNODE
S (FOUND,I)=0
F S I=$O(^GMR(123,GMRCIEN,50,I)) Q:'I D
. S TIUNODE=$G(^GMR(123,GMRCIEN,50,I,0))
. I $P(TIUNODE,";",2)="TIU(8925," S TIUIEN=$P(TIUNODE,";",1) D
. . Q:'TIUIEN
. . S TIU892591=""
. . F S TIU892591=$O(^TIU(8925.91,"B",TIUIEN,TIU892591)) Q:'TIU892591 D
. . . S TIU91NODE=^TIU(8925.91,TIU892591,0),MAGIEN=$P(TIU91NODE,"^",2)
. . . I MAGIEN S FOUND=FOUND+$$CHECKMAG(MAGIEN,TIUIEN,TIU892591)
. . . Q
. . Q
. Q
Q FOUND
;
CHECKMAG(MAGIEN,TIUIEN,TIU892591) ;
; -- ensure #2005 entry exists --
I '$D(^MAG(2005,MAGIEN,0)) Q 0 ; no entry in file #2005
; -- check if image valid --
I '$$MAG^MAGDSTD2(MAGIEN) Q 0 ; invalid patient or child entry
; -- check #2005 pointer back to #8925.91 --
I '$$PARENT(MAGIEN,TIUIEN,TIU892591) Q 0 ; bad pointer
Q 1
;
PARENT(MAGIEN,TIUIEN,TIU892591) ; check #2005 pointer back to #8925
N MAG2,PARENTDFIP,PARENTDFNU,PARENTGRD0
S MAG2=$G(^MAG(2005,MAGIEN,2)) Q:MAG2="" 0
S PARENTDFNU=$P(MAG2,"^",6) ; parent data file number
S PARENTGRD0=$P(MAG2,"^",7) ; parent global root D0
S PARENTDFIP=$P(MAG2,"^",8) ; parent data file image pointer
I PARENTDFNU'=8925 Q 0 ; parent file is not TIU
I PARENTGRD0'=TIUIEN Q 0 ; parent global root D0 not TIUIEN
I PARENTDFIP'=TIU892591 Q 0 ; parent data file image pointer not TIU892591
Q 1
;
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 Q:STOP=1 D
. . S ACNUMB="" F S ACNUMB=$O(^TMP("MAG",$J,LOC,EXAMDATE,ACNUMB)) Q:ACNUMB="" Q: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 !,?37,"Clinical Specialty Exams without Images in VistA Imaging"
W !,?93,"From "_FDATE_" to "_TDATE
W !!,"Medical Service: "_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[HMAGDSTD3 7745 printed Sep 23, 2025@19:38:07 Page 2
MAGDSTD3 ; OI&T-Clin3/DWM,WOIFO/PMK - rad exams w/o VI images; Jul 06, 2021@08:27:03
+1 ;;3.0;Support;**231,306**;11/13/2018;Build 1
+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 ; Supported IA #2056 reference $$GET1^DIQ function call;
+18 ; Controlled Subscription IA #10035 for Fileman reads of ^DPT
+19 ; Supported IA #10026 reference ^DIR subroutine call
+20 ; Supported IA #1519 reference EN^XUTMDEVQ subroutine call
+21 ; Controlled IA #4110 to read REQUEST/CONSULTATION file (#123)
+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 ;
+28 ; This is the CONSULT version of MAGDSTD2
+29 ;
DATES ; enter date range to search
+1 NEW CONSULTSERVICES,DIR,DTFR,DTTO,SERVICE,Y,X
+2 ;
+3 NEW $ETRAP,$ESTACK
SET $ETRAP="D ERROR^MAGDSTA"
+4 ;
+5 ;
+6 WRITE !!!,"Search for Clinical Specialty Exams Lacking Images"
+7 WRITE !,"--------------------------------------------------"
+8 DO BEGDATE^MAGDSTA2
+9 SET DTFR=$GET(^TMP("MAG",$JOB,"BATCH Q/R","BEGIN DATE"))
+10 IF DTFR=""
GOTO EXIT
+11 DO ENDDATE^MAGDSTA2
+12 SET DTTO=$GET(^TMP("MAG",$JOB,"BATCH Q/R","END DATE"))
+13 IF DTTO=""
GOTO EXIT
+14 WRITE !
SET X=$$SERVICES^MAGDSTA8(.CONSULTSERVICES)
+15 IF X<0
WRITE !,"Exiting"
QUIT
+16 ;
QUE ; queue to run report
+1 WRITE !!,"Recommend report output of 132 columns",!!
+2 ;
+3 NEW %ZIS,ZTDESC,ZTSAVE
+4 SET ZTDESC="Clinical Specialty Exams w/o VI Images"
+5 SET ZTSAVE("DTFR")=""
+6 SET ZTSAVE("DTTO")=""
+7 SET ZTSAVE("CONSULTSERVICES(")=""
+8 DO EN^XUTMDEVQ("EN^"_$TEXT(+0),ZTDESC,.ZTSAVE,.%ZIS)
+9 GOTO EXIT
+10 QUIT
+11 ;
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 SET SERVICE=""
FOR
SET SERVICE=$ORDER(CONSULTSERVICES(SERVICE))
if SERVICE=""
QUIT
Begin DoDot:1
+8 DO COUNTS(DTFR,DTTO,.SERVICE)
+9 QUIT
End DoDot:1
+10 ;
+11 ; display results
+12 IF '$DATA(^TMP("MAG",$JOB))
WRITE !!,"No data for display!",!!
GOTO EXIT
+13 DO DISPLAY
+14 WRITE !!,"RUN COMPLETED at ",$$FMTE^XLFDT($$NOW^XLFDT,1)
+15 DO CONTINUE^MAGDSTQ
+16 ;
EXIT ;
+1 KILL ^TMP("MAG",$JOB)
+2 QUIT
+3 ;
COUNTS(DTFR,DTTO,SERVICE) ; build list of exams w/o images
+1 ; ^TMP("MAG",$J,SERVICE,EXAMDATE,ACNUMB)=PNAME_"^"_SSN_"^"_PROC
+2 NEW COMPLETE,EXAMDATE,GMRCIEN,REVDATE,XDTFR,XDTTO
+3 ;
+4 SET XDTFR=DTFR-.0001
SET XDTTO=DTTO+.9999
+5 ; S XDTFR=9999999.9999-XDTFR ; reverse date & time
+6 ; reverse date & time
SET XDTFR=$$GMRCDATE^MAGDSTA7(XDTFR)
+7 ; S XDTTO=9999999.9999-XDTTO ; reverse date & time
+8 ; reverse date & time
SET XDTTO=$$GMRCDATE^MAGDSTA7(XDTTO)
+9 ;
+10 ; search completed consult/procedure request
+11 ; ORDER STATUS file (#100.01) COMPLETE status
SET COMPLETE=2
+12 SET REVDATE=XDTFR
+13 FOR
SET REVDATE=$ORDER(^GMR(123,"AE",SERVICE,COMPLETE,REVDATE),-1)
if REVDATE=""
QUIT
if REVDATE<DTTO
QUIT
Begin DoDot:1
+14 ; get regular FM date/time from reverse date/time
SET EXAMDATE=9999999.9999-REVDATE
+15 SET GMRCIEN=""
+16 FOR
SET GMRCIEN=$ORDER(^GMR(123,"AE",SERVICE,COMPLETE,REVDATE,GMRCIEN))
if GMRCIEN=""
QUIT
Begin DoDot:2
+17 DO LOOKUP(GMRCIEN)
+18 QUIT
End DoDot:2
+19 QUIT
End DoDot:1
+20 QUIT
+21 ;
LOOKUP(GMRCIEN) ;
+1 NEW DFN,GMRCACN,FOUND,PNAME,PROC,SENDIT,SSN
+2 SET DFN=$$GET1^DIQ(123,GMRCIEN,.02,"I")
if DFN=""
QUIT
+3 SET PNAME=$$GET1^DIQ(2,DFN,.01,"E")
if PNAME=""
QUIT
+4 SET SSN=$$GET1^DIQ(2,DFN,.09,"E")
if SSN=""
QUIT
+5 ;
+6 ; check if the consult is supported by a DICOM modality worklist
+7 ; no worklist defined
IF '$$SERVICE^MAGDHOW1(SERVICE,GMRCIEN)
QUIT
+8 ;
+9 ; worklist defined - check if the consult/procedure has images
+10 ;
+11 SET GMRCACN=$$GMRCACN^MAGDFCNV(GMRCIEN)
+12 ; lookup in legacy database
SET FOUND=$$LEGACY(GMRCIEN)
+13 IF 'FOUND
Begin DoDot:1
+14 ; lookup in new sop class database
SET FOUND=$$NEWSOP^MAGDSTD2(GMRCACN)
+15 QUIT
End DoDot:1
+16 ; image(s) not found (or maybe incorrect)
IF 'FOUND
Begin DoDot:1
+17 SET PROC=$$GET1^DIQ(123,GMRCIEN,4,"E")
IF PROC=""
SET PROC="CONSULT"
+18 SET ^TMP("MAG",$JOB,CONSULTSERVICES(SERVICE),EXAMDATE,GMRCACN)=PNAME_"^"_SSN_"^"_PROC
+19 QUIT
End DoDot:1
+20 QUIT
+21 ;
LEGACY(GMRCIEN) ; lookup in legacy database
+1 NEW FOUND,I,MAGIEN,TIU892591,TIU91NODE,TIUIEN,TIUNODE
+2 SET (FOUND,I)=0
+3 FOR
SET I=$ORDER(^GMR(123,GMRCIEN,50,I))
if 'I
QUIT
Begin DoDot:1
+4 SET TIUNODE=$GET(^GMR(123,GMRCIEN,50,I,0))
+5 IF $PIECE(TIUNODE,";",2)="TIU(8925,"
SET TIUIEN=$PIECE(TIUNODE,";",1)
Begin DoDot:2
+6 if 'TIUIEN
QUIT
+7 SET TIU892591=""
+8 FOR
SET TIU892591=$ORDER(^TIU(8925.91,"B",TIUIEN,TIU892591))
if 'TIU892591
QUIT
Begin DoDot:3
+9 SET TIU91NODE=^TIU(8925.91,TIU892591,0)
SET MAGIEN=$PIECE(TIU91NODE,"^",2)
+10 IF MAGIEN
SET FOUND=FOUND+$$CHECKMAG(MAGIEN,TIUIEN,TIU892591)
+11 QUIT
End DoDot:3
+12 QUIT
End DoDot:2
+13 QUIT
End DoDot:1
+14 QUIT FOUND
+15 ;
CHECKMAG(MAGIEN,TIUIEN,TIU892591) ;
+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^MAGDSTD2(MAGIEN)
QUIT 0
+5 ; -- check #2005 pointer back to #8925.91 --
+6 ; bad pointer
IF '$$PARENT(MAGIEN,TIUIEN,TIU892591)
QUIT 0
+7 QUIT 1
+8 ;
PARENT(MAGIEN,TIUIEN,TIU892591) ; check #2005 pointer back to #8925
+1 NEW MAG2,PARENTDFIP,PARENTDFNU,PARENTGRD0
+2 SET MAG2=$GET(^MAG(2005,MAGIEN,2))
if MAG2=""
QUIT 0
+3 ; parent data file number
SET PARENTDFNU=$PIECE(MAG2,"^",6)
+4 ; parent global root D0
SET PARENTGRD0=$PIECE(MAG2,"^",7)
+5 ; parent data file image pointer
SET PARENTDFIP=$PIECE(MAG2,"^",8)
+6 ; parent file is not TIU
IF PARENTDFNU'=8925
QUIT 0
+7 ; parent global root D0 not TIUIEN
IF PARENTGRD0'=TIUIEN
QUIT 0
+8 ; parent data file image pointer not TIU892591
IF PARENTDFIP'=TIU892591
QUIT 0
+9 QUIT 1
+10 ;
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
QUIT
if STOP=1
QUIT
Begin DoDot:2
+6 SET ACNUMB=""
FOR
SET ACNUMB=$ORDER(^TMP("MAG",$JOB,LOC,EXAMDATE,ACNUMB))
if ACNUMB=""
QUIT
if 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 !,?37,"Clinical Specialty Exams without Images in VistA Imaging"
+11 WRITE !,?93,"From "_FDATE_" to "_TDATE
+12 WRITE !!,"Medical Service: "_LOC,!
+13 WRITE !,"Accession",?20,"Patient Name",?53,"Last4",?60,"Exam Date"
+14 WRITE ?75,"Procedure",!,LN
+15 QUIT
