source: FOIAVistA/trunk/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RAPM3.m@ 1397

Last change on this file since 1397 was 628, checked in by George Lilly, 15 years ago

initial load of FOIAVistA 6/30/08 version
File size: 9.1 KB
Line 
1RAPM3 ;HOIFO/SM-Radiology Performance Monitors/Indicator ;1/5/04 11:11
2 ;;5.0;Radiology/Nuclear Medicine;**37,44,63,67**;Mar 16, 1998
3 ;; IA #11090 allows Fileman read of Entire file 4
4 Q
5EN1 ;entry/edit OUTLOOK mail groups
6 N RA1,RA2
7 S RA1=$O(^RA(79,0)) Q:'RA1
8 I $O(^RA(79,RA1,1,0)) D
9 . W !?5,"OUTLOOK mail groups previously entered:",!?56,"OQP Perf. Mgmt?",!?56,"--------------"
10 . S RA2=0
11 . F S RA2=$O(^RA(79,RA1,1,RA2)) Q:'RA2 W !?8,$P(^(RA2,0),U),?63,$P(^(0),U,2)
12 . Q
13 W !!?5,"You may add another mail group."
14 W !,?5,"To edit or replace a mail group, you must delete the old one first.",!
15 L +^RA(79,RA1,1):1 I '$T W !,$C(7),"Can't lock ^RA,",RA1,",1) now, try again later." Q
16 S DIE="^RA(79,",DA=RA1,DR="175"
17 D ^DIE
18 L -^RA(79,RA1,1)
19 Q
20TASKLM ; task off last month's Perf. Indic. Summary Report [RA PERFORMIN TASKLM]
21 ; define report type as summary
22 N RA1,RA2,RA3,RABDATE,RAEDATE,RADAYS,RAENDDT,RABEGDT,RAUTOM,RALASTM
23 N M1,M2,X1,X2,Y1,Y2
24 ; RALASTM flags this option RA PERFORMIN TASKLM, queued or interactive
25 S RALASTM=1
26 ; if tasked here, set RAUTOM to flag automatic queued mid-month report
27 I $D(ZTQUEUED) S RAUTOM=1
28 ; if interactive, display Outlook mail groups and ask if continue
29 I '$D(ZTQUEUED) D I 'RA3 W !!?5,"** Nothing Done **" Q
30 . W !!?5,"The Summary Report of Last Month's data will be sent to the"
31 . W !?5,"Outlook mail group(s) in File 79's PERF INDC SMPT E-MAIL ADDRESS"
32 . W !?5,"with ""N"" defined for OQP Performance Management."
33 . S RA1=$O(^RA(79,0))
34 . 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
35 . S RA2=0
36 . W !?56,"OQP Perf. Mgmt?",!?56,"---------------"
37 . F S RA2=$O(^RA(79,RA1,1,RA2)) Q:'RA2 W !?3,$P(^(RA2,0),U),?63,$P(^(0),U,2)
38 . W !
39 . D HQASK^RAPM4
40 . S DIR(0)="Y"
41 . S DIR("A",1)=""
42 . S DIR("A")=" Do you want to continue"
43 . D ^DIR S RA3=Y
44 . Q:'RA3
45 . ; ask Task Start Time
46 . W !!?5,"The requested start time must be within day 10 through the last",!?5,"day of the current month.",!
47 . ; find end day of current month
48 . S Y1=$E(DT,1,3),M1=$E(DT,4,5)
49 . S Y2=$S(M1="12":Y1+1,1:Y1),M2=$S(M1="12":"01",1:M1+1)
50 . S:$L(M2)=1 M2="0"_M2
51 . S RA1=Y1_M1_"10"
52 . S RA2=Y2_M2_"01"
53 . S X2=RA1,X1=RA2 D ^%DTC
54 . S X2=X-1,X1=RA1 D C^%DTC S RA2=X
55 . S DIR(0)="D^"_RA1_":"_RA2_":AE"
56 . S DIR("A",1)=" Enter date to start this Task"
57 . S DIR("A")=" (time will be the same hh:mm as now.)"
58 . S DIR("?",1)=" The Task date must be at least 10 days from the"
59 . S DIR("?")=" beginning of this month through the end of this month."
60 . D ^DIR
61 . S:$D(DIRUT) RA3=0
62 . S ZTDTH=Y_"."_$P(($$NOW^XLFDT),".",2)
63 . Q
64 K ^TMP($J)
65 S RARAD="" ; all radiologists
66 S RARPT="S",RAANS=0,RAANS2=1 ; summary, no local mail, send Outlook mail
67 ; define LAST MONTH'S begin and end dates
68 S Y1=$E(DT,1,3),M1=$E(DT,4,5) ; current month
69 S Y2=$S(M1="01":Y1-1,1:Y1),M2=$S(M1="01":12,1:M1-1) ; last month
70 S:$L(M2)=1 M2="0"_M2
71 S RA1=Y1_M1_"01" ; Current year and month, 1st day of month
72 S RABDATE=Y2_M2_"01" ; Begin date for last month
73 S X1=RA1,X2=RABDATE D ^%DTC S RADAYS=X ; No. days in last month
74 S X2=(RADAYS-1),X1=RABDATE D C^%DTC S RAEDATE=X ; End date last month
75 S RAENDDT=RAEDATE_.9999 ; convert for search loop
76 S RABEGDT=(RABDATE-1)_.9999 ; convert for search loop
77 ; define divisions that have at least 1 active img loc
78 S RA1=0
79 F S RA1=$O(^RA(79,RA1)) Q:'RA1 D
80 . S RA2=0
81 . ;if div has at least 1 active img loc, then store div in ^tmp
82 . 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
83 ; define imaging types if not vascular lab but has file 79.1 BIMG xref
84 S RA1=0
85 F S RA1=$O(^RA(79.2,RA1)) Q:'RA1 D
86 . 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)=""
87 ; task job
88 S ZTIO=""
89 D TASK^RAPM
90 S X1=ZTDESC,X2=ZTDTH ; save taskman vars
91 D ^%ZTLOAD
92 I +$G(ZTSK("D"))>0,$D(ZTSK) D
93 . W !?5,*7,"Request queued: ",X1
94 . W !?5,"to start on: ",$$FMTE^XLFDT(X2)
95 . W !?5,"Task #: "_$G(ZTSK)
96 K ^TMP($J)
97 Q
98RESCH ; reschedule option that is in file 19.2
99 N RABY,RADT,RAERR,RAWHEN,RAFLAG
100 N D1,M1,Y1,M2,Y2,X
101 ; RAFLAG="" determines if allow LAYGO to file 19.2, if the option "RA
102 ; PERFORMIN TASKLM" was installed in file 19.2, RAFLAG = "",
103 ; if not installed, then RAFLAG = "L"
104 S RAFLAG=""
105 ; get task status of option
106 D OPTSTAT^XUTMOPT("RA PERFORMIN TASKLM",.RAR)
107 I $P($G(RAR(1)),U) D EN^DDIOL("** Option RA PERFORMIN TASKLM is already scheduled, so nothing done. **",,"!!?5") D PRESS Q
108 I '$D(RAR(1)) D
109 . D EN^DDIOL("** Option RA PERFORMIN TASKLM has not been installed into file 19.2 **",,"!!?5")
110 . D EN^DDIOL("** will install it into file 19.2 now. **",,"!!?5")
111 . S RAFLAG="L"
112 . Q
113 ; task the option that seems to be lost from the task queue
114 D SET15
115 D EN^DDIOL("Now scheduling RA PERFORMIN TASKLM to run on: ",,"!!?5")
116 D RESCH^XUTMOPT("RA PERFORMIN TASKLM",RAWHEN,,RABY,RAFLAG,.RAERR)
117 D OPTSTAT^XUTMOPT("RA PERFORMIN TASKLM",.RAR)
118 I $D(RAR(1))#2 D EN^DDIOL("Task number : "_+RAR(1),,"!!?37")
119 D PRESS
120 Q
121PRESS R !!?5,"Press RETURN to continue. ",X:DTIME
122 Q
123SET15 ; set some variables for scheduling task
124 S Y1=$E(DT,1,3),M1=$E(DT,4,5),D1=$E(DT,6,7)
125 S Y2=$S(M1="12":Y1+1,1:1),M2=$S(M1="12":"01",1:M1+1)
126 S:$L(M2)=1 M2="0"_M2
127 D:D1=15 TODAY D:D1<15 THISM D:D1>15 NEXTM
128 S RAWHEN=$$FMADD^XLFDT(RADT,,,5) ; add 5 mins to scheduled date
129 S RABY="1M(15)" ; every month on the 15th day
130 Q
131TODAY ; today is the 15th
132 S RADT=$$NOW^XLFDT
133 Q
134THISM ; this month on the 15th
135 S RADT=Y1_M1_"15."_$P(($$NOW^XLFDT),".",2)
136 Q
137NEXTM ; next month on the 15th
138 S RADT=Y2_M2_"15."_$P(($$NOW^XLFDT),".",2)
139 Q
140SFOOT ; Footer for Summary Report
141 G:'RAIO SFOOT2
142 I ($Y+5)>IOSL,IO=IO(0) D
143 . I $E(IOST,1,2)="C-" R !,"Press RETURN to continue.",X:DTIME
144 . S RAPG=RAPG+1,RAHDR="Summary Verification Timeliness Report"
145 . W @IOF,!?(RAIOM-$L(RAHDR)\2),RAHDR,?(RAIOM-10),"Page: ",$G(RAPG)
146 W !!?5,"* Columns represent # of hours elapsed from exam date/time through",!?7,"date/time report entered or date/time report was verified."
147 W !?7,"e.g. "">0-24 Hrs"" column represents those exams that had a report"
148 W !?7,"transcribed and/or verified within 0-24 hours from the exam date/time."
149 W !!?5,"* Columns following the initial elapsed time column "">0-24 Hrs"" begin"
150 W !?7,"at .0001 after the starting hour (e.g. "">24-48 Hrs"" = starts at 24.001",!?7,"through the 48th hour.)",!
151 W !?5,"* PENDING means there's no data for DATE REPORT ENTERED or VERIFIED DATE."
152 W !?7,"So, if the expected report is missing one of these fields, or is missing"
153 W !?7,"data for fields .01 through 17 from file #74, RAD/NUC MED REPORTS, or"
154 W !?7,"is a Stub Report that was entered by the Imaging package when images"
155 W !?7,"were captured before a report was entered, then the expected report"
156 W !?7,"would be counted in the PENDING column."
157 ;
158SFOOT2 ; store in tmp
159 S (^TMP($J,"RAPM",RAN),^TMP($J,"RAPM",RAN+1))="",RAN=RAN+1
160 ;
161 S ^TMP($J,"RAPM",RAN)=" * Columns represent # of hours elapsed from exam date/time through",RAN=RAN+1
162 S ^TMP($J,"RAPM",RAN)=" date/time report entered or date/time report was verified.",RAN=RAN+1
163 S ^TMP($J,"RAPM",RAN)=" e.g. "">0-24 Hrs"" column represents those exams that had a report",RAN=RAN+1
164 S ^TMP($J,"RAPM",RAN)=" transcribed and/or verified within 0-24 hours from the exam date/time.",RAN=RAN+1
165 S ^TMP($J,"RAPM",RAN)="",RAN=RAN+1
166 S ^TMP($J,"RAPM",RAN)=" * Columns following the initial elapsed time column (0-24 Hrs) begin",RAN=RAN+1
167 S ^TMP($J,"RAPM",RAN)=" at .0001 after the starting hour (e.g. "">24-48 Hrs"" = starts at 24.001",RAN=RAN+1
168 S ^TMP($J,"RAPM",RAN)=" through the 48th hour.)",RAN=RAN+1
169 S ^TMP($J,"RAPM",RAN)="",RAN=RAN+1
170 S ^TMP($J,"RAPM",RAN)=" * PENDING means there's no data for DATE REPORT ENTERED or VERIFIED DATE.",RAN=RAN+1
171 S ^TMP($J,"RAPM",RAN)=" So, if the expected report is missing one of these fields, or is missing",RAN=RAN+1
172 S ^TMP($J,"RAPM",RAN)=" data for fields .01 through 17 from file #74, RAD/NUC MED REPORTS, or",RAN=RAN+1
173 S ^TMP($J,"RAPM",RAN)=" is a Stub Report that was entered by the Imaging package when images",RAN=RAN+1
174 S ^TMP($J,"RAPM",RAN)=" were captured before a report was entered, then the expected report",RAN=RAN+1
175 S ^TMP($J,"RAPM",RAN)=" would be counted in the PENDING column."
176 D BFOOT
177 Q
178BFOOT ;footer for both
179 G:'RAIO BFOOT2
180 W !!?5,"* A printset, i.e., a set of multiple exams that share the same report,",!?7,"will be expected to have 1 report."
181 W !!?5,"* Cancelled and ""No Credit"" cases are excluded from this report."
182BFOOT2 ; used in summary
183 Q:'$G(RAN)
184 S RAN=RAN+1
185 S ^TMP($J,"RAPM",RAN)="",RAN=RAN+1
186 S ^TMP($J,"RAPM",RAN)=" * A printset, i.e., a set of multiple exams that share the same report,",RAN=RAN+1
187 S ^TMP($J,"RAPM",RAN)=" will be expected to have 1 report.",RAN=RAN+1
188 S ^TMP($J,"RAPM",RAN)="",RAN=RAN+1
189 S ^TMP($J,"RAPM",RAN)=" * Cancelled and ""No Credit"" cases are excluded from this report."
190 Q
191RADIOL ; select Radiologist for Summary Report
192 W !
193 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
194 Q
Note: See TracBrowser for help on using the repository browser.