RAPM2 ;HOIFO/TH-Radiology Performance Monitors/Indicator; ;3/20/04 12:41
;;5.0;Radiology/Nuclear Medicine;**37,44,48,63,67,99,47**;Mar 16, 1998;Build 21
; IA 10090 allows Read w/Fileman for entire file 4
; Supported IA #10103 reference to ^XLFDT
; Supported IA #2056 reference to ^DIQ
; Supported IA #2541 reference to KSP^XUPARAM
; RVD - 3/20/09 p99
; Print Detail report
DETAIL ; Print Detail report
I ($Y+5)>IOSL!(RARPT="B") D
. I IO=IO(0),($E(IOST,1,2)="C-") D
. . R !,"Press RETURN to continue. ",X:DTIME
D HDR("D")
D PRTTOT
D DHDR
D DRPT Q:RAXIT
D DFOOT
Q
;
PRTTOT ; Print total number of reports
S RATOTCNT=+$G(^TMP($J,"RAPM","TOTAL"))
W !,"Total number of reports expected for procedures performed during specified date range: ",$J(RATOTCNT,$L(RATOTCNT))
Q
;
DHDR ; Header
I ($Y+5)>IOSL D
. S RAPG=RAPG+1,RAHD(0)="Detail Verification Timeliness Report"
. W @IOF,!?(RAIOM-$L(RAHD(0))\2),RAHD(0),?(RAIOM-10),"Page: ",$G(RAPG)
W !!,?34,"Date/Time",?49,"Date/Time",?69,"Date/Time",?102,"Cat"
W ?106,"Rpt",?110,"Img",?116,"Procedure"
W !,"Patient Name",?17,"Case #",?34,"Registered",?49,"Transcribed",?63,"Hrs"
W ?69,"Verified",?83,"Hrs",?88,"Radiologist",?102,"Exm",?106,"Sts"
W ?110,"Typ",?119,"Name",!
Q
;
DRPT ; Read records
S RAXIT=0
I '$D(^TMP($J,"RAPM2")) W !!?30,"No data to print...",!!!!! Q
S D1="" F S D1=$O(^TMP($J,"RAPM2",D1)) Q:D1="" Q:RAXIT D
. S D2="" F S D2=$O(^TMP($J,"RAPM2",D1,D2)) Q:D2="" Q:RAXIT D
. . S D3="" F S D3=$O(^TMP($J,"RAPM2",D1,D2,D3)) Q:D3="" Q:RAXIT D
. . . D SRT
Q
;
SRT ; Read records
I RASORT="C"!(RASORT="P") S RAREC=$G(^TMP($J,"RAPM2",D1,D2,D3)) D DET Q
S D4="" F S D4=$O(^TMP($J,"RAPM2",D1,D2,D3,D4)) Q:D4="" Q:RAXIT D
. S RAREC=$G(^TMP($J,"RAPM2",D1,D2,D3,D4)) D DET
Q
;
DET ; Print detail records
; use Transcription elasped hr for all sorts, except if sort by Verif.
S RAVAL=$S(RASORT="V":$P(RAREC,U,13),1:$P(RAREC,U,12))
; remove symbols before comparison
S:$E(RAVAL)="<" RAVAL=.5 S:$E(RAVAL)=">" RAVAL=999
; include PENDING and those with hours > RASINCE
I RAVAL'="",RAVAL<RASINCE Q
I ($Y+5)>IOSL D
. I IO=IO(0) D
. . I $E(IOST,1,2)="C-" R !,"Press RETURN to continue or ""^"" to exit. ",X:DTIME S:X="^" RAXIT=1
. Q:RAXIT
. D DHDR
Q:RAXIT
W !,$E($P(RAREC,U,2),1,14)
W ?16,$P(RAREC,U,1)
W ?33,$P($$FMTE^XLFDT($P(RAREC,U,3),"2FS"),":",1,2)
W ?48,$P($$FMTE^XLFDT($P(RAREC,U,4),"2FS"),":",1,2),?63,$J($P(RAREC,U,12),4)
W ?68,$P($$FMTE^XLFDT($P(RAREC,U,5),"2FS"),":",1,2),?82,$J($P(RAREC,U,13),4)
I $P(RAREC,U,6)'="" W ?88,$E($P(RAREC,U,6),1,14)
W ?104,$P(RAREC,U,7),?107,$P(RAREC,U,8)
W ?110,$E($P(RAREC,U,9),1,3),?114,$E($P(RAREC,U,14),1,15)
W:$P(RAREC,U,11)="" ?130,"*D"
Q
;
I ($Y+5)>IOSL D
. I IO=IO(0) D
. . I $E(IOST,1,2)="C-" R !,"Press RETURN to continue. ",X:DTIME
. D DHDR
W !!,"Note: Category of Exam: 'I' for Inpatient; 'O' for Outpatient; "
W "'C' for Contract; 'S' for Sharing; 'E' for Employee; 'R' for Research"
W !," Report Status: 'V' for Verififed; 'R' for Released/Not "
W "Verified; 'PD' for Problem Draft; 'D' for Draft"
W:RANODIV !," *D = Division is missing"
W !!?5,"* A printset, i.e., a set of multiple exams that share the same report, will be expected to have 1 report."
W !!?5,"* Cancelled and ""No Credit"" cases are excluded from this report."
Q
;
STORE ; Store detail information
Q:RARPT="S"
; for storage subscript: if no rpt dt, set to neg
S RADHT=$S(RARPTDT="":-1,1:RATDFHR)
S RADHV=$S(RAVERDT="":-1,1:RAVDFHR)
; for display: truncate decimal portion of hours
S:RATDFHR'="" RATDFHR=RATDFHR\1
S:RAVDFHR'="" RAVDFHR=RAVDFHR\1
S RATDFHR=$S(RATDFHR="":"",RATDFHR<1:"<1",RATDFHR>999:">999",1:RATDFHR)
S RAVDFHR=$S(RAVDFHR="":"",RAVDFHR<1:"<1",RAVDFHR>999:">999",1:RAVDFHR)
;
I $$USESSAN^RAHLRU1() S RAREC1=RACNDSP_U_RAPATNM_U_RADTE_U_RARPTDT_U
I '$$USESSAN^RAHLRU1() S RAREC1=RACN_U_RAPATNM_U_RADTE_U_RARPTDT_U
S RAREC1=RAREC1_RAVERDT_U_RAPRIMNM_U_RACAT_U_RARPTST_U_RAIMGTYP_U
S RAREC1=RAREC1_RADFN_U_RACHKDIV_U_RATDFHR_U_RAVDFHR_U_RAPRCN
;
I RASORT="C" S ^TMP($J,"RAPM2",$P(RADTE,"."),RACN,RAPATNM)=RAREC1
I RASORT="P" S ^TMP($J,"RAPM2",RAPATNM,$P(RADTE,"."),RACN)=RAREC1
I RASORT="I" S ^TMP($J,"RAPM2",RAIMGTYP,$P(RADTE,"."),RACN,RAPATNM)=RAREC1
I RASORT="E" S ^TMP($J,"RAPM2",RACAT,$P(RADTE,"."),RACN,RAPATNM)=RAREC1
I RASORT="R" S ^TMP($J,"RAPM2",RAPRIMNM,$P(RADTE,"."),RACN,RAPATNM)=RAREC1
I RASORT="T" S ^TMP($J,"RAPM2",RADHT,RADTE,RACN,RAPATNM)=RAREC1
I RASORT="V" S ^TMP($J,"RAPM2",RADHV,RADTE,RACN,RAPATNM)=RAREC1
Q
EMAIL ; Ask if ready to email the summary report
N RA1
W ! S DIR(0)="Y"
S DIR("A")="Send summary report to local mail group ""G.RAD PERFORMANCE INDICATOR"""
S DIR("B")="Yes"
D ^DIR
Q:$D(DIRUT)
S RAANS=Y
S RA1=$O(^RA(79,0)) Q:'RA1
I '$O(^RA(79,RA1,1,0)) D Q
. W !!,?5,"No OUTLOOK mail group(s) have been entered yet."
. Q
W ! S DIR(0)="Y"
S DIR("A")="Send summary report to OUTLOOK mail group(s)"
S DIR("B")="Yes"
D ^DIR
S RAANS2=Y
I RAANS2 D CKMONTH^RAPM4
Q
SEND ; Send summary report to mail group
I RAANS=0,RAANS2=0 Q
N RA1,RA2,RASVSUB,RASVTEXT,RASTR
S:$G(RAP99) XMSUB="Radiology Timeliness Performance Reports"
S:'$G(RAP99) XMSUB="Radiology Summary Verification Timeliness"
S XMDUZ=DUZ
S XMTEXT="^TMP($J,""RAPM"","
S RASVSUB=XMSUB,RASVTEXT=XMTEXT
I RAANS=1 D
. S XMY("G.RAD PERFORMANCE INDICATOR")=""
. D ^XMD
. K XMY
. Q
I RAANS2=1 D
. S RA1=$O(^RA(79,0)) Q:'RA1
. S XMSUB=RASVSUB,XMTEXT=RASVTEXT
. S RA2=0
.; Outlook mailgroup flagged for HQ should always get automatic mid-
.; mid-month rpt, but only get user-initiated rpt if user specifies so
.;
.; All non-HQ outlook mailgroups get all reports, including autom rpt
.;
. F S RA2=$O(^RA(79,RA1,1,RA2)) Q:'RA2 S RASTR=$G(^(RA2,0)) D
.. I $P(RASTR,U,2)="Y",$G(RAUTOM) S XMY($P(RASTR,U))=""
.. I $P(RASTR,U,2)'="Y" S XMY($P(RASTR,U))=""
.. Q
. Q:'$D(XMY)
. D ^XMD
. K XMY
. Q
K XMDUZ
Q
HDR(RATYP) ; Print appropriate header and process wait and time
U:RAIO IO S RAPG=$G(RAPG)+1
I RAPG>1!($E(IOST,1,2)="C-") W:RAIO @IOF
I $E(IOST,1,2)="P-",(RAPG>1) W:RAIO @IOF
S RAHD(0)=$S(RATYP="S":"Summary",RATYP="D":"Detail",1:"")
S RAHD(0)=RAHD(0)_" Verification Timeliness Report"
S RAIOM=$S(RATYP="S":80,1:IOM)
W:RAIO !?(RAIOM-$L(RAHD(0))\2),RAHD(0),?(RAIOM-10),"Page: ",$G(RAPG),!
I RATYP="S" S RAN=RAN+1 D
. S ^TMP($J,"RAPM",RAN)=" Summary Verification Timeliness Report Page: "_$G(RAPG) S RAN=RAN+1
. S ^TMP($J,"RAPM",RAN)="",RAN=RAN+1
;
S:'$G(DUZ(2)) DUZ(2)=$$KSP^XUPARAM("INST") ;added by p99
D GETS^DIQ(4,DUZ(2),".01;14*;99","E","RAR","RAMSG")
K X
S X(1)=RAR(4,DUZ(2)_",",.01,"E") ; Name of facility
S X(2)=RAR(4,DUZ(2)_",",99,"E") ; Station Number
I $D(RAR(4.014)) D
. S X(3)=RAR(4.014,"1,"_DUZ(2)_",",.01,"E") ; Association
. S X(4)=RAR(4.014,"1,"_DUZ(2)_",",1,"E") ; Parent of Association
. S X(5)=$S(X(3)="VISN":X(4),1:"") ; should be VISN number
E S X(5)=""
;
W:RAIO !,"Facility: ",X(1),?41,"Station: ",X(2),?60,"VISN: ",X(5)
I RATYP="S" D
. S $P(X(6)," ",79)=""
. S $E(X(6),1,(10+$L(X(1))))="Facility: "_X(1)
. S $E(X(6),41,(50+$L(X(2))))="Station: "_X(2)
. S $E(X(6),60,(66+$L(X(5))))="VISN: "_X(5)
. S ^TMP($J,"RAPM",RAN)=X(6)
. S RAN=RAN+1
. Q
W !,"Division: "
I RATYP="S" S ^TMP($J,"RAPM",RAN)="Division: "
D DIV
S:(RATYP="S") RAN=RAN+1
;
W:RAIO !,"Exam Date Range: "
W:RAIO $$FMTE^XLFDT(RABDATE,"2D")," - ",$$FMTE^XLFDT(RAEDATE,"2D")
I RATYP="S" D
.S:'$G(RAP99) ^TMP($J,"RAPM",RAN)=""
.S RAN=RAN+1,^TMP($J,"RAPM",RAN)="Exam Date Range: "_$$FMTE^XLFDT(RABDATE,"2D")_" - "_$$FMTE^XLFDT(RAEDATE,"2D")_" " S RAN=RAN+1
;
W:RAIO !,"Imaging Type(s): "
I RATYP="S",'$G(RAP99) S RAN=RAN+1,^TMP($J,"RAPM",RAN)="",RAN=RAN+1,^TMP($J,"RAPM",RAN)="Imaging Type(s): "
D IMG
S:RATYP="S" RAN=RAN+1
;
; Run date and time
S NOW=$$NOW^XLFDT,NOW=$P(NOW,".",1)_"."_$E($P(NOW,".",2),1,4)
W:RAIO !,"Run Date/Time: ",$$FMTE^XLFDT(NOW,"2P"),!
I RATYP="S" S RAN=RAN+1,^TMP($J,"RAPM",RAN)="Run Date/Time: "_$$FMTE^XLFDT(NOW,"2P"),RAN=RAN+1
I RARAD D
. W:RAIO !,"Primary Interpreting Staff Physician: ",$$GET1^DIQ(200,RARAD,.01),!
. I RATYP="S" D
.. S ^TMP($J,"RAPM",RAN)="",RAN=RAN+1
.. S ^TMP($J,"RAPM",RAN)="Primary Interpreting Staff Physician: "_$$GET1^DIQ(200,RARAD,.01),RAN=RAN+1
.. Q
. Q
I (RARPT="D"!(RARPT="B")),(RATYP'="S") D
. S RASRT=$S(RASORT="C":"Case Number",RASORT="E":"Category of Exam",RASORT="I":"Imaging Type",RASORT="P":"Patient Name",RASORT="R":"Radiologist",RASORT="T":"Hrs to Transcription",RASORT="V":"Hrs to Verification",1:"")
. W:RAIO !,"Sorted by: ",RASRT,?45,"Min. hours elasped to "_$S(RASORT="V":"Verification",1:"Transcription")_": "_RASINCE
Q
DIV ; List selected Division
Q:'$D(^TMP($J,"RA D-TYPE"))
S RADIV="" F I=1:1 S RADIV=$O(^TMP($J,"RA D-TYPE",RADIV)) Q:RADIV="" D
. I $X'>(RAIOM-$L("Division(s): ")) D
. . W:RAIO RADIV_$S($O(^TMP($J,"RA D-TYPE",RADIV))]"":", ",1:"")
. . I RATYP="S" S ^TMP($J,"RAPM",RAN)=^TMP($J,"RAPM",RAN)_RADIV_$S($O(^TMP($J,"RA D-TYPE",RADIV))]"":", ",1:"")
. I $X>(RAIOM-$L("Division(s): ")) D
. . W:RAIO !?($X+$L("Division(s): "))
. . I RATYP="S" S:'$G(RAP99) RAN=RAN+1,^TMP($J,"RAPM",RAN)=" "
Q
IMG ; List selected Imaging Type(s)
Q:'$D(^TMP($J,"RA I-TYPE"))
;N RALMAX,RALUSED,RATAIL,RALDENT
S RALDENT=$L("Imaging Type(s): ")
S RALMAX=RAIOM-RALDENT
S RALUSED=0
S RAIMG="" F J=1:1 S RAIMG=$O(^TMP($J,"RA I-TYPE",RAIMG)) Q:RAIMG="" D
. S RATAIL=$S($O(^TMP($J,"RA I-TYPE",RAIMG))]"":", ",1:"")
. I (RALUSED+$L(RAIMG)+$L(RATAIL))>RALMAX D
.. W:RAIO !?RALDENT
.. I RATYP="S",'$G(RAP99) S RAN=RAN+1,^TMP($J,"RAPM",RAN)=" "
.. S RALUSED=0
.. Q
. W:RAIO RAIMG_RATAIL
. I RATYP="S",'$G(RAP99) S ^TMP($J,"RAPM",RAN)=^TMP($J,"RAPM",RAN)_RAIMG_RATAIL
. S RALUSED=RALUSED+$L(RAIMG)+$L(RATAIL)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRAPM2 10095 printed Sep 23, 2025@20:14:42 Page 2
RAPM2 ;HOIFO/TH-Radiology Performance Monitors/Indicator; ;3/20/04 12:41
+1 ;;5.0;Radiology/Nuclear Medicine;**37,44,48,63,67,99,47**;Mar 16, 1998;Build 21
+2 ; IA 10090 allows Read w/Fileman for entire file 4
+3 ; Supported IA #10103 reference to ^XLFDT
+4 ; Supported IA #2056 reference to ^DIQ
+5 ; Supported IA #2541 reference to KSP^XUPARAM
+6 ; RVD - 3/20/09 p99
+7 ; Print Detail report
DETAIL ; Print Detail report
+1 IF ($Y+5)>IOSL!(RARPT="B")
Begin DoDot:1
+2 IF IO=IO(0)
IF ($EXTRACT(IOST,1,2)="C-")
Begin DoDot:2
+3 READ !,"Press RETURN to continue. ",X:DTIME
End DoDot:2
End DoDot:1
+4 DO HDR("D")
+5 DO PRTTOT
+6 DO DHDR
+7 DO DRPT
if RAXIT
QUIT
+8 DO DFOOT
+9 QUIT
+10 ;
PRTTOT ; Print total number of reports
+1 SET RATOTCNT=+$GET(^TMP($JOB,"RAPM","TOTAL"))
+2 WRITE !,"Total number of reports expected for procedures performed during specified date range: ",$JUSTIFY(RATOTCNT,$LENGTH(RATOTCNT))
+3 QUIT
+4 ;
DHDR ; Header
+1 IF ($Y+5)>IOSL
Begin DoDot:1
+2 SET RAPG=RAPG+1
SET RAHD(0)="Detail Verification Timeliness Report"
+3 WRITE @IOF,!?(RAIOM-$LENGTH(RAHD(0))\2),RAHD(0),?(RAIOM-10),"Page: ",$GET(RAPG)
End DoDot:1
+4 WRITE !!,?34,"Date/Time",?49,"Date/Time",?69,"Date/Time",?102,"Cat"
+5 WRITE ?106,"Rpt",?110,"Img",?116,"Procedure"
+6 WRITE !,"Patient Name",?17,"Case #",?34,"Registered",?49,"Transcribed",?63,"Hrs"
+7 WRITE ?69,"Verified",?83,"Hrs",?88,"Radiologist",?102,"Exm",?106,"Sts"
+8 WRITE ?110,"Typ",?119,"Name",!
+9 QUIT
+10 ;
DRPT ; Read records
+1 SET RAXIT=0
+2 IF '$DATA(^TMP($JOB,"RAPM2"))
WRITE !!?30,"No data to print...",!!!!!
QUIT
+3 SET D1=""
FOR
SET D1=$ORDER(^TMP($JOB,"RAPM2",D1))
if D1=""
QUIT
if RAXIT
QUIT
Begin DoDot:1
+4 SET D2=""
FOR
SET D2=$ORDER(^TMP($JOB,"RAPM2",D1,D2))
if D2=""
QUIT
if RAXIT
QUIT
Begin DoDot:2
+5 SET D3=""
FOR
SET D3=$ORDER(^TMP($JOB,"RAPM2",D1,D2,D3))
if D3=""
QUIT
if RAXIT
QUIT
Begin DoDot:3
+6 DO SRT
End DoDot:3
End DoDot:2
End DoDot:1
+7 QUIT
+8 ;
SRT ; Read records
+1 IF RASORT="C"!(RASORT="P")
SET RAREC=$GET(^TMP($JOB,"RAPM2",D1,D2,D3))
DO DET
QUIT
+2 SET D4=""
FOR
SET D4=$ORDER(^TMP($JOB,"RAPM2",D1,D2,D3,D4))
if D4=""
QUIT
if RAXIT
QUIT
Begin DoDot:1
+3 SET RAREC=$GET(^TMP($JOB,"RAPM2",D1,D2,D3,D4))
DO DET
End DoDot:1
+4 QUIT
+5 ;
DET ; Print detail records
+1 ; use Transcription elasped hr for all sorts, except if sort by Verif.
+2 SET RAVAL=$SELECT(RASORT="V":$PIECE(RAREC,U,13),1:$PIECE(RAREC,U,12))
+3 ; remove symbols before comparison
+4 if $EXTRACT(RAVAL)="<"
SET RAVAL=.5
if $EXTRACT(RAVAL)=">"
SET RAVAL=999
+5 ; include PENDING and those with hours > RASINCE
+6 IF RAVAL'=""
IF RAVAL<RASINCE
QUIT
+7 IF ($Y+5)>IOSL
Begin DoDot:1
+8 IF IO=IO(0)
Begin DoDot:2
+9 IF $EXTRACT(IOST,1,2)="C-"
READ !,"Press RETURN to continue or ""^"" to exit. ",X:DTIME
if X="^"
SET RAXIT=1
End DoDot:2
+10 if RAXIT
QUIT
+11 DO DHDR
End DoDot:1
+12 if RAXIT
QUIT
+13 WRITE !,$EXTRACT($PIECE(RAREC,U,2),1,14)
+14 WRITE ?16,$PIECE(RAREC,U,1)
+15 WRITE ?33,$PIECE($$FMTE^XLFDT($PIECE(RAREC,U,3),"2FS"),":",1,2)
+16 WRITE ?48,$PIECE($$FMTE^XLFDT($PIECE(RAREC,U,4),"2FS"),":",1,2),?63,$JUSTIFY($PIECE(RAREC,U,12),4)
+17 WRITE ?68,$PIECE($$FMTE^XLFDT($PIECE(RAREC,U,5),"2FS"),":",1,2),?82,$JUSTIFY($PIECE(RAREC,U,13),4)
+18 IF $PIECE(RAREC,U,6)'=""
WRITE ?88,$EXTRACT($PIECE(RAREC,U,6),1,14)
+19 WRITE ?104,$PIECE(RAREC,U,7),?107,$PIECE(RAREC,U,8)
+20 WRITE ?110,$EXTRACT($PIECE(RAREC,U,9),1,3),?114,$EXTRACT($PIECE(RAREC,U,14),1,15)
+21 if $PIECE(RAREC,U,11)=""
WRITE ?130,"*D"
+22 QUIT
+23 ;
+1 IF ($Y+5)>IOSL
Begin DoDot:1
+2 IF IO=IO(0)
Begin DoDot:2
+3 IF $EXTRACT(IOST,1,2)="C-"
READ !,"Press RETURN to continue. ",X:DTIME
End DoDot:2
+4 DO DHDR
End DoDot:1
+5 WRITE !!,"Note: Category of Exam: 'I' for Inpatient; 'O' for Outpatient; "
+6 WRITE "'C' for Contract; 'S' for Sharing; 'E' for Employee; 'R' for Research"
+7 WRITE !," Report Status: 'V' for Verififed; 'R' for Released/Not "
+8 WRITE "Verified; 'PD' for Problem Draft; 'D' for Draft"
+9 if RANODIV
WRITE !," *D = Division is missing"
+10 WRITE !!?5,"* A printset, i.e., a set of multiple exams that share the same report, will be expected to have 1 report."
+11 WRITE !!?5,"* Cancelled and ""No Credit"" cases are excluded from this report."
+12 QUIT
+13 ;
STORE ; Store detail information
+1 if RARPT="S"
QUIT
+2 ; for storage subscript: if no rpt dt, set to neg
+3 SET RADHT=$SELECT(RARPTDT="":-1,1:RATDFHR)
+4 SET RADHV=$SELECT(RAVERDT="":-1,1:RAVDFHR)
+5 ; for display: truncate decimal portion of hours
+6 if RATDFHR'=""
SET RATDFHR=RATDFHR\1
+7 if RAVDFHR'=""
SET RAVDFHR=RAVDFHR\1
+8 SET RATDFHR=$SELECT(RATDFHR="":"",RATDFHR<1:"<1",RATDFHR>999:">999",1:RATDFHR)
+9 SET RAVDFHR=$SELECT(RAVDFHR="":"",RAVDFHR<1:"<1",RAVDFHR>999:">999",1:RAVDFHR)
+10 ;
+11 IF $$USESSAN^RAHLRU1()
SET RAREC1=RACNDSP_U_RAPATNM_U_RADTE_U_RARPTDT_U
+12 IF '$$USESSAN^RAHLRU1()
SET RAREC1=RACN_U_RAPATNM_U_RADTE_U_RARPTDT_U
+13 SET RAREC1=RAREC1_RAVERDT_U_RAPRIMNM_U_RACAT_U_RARPTST_U_RAIMGTYP_U
+14 SET RAREC1=RAREC1_RADFN_U_RACHKDIV_U_RATDFHR_U_RAVDFHR_U_RAPRCN
+15 ;
+16 IF RASORT="C"
SET ^TMP($JOB,"RAPM2",$PIECE(RADTE,"."),RACN,RAPATNM)=RAREC1
+17 IF RASORT="P"
SET ^TMP($JOB,"RAPM2",RAPATNM,$PIECE(RADTE,"."),RACN)=RAREC1
+18 IF RASORT="I"
SET ^TMP($JOB,"RAPM2",RAIMGTYP,$PIECE(RADTE,"."),RACN,RAPATNM)=RAREC1
+19 IF RASORT="E"
SET ^TMP($JOB,"RAPM2",RACAT,$PIECE(RADTE,"."),RACN,RAPATNM)=RAREC1
+20 IF RASORT="R"
SET ^TMP($JOB,"RAPM2",RAPRIMNM,$PIECE(RADTE,"."),RACN,RAPATNM)=RAREC1
+21 IF RASORT="T"
SET ^TMP($JOB,"RAPM2",RADHT,RADTE,RACN,RAPATNM)=RAREC1
+22 IF RASORT="V"
SET ^TMP($JOB,"RAPM2",RADHV,RADTE,RACN,RAPATNM)=RAREC1
+23 QUIT
EMAIL ; Ask if ready to email the summary report
+1 NEW RA1
+2 WRITE !
SET DIR(0)="Y"
+3 SET DIR("A")="Send summary report to local mail group ""G.RAD PERFORMANCE INDICATOR"""
+4 SET DIR("B")="Yes"
+5 DO ^DIR
+6 if $DATA(DIRUT)
QUIT
+7 SET RAANS=Y
+8 SET RA1=$ORDER(^RA(79,0))
if 'RA1
QUIT
+9 IF '$ORDER(^RA(79,RA1,1,0))
Begin DoDot:1
+10 WRITE !!,?5,"No OUTLOOK mail group(s) have been entered yet."
+11 QUIT
End DoDot:1
QUIT
+12 WRITE !
SET DIR(0)="Y"
+13 SET DIR("A")="Send summary report to OUTLOOK mail group(s)"
+14 SET DIR("B")="Yes"
+15 DO ^DIR
+16 SET RAANS2=Y
+17 IF RAANS2
DO CKMONTH^RAPM4
+18 QUIT
SEND ; Send summary report to mail group
+1 IF RAANS=0
IF RAANS2=0
QUIT
+2 NEW RA1,RA2,RASVSUB,RASVTEXT,RASTR
+3 if $GET(RAP99)
SET XMSUB="Radiology Timeliness Performance Reports"
+4 if '$GET(RAP99)
SET XMSUB="Radiology Summary Verification Timeliness"
+5 SET XMDUZ=DUZ
+6 SET XMTEXT="^TMP($J,""RAPM"","
+7 SET RASVSUB=XMSUB
SET RASVTEXT=XMTEXT
+8 IF RAANS=1
Begin DoDot:1
+9 SET XMY("G.RAD PERFORMANCE INDICATOR")=""
+10 DO ^XMD
+11 KILL XMY
+12 QUIT
End DoDot:1
+13 IF RAANS2=1
Begin DoDot:1
+14 SET RA1=$ORDER(^RA(79,0))
if 'RA1
QUIT
+15 SET XMSUB=RASVSUB
SET XMTEXT=RASVTEXT
+16 SET RA2=0
+17 ; Outlook mailgroup flagged for HQ should always get automatic mid-
+18 ; mid-month rpt, but only get user-initiated rpt if user specifies so
+19 ;
+20 ; All non-HQ outlook mailgroups get all reports, including autom rpt
+21 ;
+22 FOR
SET RA2=$ORDER(^RA(79,RA1,1,RA2))
if 'RA2
QUIT
SET RASTR=$GET(^(RA2,0))
Begin DoDot:2
+23 IF $PIECE(RASTR,U,2)="Y"
IF $GET(RAUTOM)
SET XMY($PIECE(RASTR,U))=""
+24 IF $PIECE(RASTR,U,2)'="Y"
SET XMY($PIECE(RASTR,U))=""
+25 QUIT
End DoDot:2
+26 if '$DATA(XMY)
QUIT
+27 DO ^XMD
+28 KILL XMY
+29 QUIT
End DoDot:1
+30 KILL XMDUZ
+31 QUIT
HDR(RATYP) ; Print appropriate header and process wait and time
+1 if RAIO
USE IO
SET RAPG=$GET(RAPG)+1
+2 IF RAPG>1!($EXTRACT(IOST,1,2)="C-")
if RAIO
WRITE @IOF
+3 IF $EXTRACT(IOST,1,2)="P-"
IF (RAPG>1)
if RAIO
WRITE @IOF
+4 SET RAHD(0)=$SELECT(RATYP="S":"Summary",RATYP="D":"Detail",1:"")
+5 SET RAHD(0)=RAHD(0)_" Verification Timeliness Report"
+6 SET RAIOM=$SELECT(RATYP="S":80,1:IOM)
+7 if RAIO
WRITE !?(RAIOM-$LENGTH(RAHD(0))\2),RAHD(0),?(RAIOM-10),"Page: ",$GET(RAPG),!
+8 IF RATYP="S"
SET RAN=RAN+1
Begin DoDot:1
+9 SET ^TMP($JOB,"RAPM",RAN)=" Summary Verification Timeliness Report Page: "_$GET(RAPG)
SET RAN=RAN+1
+10 SET ^TMP($JOB,"RAPM",RAN)=""
SET RAN=RAN+1
End DoDot:1
+11 ;
+12 ;added by p99
if '$GET(DUZ(2))
SET DUZ(2)=$$KSP^XUPARAM("INST")
+13 DO GETS^DIQ(4,DUZ(2),".01;14*;99","E","RAR","RAMSG")
+14 KILL X
+15 ; Name of facility
SET X(1)=RAR(4,DUZ(2)_",",.01,"E")
+16 ; Station Number
SET X(2)=RAR(4,DUZ(2)_",",99,"E")
+17 IF $DATA(RAR(4.014))
Begin DoDot:1
+18 ; Association
SET X(3)=RAR(4.014,"1,"_DUZ(2)_",",.01,"E")
+19 ; Parent of Association
SET X(4)=RAR(4.014,"1,"_DUZ(2)_",",1,"E")
+20 ; should be VISN number
SET X(5)=$SELECT(X(3)="VISN":X(4),1:"")
End DoDot:1
+21 IF '$TEST
SET X(5)=""
+22 ;
+23 if RAIO
WRITE !,"Facility: ",X(1),?41,"Station: ",X(2),?60,"VISN: ",X(5)
+24 IF RATYP="S"
Begin DoDot:1
+25 SET $PIECE(X(6)," ",79)=""
+26 SET $EXTRACT(X(6),1,(10+$LENGTH(X(1))))="Facility: "_X(1)
+27 SET $EXTRACT(X(6),41,(50+$LENGTH(X(2))))="Station: "_X(2)
+28 SET $EXTRACT(X(6),60,(66+$LENGTH(X(5))))="VISN: "_X(5)
+29 SET ^TMP($JOB,"RAPM",RAN)=X(6)
+30 SET RAN=RAN+1
+31 QUIT
End DoDot:1
+32 WRITE !,"Division: "
+33 IF RATYP="S"
SET ^TMP($JOB,"RAPM",RAN)="Division: "
+34 DO DIV
+35 if (RATYP="S")
SET RAN=RAN+1
+36 ;
+37 if RAIO
WRITE !,"Exam Date Range: "
+38 if RAIO
WRITE $$FMTE^XLFDT(RABDATE,"2D")," - ",$$FMTE^XLFDT(RAEDATE,"2D")
+39 IF RATYP="S"
Begin DoDot:1
+40 if '$GET(RAP99)
SET ^TMP($JOB,"RAPM",RAN)=""
+41 SET RAN=RAN+1
SET ^TMP($JOB,"RAPM",RAN)="Exam Date Range: "_$$FMTE^XLFDT(RABDATE,"2D")_" - "_$$FMTE^XLFDT(RAEDATE,"2D")_" "
SET RAN=RAN+1
End DoDot:1
+42 ;
+43 if RAIO
WRITE !,"Imaging Type(s): "
+44 IF RATYP="S"
IF '$GET(RAP99)
SET RAN=RAN+1
SET ^TMP($JOB,"RAPM",RAN)=""
SET RAN=RAN+1
SET ^TMP($JOB,"RAPM",RAN)="Imaging Type(s): "
+45 DO IMG
+46 if RATYP="S"
SET RAN=RAN+1
+47 ;
+48 ; Run date and time
+49 SET NOW=$$NOW^XLFDT
SET NOW=$PIECE(NOW,".",1)_"."_$EXTRACT($PIECE(NOW,".",2),1,4)
+50 if RAIO
WRITE !,"Run Date/Time: ",$$FMTE^XLFDT(NOW,"2P"),!
+51 IF RATYP="S"
SET RAN=RAN+1
SET ^TMP($JOB,"RAPM",RAN)="Run Date/Time: "_$$FMTE^XLFDT(NOW,"2P")
SET RAN=RAN+1
+52 IF RARAD
Begin DoDot:1
+53 if RAIO
WRITE !,"Primary Interpreting Staff Physician: ",$$GET1^DIQ(200,RARAD,.01),!
+54 IF RATYP="S"
Begin DoDot:2
+55 SET ^TMP($JOB,"RAPM",RAN)=""
SET RAN=RAN+1
+56 SET ^TMP($JOB,"RAPM",RAN)="Primary Interpreting Staff Physician: "_$$GET1^DIQ(200,RARAD,.01)
SET RAN=RAN+1
+57 QUIT
End DoDot:2
+58 QUIT
End DoDot:1
+59 IF (RARPT="D"!(RARPT="B"))
IF (RATYP'="S")
Begin DoDot:1
+60 SET RASRT=$SELECT(RASORT="C":"Case Number",RASORT="E":"Category of Exam",RASORT="I":"Imaging Type",RASORT="P":"Patient Name",RASORT="R":"Radiologist",RASORT="T":"Hrs to Transcription",RASORT="V":"Hrs to Verification",1:"")
+61 if RAIO
WRITE !,"Sorted by: ",RASRT,?45,"Min. hours elasped to "_$SELECT(RASORT="V":"Verification",1:"Transcription")_": "_RASINCE
End DoDot:1
+62 QUIT
DIV ; List selected Division
+1 if '$DATA(^TMP($JOB,"RA D-TYPE"))
QUIT
+2 SET RADIV=""
FOR I=1:1
SET RADIV=$ORDER(^TMP($JOB,"RA D-TYPE",RADIV))
if RADIV=""
QUIT
Begin DoDot:1
+3 IF $X'>(RAIOM-$LENGTH("Division(s): "))
Begin DoDot:2
+4 if RAIO
WRITE RADIV_$SELECT($ORDER(^TMP($JOB,"RA D-TYPE",RADIV))]"":", ",1:"")
+5 IF RATYP="S"
SET ^TMP($JOB,"RAPM",RAN)=^TMP($JOB,"RAPM",RAN)_RADIV_$SELECT($ORDER(^TMP($JOB,"RA D-TYPE",RADIV))]"":", ",1:"")
End DoDot:2
+6 IF $X>(RAIOM-$LENGTH("Division(s): "))
Begin DoDot:2
+7 if RAIO
WRITE !?($X+$LENGTH("Division(s): "))
+8 IF RATYP="S"
if '$GET(RAP99)
SET RAN=RAN+1
SET ^TMP($JOB,"RAPM",RAN)=" "
End DoDot:2
End DoDot:1
+9 QUIT
IMG ; List selected Imaging Type(s)
+1 if '$DATA(^TMP($JOB,"RA I-TYPE"))
QUIT
+2 ;N RALMAX,RALUSED,RATAIL,RALDENT
+3 SET RALDENT=$LENGTH("Imaging Type(s): ")
+4 SET RALMAX=RAIOM-RALDENT
+5 SET RALUSED=0
+6 SET RAIMG=""
FOR J=1:1
SET RAIMG=$ORDER(^TMP($JOB,"RA I-TYPE",RAIMG))
if RAIMG=""
QUIT
Begin DoDot:1
+7 SET RATAIL=$SELECT($ORDER(^TMP($JOB,"RA I-TYPE",RAIMG))]"":", ",1:"")
+8 IF (RALUSED+$LENGTH(RAIMG)+$LENGTH(RATAIL))>RALMAX
Begin DoDot:2
+9 if RAIO
WRITE !?RALDENT
+10 IF RATYP="S"
IF '$GET(RAP99)
SET RAN=RAN+1
SET ^TMP($JOB,"RAPM",RAN)=" "
+11 SET RALUSED=0
+12 QUIT
End DoDot:2
+13 if RAIO
WRITE RAIMG_RATAIL
+14 IF RATYP="S"
IF '$GET(RAP99)
SET ^TMP($JOB,"RAPM",RAN)=^TMP($JOB,"RAPM",RAN)_RAIMG_RATAIL
+15 SET RALUSED=RALUSED+$LENGTH(RAIMG)+$LENGTH(RATAIL)
End DoDot:1
+16 QUIT
