RAPM3 ;HOIFO/SM-Radiology Performance Monitors/Indicator ;3/20/09 11:11
;;5.0;Radiology/Nuclear Medicine;**37,44,63,67,99**;Mar 16, 1998;Build 5
; IA #11090 allows Fileman read of Entire file 4
; Supported IA #10103 reference to ^XLFDT
; Supported IA #10000 reference to C^%DTC
; Supported IA #2056 reference to ^DIQ
; Supported IA #10142 reference to EN^DDIOL
; RVD - 9/19/09 p99
Q
EN1 ;entry/edit OUTLOOK mail groups
N RA1,RA2
S RA1=$O(^RA(79,0)) Q:'RA1
I $O(^RA(79,RA1,1,0)) D
. W !?5,"OUTLOOK mail groups previously entered:",!?56,"OQP Perf. Mgmt?",!?56,"--------------"
. S RA2=0
. F S RA2=$O(^RA(79,RA1,1,RA2)) Q:'RA2 W !?8,$P(^(RA2,0),U),?63,$P(^(0),U,2)
. Q
W !!?5,"You may add another mail group."
W !,?5,"To edit or replace a mail group, you must delete the old one first.",!
L +^RA(79,RA1,1):1 I '$T W !,$C(7),"Can't lock ^RA,",RA1,",1) now, try again later." Q
S DIE="^RA(79,",DA=RA1,DR="175"
D ^DIE
L -^RA(79,RA1,1)
Q
TASKLM ; task off last quarters's Perf. Indic. Summary Report [RA PERFORMIN TASKLM]
; define report type as summary
N RA1,RA2,RA3,RABDATE,RAEDATE,RADAYS,RAENDDT,RABEGDT,RAUTOM,RALASTM,RAP99,RADAY,DIR
N M1,M2,X1,X2,Y1,Y2
; RALASTM flags this option RA PERFORMIN TASKLM, queued or interactive
S (RA3,RAP99,RALASTM)=1
; if tasked here, set RAUTOM to flag automatic queued mid-month report for the last quarter
I $D(ZTQUEUED) S RAUTOM=1
; if interactive, display Outlook mail groups and ask if continue
I '$D(ZTQUEUED) D I 'RA3 W !!?5,"** Nothing Done **" Q
. W !!?5,"The Summary Report of Last Quarter's data will be sent to the"
. W !?5,"Outlook mail group(s) in File 79's PERF INDC SMTP E-MAIL ADDRESS",!
. S RA1=$O(^RA(79,0))
. I '$O(^RA(79,RA1,1,0)) S RA3=0 W !?5,"** There is no Outlook mail group defined in File 79's",!?8,"PERF INDC SMTP E-MAIL ADDRESS. **",! Q
. S RA2=0
. F S RA2=$O(^RA(79,RA1,1,RA2)) Q:'RA2 W !?3,$P(^(RA2,0),U)
. W !
. ; ask Task Start Time
. D RA2DT ;get ending date for a task range, RA2 variable .
. S DIR(0)="D^"_DT_":"_RA2_":AEX"
. S DIR("A",1)=" Enter date to start this Task"
. S DIR("A")=" (time will be the same hh:mm as now.)"
. S DIR("?",1)="The Task date must be at least 11 days from the beginning of this quarter"
. S DIR("?",2)="through 10 days after the end of this quarter, based upon calendar quarters:"
. S DIR("?",3)=""
. S DIR("?",4)="Report Data Qtr: Task Date Range:"
. S DIR("?",5)="First Quarter Mar 11 - Jul 10"
. S DIR("?",6)="Second Quarter Jul 11 - Oct 10"
. S DIR("?",7)="Third Quarter Oct 11 - Jan 10"
. S DIR("?")="Fourth Quarter Jan 11 - Apr 10"
. D ^DIR
. I $D(DIRUT) S RA3=0 Q
. S ZTDTH=Y_"."_$P(($$NOW^XLFDT),".",2)
. Q
;
; define LAST QUARTER'S begin and end dates
S (Y1,Y2,RAQTRYR)=$E(DT,1,3),RAM1=$E(DT,4,5),RADAY=$E(DT,6,7) ; current yr, month, day
; if background job, only run on 1st, 4th, 7th and 10th after the 10th day,
; so that background job will not run multiple times per quarter. This process
; can still be initiated by a user anytime, automatically process the previous quarter
; and date range not more than 92 days.
I $D(ZTQUEUED),('$S(RAM1="01":1,RAM1="04":1,RAM1="07":1,RAM1=10:1,1:0)!(RADAY<11)) Q
K ^TMP($J)
S RARAD="" ; all radiologists
S RARPT="S",RAANS=0,RAANS2=1 ; summary, no local mail, send Outlook mail
S RAPQTR=$S(RAM1>9:3,RAM1>6:2,RAM1>3:1,1:4) ;get quarter to process report
S M1=$S(RAM1>9:10,RAM1>6:"07",RAM1>3:"04",1:"01") ;get beg month of the next quarter
S M2=$S(RAPQTR=4:10,RAPQTR=3:"07",RAPQTR=2:"04",1:"01")
S:RAPQTR=4 Y2=Y1-1
I (RAM1=10)&(RADAY<11)!(RAM1="07")&(RADAY<11)!(RAM1="04")&(RADAY<11)!(RAM1="01")&(RADAY<11) D
.S M1=$S(RAM1=10:"07",RAM1="07":"04",RAM1="04":"01",1:10)
.S M2=$S(RAPQTR=4:"07",RAPQTR=3:"04",RAPQTR=2:"01",1:10)
.S Y2=$S(RAPQTR=1:Y1-1,1:Y1)
S RA1=Y1_M1_"01" ; Current year and quarter's 1st day of month
S RABDATE=Y2_M2_"01" ; Begin date for last quarter's first month
S X1=RA1,X2=RABDATE D ^%DTC S RADAYS=X ; No. days in last month
S X2=(RADAYS-1),X1=RABDATE D C^%DTC S RAEDATE=X ; End date last month
S (RAEDTSV,RAENDDT)=RAEDATE_.9999 ; convert for search loop
S (RABDTSV,RABEGDT)=(RABDATE-1)_.9999 ; convert for search loop
; define divisions that have at least 1 active img loc
S RA1=0
F S RA1=$O(^RA(79,RA1)) Q:'RA1 D
. S RA2=0
. ;if div has at least 1 active img loc, then store div in ^tmp
. F S RA2=$O(^RA(79,RA1,"L",RA2)) Q:'RA2 I $D(^(RA2,0)),$P($G(^RA(79.1,+^(0),0)),U,19)="" S RA3=$$GET1^DIQ(4,RA1,.01),^TMP($J,"RA D-TYPE",RA3,RA1)="" Q
; define imaging types if not vascular lab but has file 79.1 BIMG xref
S RA1=0
F S RA1=$O(^RA(79.2,RA1)) Q:'RA1 D
. I $D(^RA(79.2,RA1,0)) S RA2=$P(^(0),U) I RA2'["VASCULAR LAB",$D(^RA(79.1,"BIMG",RA1)) S ^TMP($J,"RA I-TYPE",RA2,RA1)=""
; task job
S ZTIO=""
D TASK^RAPM
S X1=ZTDESC,X2=ZTDTH ; save taskman vars
D ^%ZTLOAD
I +$G(ZTSK("D"))>0,$D(ZTSK) D
. W !?5,$C(7),"Request queued: ",X1
. W !?5,"to start on: ",$$FMTE^XLFDT(X2)
. W !?5,"Task #: "_$G(ZTSK)
K ^TMP($J)
K RAANS,RAANS2,RABDTSV,RAEDTSV,RAM1,RAPQTR,RAQTRYR,RARAD,RARPT,RAP99 ;added in p99
Q
RESCH ; reschedule option that is in file 19.2
N RABY,RADT,RAERR,RAWHEN,RAFLAG
N D1,M1,Y1,M2,Y2,X
; RAFLAG="" determines if allow LAYGO to file 19.2, if the option "RA
; PERFORMIN TASKLM" was installed in file 19.2, RAFLAG = "",
; if not installed, then RAFLAG = "L"
S RAFLAG=""
; get task status of option
D OPTSTAT^XUTMOPT("RA PERFORMIN TASKLM",.RAR)
I $P($G(RAR(1)),U) D EN^DDIOL("** Option RA PERFORMIN TASKLM is already scheduled, so nothing done. **",,"!!?5") D PRESS Q
I '$D(RAR(1)) D
. D EN^DDIOL("** Option RA PERFORMIN TASKLM has not been installed into file 19.2 **",,"!!?5")
. D EN^DDIOL("** will install it into file 19.2 now. **",,"!!?5")
. S RAFLAG="L"
. Q
; task the option that seems to be lost from the task queue
D SET15
D EN^DDIOL("Now scheduling RA PERFORMIN TASKLM to run on: ",,"!!?5")
D RESCH^XUTMOPT("RA PERFORMIN TASKLM",RAWHEN,,RABY,RAFLAG,.RAERR)
D OPTSTAT^XUTMOPT("RA PERFORMIN TASKLM",.RAR)
I $D(RAR(1))#2 D EN^DDIOL("Task number : "_+RAR(1),,"!!?37")
D PRESS
Q
PRESS R !!?5,"Press RETURN to continue. ",X:DTIME
Q
SET15 ; set some variables for scheduling task
S Y1=$E(DT,1,3),M1=$E(DT,4,5),D1=$E(DT,6,7)
S Y2=$S(M1="12":Y1+1,1:Y1),M2=$S(M1="12":"01",1:M1+1)
S:$L(M2)=1 M2="0"_M2
D:D1=15 TODAY D:D1<15 THISM D:D1>15 NEXTM
S RAWHEN=$$FMADD^XLFDT(RADT,,,5) ; add 5 mins to scheduled date
S RABY="1M(15)" ; every month on the 15th day
Q
TODAY ; today is the 15th
S RADT=$$NOW^XLFDT
Q
THISM ; this month on the 15th
S RADT=Y1_M1_"15."_$P(($$NOW^XLFDT),".",2)
Q
NEXTM ; next month on the 15th
S RADT=Y2_M2_"15."_$P(($$NOW^XLFDT),".",2)
Q
G:'RAIO SFOOT2
I ($Y+5)>IOSL,IO=IO(0) D
. I $E(IOST,1,2)="C-" R !,"Press RETURN to continue.",X:DTIME
. S RAPG=RAPG+1,RAHDR="Summary Verification Timeliness Report"
. W @IOF,!?(RAIOM-$L(RAHDR)\2),RAHDR,?(RAIOM-10),"Page: ",$G(RAPG)
W !!?5,"* Columns represent # of hours elapsed from exam date/time through",!?7,"date/time report entered or date/time report was verified."
W !?7,"e.g. "">0-24 Hrs"" column represents those exams that had a report"
W !?7,"transcribed and/or verified within 0-24 hours from the exam date/time."
W !!?5,"* Columns following the initial elapsed time column "">0-24 Hrs"" begin"
W !?7,"at .0001 after the starting hour (e.g. "">24-48 Hrs"" = starts at 24.001",!?7,"through the 48th hour.)",!
W !?5,"* PENDING means there's no data for DATE REPORT ENTERED or VERIFIED DATE."
W !?7,"So, if the expected report is missing one of these fields, or is missing"
W !?7,"data for fields .01 through 17 from file #74, RAD/NUC MED REPORTS, or"
W !?7,"is a Stub Report that was entered by the Imaging package when images"
W !?7,"were captured before a report was entered, then the expected report"
W !?7,"would be counted in the PENDING column."
;
S (^TMP($J,"RAPM",RAN),^TMP($J,"RAPM",RAN+1))="",RAN=RAN+1
;
S ^TMP($J,"RAPM",RAN)=" * Columns represent # of hours elapsed from exam date/time through",RAN=RAN+1
S ^TMP($J,"RAPM",RAN)=" date/time report entered or date/time report was verified.",RAN=RAN+1
S ^TMP($J,"RAPM",RAN)=" e.g. "">0-24 Hrs"" column represents those exams that had a report",RAN=RAN+1
S ^TMP($J,"RAPM",RAN)=" transcribed and/or verified within 0-24 hours from the exam date/time.",RAN=RAN+1
S ^TMP($J,"RAPM",RAN)="",RAN=RAN+1
S ^TMP($J,"RAPM",RAN)=" * Columns following the initial elapsed time column (0-24 Hrs) begin",RAN=RAN+1
S ^TMP($J,"RAPM",RAN)=" at .0001 after the starting hour (e.g. "">24-48 Hrs"" = starts at 24.001",RAN=RAN+1
S ^TMP($J,"RAPM",RAN)=" through the 48th hour.)",RAN=RAN+1
S ^TMP($J,"RAPM",RAN)="",RAN=RAN+1
S ^TMP($J,"RAPM",RAN)=" * PENDING means there's no data for DATE REPORT ENTERED or VERIFIED DATE.",RAN=RAN+1
S ^TMP($J,"RAPM",RAN)=" So, if the expected report is missing one of these fields, or is missing",RAN=RAN+1
S ^TMP($J,"RAPM",RAN)=" data for fields .01 through 17 from file #74, RAD/NUC MED REPORTS, or",RAN=RAN+1
S ^TMP($J,"RAPM",RAN)=" is a Stub Report that was entered by the Imaging package when images",RAN=RAN+1
S ^TMP($J,"RAPM",RAN)=" were captured before a report was entered, then the expected report",RAN=RAN+1
S ^TMP($J,"RAPM",RAN)=" would be counted in the PENDING column."
D BFOOT
Q
G:'RAIO BFOOT2
W !!?5,"* A printset, i.e., a set of multiple exams that share the same report,",!?7,"will be expected to have 1 report."
W !!?5,"* Cancelled and ""No Credit"" cases are excluded from this report."
Q:'$G(RAN)
S RAN=RAN+1
S ^TMP($J,"RAPM",RAN)="",RAN=RAN+1
S ^TMP($J,"RAPM",RAN)=" * A printset, i.e., a set of multiple exams that share the same report,",RAN=RAN+1
S ^TMP($J,"RAPM",RAN)=" will be expected to have 1 report.",RAN=RAN+1
S ^TMP($J,"RAPM",RAN)="",RAN=RAN+1
S ^TMP($J,"RAPM",RAN)=" * Cancelled and ""No Credit"" cases are excluded from this report."
Q
RADIOL ; select Radiologist for Summary Report
W !
S DIC("S")="I $D(^VA(200,""ARC"",""R"",Y))!($D(^VA(200,""ARC"",""S"",Y)))",DIC("A")="Select Primary Interpreting Staff Physician (Optional): ",DIC="^VA(200,",DIC(0)="AEMQ" D ^DIC K DIC Q:Y<0 S RARAD=+Y
Q
RA2DT ;SET RA2 variable for task date range
N RADTNW
S Y1=$E(DT,1,3),M1=$E(DT,4,5),RADTNW=$E(DT,6,7)
S Y2=$S((M1="11")!(M1="12"):Y1+1,1:Y1)
S:(M1="10")&(RADTNW>10) Y2=Y1+1
;
S:(M1="01")&(RADTNW<11) RA2=Y2_"01"_10
S:(M1="01")&(RADTNW>10) RA2=Y2_"04"_10
S:(M1="02")!(M1="03") RA2=Y2_"04"_10
;
S:(M1="04")&(RADTNW<11) RA2=Y2_"04"_10
S:(M1="04")&(RADTNW>10) RA2=Y2_"07"_10
S:(M1="05")!(M1="06") RA2=Y2_"07"_10
;
S:(M1="07")&(RADTNW<11) RA2=Y2_"07"_10
S:(M1="07")&(RADTNW>10) RA2=Y2_10_10
S:(M1="08")!(M1="09") RA2=Y2_10_10
;
S:(M1="10")&(RADTNW<11) RA2=Y2_10_10
S:(M1="10")&(RADTNW>10) RA2=Y2_"01"_10
S:(M1=11)!(M1=12) RA2=Y2_"01"_10
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRAPM3 11293 printed Apr 09, 2024@21:36:16 Page 2
RAPM3 ;HOIFO/SM-Radiology Performance Monitors/Indicator ;3/20/09 11:11
+1 ;;5.0;Radiology/Nuclear Medicine;**37,44,63,67,99**;Mar 16, 1998;Build 5
+2 ; IA #11090 allows Fileman read of Entire file 4
+3 ; Supported IA #10103 reference to ^XLFDT
+4 ; Supported IA #10000 reference to C^%DTC
+5 ; Supported IA #2056 reference to ^DIQ
+6 ; Supported IA #10142 reference to EN^DDIOL
+7 ; RVD - 9/19/09 p99
+8 QUIT
EN1 ;entry/edit OUTLOOK mail groups
+1 NEW RA1,RA2
+2 SET RA1=$ORDER(^RA(79,0))
if 'RA1
QUIT
+3 IF $ORDER(^RA(79,RA1,1,0))
Begin DoDot:1
+4 WRITE !?5,"OUTLOOK mail groups previously entered:",!?56,"OQP Perf. Mgmt?",!?56,"--------------"
+5 SET RA2=0
+6 FOR
SET RA2=$ORDER(^RA(79,RA1,1,RA2))
if 'RA2
QUIT
WRITE !?8,$PIECE(^(RA2,0),U),?63,$PIECE(^(0),U,2)
+7 QUIT
End DoDot:1
+8 WRITE !!?5,"You may add another mail group."
+9 WRITE !,?5,"To edit or replace a mail group, you must delete the old one first.",!
+10 LOCK +^RA(79,RA1,1):1
IF '$TEST
WRITE !,$CHAR(7),"Can't lock ^RA,",RA1,",1) now, try again later."
QUIT
+11 SET DIE="^RA(79,"
SET DA=RA1
SET DR="175"
+12 DO ^DIE
+13 LOCK -^RA(79,RA1,1)
+14 QUIT
TASKLM ; task off last quarters's Perf. Indic. Summary Report [RA PERFORMIN TASKLM]
+1 ; define report type as summary
+2 NEW RA1,RA2,RA3,RABDATE,RAEDATE,RADAYS,RAENDDT,RABEGDT,RAUTOM,RALASTM,RAP99,RADAY,DIR
+3 NEW M1,M2,X1,X2,Y1,Y2
+4 ; RALASTM flags this option RA PERFORMIN TASKLM, queued or interactive
+5 SET (RA3,RAP99,RALASTM)=1
+6 ; if tasked here, set RAUTOM to flag automatic queued mid-month report for the last quarter
+7 IF $DATA(ZTQUEUED)
SET RAUTOM=1
+8 ; if interactive, display Outlook mail groups and ask if continue
+9 IF '$DATA(ZTQUEUED)
Begin DoDot:1
+10 WRITE !!?5,"The Summary Report of Last Quarter's data will be sent to the"
+11 WRITE !?5,"Outlook mail group(s) in File 79's PERF INDC SMTP E-MAIL ADDRESS",!
+12 SET RA1=$ORDER(^RA(79,0))
+13 IF '$ORDER(^RA(79,RA1,1,0))
SET RA3=0
WRITE !?5,"** There is no Outlook mail group defined in File 79's",!?8,"PERF INDC SMTP E-MAIL ADDRESS. **",!
QUIT
+14 SET RA2=0
+15 FOR
SET RA2=$ORDER(^RA(79,RA1,1,RA2))
if 'RA2
QUIT
WRITE !?3,$PIECE(^(RA2,0),U)
+16 WRITE !
+17 ; ask Task Start Time
+18 ;get ending date for a task range, RA2 variable .
DO RA2DT
+19 SET DIR(0)="D^"_DT_":"_RA2_":AEX"
+20 SET DIR("A",1)=" Enter date to start this Task"
+21 SET DIR("A")=" (time will be the same hh:mm as now.)"
+22 SET DIR("?",1)="The Task date must be at least 11 days from the beginning of this quarter"
+23 SET DIR("?",2)="through 10 days after the end of this quarter, based upon calendar quarters:"
+24 SET DIR("?",3)=""
+25 SET DIR("?",4)="Report Data Qtr: Task Date Range:"
+26 SET DIR("?",5)="First Quarter Mar 11 - Jul 10"
+27 SET DIR("?",6)="Second Quarter Jul 11 - Oct 10"
+28 SET DIR("?",7)="Third Quarter Oct 11 - Jan 10"
+29 SET DIR("?")="Fourth Quarter Jan 11 - Apr 10"
+30 DO ^DIR
+31 IF $DATA(DIRUT)
SET RA3=0
QUIT
+32 SET ZTDTH=Y_"."_$PIECE(($$NOW^XLFDT),".",2)
+33 QUIT
End DoDot:1
IF 'RA3
WRITE !!?5,"** Nothing Done **"
QUIT
+34 ;
+35 ; define LAST QUARTER'S begin and end dates
+36 ; current yr, month, day
SET (Y1,Y2,RAQTRYR)=$EXTRACT(DT,1,3)
SET RAM1=$EXTRACT(DT,4,5)
SET RADAY=$EXTRACT(DT,6,7)
+37 ; if background job, only run on 1st, 4th, 7th and 10th after the 10th day,
+38 ; so that background job will not run multiple times per quarter. This process
+39 ; can still be initiated by a user anytime, automatically process the previous quarter
+40 ; and date range not more than 92 days.
+41 IF $DATA(ZTQUEUED)
IF ('$SELECT(RAM1="01":1,RAM1="04":1,RAM1="07":1,RAM1=10:1,1:0)!(RADAY<11))
QUIT
+42 KILL ^TMP($JOB)
+43 ; all radiologists
SET RARAD=""
+44 ; summary, no local mail, send Outlook mail
SET RARPT="S"
SET RAANS=0
SET RAANS2=1
+45 ;get quarter to process report
SET RAPQTR=$SELECT(RAM1>9:3,RAM1>6:2,RAM1>3:1,1:4)
+46 ;get beg month of the next quarter
SET M1=$SELECT(RAM1>9:10,RAM1>6:"07",RAM1>3:"04",1:"01")
+47 SET M2=$SELECT(RAPQTR=4:10,RAPQTR=3:"07",RAPQTR=2:"04",1:"01")
+48 if RAPQTR=4
SET Y2=Y1-1
+49 IF (RAM1=10)&(RADAY<11)!(RAM1="07")&(RADAY<11)!(RAM1="04")&(RADAY<11)!(RAM1="01")&(RADAY<11)
Begin DoDot:1
+50 SET M1=$SELECT(RAM1=10:"07",RAM1="07":"04",RAM1="04":"01",1:10)
+51 SET M2=$SELECT(RAPQTR=4:"07",RAPQTR=3:"04",RAPQTR=2:"01",1:10)
+52 SET Y2=$SELECT(RAPQTR=1:Y1-1,1:Y1)
End DoDot:1
+53 ; Current year and quarter's 1st day of month
SET RA1=Y1_M1_"01"
+54 ; Begin date for last quarter's first month
SET RABDATE=Y2_M2_"01"
+55 ; No. days in last month
SET X1=RA1
SET X2=RABDATE
DO ^%DTC
SET RADAYS=X
+56 ; End date last month
SET X2=(RADAYS-1)
SET X1=RABDATE
DO C^%DTC
SET RAEDATE=X
+57 ; convert for search loop
SET (RAEDTSV,RAENDDT)=RAEDATE_.9999
+58 ; convert for search loop
SET (RABDTSV,RABEGDT)=(RABDATE-1)_.9999
+59 ; define divisions that have at least 1 active img loc
+60 SET RA1=0
+61 FOR
SET RA1=$ORDER(^RA(79,RA1))
if 'RA1
QUIT
Begin DoDot:1
+62 SET RA2=0
+63 ;if div has at least 1 active img loc, then store div in ^tmp
+64 FOR
SET RA2=$ORDER(^RA(79,RA1,"L",RA2))
if 'RA2
QUIT
IF $DATA(^(RA2,0))
IF $PIECE($GET(^RA(79.1,+^(0),0)),U,19)=""
SET RA3=$$GET1^DIQ(4,RA1,.01)
SET ^TMP($JOB,"RA D-TYPE",RA3,RA1)=""
QUIT
End DoDot:1
+65 ; define imaging types if not vascular lab but has file 79.1 BIMG xref
+66 SET RA1=0
+67 FOR
SET RA1=$ORDER(^RA(79.2,RA1))
if 'RA1
QUIT
Begin DoDot:1
+68 IF $DATA(^RA(79.2,RA1,0))
SET RA2=$PIECE(^(0),U)
IF RA2'["VASCULAR LAB"
IF $DATA(^RA(79.1,"BIMG",RA1))
SET ^TMP($JOB,"RA I-TYPE",RA2,RA1)=""
End DoDot:1
+69 ; task job
+70 SET ZTIO=""
+71 DO TASK^RAPM
+72 ; save taskman vars
SET X1=ZTDESC
SET X2=ZTDTH
+73 DO ^%ZTLOAD
+74 IF +$GET(ZTSK("D"))>0
IF $DATA(ZTSK)
Begin DoDot:1
+75 WRITE !?5,$CHAR(7),"Request queued: ",X1
+76 WRITE !?5,"to start on: ",$$FMTE^XLFDT(X2)
+77 WRITE !?5,"Task #: "_$GET(ZTSK)
End DoDot:1
+78 KILL ^TMP($JOB)
+79 ;added in p99
KILL RAANS,RAANS2,RABDTSV,RAEDTSV,RAM1,RAPQTR,RAQTRYR,RARAD,RARPT,RAP99
+80 QUIT
RESCH ; reschedule option that is in file 19.2
+1 NEW RABY,RADT,RAERR,RAWHEN,RAFLAG
+2 NEW D1,M1,Y1,M2,Y2,X
+3 ; RAFLAG="" determines if allow LAYGO to file 19.2, if the option "RA
+4 ; PERFORMIN TASKLM" was installed in file 19.2, RAFLAG = "",
+5 ; if not installed, then RAFLAG = "L"
+6 SET RAFLAG=""
+7 ; get task status of option
+8 DO OPTSTAT^XUTMOPT("RA PERFORMIN TASKLM",.RAR)
+9 IF $PIECE($GET(RAR(1)),U)
DO EN^DDIOL("** Option RA PERFORMIN TASKLM is already scheduled, so nothing done. **",,"!!?5")
DO PRESS
QUIT
+10 IF '$DATA(RAR(1))
Begin DoDot:1
+11 DO EN^DDIOL("** Option RA PERFORMIN TASKLM has not been installed into file 19.2 **",,"!!?5")
+12 DO EN^DDIOL("** will install it into file 19.2 now. **",,"!!?5")
+13 SET RAFLAG="L"
+14 QUIT
End DoDot:1
+15 ; task the option that seems to be lost from the task queue
+16 DO SET15
+17 DO EN^DDIOL("Now scheduling RA PERFORMIN TASKLM to run on: ",,"!!?5")
+18 DO RESCH^XUTMOPT("RA PERFORMIN TASKLM",RAWHEN,,RABY,RAFLAG,.RAERR)
+19 DO OPTSTAT^XUTMOPT("RA PERFORMIN TASKLM",.RAR)
+20 IF $DATA(RAR(1))#2
DO EN^DDIOL("Task number : "_+RAR(1),,"!!?37")
+21 DO PRESS
+22 QUIT
PRESS READ !!?5,"Press RETURN to continue. ",X:DTIME
+1 QUIT
SET15 ; set some variables for scheduling task
+1 SET Y1=$EXTRACT(DT,1,3)
SET M1=$EXTRACT(DT,4,5)
SET D1=$EXTRACT(DT,6,7)
+2 SET Y2=$SELECT(M1="12":Y1+1,1:Y1)
SET M2=$SELECT(M1="12":"01",1:M1+1)
+3 if $LENGTH(M2)=1
SET M2="0"_M2
+4 if D1=15
DO TODAY
if D1<15
DO THISM
if D1>15
DO NEXTM
+5 ; add 5 mins to scheduled date
SET RAWHEN=$$FMADD^XLFDT(RADT,,,5)
+6 ; every month on the 15th day
SET RABY="1M(15)"
+7 QUIT
TODAY ; today is the 15th
+1 SET RADT=$$NOW^XLFDT
+2 QUIT
THISM ; this month on the 15th
+1 SET RADT=Y1_M1_"15."_$PIECE(($$NOW^XLFDT),".",2)
+2 QUIT
NEXTM ; next month on the 15th
+1 SET RADT=Y2_M2_"15."_$PIECE(($$NOW^XLFDT),".",2)
+2 QUIT
+1 if 'RAIO
GOTO SFOOT2
+2 IF ($Y+5)>IOSL
IF IO=IO(0)
Begin DoDot:1
+3 IF $EXTRACT(IOST,1,2)="C-"
READ !,"Press RETURN to continue.",X:DTIME
+4 SET RAPG=RAPG+1
SET RAHDR="Summary Verification Timeliness Report"
+5 WRITE @IOF,!?(RAIOM-$LENGTH(RAHDR)\2),RAHDR,?(RAIOM-10),"Page: ",$GET(RAPG)
End DoDot:1
+6 WRITE !!?5,"* Columns represent # of hours elapsed from exam date/time through",!?7,"date/time report entered or date/time report was verified."
+7 WRITE !?7,"e.g. "">0-24 Hrs"" column represents those exams that had a report"
+8 WRITE !?7,"transcribed and/or verified within 0-24 hours from the exam date/time."
+9 WRITE !!?5,"* Columns following the initial elapsed time column "">0-24 Hrs"" begin"
+10 WRITE !?7,"at .0001 after the starting hour (e.g. "">24-48 Hrs"" = starts at 24.001",!?7,"through the 48th hour.)",!
+11 WRITE !?5,"* PENDING means there's no data for DATE REPORT ENTERED or VERIFIED DATE."
+12 WRITE !?7,"So, if the expected report is missing one of these fields, or is missing"
+13 WRITE !?7,"data for fields .01 through 17 from file #74, RAD/NUC MED REPORTS, or"
+14 WRITE !?7,"is a Stub Report that was entered by the Imaging package when images"
+15 WRITE !?7,"were captured before a report was entered, then the expected report"
+16 WRITE !?7,"would be counted in the PENDING column."
+17 ;
+1 SET (^TMP($JOB,"RAPM",RAN),^TMP($JOB,"RAPM",RAN+1))=""
SET RAN=RAN+1
+2 ;
+3 SET ^TMP($JOB,"RAPM",RAN)=" * Columns represent # of hours elapsed from exam date/time through"
SET RAN=RAN+1
+4 SET ^TMP($JOB,"RAPM",RAN)=" date/time report entered or date/time report was verified."
SET RAN=RAN+1
+5 SET ^TMP($JOB,"RAPM",RAN)=" e.g. "">0-24 Hrs"" column represents those exams that had a report"
SET RAN=RAN+1
+6 SET ^TMP($JOB,"RAPM",RAN)=" transcribed and/or verified within 0-24 hours from the exam date/time."
SET RAN=RAN+1
+7 SET ^TMP($JOB,"RAPM",RAN)=""
SET RAN=RAN+1
+8 SET ^TMP($JOB,"RAPM",RAN)=" * Columns following the initial elapsed time column (0-24 Hrs) begin"
SET RAN=RAN+1
+9 SET ^TMP($JOB,"RAPM",RAN)=" at .0001 after the starting hour (e.g. "">24-48 Hrs"" = starts at 24.001"
SET RAN=RAN+1
+10 SET ^TMP($JOB,"RAPM",RAN)=" through the 48th hour.)"
SET RAN=RAN+1
+11 SET ^TMP($JOB,"RAPM",RAN)=""
SET RAN=RAN+1
+12 SET ^TMP($JOB,"RAPM",RAN)=" * PENDING means there's no data for DATE REPORT ENTERED or VERIFIED DATE."
SET RAN=RAN+1
+13 SET ^TMP($JOB,"RAPM",RAN)=" So, if the expected report is missing one of these fields, or is missing"
SET RAN=RAN+1
+14 SET ^TMP($JOB,"RAPM",RAN)=" data for fields .01 through 17 from file #74, RAD/NUC MED REPORTS, or"
SET RAN=RAN+1
+15 SET ^TMP($JOB,"RAPM",RAN)=" is a Stub Report that was entered by the Imaging package when images"
SET RAN=RAN+1
+16 SET ^TMP($JOB,"RAPM",RAN)=" were captured before a report was entered, then the expected report"
SET RAN=RAN+1
+17 SET ^TMP($JOB,"RAPM",RAN)=" would be counted in the PENDING column."
+18 DO BFOOT
+19 QUIT
+1 if 'RAIO
GOTO BFOOT2
+2 WRITE !!?5,"* A printset, i.e., a set of multiple exams that share the same report,",!?7,"will be expected to have 1 report."
+3 WRITE !!?5,"* Cancelled and ""No Credit"" cases are excluded from this report."
+1 if '$GET(RAN)
QUIT
+2 SET RAN=RAN+1
+3 SET ^TMP($JOB,"RAPM",RAN)=""
SET RAN=RAN+1
+4 SET ^TMP($JOB,"RAPM",RAN)=" * A printset, i.e., a set of multiple exams that share the same report,"
SET RAN=RAN+1
+5 SET ^TMP($JOB,"RAPM",RAN)=" will be expected to have 1 report."
SET RAN=RAN+1
+6 SET ^TMP($JOB,"RAPM",RAN)=""
SET RAN=RAN+1
+7 SET ^TMP($JOB,"RAPM",RAN)=" * Cancelled and ""No Credit"" cases are excluded from this report."
+8 QUIT
RADIOL ; select Radiologist for Summary Report
+1 WRITE !
+2 SET DIC("S")="I $D(^VA(200,""ARC"",""R"",Y))!($D(^VA(200,""ARC"",""S"",Y)))"
SET DIC("A")="Select Primary Interpreting Staff Physician (Optional): "
SET DIC="^VA(200,"
SET DIC(0)="AEMQ"
DO ^DIC
KILL DIC
if Y<0
QUIT
SET RARAD=+Y
+3 QUIT
RA2DT ;SET RA2 variable for task date range
+1 NEW RADTNW
+2 SET Y1=$EXTRACT(DT,1,3)
SET M1=$EXTRACT(DT,4,5)
SET RADTNW=$EXTRACT(DT,6,7)
+3 SET Y2=$SELECT((M1="11")!(M1="12"):Y1+1,1:Y1)
+4 if (M1="10")&(RADTNW>10)
SET Y2=Y1+1
+5 ;
+6 if (M1="01")&(RADTNW<11)
SET RA2=Y2_"01"_10
+7 if (M1="01")&(RADTNW>10)
SET RA2=Y2_"04"_10
+8 if (M1="02")!(M1="03")
SET RA2=Y2_"04"_10
+9 ;
+10 if (M1="04")&(RADTNW<11)
SET RA2=Y2_"04"_10
+11 if (M1="04")&(RADTNW>10)
SET RA2=Y2_"07"_10
+12 if (M1="05")!(M1="06")
SET RA2=Y2_"07"_10
+13 ;
+14 if (M1="07")&(RADTNW<11)
SET RA2=Y2_"07"_10
+15 if (M1="07")&(RADTNW>10)
SET RA2=Y2_10_10
+16 if (M1="08")!(M1="09")
SET RA2=Y2_10_10
+17 ;
+18 if (M1="10")&(RADTNW<11)
SET RA2=Y2_10_10
+19 if (M1="10")&(RADTNW>10)
SET RA2=Y2_"01"_10
+20 if (M1=11)!(M1=12)
SET RA2=Y2_"01"_10
+21 QUIT
