- 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 Feb 18, 2025@23:28:22 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