source: FOIAVistA/tag/r/ASISTS-OOPS/OOPSGUIR.m@ 1590

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

initial load of FOIAVistA 6/30/08 version

File size: 9.1 KB
Line 
1OOPSGUIR ;WIOFO/LLH-RPC routine for misc reports ;03/16/04
2 ;;2.0;ASISTS;**8,7,11**;Jun 03, 2002
3 ;
4ENT(RESULTS,INPUT,CALL) ; get the data for the report
5 ; Input: INPUT - contains 3 values, the START AND END DATE,
6 ; STATION. The Date of Occ (fld #4) is used to
7 ; in/exclude claims from the report. If Station='ALL'
8 ; then all claims are included, if not 'All', then
9 ; only 1 station is included.
10 ; CALL - contains the report call which will invoke
11 ; the appropriate M call
12 ; Output: RESULTS - the results array passes data back to the client.
13 N CAX,FI,LP,MENU,SDATE,STDT,STA,STATION,ENDDT,EDATE,TAG,X,Y,%DT
14 S RESULTS(0)="Processing..."
15 S STDT=$P($G(INPUT),U),ENDDT=$P($G(INPUT),U,2)
16 S STA=$P($G(INPUT),U,3),TAG=CALL
17 I (STDT="")!(ENDDT="")!(STA="")!(TAG="") D Q
18 . S RESULTS(0)="Input parameters missing, cannot run report." Q
19 K ^TMP($J,TAG)
20 S (SDATE,EDATE,MENU)=""
21 S X=STDT D ^%DT S SDATE=Y
22 S X=ENDDT D ^%DT S EDATE=Y
23 ; SDATE made last time in day prior so start date correct
24 I TAG="LOG300U" S TAG="LOG300",MENU="U"
25 S SDATE=(SDATE-1)+.9999,EDATE=EDATE_".9999"
26 D @TAG
27 Q
28SERVICE ; Service/Detail Location report - patch 11
29DSPUTE ; Reason for Dispute report. Patch 11
30FLD174 ; Report compiles filing instruction result counts
31FLD332 ; Use this tag for Reason for Controvert report. Patch 11
32 N ARR,CODE,CN,LP,IEN,I,GOON,P2,TX
33 S LP="",IEN="",CN=0
34 I TAG="FLD174" D
35 .S CODE=$P($G(^DD(2260,174,0)),U,3)
36 .F I=1:1 S LP=$P(CODE,";",I) Q:$G(LP)="" I $P(LP,":",2)'="" S ARR(LP)=0
37 .S ARR(I_":No Data Entered")=0
38 I TAG="FLD332" D
39 .F I=1:1 Q:'$D(^OOPS(2262.4,I)) S ARR(I_":"_$P(^OOPS(2262.4,I,0),U))=0
40 .S ARR(98_":Blk 36 also has text entered")=0
41 .S ARR(99_":Controvert question checked Yes, but no Controvert Code entered")=0
42 F LP=SDATE:0 S LP=$O(^OOPS(2260,"AD",LP)) Q:(LP'>0)!(LP>EDATE) D
43 .F S IEN=$O(^OOPS(2260,"AD",LP,IEN)) Q:IEN'>0 D
44 ..I $$GET1^DIQ(2260,IEN,51,"I")>1 Q ;only allow open/closed cases
45 ..S CAX=$$GET1^DIQ(2260,IEN,52,"I")
46 ..I TAG'="SERVICE"&(CAX=2) Q ;only allow CA1's
47 ..S STATION=$P(^OOPS(2260,IEN,"2162A"),U,9)
48 ..I ($G(STA)'="A"),(STATION'=STA) Q ;get correct station
49 ..;patch 11 - sent to OOPSGUIF due to size this routine
50 ..I TAG="DSPUTE" D DSPUTE^OOPSGUIF
51 ..I TAG="SERVICE" D SERVICE^OOPSGUIU
52 ..; Filing instructions report
53 ..I TAG="FLD174" D
54 ...S FI=$$GET1^DIQ(2260,IEN,174,"I")_":"_$$GET1^DIQ(2260,IEN,174)
55 ...I $$GET1^DIQ(2260,IEN,174)="" S FI=I_":No Data Entered"
56 ...S ARR(FI)=ARR(FI)+1
57 ...;patch 11 - Reason for controvert report
58 ..I TAG="FLD332" D
59 ...;first Agency Controvert must = "Y" to be counted
60 ...S GOON=$$GET1^DIQ(2260,IEN,165.1,"I") I $G(GOON)'="Y" D Q
61 ....S:'$D(ARR("999:Case not controverted, no controvert code expected")) ARR("999:Case not controverted, no controvert code expected")=0
62 ....S ARR("999:Case not controverted, no controvert code expected")=ARR("999:Case not controverted, no controvert code expected")+1
63 ...S FI=$$GET1^DIQ(2260,IEN,332,"I")_":"_$$GET1^DIQ(2260,IEN,332)
64 ...I $$GET1^DIQ(2260,IEN,332)="" S FI=99_":Controvert question checked Yes, but no Controvert Code entered"
65 ...S ARR(FI)=ARR(FI)+1
66 ...I $G(^OOPS(2260,IEN,"CA1K",1,0))'="" D
67 ....;if case is diputed, don't count in Controvert rpt - quit
68 ....S GOON=$$GET1^DIQ(2260,IEN,165.2,"I") I $G(GOON)="Y" Q
69 ....S ARR(98_":Blk 36 also has text entered")=ARR(98_":Blk 36 also has text entered")+1
70 I TAG'="DSPUTE",(TAG'="SERVICE") D
71 .S CN=0,FI="",P2=""
72 .F S FI=$O(ARR(FI)) Q:FI="" D
73 ..S CN=$P(FI,":"),P2=$P(FI,":",2),CODE=0
74 ..I TAG="FLD332" S TX=$O(^OOPS(2262.4,"B",P2,"")) I $G(TX) S CODE=$P(^OOPS(2262.4,TX,0),U,2)
75 ..S ^TMP($J,TAG,CN)=P2_U_CODE_U_ARR(FI)
76 ..; rearrange 'bogus' Controvert Codes for report formating
77 ..I TAG="FLD332",(CN>97) S ^TMP($J,TAG,CN)=U_P2_U_ARR(FI)
78 I TAG="SERVICE" D CMPLSRV^OOPSGUIU
79 I TAG="DSPUTE" D DSPUTE^OOPSGUIU
80 S RESULTS=$NA(^TMP($J,TAG))
81 Q
82SUM300A ; Summary of Work-related injuries and illness report
83 N CN,EMP,FAC,HRS,STATE,STR
84 N COLG,COLH,COLI,COLJ,COLK,COLL,COLM
85 S (COLG,COLH,COLI,COLJ,COLK,COLL)=0
86 S (COLM(1),COLM(2),COLM(3),COLM(4),COLM(5),COLM(6))=0
87 S ^TMP($J,TAG,0)="No worksheet data for this station."
88 S FAC=$$GET1^DIQ(4,STA,.01,"E")
89 K ARR D STATINFO^OOPSGUI3(.ARR,STA) I $D(ARR) D
90 .S STATE=$P($G(ARR(0)),U,3)
91 .I $G(STATE)'="" D
92 ..S STATE=$O(^DIC(5,"B",STATE,""))
93 ..S $P(ARR(0),U,3)=$P(^DIC(5,STATE,0),U,2)
94 .S ^TMP($J,TAG,0)=FAC_U_ARR(0)
95 K ARR D SITEPGET^OOPSGUI6(.ARR,"OSHA300") I $D(ARR) D
96 .S CN=0 F S CN=$O(ARR(CN)) Q:CN="" D
97 ..I $P(ARR(CN),U,11)'=STA Q
98 ..S STR=$P($P(ARR(CN),U,1)," = ",2)
99 ..S STR=$P(ARR(CN),U,3)_U_$P(ARR(CN),U,4)_U_$P(ARR(CN),U,6)_U
100 ..S STR=STR_$P(ARR(CN),U,7)_U_$P(ARR(CN),U,8)
101 ..S ^TMP($J,TAG,0)=^TMP($J,TAG,0)_U_STR
102 K ARR,DATA S DATA=""
103 D EMPHRS,DETAIL
104 Q
105IRWSHT ; Incidence Rates Worksheet Report
106 N COLHI,EMP,HRS
107 S ^TMP($J,TAG,1)="No Worksheet Data for this Station"
108 S COLHI=0
109 K ARR,DATA S DATA=""
110 D EMPHRS,DETAIL
111 Q
112DETAIL ; now get employee information
113LOG300 ; entry point for the OSHA 300 LOG
114 N CN,CASES,DOI,FLD,IEN,INC,STATION,TYPE
115 S DOI=SDATE,CASES=0,CN=1
116 F S DOI=$O(^OOPS(2260,"AF",DOI)) Q:(DOI>EDATE)!(DOI="") S IEN=0 D
117 .F S IEN=$O(^OOPS(2260,"AF",DOI,"Y",IEN)) Q:IEN="" D
118 ..S STATION=$P(^OOPS(2260,IEN,"2162A"),U,9) I $G(STATION)'=STA Q
119 ..I $P(^OOPS(2260,IEN,0),U,6)>1 Q
120 ..S CASES=CASES+1
121 ..I TAG="IRWSHT" D
122 ...I $D(^OOPS(2260,IEN,"OUTC","AC","A","J"))!$D(^OOPS(2260,IEN,"OUTC","AC","A","A")) S COLHI=COLHI+1
123 ..I TAG="SUM300A" D FLD95
124 ..I TAG="LOG300" D FLD95 D
125 ...S ARR(1)=$$GET1^DIQ(2260,IEN,.01),ARR(2)=$$GET1^DIQ(2260,IEN,1)
126 ...I $$GET1^DIQ(2260,IEN,337,"I")="Y" S ARR(2)="Privacy Case"
127 ...S TYPE=$$GET1^DIQ(2260,IEN,3,"I")
128 ...I TYPE>10&(TYPE<15) S ARR(2)="Privacy Case"
129 ...I MENU="U" S ARR(2)=""
130 ...S INC=$$GET1^DIQ(2260,IEN,52,"I"),FLD=$S(INC=1:111,INC=2:208,1:"")
131 ...S ARR(3)=$$GET1^DIQ(2260,IEN,FLD)
132 ...S ARR(4)=$P($$FMTE^XLFDT(($$GET1^DIQ(2260,IEN,4,"I")),2),"@")
133 ...S ARR(5)=$$GET1^DIQ(2260,IEN,27,"E")
134 ...S ARR(6)=$$GET1^DIQ(2260,IEN,3)_";"_$$GET1^DIQ(2260,IEN,30)
135 ...S DATA=ARR(1)_U_ARR(2)_U_ARR(3)_U_ARR(4)_U_ARR(5)_U_ARR(6)_U_ARR(7)_U
136 ...S DATA=DATA_ARR(8)_U_ARR(9)_U_ARR(10)
137 ...S ^TMP($J,TAG,CN)=DATA,CN=CN+1
138 I TAG="IRWSHT" S ^TMP($J,TAG,1)=CASES_U_COLHI_U_HRS
139 I TAG="SUM300A" D
140 .S DATA=CASES_U_EMP_U_HRS_U_COLG_U_COLH_U_COLI_U_COLJ_U_COLK_U_COLL_U
141 .S DATA=DATA_COLM(1)_U_COLM(2)_U_COLM(3)_U_COLM(4)_U_COLM(5)_U_COLM(6)
142 .S ^TMP($J,TAG,1)=DATA
143 S RESULTS=$NA(^TMP($J,TAG))
144 K ARR,DATA
145 Q
146FLD95 ; use OUTC subrecord to retrieve data
147 N AVAIL,ED,SD,S0,INC,ILL,DAYA,DAYJ,DAYS,IEN95,OC,OUTC,S95,TDAY
148 S S0=$G(^OOPS(2260,IEN,0)),INC=$P(S0,U,7)
149 S ILL=$P($G(^OOPS(2260,IEN,"2162B")),U,15)
150 S TDAY=$$HTFM^XLFDT(+$H)
151 ; add days away & job transfer up only to 180 for log, 4 300A get all
152 S (DAYA,DAYJ,TAWAY)=0,IEN95=0
153 F S IEN95=$O(^OOPS(2260,IEN,"OUTC",IEN95)) Q:IEN95'>0 D
154 .S S95=$G(^OOPS(2260,IEN,"OUTC",IEN95,0))
155 .S SD=$P(S95,U,1),ED=$P(S95,U,2),OC=$P(S95,U,3),DAYS=0
156 .I $P(S95,U,11)="D" Q ; entry is deleted
157 .;patch 11 - added logic that if TAG=LOG300 include all incident days
158 .; up to 180, else 300A, only include date range incidents
159 .I (TAG="SUM300A"),(EDATE<SD) Q
160 .I $G(OC)'="" S OUTC(OC)=""
161 .I TAG="SUM300A" D
162 ..I $G(ED)=""!($G(ED)>EDATE) S DAYS=$$FMDIFF^XLFDT(EDATE,SD,1)+1
163 .I TAG="LOG300",($G(ED)="") S DAYS=$$FMDIFF^XLFDT(TDAY,SD,1)+1
164 .I '$G(DAYS) S DAYS=$S(OC="A":$P(S95,U,4),OC="J":$P(S95,U,5),1:0)
165 .I DAYA+DAYJ>180 Q
166 .S AVAIL=0
167 .I DAYS>180 S AVAIL=180
168 .I (DAYS<180) D
169 ..I (DAYS+DAYA+DAYJ)<180 S AVAIL=DAYS
170 ..I (DAYS+DAYA+DAYJ)>180 S AVAIL=(180-(DAYA+DAYJ))
171 .I $G(OC)="A" S DAYA=DAYA+AVAIL
172 .I $G(OC)="J" S DAYJ=DAYJ+AVAIL
173 I TAG="SUM300A" D
174 .S:$G(INC)=1 COLM(1)=COLM(1)+1
175 .I INC=2 D
176 ..I $G(ILL) S COLM(ILL)=COLM(ILL)+1
177 ..I '$G(ILL) S COLM(6)=COLM(6)+1
178 .S COLK=COLK+DAYA,COLL=COLL+DAYJ
179 .I $D(OUTC("D")) S COLG=COLG+1 Q
180 .I $D(OUTC("A")) S COLH=COLH+1 Q
181 .I $D(OUTC("J")) S COLI=COLI+1 Q
182 .I $D(OUTC("O")) S COLJ=COLJ+1 Q
183 I TAG="LOG300" D
184 .S ARR(7)="",ARR(10)="",(ARR(8),ARR(9))=0
185 .I INC=1 S ARR(10)=1
186 .I INC=2 S:$G(ILL) ARR(10)=ILL S:'$G(ILL) ARR(10)=6
187 .S ARR(8)=DAYA,ARR(9)=DAYJ
188 .I $D(OUTC("D")) S ARR(7)="D" S (ARR(8),ARR(9))=0 Q
189 .I $D(OUTC("A")) S ARR(7)="A" Q
190 .I $D(OUTC("J")) S ARR(7)="J" Q
191 .I $D(OUTC("O")) S ARR(7)="O" Q
192 Q
193EMPHRS ; get Total Num Employees and Hours worked
194 N CASES,ED,LV1,LV2,MON,OK,PAR,SD,SIEN,STR,WS,X,X1,X2
195 S (EMP,HRS,WS)=0
196 S PAR="^OOPS(2262,0)",PAR=$Q(@PAR),PAR=$Q(@PAR)
197 S LV1=$P(PAR,",",2),LV2=$P(PAR,",",3)
198 S SIEN=$O(^OOPS(2262,LV1,LV2,"B",STA,-1)) Q:SIEN=""
199 ; get month range to make sure all emp numbers and hours are entered
200 S SDATE=SDATE\1
201 S SD=$E(SDATE,1,5)_"00"_$E(SDATE,8,$L(SDATE))
202 S ED=$E(EDATE,1,5)_"00"_$E(EDATE,8,$L(EDATE))
203 S X1=$E(ED,1,3),X2=$E(SD,1,3)
204 I X1>X2 D
205 .S OK=0,X=(X1-X2) S:X>1 OK=(X-1)*12
206 .S OK=OK+(($E(ED,4,5)-$E(SD,4,5))+1)+$E(SD,4,5)
207 I X1=X2 S OK=($E(ED,4,5)-$E(SD,4,5))+1
208 S MON=OK
209 F S WS=$O(^OOPS(2262,LV1,LV2,SIEN,2,WS)) Q:(WS'>0) D
210 .S STR=^OOPS(2262,LV1,LV2,SIEN,2,WS,0)
211 .I ($P(STR,U)'<SD)&($P(STR,U)'>ED) D
212 ..I ($P(STR,U,2)="")!($P(STR,U,3)="") Q
213 ..S EMP=EMP+$P(STR,U,2),HRS=HRS+$P(STR,U,3),OK=OK-1
214 I '$G(OK) S EMP=EMP/MON
215 I $G(OK) S (EMP,HRS)="INCOMPLETE DATA"
216 Q
Note: See TracBrowser for help on using the repository browser.