RAPM ;HOIFO/TH-Radiology Performance Monitors/Indicator; ;5/12/04 10:03
;;5.0;Radiology/Nuclear Medicine;**37,44,48,67,99,47**;Mar 16, 1998;Build 21
;RVD - 3/19/09 p99.
;Supported IA #2056 reference to ^DIQ
;Supported IA #10000 reference to C^%DTC
;Supported IA #10090 reference to ^DIC(4
; *** Application variables: ***
;
; Exam Date - RADTE (Regular Fileman format)
; RADTI (Inverse Fileman format)
; Case Number - RACN Exam Status - RAEXST
; Category of Exam - RACAT Primary Interpreting Staff - RAPRIM
; Date Report Entered - RARPTDT Verified Date - RAVERDT
; Report Status - RARPTST Page Number - RAPG
; Type of Report - RARPT
; Internal number of an entry in the Patient file (#2) - RADFN
;
INIT ; Check for the existence of RACESS. Pass in user's DUZ!
I $D(DUZ),($O(RACCESS(DUZ,""))']"") D CHECK^RADLQ3(DUZ)
;
N DIR,DIRUT,RABDATE,RAEDATE,RARPT,DTDIFF,RABEGDT,RAENDDT,RA1
N RAM,RARAD,RAR,RAMSG,X,Y K RAP99
S (RABDATE,RAEDATE,RAANS,RAANS2,RANODIV,RASINCE,RARAD)="",RAN=0
; RANODIV=1 if one or more exams are missing DIVISION
PROMPT ;
W @IOF
W !!,"Radiology Verification Timeliness Report",!!
; Prompt for Report Type. Quit if no report type selected
D GETRPT K DIR Q:$D(DIRUT)
; Prompt for Date Range - Quit if no dates selected
W !! D GETDATE K DIR Q:$D(DIRUT)
; Prompt for Radiologist if Short or Both
D RADIOL^RAPM3
; Prompt for Division and Imaging Types
S X=$$DIVLOC^RAUTL7() I X G EXIT
I $D(^TMP($J,"RA I-TYPE","VASCULAR LAB")) D
. K ^TMP($J,"RA I-TYPE","VASCULAR LAB")
. W !!?5,"*** Imaging type 'Vascular Lab' will not be included in this report ***"
; Prompt for sort option if Detail
D:RARPT'="S" SORT K DIR Q:$D(DIRUT)
; Prompt for mail delivery if Short or Both
I RARPT'="D" D EMAIL^RAPM2 K DIR Q:$D(DIRUT)
; Warning for Detail or Both
I RARPT="D"!(RARPT="B") D
. S RATXT="*** The detail report requires a 132 column output device ***"
. S RALINE="",$P(RALINE,"*",$L(RATXT))=""
. W !!?(80-$L(RATXT)\2),RALINE,!?(80-$L(RATXT)\2),RATXT,!?(80-$L(RATXT)\2),RALINE,!
.Q
D DEV
I RAPOP D G EXIT
. I RAANS!(RAANS2) W !?5,"** No mail will be sent **",$C(7)
. Q
START ; Get data and print the report
S:$D(ZTQUEUED) ZTREQ="@" S RAIO=$S(IO="":0,1:1),RAN=0
;added by patch #99
D GETDATA
I $G(RAP99) S RAS99=1 D PWT^RAPMW(RABDATE,RAEDATE) ;process partial Wait and Time report
;
;D GETDATA
I RARPT="S"!(RARPT="B") S RAPG=0 D ^RAPM1
I RARPT="D"!(RARPT="B") S RAPG=0 D ^RAPM2
I $G(RAP99) K RAS99 S RAL99=1 D PWT^RAPMW(RABDATE,RAEDATE) ;process all wait and time reports
; see if need send email
D SEND^RAPM2
D EXIT
Q
;
GETRPT ; Prompt for Summary or Detail or Both reports; Default = Summary Report
W !,"Enter Report Type"
S DIR(0)="S^S:Summary;D:Detail;B:Both"
S DIR("A")="Select Report Type",DIR("B")="S"
S DIR("?")="Enter Summary report OR Detail report OR Both reports"
D ^DIR
Q:$D(DIRUT)
S RARPT=Y
Q
GETDATE ; Prompt for start and end dates
S DIR(0)="D^:"_DT_":AEX"
I RARPT'="D" D
. W !!?4,"The begin date for Summary and Both must be at least 10 days before today.",!
. S X1=DT,X2=-10 D C^%DTC S RA1=X
. S DIR(0)="D^:"_RA1_":AEX"
. Q
S DIR("A")="Enter starting date"
S DIR("?")="Enter date to begin searching from"
D ^DIR
Q:$D(DIRUT)
S RABDATE=Y
;
S RADD=91,X1=RABDATE,X2=RADD D C^%DTC S RAMAXDT=X
; put 10 day block for summary report or Both
I RARPT'="D" D
. W !!?4,"The ending date for Summary and Both must be at least 10 days before today.",!
. S X1=DT,X2=-10 D C^%DTC S:X<RAMAXDT RAMAXDT=X
S:RAMAXDT>DT RAMAXDT=DT
S DIR(0)="D^"_RABDATE_":"_RAMAXDT_":AE"
S DIR("A")="Enter ending date"
S DIR("?",1)=" +91 days max. for Summary and Detail."
S DIR("?",2)=" And the ending date for the Summary and Both"
S DIR("?")=" must be at least 10 days before today."
D ^DIR
Q:$D(DIRUT)
;
; Set end date to end of day
; RABDATE and RAEDATE are original values
; RABEGDT and RAENDDT are used in GETDATA
S RAEDATE=Y,RAENDDT=RAEDATE_.9999
; Set start date back to include current day
S RABEGDT=(RABDATE-1)_.9999
Q
SORT ; Prompt for Sorted by
W !!,"Sort report by"
S DIR(0)="S^C:Case Number;E:Category of Exam;I:Imaging Type;P:Patient Name;R:Radiologist;T:Hrs to Transcrip.;V:Hrs to Verif."
S DIR("A")="Select Sorted by",DIR("B")="C"
D ^DIR
Q:$D(DIRUT)
S RASORT=Y
S DIR(0)="N^0:240"
S DIR("A")="Print PENDING and "_$S(RASORT="V":"Verif.",1:"Transrip.")_" hours greater than or equal to"
S DIR("B")="72"
S DIR("?")="Enter minimum number of hours elapsed since registration."
D ^DIR Q:$D(DIRUT) S RASINCE=Y
Q
DEV ; Device
I $D(DIRUT) D EXIT Q
W:RARPT="B" !!,"Specify device for both summary and detail reports."
D TASK
D ZIS^RAUTL
Q
TASK ; set vars for taskman
S ZTRTN="START^RAPM"
S ZTSAVE("RA*")=""
S ZTSAVE("^TMP($J,")=""
;S ZTSAVE("^TMP($J,""RA D-TYPE"",")=""
;S ZTSAVE("^TMP($J,""RA I-TYPE"",")=""
S:$G(RAP99) ZTDESC="Radiology Timeliness Performance Reports"
S:'$G(RAP99) ZTDESC="Radiology Verification Timeliness Report"
Q
;
GETDATA ; Get all the data
; Order thru Exam Date (RADTE)
S RADTE=RABEGDT F S RADTE=$O(^RADPT("AR",RADTE)) Q:'RADTE Q:(RADTE>RAENDDT) D
. S RADFN="" F S RADFN=$O(^RADPT("AR",RADTE,RADFN)) Q:'RADFN D
. . ; Get patient name
. . S RAPATNM=$$GET1^DIQ(2,RADFN,.01) S:RAPATNM="" RAPATNM=" "
. . ; Order thru inverse Exam Date (RADTI)
. . S RADTI="" F S RADTI=$O(^RADPT("AR",RADTE,RADFN,RADTI)) Q:'RADTI D CHECK
. . Q
. Q
Q
CHECK ; Check type of image
Q:'$D(^RADPT(RADFN,"DT",RADTI)) ;no exam data at all
S RAITYP=$P($G(^RADPT(RADFN,"DT",RADTI,0)),U,2)
S RAIMGTYP=$P($G(^RA(79.2,+RAITYP,0)),U,1)
; quit if img typ is known AND does not match selection
I RAIMGTYP'="",'$D(^TMP($J,"RA I-TYPE",RAIMGTYP)) Q
I RAIMGTYP="" S RAIMGTYP="(unknown)"
;
; Check division - Quit if no division selected
S RASELDIV=$P($G(^RADPT(RADFN,"DT",RADTI,0)),U,3)
S RACHKDIV=$P($G(^DIC(4,+RASELDIV,0)),U,1)
; quit if div is known AND does not match selection
I RACHKDIV'="",'$D(^TMP($J,"RA D-TYPE",RACHKDIV)) Q
S:RACHKDIV="" RANODIV=1
;
; Get exam related data
S RACNI=0 F S RACNI=$O(^RADPT(RADFN,"DT",RADTI,"P",RACNI)) Q:'RACNI D
. S (RACN0,RAEXST,RANUM,RACN,RAPRIM,RAPRIMNM,RACAT,RARPTTXT)=""
. S (RARPTDT,RAVERDT,RARPTST,RADHT,RADHV,RATDFHR,RAVDFHR)=""
. ; Get 0 node (RACN0) of ^RADPT(RADFN,"DT",RADTI,"P",RACNI,0)
. S RACN0=$G(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0))
. Q:RACN0="" ; no exam data
. ; Get Case number: Exam Date - Case Number
. S RACN=$E(RADTE,4,7)_$E(RADTE,2,3)_"-"_$P(RACN0,U,1)
. N RASSAN,RACNDSP S RASSAN=$$SSANVAL^RAHLRU1(RADFN,RADTI,RACNI)
. S RACNDSP=$S((RASSAN'=""):RASSAN,1:RACN)
. ; Get exam status
. S RAEXST=$P(RACN0,U,3)
. Q:RAEXST="" ; no exam status
. ; Quit if exam's CREDIT METHOD is 2 = no credit
. Q:$P(RACN0,U,26)=2
. ; Quit if exam status is "Cancelled"
. I $P(^RA(72,RAEXST,0),U,3)=0 Q
. ; Get number of set - '1' separate; '2' for combined report.
. S RANUM=$P(RACN0,U,25)
. ; if member of set > 1 then set RACNI to 99999 to skip remaining cases
. I RANUM>1 S RACNI=99999
. ; Get Radiologist (Primary Interpreting Staff) internal # and name.
. S RAPRIM=$P(RACN0,U,15)
. ; if specific radiologist requested, quit if not his/her case
. I RARAD,RAPRIM'=RARAD Q
. S RAPRIMNM=$$GET1^DIQ(200,RAPRIM,.01) S:RAPRIMNM="" RAPRIMNM=" "
. ; Get Category of Exam
. S RACAT=$P(RACN0,U,4)
. ; Get Procedure Name
. S RAPRCN=$P($G(^RAMIS(71,+$P(RACN0,U,2),0)),U)
. ; Get IEN of imaging report
. S RARPTTXT=$P(RACN0,U,17)
. ; Pending if no imaging report OR report doesn't exist in the Report
. ; file (#74) OR Stub report
. S RAHASR=0 ;=1 has real report
. I $D(^RARPT(+RARPTTXT,0)),'$$STUB^RAEDCN1(+RARPTTXT) S RAHASR=1
. I 'RAHASR D
. . S ^TMP($J,"RAPM","TR",0)=$G(^TMP($J,"RAPM","TR",0))+1
. . S ^TMP($J,"RAPM","VR",0)=$G(^TMP($J,"RAPM","VR",0))+1
. ; Get report info. if real report exists.
. I RAHASR D RPTINFO^RAPM1
. D STORE^RAPM2
. ; Calculate the total number of reports
. S ^TMP($J,"RAPM","TOTAL")=$G(^TMP($J,"RAPM","TOTAL"))+1
Q
EXIT ; Exit
; Close device
D CLOSE^RAUTL
K RACN0,RAEXST,RANUM,RACN,RAPRIM,RAPRIMNM,RACAT,RARPTTXT,RAANS,RATXT
K DIR,DIRUT,RABDATE,RAEDATE,RARPT,DTDIFF,RABEGDT,RAENDDT,RAITYP,RAIMGTYP,RATYP
K ZTRTN,ZTSAVE,ZTDESC,RAPG,RASELDIV,RACHKDIV,RACNO,RAVHRS,RACNDSP,RASSAN
K RADIV,RAN,RAIMG,RAREC1,RATOTCNT,RACNI,RADFN,RADTE,RADTI,RAHD,RAPATNM
K RAPOP,RAPSTX,RAQUIT,RAREC,RARPTDT,RARPTST,RASORT,RASRT,RATDFHR,RAHASR
K RATDFSEC,RATHRS,RAVDFHR,RAVDFSEC,RAVERDT,RAMES,RALINE,RAMAXDT,RADD
K RAANS2,RAIOM,RAHDR,RANODIV,RASINCE,RADHT,RADHV,RAVAL,RAPRCN
K RAXIT,RAIO,RALDENT,RALMAX,RALUSED,RATAIL,RAS99,RAL99,RAP99,RAN
K ^TMP($J)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRAPM 8890 printed Sep 23, 2025@20:14:40 Page 2
RAPM ;HOIFO/TH-Radiology Performance Monitors/Indicator; ;5/12/04 10:03
+1 ;;5.0;Radiology/Nuclear Medicine;**37,44,48,67,99,47**;Mar 16, 1998;Build 21
+2 ;RVD - 3/19/09 p99.
+3 ;Supported IA #2056 reference to ^DIQ
+4 ;Supported IA #10000 reference to C^%DTC
+5 ;Supported IA #10090 reference to ^DIC(4
+6 ; *** Application variables: ***
+7 ;
+8 ; Exam Date - RADTE (Regular Fileman format)
+9 ; RADTI (Inverse Fileman format)
+10 ; Case Number - RACN Exam Status - RAEXST
+11 ; Category of Exam - RACAT Primary Interpreting Staff - RAPRIM
+12 ; Date Report Entered - RARPTDT Verified Date - RAVERDT
+13 ; Report Status - RARPTST Page Number - RAPG
+14 ; Type of Report - RARPT
+15 ; Internal number of an entry in the Patient file (#2) - RADFN
+16 ;
INIT ; Check for the existence of RACESS. Pass in user's DUZ!
+1 IF $DATA(DUZ)
IF ($ORDER(RACCESS(DUZ,""))']"")
DO CHECK^RADLQ3(DUZ)
+2 ;
+3 NEW DIR,DIRUT,RABDATE,RAEDATE,RARPT,DTDIFF,RABEGDT,RAENDDT,RA1
+4 NEW RAM,RARAD,RAR,RAMSG,X,Y
KILL RAP99
+5 SET (RABDATE,RAEDATE,RAANS,RAANS2,RANODIV,RASINCE,RARAD)=""
SET RAN=0
+6 ; RANODIV=1 if one or more exams are missing DIVISION
PROMPT ;
+1 WRITE @IOF
+2 WRITE !!,"Radiology Verification Timeliness Report",!!
+3 ; Prompt for Report Type. Quit if no report type selected
+4 DO GETRPT
KILL DIR
if $DATA(DIRUT)
QUIT
+5 ; Prompt for Date Range - Quit if no dates selected
+6 WRITE !!
DO GETDATE
KILL DIR
if $DATA(DIRUT)
QUIT
+7 ; Prompt for Radiologist if Short or Both
+8 DO RADIOL^RAPM3
+9 ; Prompt for Division and Imaging Types
+10 SET X=$$DIVLOC^RAUTL7()
IF X
GOTO EXIT
+11 IF $DATA(^TMP($JOB,"RA I-TYPE","VASCULAR LAB"))
Begin DoDot:1
+12 KILL ^TMP($JOB,"RA I-TYPE","VASCULAR LAB")
+13 WRITE !!?5,"*** Imaging type 'Vascular Lab' will not be included in this report ***"
End DoDot:1
+14 ; Prompt for sort option if Detail
+15 if RARPT'="S"
DO SORT
KILL DIR
if $DATA(DIRUT)
QUIT
+16 ; Prompt for mail delivery if Short or Both
+17 IF RARPT'="D"
DO EMAIL^RAPM2
KILL DIR
if $DATA(DIRUT)
QUIT
+18 ; Warning for Detail or Both
+19 IF RARPT="D"!(RARPT="B")
Begin DoDot:1
+20 SET RATXT="*** The detail report requires a 132 column output device ***"
+21 SET RALINE=""
SET $PIECE(RALINE,"*",$LENGTH(RATXT))=""
+22 WRITE !!?(80-$LENGTH(RATXT)\2),RALINE,!?(80-$LENGTH(RATXT)\2),RATXT,!?(80-$LENGTH(RATXT)\2),RALINE,!
+23 QUIT
End DoDot:1
+24 DO DEV
+25 IF RAPOP
Begin DoDot:1
+26 IF RAANS!(RAANS2)
WRITE !?5,"** No mail will be sent **",$CHAR(7)
+27 QUIT
End DoDot:1
GOTO EXIT
START ; Get data and print the report
+1 if $DATA(ZTQUEUED)
SET ZTREQ="@"
SET RAIO=$SELECT(IO="":0,1:1)
SET RAN=0
+2 ;added by patch #99
+3 DO GETDATA
+4 ;process partial Wait and Time report
IF $GET(RAP99)
SET RAS99=1
DO PWT^RAPMW(RABDATE,RAEDATE)
+5 ;
+6 ;D GETDATA
+7 IF RARPT="S"!(RARPT="B")
SET RAPG=0
DO ^RAPM1
+8 IF RARPT="D"!(RARPT="B")
SET RAPG=0
DO ^RAPM2
+9 ;process all wait and time reports
IF $GET(RAP99)
KILL RAS99
SET RAL99=1
DO PWT^RAPMW(RABDATE,RAEDATE)
+10 ; see if need send email
+11 DO SEND^RAPM2
+12 DO EXIT
+13 QUIT
+14 ;
GETRPT ; Prompt for Summary or Detail or Both reports; Default = Summary Report
+1 WRITE !,"Enter Report Type"
+2 SET DIR(0)="S^S:Summary;D:Detail;B:Both"
+3 SET DIR("A")="Select Report Type"
SET DIR("B")="S"
+4 SET DIR("?")="Enter Summary report OR Detail report OR Both reports"
+5 DO ^DIR
+6 if $DATA(DIRUT)
QUIT
+7 SET RARPT=Y
+8 QUIT
GETDATE ; Prompt for start and end dates
+1 SET DIR(0)="D^:"_DT_":AEX"
+2 IF RARPT'="D"
Begin DoDot:1
+3 WRITE !!?4,"The begin date for Summary and Both must be at least 10 days before today.",!
+4 SET X1=DT
SET X2=-10
DO C^%DTC
SET RA1=X
+5 SET DIR(0)="D^:"_RA1_":AEX"
+6 QUIT
End DoDot:1
+7 SET DIR("A")="Enter starting date"
+8 SET DIR("?")="Enter date to begin searching from"
+9 DO ^DIR
+10 if $DATA(DIRUT)
QUIT
+11 SET RABDATE=Y
+12 ;
+13 SET RADD=91
SET X1=RABDATE
SET X2=RADD
DO C^%DTC
SET RAMAXDT=X
+14 ; put 10 day block for summary report or Both
+15 IF RARPT'="D"
Begin DoDot:1
+16 WRITE !!?4,"The ending date for Summary and Both must be at least 10 days before today.",!
+17 SET X1=DT
SET X2=-10
DO C^%DTC
if X<RAMAXDT
SET RAMAXDT=X
End DoDot:1
+18 if RAMAXDT>DT
SET RAMAXDT=DT
+19 SET DIR(0)="D^"_RABDATE_":"_RAMAXDT_":AE"
+20 SET DIR("A")="Enter ending date"
+21 SET DIR("?",1)=" +91 days max. for Summary and Detail."
+22 SET DIR("?",2)=" And the ending date for the Summary and Both"
+23 SET DIR("?")=" must be at least 10 days before today."
+24 DO ^DIR
+25 if $DATA(DIRUT)
QUIT
+26 ;
+27 ; Set end date to end of day
+28 ; RABDATE and RAEDATE are original values
+29 ; RABEGDT and RAENDDT are used in GETDATA
+30 SET RAEDATE=Y
SET RAENDDT=RAEDATE_.9999
+31 ; Set start date back to include current day
+32 SET RABEGDT=(RABDATE-1)_.9999
+33 QUIT
SORT ; Prompt for Sorted by
+1 WRITE !!,"Sort report by"
+2 SET DIR(0)="S^C:Case Number;E:Category of Exam;I:Imaging Type;P:Patient Name;R:Radiologist;T:Hrs to Transcrip.;V:Hrs to Verif."
+3 SET DIR("A")="Select Sorted by"
SET DIR("B")="C"
+4 DO ^DIR
+5 if $DATA(DIRUT)
QUIT
+6 SET RASORT=Y
+7 SET DIR(0)="N^0:240"
+8 SET DIR("A")="Print PENDING and "_$SELECT(RASORT="V":"Verif.",1:"Transrip.")_" hours greater than or equal to"
+9 SET DIR("B")="72"
+10 SET DIR("?")="Enter minimum number of hours elapsed since registration."
+11 DO ^DIR
if $DATA(DIRUT)
QUIT
SET RASINCE=Y
+12 QUIT
DEV ; Device
+1 IF $DATA(DIRUT)
DO EXIT
QUIT
+2 if RARPT="B"
WRITE !!,"Specify device for both summary and detail reports."
+3 DO TASK
+4 DO ZIS^RAUTL
+5 QUIT
TASK ; set vars for taskman
+1 SET ZTRTN="START^RAPM"
+2 SET ZTSAVE("RA*")=""
+3 SET ZTSAVE("^TMP($J,")=""
+4 ;S ZTSAVE("^TMP($J,""RA D-TYPE"",")=""
+5 ;S ZTSAVE("^TMP($J,""RA I-TYPE"",")=""
+6 if $GET(RAP99)
SET ZTDESC="Radiology Timeliness Performance Reports"
+7 if '$GET(RAP99)
SET ZTDESC="Radiology Verification Timeliness Report"
+8 QUIT
+9 ;
GETDATA ; Get all the data
+1 ; Order thru Exam Date (RADTE)
+2 SET RADTE=RABEGDT
FOR
SET RADTE=$ORDER(^RADPT("AR",RADTE))
if 'RADTE
QUIT
if (RADTE>RAENDDT)
QUIT
Begin DoDot:1
+3 SET RADFN=""
FOR
SET RADFN=$ORDER(^RADPT("AR",RADTE,RADFN))
if 'RADFN
QUIT
Begin DoDot:2
+4 ; Get patient name
+5 SET RAPATNM=$$GET1^DIQ(2,RADFN,.01)
if RAPATNM=""
SET RAPATNM=" "
+6 ; Order thru inverse Exam Date (RADTI)
+7 SET RADTI=""
FOR
SET RADTI=$ORDER(^RADPT("AR",RADTE,RADFN,RADTI))
if 'RADTI
QUIT
DO CHECK
+8 QUIT
End DoDot:2
+9 QUIT
End DoDot:1
+10 QUIT
CHECK ; Check type of image
+1 ;no exam data at all
if '$DATA(^RADPT(RADFN,"DT",RADTI))
QUIT
+2 SET RAITYP=$PIECE($GET(^RADPT(RADFN,"DT",RADTI,0)),U,2)
+3 SET RAIMGTYP=$PIECE($GET(^RA(79.2,+RAITYP,0)),U,1)
+4 ; quit if img typ is known AND does not match selection
+5 IF RAIMGTYP'=""
IF '$DATA(^TMP($JOB,"RA I-TYPE",RAIMGTYP))
QUIT
+6 IF RAIMGTYP=""
SET RAIMGTYP="(unknown)"
+7 ;
+8 ; Check division - Quit if no division selected
+9 SET RASELDIV=$PIECE($GET(^RADPT(RADFN,"DT",RADTI,0)),U,3)
+10 SET RACHKDIV=$PIECE($GET(^DIC(4,+RASELDIV,0)),U,1)
+11 ; quit if div is known AND does not match selection
+12 IF RACHKDIV'=""
IF '$DATA(^TMP($JOB,"RA D-TYPE",RACHKDIV))
QUIT
+13 if RACHKDIV=""
SET RANODIV=1
+14 ;
+15 ; Get exam related data
+16 SET RACNI=0
FOR
SET RACNI=$ORDER(^RADPT(RADFN,"DT",RADTI,"P",RACNI))
if 'RACNI
QUIT
Begin DoDot:1
+17 SET (RACN0,RAEXST,RANUM,RACN,RAPRIM,RAPRIMNM,RACAT,RARPTTXT)=""
+18 SET (RARPTDT,RAVERDT,RARPTST,RADHT,RADHV,RATDFHR,RAVDFHR)=""
+19 ; Get 0 node (RACN0) of ^RADPT(RADFN,"DT",RADTI,"P",RACNI,0)
+20 SET RACN0=$GET(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0))
+21 ; no exam data
if RACN0=""
QUIT
+22 ; Get Case number: Exam Date - Case Number
+23 SET RACN=$EXTRACT(RADTE,4,7)_$EXTRACT(RADTE,2,3)_"-"_$PIECE(RACN0,U,1)
+24 NEW RASSAN,RACNDSP
SET RASSAN=$$SSANVAL^RAHLRU1(RADFN,RADTI,RACNI)
+25 SET RACNDSP=$SELECT((RASSAN'=""):RASSAN,1:RACN)
+26 ; Get exam status
+27 SET RAEXST=$PIECE(RACN0,U,3)
+28 ; no exam status
if RAEXST=""
QUIT
+29 ; Quit if exam's CREDIT METHOD is 2 = no credit
+30 if $PIECE(RACN0,U,26)=2
QUIT
+31 ; Quit if exam status is "Cancelled"
+32 IF $PIECE(^RA(72,RAEXST,0),U,3)=0
QUIT
+33 ; Get number of set - '1' separate; '2' for combined report.
+34 SET RANUM=$PIECE(RACN0,U,25)
+35 ; if member of set > 1 then set RACNI to 99999 to skip remaining cases
+36 IF RANUM>1
SET RACNI=99999
+37 ; Get Radiologist (Primary Interpreting Staff) internal # and name.
+38 SET RAPRIM=$PIECE(RACN0,U,15)
+39 ; if specific radiologist requested, quit if not his/her case
+40 IF RARAD
IF RAPRIM'=RARAD
QUIT
+41 SET RAPRIMNM=$$GET1^DIQ(200,RAPRIM,.01)
if RAPRIMNM=""
SET RAPRIMNM=" "
+42 ; Get Category of Exam
+43 SET RACAT=$PIECE(RACN0,U,4)
+44 ; Get Procedure Name
+45 SET RAPRCN=$PIECE($GET(^RAMIS(71,+$PIECE(RACN0,U,2),0)),U)
+46 ; Get IEN of imaging report
+47 SET RARPTTXT=$PIECE(RACN0,U,17)
+48 ; Pending if no imaging report OR report doesn't exist in the Report
+49 ; file (#74) OR Stub report
+50 ;=1 has real report
SET RAHASR=0
+51 IF $DATA(^RARPT(+RARPTTXT,0))
IF '$$STUB^RAEDCN1(+RARPTTXT)
SET RAHASR=1
+52 IF 'RAHASR
Begin DoDot:2
+53 SET ^TMP($JOB,"RAPM","TR",0)=$GET(^TMP($JOB,"RAPM","TR",0))+1
+54 SET ^TMP($JOB,"RAPM","VR",0)=$GET(^TMP($JOB,"RAPM","VR",0))+1
End DoDot:2
+55 ; Get report info. if real report exists.
+56 IF RAHASR
DO RPTINFO^RAPM1
+57 DO STORE^RAPM2
+58 ; Calculate the total number of reports
+59 SET ^TMP($JOB,"RAPM","TOTAL")=$GET(^TMP($JOB,"RAPM","TOTAL"))+1
End DoDot:1
+60 QUIT
EXIT ; Exit
+1 ; Close device
+2 DO CLOSE^RAUTL
+3 KILL RACN0,RAEXST,RANUM,RACN,RAPRIM,RAPRIMNM,RACAT,RARPTTXT,RAANS,RATXT
+4 KILL DIR,DIRUT,RABDATE,RAEDATE,RARPT,DTDIFF,RABEGDT,RAENDDT,RAITYP,RAIMGTYP,RATYP
+5 KILL ZTRTN,ZTSAVE,ZTDESC,RAPG,RASELDIV,RACHKDIV,RACNO,RAVHRS,RACNDSP,RASSAN
+6 KILL RADIV,RAN,RAIMG,RAREC1,RATOTCNT,RACNI,RADFN,RADTE,RADTI,RAHD,RAPATNM
+7 KILL RAPOP,RAPSTX,RAQUIT,RAREC,RARPTDT,RARPTST,RASORT,RASRT,RATDFHR,RAHASR
+8 KILL RATDFSEC,RATHRS,RAVDFHR,RAVDFSEC,RAVERDT,RAMES,RALINE,RAMAXDT,RADD
+9 KILL RAANS2,RAIOM,RAHDR,RANODIV,RASINCE,RADHT,RADHV,RAVAL,RAPRCN
+10 KILL RAXIT,RAIO,RALDENT,RALMAX,RALUSED,RATAIL,RAS99,RAL99,RAP99,RAN
+11 KILL ^TMP($JOB)
+12 QUIT
