- 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 Jan 18, 2025@03:39:38 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