source: FOIAVistA/trunk/r/RADIOLOGY_NUCLEAR_MEDICINE-RA/RAPM.m@ 1757

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

initial load of FOIAVistA 6/30/08 version

File size: 7.9 KB
Line 
1RAPM ;HOIFO/TH-Radiology Performance Monitors/Indicator; ;5/12/04 10:03
2 ;;5.0;Radiology/Nuclear Medicine;**37,44,48,67**;Mar 16, 1998
3 ;
4 ; *** Application variables: ***
5 ;
6 ; Exam Date - RADTE (Regular Fileman format)
7 ; RADTI (Inverse Fileman format)
8 ; Case Number - RACN Exam Status - RAEXST
9 ; Category of Exam - RACAT Primary Interpreting Staff - RAPRIM
10 ; Date Report Entered - RARPTDT Verified Date - RAVERDT
11 ; Report Status - RARPTST Page Number - RAPG
12 ; Type of Report - RARPT
13 ; Internal number of an entry in the Patient file (#2) - RADFN
14 ;
15INIT ; Check for the existence of RACESS. Pass in user's DUZ!
16 I $D(DUZ),($O(RACCESS(DUZ,""))']"") D CHECK^RADLQ3(DUZ)
17 ;
18 N DIR,DIRUT,RABDATE,RAEDATE,RARPT,DTDIFF,RABEGDT,RAENDDT,RA1
19 N RAM,RARAD,RAR,RAMSG,X,Y
20 S (RABDATE,RAEDATE,RAANS,RAANS2,RANODIV,RASINCE,RARAD)=""
21 ; RANODIV=1 if one or more exams are missing DIVISION
22PROMPT ;
23 W @IOF
24 W !!,"Radiology Verification Timeliness Report",!!
25 ; Prompt for Report Type. Quit if no report type selected
26 D GETRPT K DIR Q:$D(DIRUT)
27 ; Prompt for Date Range - Quit if no dates selected
28 W !! D GETDATE K DIR Q:$D(DIRUT)
29 ; Prompt for Radiologist if Short or Both
30 D RADIOL^RAPM3
31 ; Prompt for Division and Imaging Types
32 S X=$$DIVLOC^RAUTL7() I X G EXIT
33 I $D(^TMP($J,"RA I-TYPE","VASCULAR LAB")) D
34 . K ^TMP($J,"RA I-TYPE","VASCULAR LAB")
35 . W !!?5,"*** Imaging type 'Vascular Lab' will not be included in this report ***"
36 ; Prompt for sort option if Detail
37 D:RARPT'="S" SORT K DIR Q:$D(DIRUT)
38 ; Prompt for mail delivery if Short or Both
39 I RARPT'="D" D EMAIL^RAPM2 K DIR Q:$D(DIRUT)
40 ; Warning for Detail or Both
41 I RARPT="D"!(RARPT="B") D
42 . S RATXT="*** The detail report requires a 132 column output device ***"
43 . S RALINE="",$P(RALINE,"*",$L(RATXT))=""
44 . W !!?(80-$L(RATXT)\2),RALINE,!?(80-$L(RATXT)\2),RATXT,!?(80-$L(RATXT)\2),RALINE,!
45 .Q
46 D DEV
47 I RAPOP D G EXIT
48 . I RAANS!(RAANS2) W !?5,"** No mail will be sent **",$C(7)
49 . Q
50START ; Get data and print the report
51 S:$D(ZTQUEUED) ZTREQ="@" S RAIO=$S(IO="":0,1:1)
52 D GETDATA
53 I RARPT="S"!(RARPT="B") S RAPG=0 D ^RAPM1
54 I RARPT="D"!(RARPT="B") S RAPG=0 D ^RAPM2
55 ; see if need send email
56 D SEND^RAPM2
57 D EXIT
58 Q
59 ;
60GETRPT ; Prompt for Summary or Detail or Both reports; Default = Summary Report
61 W !,"Enter Report Type"
62 S DIR(0)="S^S:Summary;D:Detail;B:Both"
63 S DIR("A")="Select Report Type",DIR("B")="S"
64 S DIR("?")="Enter Summary report OR Detail report OR Both reports"
65 D ^DIR
66 Q:$D(DIRUT)
67 S RARPT=Y
68 Q
69GETDATE ; Prompt for start and end dates
70 S DIR(0)="D^:"_DT_":AE"
71 I RARPT'="D" D
72 . W !!?4,"The begin date for Summary and Both must be at least 10 days before today.",!
73 . S X1=DT,X2=-10 D C^%DTC S RA1=X
74 . S DIR(0)="D^:"_RA1_":AE"
75 . Q
76 S DIR("A")="Enter starting date"
77 S DIR("?")="Enter date to begin searching from"
78 D ^DIR
79 Q:$D(DIRUT)
80 S RABDATE=Y
81 ;
82 S RADD=$S(RARPT="S":91,1:31),X1=RABDATE,X2=RADD D C^%DTC S RAMAXDT=X
83 ; put 10 day block for summary report or Both
84 I RARPT'="D" D
85 . W !!?4,"The ending date for Summary and Both must be at least 10 days before today.",!
86 . S X1=DT,X2=-10 D C^%DTC S:X<RAMAXDT RAMAXDT=X
87 S:RAMAXDT>DT RAMAXDT=DT
88 S DIR(0)="D^"_RABDATE_":"_RAMAXDT_":AE"
89 S DIR("A")="Enter ending date"
90 S DIR("?",1)=" +91 days max. for Summary, +31 days max. for Detail."
91 S DIR("?",2)=" And the ending date for the Summary and Both"
92 S DIR("?")=" must be at least 10 days before today."
93 D ^DIR
94 Q:$D(DIRUT)
95 ;
96 ; Set end date to end of day
97 ; RABDATE and RAEDATE are original values
98 ; RABEGDT and RAENDDT are used in GETDATA
99 S RAEDATE=Y,RAENDDT=RAEDATE_.9999
100 ; Set start date back to include current day
101 S RABEGDT=(RABDATE-1)_.9999
102 Q
103SORT ; Prompt for Sorted by
104 W !!,"Sort report by"
105 S DIR(0)="S^C:Case Number;E:Category of Exam;I:Imaging Type;P:Patient Name;R:Radiologist;T:Hrs to Transcrip.;V:Hrs to Verif."
106 S DIR("A")="Select Sorted by",DIR("B")="C"
107 D ^DIR
108 Q:$D(DIRUT)
109 S RASORT=Y
110 S DIR(0)="N^0:240"
111 S DIR("A")="Print PENDING and "_$S(RASORT="V":"Verif.",1:"Transrip.")_" hours greater than or equal to"
112 S DIR("B")="72"
113 S DIR("?")="Enter minimum number of hours elapsed since registration."
114 D ^DIR Q:$D(DIRUT) S RASINCE=Y
115 Q
116DEV ; Device
117 I $D(DIRUT) D EXIT Q
118 W:RARPT="B" !!,"Specify device for both summary and detail reports."
119 D TASK
120 D ZIS^RAUTL
121 Q
122TASK ; set vars for taskman
123 S ZTRTN="START^RAPM"
124 S ZTSAVE("RA*")=""
125 S ZTSAVE("^TMP($J,""RA D-TYPE"",")=""
126 S ZTSAVE("^TMP($J,""RA I-TYPE"",")=""
127 S ZTDESC="Radiology Verification Timeliness Report"
128 Q
129 ;
130GETDATA ; Get all the data
131 ; Order thru Exam Date (RADTE)
132 S RADTE=RABEGDT F S RADTE=$O(^RADPT("AR",RADTE)) Q:'RADTE Q:(RADTE>RAENDDT) D
133 . S RADFN="" F S RADFN=$O(^RADPT("AR",RADTE,RADFN)) Q:'RADFN D
134 . . ; Get patient name
135 . . S RAPATNM=$$GET1^DIQ(2,RADFN,.01) S:RAPATNM="" RAPATNM=" "
136 . . ; Order thru inverse Exam Date (RADTI)
137 . . S RADTI="" F S RADTI=$O(^RADPT("AR",RADTE,RADFN,RADTI)) Q:'RADTI D CHECK
138 . . Q
139 . Q
140 Q
141CHECK ; Check type of image
142 Q:'$D(^RADPT(RADFN,"DT",RADTI)) ;no exam data at all
143 S RAITYP=$P($G(^RADPT(RADFN,"DT",RADTI,0)),U,2)
144 S RAIMGTYP=$P($G(^RA(79.2,+RAITYP,0)),U,1)
145 ; quit if img typ is known AND does not match selection
146 I RAIMGTYP'="",'$D(^TMP($J,"RA I-TYPE",RAIMGTYP)) Q
147 I RAIMGTYP="" S RAIMGTYP="(unknown)"
148 ;
149 ; Check division - Quit if no division selected
150 S RASELDIV=$P($G(^RADPT(RADFN,"DT",RADTI,0)),U,3)
151 S RACHKDIV=$P($G(^DIC(4,+RASELDIV,0)),U,1)
152 ; quit if div is known AND does not match selection
153 I RACHKDIV'="",'$D(^TMP($J,"RA D-TYPE",RACHKDIV)) Q
154 S:RACHKDIV="" RANODIV=1
155 ;
156 ; Get exam related data
157 S RACNI=0 F S RACNI=$O(^RADPT(RADFN,"DT",RADTI,"P",RACNI)) Q:'RACNI D
158 . S (RACN0,RAEXST,RANUM,RACN,RAPRIM,RAPRIMNM,RACAT,RARPTTXT)=""
159 . S (RARPTDT,RAVERDT,RARPTST,RADHT,RADHV,RATDFHR,RAVDFHR)=""
160 . ; Get 0 node (RACN0) of ^RADPT(RADFN,"DT",RADTI,"P",RACNI,0)
161 . S RACN0=$G(^RADPT(RADFN,"DT",RADTI,"P",RACNI,0))
162 . Q:RACN0="" ; no exam data
163 . ; Get Case number: Exam Date - Case Number
164 . S RACN=$E(RADTE,4,7)_$E(RADTE,2,3)_"-"_$P(RACN0,U,1)
165 . ; Get exam status
166 . S RAEXST=$P(RACN0,U,3)
167 . Q:RAEXST="" ; no exam status
168 . ; Quit if exam's CREDIT METHOD is 2 = no credit
169 . Q:$P(RACN0,U,26)=2
170 . ; Quit if exam status is "Cancelled"
171 . I $P(^RA(72,RAEXST,0),U,3)=0 Q
172 . ; Get number of set - '1' separate; '2' for combined report.
173 . S RANUM=$P(RACN0,U,25)
174 . ; if member of set > 1 then set RACNI to 99999 to skip remaining cases
175 . I RANUM>1 S RACNI=99999
176 . ; Get Radiologist (Primary Interpreting Staff) internal # and name.
177 . S RAPRIM=$P(RACN0,U,15)
178 . ; if specific radiologist requested, quit if not his/her case
179 . I RARAD,RAPRIM'=RARAD Q
180 . S RAPRIMNM=$$GET1^DIQ(200,RAPRIM,.01) S:RAPRIMNM="" RAPRIMNM=" "
181 . ; Get Category of Exam
182 . S RACAT=$P(RACN0,U,4)
183 . ; Get Procedure Name
184 . S RAPRCN=$P($G(^RAMIS(71,+$P(RACN0,U,2),0)),U)
185 . ; Get IEN of imaging report
186 . S RARPTTXT=$P(RACN0,U,17)
187 . ; Pending if no imaging report OR report doesn't exist in the Report
188 . ; file (#74) OR Stub report
189 . S RAHASR=0 ;=1 has real report
190 . I $D(^RARPT(+RARPTTXT,0)),'$$STUB^RAEDCN1(+RARPTTXT) S RAHASR=1
191 . I 'RAHASR D
192 . . S ^TMP($J,"RAPM","TR",0)=$G(^TMP($J,"RAPM","TR",0))+1
193 . . S ^TMP($J,"RAPM","VR",0)=$G(^TMP($J,"RAPM","VR",0))+1
194 . ; Get report info. if real report exists.
195 . I RAHASR D RPTINFO^RAPM1
196 . D STORE^RAPM2
197 . ; Calculate the total number of reports
198 . S ^TMP($J,"RAPM","TOTAL")=$G(^TMP($J,"RAPM","TOTAL"))+1
199 Q
200EXIT ; Exit
201 ; Close device
202 D CLOSE^RAUTL
203 K RACN0,RAEXST,RANUM,RACN,RAPRIM,RAPRIMNM,RACAT,RARPTTXT,RAANS,RATXT
204 K DIR,DIRUT,RABDATE,RAEDATE,RARPT,DTDIFF,RABEGDT,RAENDDT,RAITYP,RAIMGTYP,RATYP
205 K ZTRTN,ZTSAVE,ZTDESC,RAPG,RASELDIV,RACHKDIV,RACNO,RAVHRS
206 K RADIV,RAN,RAIMG,RAREC1,RATOTCNT,RACNI,RADFN,RADTE,RADTI,RAHD,RAPATNM
207 K RAPOP,RAPSTX,RAQUIT,RAREC,RARPTDT,RARPTST,RASORT,RASRT,RATDFHR,RAHASR
208 K RATDFSEC,RATHRS,RAVDFHR,RAVDFSEC,RAVERDT,RAMES,RALINE,RAMAXDT,RADD
209 K RAANS2,RAIOM,RAHDR,RANODIV,RASINCE,RADHT,RADHV,RAVAL,RAPRCN
210 K RAXIT,RAIO,RALDENT,RALMAX,RALUSED,RATAIL
211 K ^TMP($J)
212 Q
Note: See TracBrowser for help on using the repository browser.