Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: RAPM3

RAPM3.m

Go to the documentation of this file.
  1. 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
  1. ; IA #11090 allows Fileman read of Entire file 4
  1. ; Supported IA #10103 reference to ^XLFDT
  1. ; Supported IA #10000 reference to C^%DTC
  1. ; Supported IA #2056 reference to ^DIQ
  1. ; Supported IA #10142 reference to EN^DDIOL
  1. ; RVD - 9/19/09 p99
  1. Q
  1. EN1 ;entry/edit OUTLOOK mail groups
  1. N RA1,RA2
  1. S RA1=$O(^RA(79,0)) Q:'RA1
  1. I $O(^RA(79,RA1,1,0)) D
  1. . W !?5,"OUTLOOK mail groups previously entered:",!?56,"OQP Perf. Mgmt?",!?56,"--------------"
  1. . S RA2=0
  1. . F S RA2=$O(^RA(79,RA1,1,RA2)) Q:'RA2 W !?8,$P(^(RA2,0),U),?63,$P(^(0),U,2)
  1. . Q
  1. W !!?5,"You may add another mail group."
  1. W !,?5,"To edit or replace a mail group, you must delete the old one first.",!
  1. L +^RA(79,RA1,1):1 I '$T W !,$C(7),"Can't lock ^RA,",RA1,",1) now, try again later." Q
  1. S DIE="^RA(79,",DA=RA1,DR="175"
  1. D ^DIE
  1. L -^RA(79,RA1,1)
  1. Q
  1. TASKLM ; task off last quarters's Perf. Indic. Summary Report [RA PERFORMIN TASKLM]
  1. ; define report type as summary
  1. N RA1,RA2,RA3,RABDATE,RAEDATE,RADAYS,RAENDDT,RABEGDT,RAUTOM,RALASTM,RAP99,RADAY,DIR
  1. N M1,M2,X1,X2,Y1,Y2
  1. ; RALASTM flags this option RA PERFORMIN TASKLM, queued or interactive
  1. S (RA3,RAP99,RALASTM)=1
  1. ; if tasked here, set RAUTOM to flag automatic queued mid-month report for the last quarter
  1. I $D(ZTQUEUED) S RAUTOM=1
  1. ; if interactive, display Outlook mail groups and ask if continue
  1. I '$D(ZTQUEUED) D I 'RA3 W !!?5,"** Nothing Done **" Q
  1. . W !!?5,"The Summary Report of Last Quarter's data will be sent to the"
  1. . W !?5,"Outlook mail group(s) in File 79's PERF INDC SMTP E-MAIL ADDRESS",!
  1. . S RA1=$O(^RA(79,0))
  1. . 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
  1. . S RA2=0
  1. . F S RA2=$O(^RA(79,RA1,1,RA2)) Q:'RA2 W !?3,$P(^(RA2,0),U)
  1. . W !
  1. . ; ask Task Start Time
  1. . D RA2DT ;get ending date for a task range, RA2 variable .
  1. . S DIR(0)="D^"_DT_":"_RA2_":AEX"
  1. . S DIR("A",1)=" Enter date to start this Task"
  1. . S DIR("A")=" (time will be the same hh:mm as now.)"
  1. . S DIR("?",1)="The Task date must be at least 11 days from the beginning of this quarter"
  1. . S DIR("?",2)="through 10 days after the end of this quarter, based upon calendar quarters:"
  1. . S DIR("?",3)=""
  1. . S DIR("?",4)="Report Data Qtr: Task Date Range:"
  1. . S DIR("?",5)="First Quarter Mar 11 - Jul 10"
  1. . S DIR("?",6)="Second Quarter Jul 11 - Oct 10"
  1. . S DIR("?",7)="Third Quarter Oct 11 - Jan 10"
  1. . S DIR("?")="Fourth Quarter Jan 11 - Apr 10"
  1. . D ^DIR
  1. . I $D(DIRUT) S RA3=0 Q
  1. . S ZTDTH=Y_"."_$P(($$NOW^XLFDT),".",2)
  1. . Q
  1. ;
  1. ; define LAST QUARTER'S begin and end dates
  1. S (Y1,Y2,RAQTRYR)=$E(DT,1,3),RAM1=$E(DT,4,5),RADAY=$E(DT,6,7) ; current yr, month, day
  1. ; if background job, only run on 1st, 4th, 7th and 10th after the 10th day,
  1. ; so that background job will not run multiple times per quarter. This process
  1. ; can still be initiated by a user anytime, automatically process the previous quarter
  1. ; and date range not more than 92 days.
  1. I $D(ZTQUEUED),('$S(RAM1="01":1,RAM1="04":1,RAM1="07":1,RAM1=10:1,1:0)!(RADAY<11)) Q
  1. K ^TMP($J)
  1. S RARAD="" ; all radiologists
  1. S RARPT="S",RAANS=0,RAANS2=1 ; summary, no local mail, send Outlook mail
  1. S RAPQTR=$S(RAM1>9:3,RAM1>6:2,RAM1>3:1,1:4) ;get quarter to process report
  1. S M1=$S(RAM1>9:10,RAM1>6:"07",RAM1>3:"04",1:"01") ;get beg month of the next quarter
  1. S M2=$S(RAPQTR=4:10,RAPQTR=3:"07",RAPQTR=2:"04",1:"01")
  1. S:RAPQTR=4 Y2=Y1-1
  1. I (RAM1=10)&(RADAY<11)!(RAM1="07")&(RADAY<11)!(RAM1="04")&(RADAY<11)!(RAM1="01")&(RADAY<11) D
  1. .S M1=$S(RAM1=10:"07",RAM1="07":"04",RAM1="04":"01",1:10)
  1. .S M2=$S(RAPQTR=4:"07",RAPQTR=3:"04",RAPQTR=2:"01",1:10)
  1. .S Y2=$S(RAPQTR=1:Y1-1,1:Y1)
  1. S RA1=Y1_M1_"01" ; Current year and quarter's 1st day of month
  1. S RABDATE=Y2_M2_"01" ; Begin date for last quarter's first month
  1. S X1=RA1,X2=RABDATE D ^%DTC S RADAYS=X ; No. days in last month
  1. S X2=(RADAYS-1),X1=RABDATE D C^%DTC S RAEDATE=X ; End date last month
  1. S (RAEDTSV,RAENDDT)=RAEDATE_.9999 ; convert for search loop
  1. S (RABDTSV,RABEGDT)=(RABDATE-1)_.9999 ; convert for search loop
  1. ; define divisions that have at least 1 active img loc
  1. S RA1=0
  1. F S RA1=$O(^RA(79,RA1)) Q:'RA1 D
  1. . S RA2=0
  1. . ;if div has at least 1 active img loc, then store div in ^tmp
  1. . 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
  1. ; define imaging types if not vascular lab but has file 79.1 BIMG xref
  1. S RA1=0
  1. F S RA1=$O(^RA(79.2,RA1)) Q:'RA1 D
  1. . 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)=""
  1. ; task job
  1. S ZTIO=""
  1. D TASK^RAPM
  1. S X1=ZTDESC,X2=ZTDTH ; save taskman vars
  1. D ^%ZTLOAD
  1. I +$G(ZTSK("D"))>0,$D(ZTSK) D
  1. . W !?5,$C(7),"Request queued: ",X1
  1. . W !?5,"to start on: ",$$FMTE^XLFDT(X2)
  1. . W !?5,"Task #: "_$G(ZTSK)
  1. K ^TMP($J)
  1. K RAANS,RAANS2,RABDTSV,RAEDTSV,RAM1,RAPQTR,RAQTRYR,RARAD,RARPT,RAP99 ;added in p99
  1. Q
  1. RESCH ; reschedule option that is in file 19.2
  1. N RABY,RADT,RAERR,RAWHEN,RAFLAG
  1. N D1,M1,Y1,M2,Y2,X
  1. ; RAFLAG="" determines if allow LAYGO to file 19.2, if the option "RA
  1. ; PERFORMIN TASKLM" was installed in file 19.2, RAFLAG = "",
  1. ; if not installed, then RAFLAG = "L"
  1. S RAFLAG=""
  1. ; get task status of option
  1. D OPTSTAT^XUTMOPT("RA PERFORMIN TASKLM",.RAR)
  1. I $P($G(RAR(1)),U) D EN^DDIOL("** Option RA PERFORMIN TASKLM is already scheduled, so nothing done. **",,"!!?5") D PRESS Q
  1. I '$D(RAR(1)) D
  1. . D EN^DDIOL("** Option RA PERFORMIN TASKLM has not been installed into file 19.2 **",,"!!?5")
  1. . D EN^DDIOL("** will install it into file 19.2 now. **",,"!!?5")
  1. . S RAFLAG="L"
  1. . Q
  1. ; task the option that seems to be lost from the task queue
  1. D SET15
  1. D EN^DDIOL("Now scheduling RA PERFORMIN TASKLM to run on: ",,"!!?5")
  1. D RESCH^XUTMOPT("RA PERFORMIN TASKLM",RAWHEN,,RABY,RAFLAG,.RAERR)
  1. D OPTSTAT^XUTMOPT("RA PERFORMIN TASKLM",.RAR)
  1. I $D(RAR(1))#2 D EN^DDIOL("Task number : "_+RAR(1),,"!!?37")
  1. D PRESS
  1. Q
  1. PRESS R !!?5,"Press RETURN to continue. ",X:DTIME
  1. Q
  1. SET15 ; set some variables for scheduling task
  1. S Y1=$E(DT,1,3),M1=$E(DT,4,5),D1=$E(DT,6,7)
  1. S Y2=$S(M1="12":Y1+1,1:Y1),M2=$S(M1="12":"01",1:M1+1)
  1. S:$L(M2)=1 M2="0"_M2
  1. D:D1=15 TODAY D:D1<15 THISM D:D1>15 NEXTM
  1. S RAWHEN=$$FMADD^XLFDT(RADT,,,5) ; add 5 mins to scheduled date
  1. S RABY="1M(15)" ; every month on the 15th day
  1. Q
  1. TODAY ; today is the 15th
  1. S RADT=$$NOW^XLFDT
  1. Q
  1. THISM ; this month on the 15th
  1. S RADT=Y1_M1_"15."_$P(($$NOW^XLFDT),".",2)
  1. Q
  1. NEXTM ; next month on the 15th
  1. S RADT=Y2_M2_"15."_$P(($$NOW^XLFDT),".",2)
  1. Q
  1. SFOOT ; Footer for Summary Report
  1. G:'RAIO SFOOT2
  1. I ($Y+5)>IOSL,IO=IO(0) D
  1. . I $E(IOST,1,2)="C-" R !,"Press RETURN to continue.",X:DTIME
  1. . S RAPG=RAPG+1,RAHDR="Summary Verification Timeliness Report"
  1. . W @IOF,!?(RAIOM-$L(RAHDR)\2),RAHDR,?(RAIOM-10),"Page: ",$G(RAPG)
  1. W !!?5,"* Columns represent # of hours elapsed from exam date/time through",!?7,"date/time report entered or date/time report was verified."
  1. W !?7,"e.g. "">0-24 Hrs"" column represents those exams that had a report"
  1. W !?7,"transcribed and/or verified within 0-24 hours from the exam date/time."
  1. W !!?5,"* Columns following the initial elapsed time column "">0-24 Hrs"" begin"
  1. W !?7,"at .0001 after the starting hour (e.g. "">24-48 Hrs"" = starts at 24.001",!?7,"through the 48th hour.)",!
  1. W !?5,"* PENDING means there's no data for DATE REPORT ENTERED or VERIFIED DATE."
  1. W !?7,"So, if the expected report is missing one of these fields, or is missing"
  1. W !?7,"data for fields .01 through 17 from file #74, RAD/NUC MED REPORTS, or"
  1. W !?7,"is a Stub Report that was entered by the Imaging package when images"
  1. W !?7,"were captured before a report was entered, then the expected report"
  1. W !?7,"would be counted in the PENDING column."
  1. ;
  1. SFOOT2 ; store in tmp
  1. S (^TMP($J,"RAPM",RAN),^TMP($J,"RAPM",RAN+1))="",RAN=RAN+1
  1. ;
  1. S ^TMP($J,"RAPM",RAN)=" * Columns represent # of hours elapsed from exam date/time through",RAN=RAN+1
  1. S ^TMP($J,"RAPM",RAN)=" date/time report entered or date/time report was verified.",RAN=RAN+1
  1. S ^TMP($J,"RAPM",RAN)=" e.g. "">0-24 Hrs"" column represents those exams that had a report",RAN=RAN+1
  1. S ^TMP($J,"RAPM",RAN)=" transcribed and/or verified within 0-24 hours from the exam date/time.",RAN=RAN+1
  1. S ^TMP($J,"RAPM",RAN)="",RAN=RAN+1
  1. S ^TMP($J,"RAPM",RAN)=" * Columns following the initial elapsed time column (0-24 Hrs) begin",RAN=RAN+1
  1. S ^TMP($J,"RAPM",RAN)=" at .0001 after the starting hour (e.g. "">24-48 Hrs"" = starts at 24.001",RAN=RAN+1
  1. S ^TMP($J,"RAPM",RAN)=" through the 48th hour.)",RAN=RAN+1
  1. S ^TMP($J,"RAPM",RAN)="",RAN=RAN+1
  1. S ^TMP($J,"RAPM",RAN)=" * PENDING means there's no data for DATE REPORT ENTERED or VERIFIED DATE.",RAN=RAN+1
  1. S ^TMP($J,"RAPM",RAN)=" So, if the expected report is missing one of these fields, or is missing",RAN=RAN+1
  1. S ^TMP($J,"RAPM",RAN)=" data for fields .01 through 17 from file #74, RAD/NUC MED REPORTS, or",RAN=RAN+1
  1. S ^TMP($J,"RAPM",RAN)=" is a Stub Report that was entered by the Imaging package when images",RAN=RAN+1
  1. S ^TMP($J,"RAPM",RAN)=" were captured before a report was entered, then the expected report",RAN=RAN+1
  1. S ^TMP($J,"RAPM",RAN)=" would be counted in the PENDING column."
  1. D BFOOT
  1. Q
  1. BFOOT ;footer for both
  1. G:'RAIO BFOOT2
  1. W !!?5,"* A printset, i.e., a set of multiple exams that share the same report,",!?7,"will be expected to have 1 report."
  1. W !!?5,"* Cancelled and ""No Credit"" cases are excluded from this report."
  1. BFOOT2 ; used in summary
  1. Q:'$G(RAN)
  1. S RAN=RAN+1
  1. S ^TMP($J,"RAPM",RAN)="",RAN=RAN+1
  1. S ^TMP($J,"RAPM",RAN)=" * A printset, i.e., a set of multiple exams that share the same report,",RAN=RAN+1
  1. S ^TMP($J,"RAPM",RAN)=" will be expected to have 1 report.",RAN=RAN+1
  1. S ^TMP($J,"RAPM",RAN)="",RAN=RAN+1
  1. S ^TMP($J,"RAPM",RAN)=" * Cancelled and ""No Credit"" cases are excluded from this report."
  1. Q
  1. RADIOL ; select Radiologist for Summary Report
  1. W !
  1. 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
  1. Q
  1. RA2DT ;SET RA2 variable for task date range
  1. N RADTNW
  1. S Y1=$E(DT,1,3),M1=$E(DT,4,5),RADTNW=$E(DT,6,7)
  1. S Y2=$S((M1="11")!(M1="12"):Y1+1,1:Y1)
  1. S:(M1="10")&(RADTNW>10) Y2=Y1+1
  1. ;
  1. S:(M1="01")&(RADTNW<11) RA2=Y2_"01"_10
  1. S:(M1="01")&(RADTNW>10) RA2=Y2_"04"_10
  1. S:(M1="02")!(M1="03") RA2=Y2_"04"_10
  1. ;
  1. S:(M1="04")&(RADTNW<11) RA2=Y2_"04"_10
  1. S:(M1="04")&(RADTNW>10) RA2=Y2_"07"_10
  1. S:(M1="05")!(M1="06") RA2=Y2_"07"_10
  1. ;
  1. S:(M1="07")&(RADTNW<11) RA2=Y2_"07"_10
  1. S:(M1="07")&(RADTNW>10) RA2=Y2_10_10
  1. S:(M1="08")!(M1="09") RA2=Y2_10_10
  1. ;
  1. S:(M1="10")&(RADTNW<11) RA2=Y2_10_10
  1. S:(M1="10")&(RADTNW>10) RA2=Y2_"01"_10
  1. S:(M1=11)!(M1=12) RA2=Y2_"01"_10
  1. Q