source: FOIAVistA/tag/r/PAID-PRS/PRSASR1.m@ 636

Last change on this file since 636 was 636, checked in by George Lilly, 14 years ago

WorldVistAEHR overlayed on FOIAVistA
File size: 7.8 KB
Line 
1PRSASR1 ;HISC/MGD - Display VCS, Fee, ED ;04/19/05
2 ;;4.0;PAID;**6,21,82,93**;Sep 21, 1995;Build 7
3 ;;Per VHA Directive 2004-038, this routine should not be modified.
4VCS ; Display VCS Sales/Fee Basis
5 ;
6 N OLDPP
7 S PAYP=$P($G(^PRSPC(DFN,0)),"^",21)
8 ; Check the pay plan for the pay period we are dealing with
9 ; in case it's a previous pay period where an employee
10 ; had a different pay plan.
11 ; 1st put pay period in YY-PP format 4 call 2 lookup old pay plan.
12 ;Only check if called from option Display employee pay period PPERIOD
13 ;will be defined.
14 I $G(PPERIOD) D
15 .;S PPERIOD=$S(Y["-":$P(Y,"^",2),1:$P(^PRST(458,$P(Y,"^"),0),"^"))
16 .S OLDPP=$$OLDPP^PRS8UT(PPERIOD,DFN)
17 .I OLDPP'=0,(OLDPP'=PAYP) D
18 .. S PAYP=OLDPP
19 .. W !,"Employee is NOT currently under this pay plan."
20 ;
21 W !!?30,$S(PAYP="F":"Fee Basis Appointee",1:"VCS Commission Sales")
22 W !!?13,"Sun Mon Tue Wed Thu Fri Sat",!
23 W !,"Week 1" S L1=1 F K=1:1:7 S L1=L1+10,Z1=$P(Z,"^",K) I Z1'="" W ?L1,$J(Z1,7,2)
24 W !,"Week 2" S L1=1 F K=8:1:14 S L1=L1+10,Z1=$P(Z,"^",K) I Z1'="" W ?L1,$J(Z1,7,2)
25 I PAYP="F" W !! F K=19:1:21 S Z1=$P(Z,"^",K) W "Total ",$P("Hours Days Procedures"," ",K-18),": ",Z1," "
26 Q
27ED ; Display Envir. Diff.
28 W !!?26,"Environmental Differentials",!
29 S Y="" F K=1:2:5 S Z1=$P(Z,"^",K) Q:'Z1 S:Y'="" Y=Y_"; " S Y=Y_$P($G(^PRST(457.6,+Z1,0)),"^",1)_" "_$P(Z,"^",K+1)_" Hrs."
30 I Y'="" W !,"Week 1: ",Y
31 S Y="" F K=7:2:11 S Z1=$P(Z,"^",K) Q:'Z1 S:Y'="" Y=Y_"; " S Y=Y_$P($G(^PRST(457.6,+Z1,0)),"^",1)_" "_$P(Z,"^",K+1)_" Hrs."
32 I Y'="" W !,"Week 2: ",Y
33 Q
34 ;
35LD ; Display changes to the Labor Distribution Codes within the Pay
36 ; Period.
37 ;
38 N DASH,DESC,IENS,LDCC,LDCCB,LDCCEX,LDCODE,LDCNT,LDDOA,LDFCP
39 N LDHOLD,LDPCT,LDTOI,PRSLD,Y
40 S $P(DASH,"-",80)=""
41 W !
42 D LDHOLD
43 W !,"Current Labor Distribution Values:"
44 S LDDOA=$$GET1^DIQ(450,DFN,756,"E")
45 S LDCCB=$$GET1^DIQ(450,DFN,755,"E")
46 S LDTOI=$$GET1^DIQ(450,DFN,755.1,"E")
47 W !,LDDOA,?24,LDCCB,?61,LDTOI
48 F PRSLD=1:1:4 D
49 . S LDCODE=$$GET1^DIQ(450.0757,PRSLD_","_DFN,1)
50 . S LDPCT=$$GET1^DIQ(450.0757,PRSLD_","_DFN,2)
51 . S LDCC=$$GET1^DIQ(450.0757,PRSLD_","_DFN,3)
52 . S Y=LDCC,SUB454="CC"
53 . D OT^PRSDUTIL K SUB454
54 . S LDCCEX=$E(Y,1,30)
55 . S LDFCP=$$GET1^DIQ(450.0757,PRSLD_","_DFN,4)
56 . W !,"Code",PRSLD,": ",LDCODE,?12,LDPCT,?24,LDCC," - ",LDCCEX,?70,LDFCP
57 ;
58 W !!,"The previous Labor Distribution Values:"
59 S LDCNT="A"
60 S LDCNT=$O(^PRST(458,PPI,"E",DFN,"LDAUD",LDCNT),-1)
61 Q:'LDCNT
62 S IENS=LDCNT_","_DFN_","_PPI_","
63 S LDDOA=$$GET1^DIQ(458.1105,IENS,1,"E")
64 S LDCCB=$$GET1^DIQ(458.1105,IENS,2,"E")
65 S LDTOI=$$GET1^DIQ(458.1105,IENS,3,"E")
66 W !,LDDOA,?24,LDCCB,?61,LDTOI
67 F PRSLD=1:1:4 D
68 . S IENS=PRSLD_","_LDCNT_","_DFN_","_PPI_","
69 . S LDCODE=$$GET1^DIQ(458.11054,IENS,1)
70 . S LDPCT=$$GET1^DIQ(458.11054,IENS,2)
71 . S LDCC=$$GET1^DIQ(458.11054,IENS,3)
72 . S Y=LDCC,SUB454="CC"
73 . D OT^PRSDUTIL K SUB454
74 . S LDCCEX=$E(Y,1,30)
75 . S LDFCP=$$GET1^DIQ(458.11054,IENS,4)
76 . W !,"Code",PRSLD,": ",LDCODE,?12,LDPCT,?24,LDCC," - ",LDCCEX,?70,LDFCP
77 Q
78 ;
79LDHDR ; Labor Distribution Header information
80 ;
81 W !?15,"Labor Distribution Changes within the Pay Period:"
82 W !,"Date/Time",?24,"Changed by",?61,"Type of Interface"
83 W !,"Code",?12,"Percent",?24,"Cost Center - Description"
84 W ?65,"Fund Ctrl Pt"
85 W !,DASH
86 Q
87 ;
88LDHOLD ; Pause of more LD changes that will fit on 1 screen.
89 ;
90 N X
91 S LDHOLD=$$ASK^PRSLIB00(1)
92 S X=$G(^PRSPC(DFN,0))
93 W !,@IOF,?3,$P(X,"^",1)
94 S X=$P(X,"^",9)
95 I X W ?68,$E(X,1,3),"-",$E(X,4,5),"-",$E(X,6,9)
96 W !,DASH
97 D LDHDR
98 Q
99 ;
100PTP(PRSIEN,PPI) ; Updates hours credited for PT Phys w/ Memorandums
101 ; This API can be used for initial and subsequent calculation
102 ; of the PTP's ESR.
103 ; algorithm for this API follows:
104 ; 1. Grab copy of currently stored pay period hours
105 ; 2. Look at ESR/timecard data to recalculate pay period hours
106 ; 3. Calculate net difference between 1 and 2
107 ; 4. update current pay period with new pp totals from (2) above
108 ; 5. add net diff (3) to memo totals
109 ;
110 N AHRS,AHTCM,AMT,COHRS,DIFFNP,DIFFRG,DIFFWP,INPH,ITHP,ITHW,IWPH
111 N MDAT,MDATA,MEAL,MIEN,MPPIEN,POHC,POT,PPC,PPE
112 N PPHRS,PPNP,PPWP,PRSX,START,STOP,THP,TOT,TOTAL,TOTNP,TOTWP
113 S MDAT=$P($G(^PRST(458,PPI,1)),U,1)
114 S MIEN=+$$MIEN^PRSPUT1(PRSIEN,MDAT)
115 Q:'MIEN ; Not a PTP w/ memo
116 S PPE=$P($G(^PRST(458,PPI,0)),U,1)
117 ;
118 ; Locate this PP in the PTP's memorandum
119 S MPPIEN=$O(^PRST(458.7,MIEN,9,"B",PPE,0))
120 Q:'MPPIEN ; PP not found within memo (###exception message)
121 ;
122 ;get the current values for this pay period under the memo.
123 S PRSX=$G(^PRST(458.7,MIEN,9,MPPIEN,0))
124 S PPHRS=+$P(PRSX,U,2) ; Actual hours of work credited
125 S PPNP=+$P(PRSX,U,3) ; Actual hours of Non Pay
126 S PPWP=+$P(PRSX,U,4) ; Actual hours of LWOP
127 K PRSX
128 ;
129 ; Load the memo totals
130 S MDATA=$G(^PRST(458.7,MIEN,0))
131 S AHRS=+$P(MDATA,U,4) ; Agreed Hours
132 S COHRS=+$P(MDATA,U,9) ; Carryover Hours
133 S ITHW=+$P(MDATA,U,10) ; Initial Total Hours Worked
134 S ITHP=+$P(MDATA,U,11) ; Initial Total Hours Paid
135 S INPH=+$P(MDATA,U,12) ; Initial Non-Pay Hours
136 S IWPH=+$P(MDATA,U,13) ; Initial Without Pay Hours
137 S (AHTCM,DIFFRG,DIFFNP,DIFFWP)=0
138 ;
139 ; Get Non pay and Leave without pay times from 8b string or recalc.
140 N TAMTS
141 S TAMTS("WP","Leave Without Pay")=""
142 S TAMTS("NP","Non-Pay Time")=""
143 D PP8BAMT^PRSPUT3(.TAMTS,PPI,PRSIEN)
144 S TOTAL("WP")=$G(TAMTS("WP","Leave Without Pay"))
145 S TOTAL("NP")=$G(TAMTS("NP","Non-Pay Time"))
146 S DIFFNP=TOTAL("NP")-PPNP
147 S DIFFWP=TOTAL("WP")-PPWP
148 ;
149 ; Loop thru day and ESR segments looking for leave and RG time
150 N DAY,ESR,RGCODES,SEG,TOT
151 S RGCODES="AA,AD,AL,CB,CP,DL,HX,ML,RG,RL,SL,TR,TV"
152 S TOTAL("RG")=0
153 F DAY=1:1:14 D
154 . ; only add totals for supervisor approved days
155 . Q:$$GETSTAT^PRSPESR1(PRSIEN,PPI,DAY)'=5
156 . S ESR=$G(^PRST(458,PPI,"E",PRSIEN,"D",DAY,5))
157 . Q:ESR=""
158 . F SEG=0:1:6 Q:$P(ESR,U,(5*SEG)+3)="" D
159 . . S TOT=$P(ESR,U,(5*SEG)+3)
160 . . ; Types Of Time that might have been worked in week 1
161 . . I RGCODES[TOT D Q
162 . . . S TOTAL("RG")=TOTAL("RG")+$$AMT(ESR)
163 ;
164 ; Checks for Regular Time
165 S DIFFRG=TOTAL("RG")-PPHRS
166 ; determine number of memo pay periods that have been certified
167 S PRSX=$$MEMCPP^PRSPUT3(MIEN)
168 S PPC=$P(PRSX,U,2)+$S(PPE]$P(PRSX,U):1,1:0)
169 ;
170 ; Update pp totals with current calculated values
171 K IEN4587,PRSFDA
172 S IEN4587=MIEN_","
173 S PRSFDA(458.701,MPPIEN_","_IEN4587,1)=TOTAL("RG") ; PP new REG hrs
174 S PRSFDA(458.701,MPPIEN_","_IEN4587,2)=TOTAL("NP") ; PP new NP hrs
175 S PRSFDA(458.701,MPPIEN_","_IEN4587,3)=TOTAL("WP") ; PP new WP hrs
176 ;
177 ; update memo grand totals with differences found
178 S TOTNP=INPH+DIFFNP
179 S TOTWP=IWPH+DIFFWP
180 S PRSFDA(458.7,IEN4587,11)=TOTNP ; NP hrs
181 S PRSFDA(458.7,IEN4587,12)=TOTWP ; WP hrs
182 S PRSFDA(458.7,IEN4587,9)=ITHW+DIFFRG ; tot hrs worked (all creditable)
183 ;
184 ; If this is the first time the PP has been processed PPHRS will be null
185 ; so add the average hrs/pp, otherwise this count has already been added
186 S THP=ITHP+$S(PPHRS="":AHRS/26,1:0)
187 S PRSFDA(458.7,IEN4587,10)=$FN(THP-DIFFNP-DIFFWP,"",2) ; tot hrs paid
188 S PRSFDA(458.7,IEN4587,13)=$FN(PPC/26,"",2) ; % of memo completed
189 ; % OF HOURS COMPLETED
190 S POHC=$FN((ITHW+COHRS+DIFFRG)/(AHRS-TOTNP-TOTWP),"",2)
191 S PRSFDA(458.7,IEN4587,14)=POHC
192 ;
193 ; ave hrs/pp to complete mem (if certifying last pay period then then
194 ; you're out of pay periods so use 0.00 to report how many more hours)
195 S AHTCM=$S(PPC>25:"0.00",1:$FN((AHRS-(ITHW+COHRS+DIFFRG)/(26-PPC)),"",2))
196 S PRSFDA(458.7,IEN4587,15)=AHTCM
197 ; % off target
198 S POT=((AHRS/26)*PPC)-TOTNP-TOTWP
199 S POT=(ITHW+COHRS+DIFFRG)-POT/POT,POT=POT*100,POT=$FN(POT,"",2)
200 S PRSFDA(458.7,IEN4587,16)=POT
201 D FILE^DIE("","PRSFDA")
202 Q
203 ;
204AMT(ESR) ; Return hours elapsed for time segment in decimal format
205 ; deduct meal
206 ; e.g. AMT=2.5 (2 hours 30 min)
207 N START,STOP,MEAL,AMT,X
208 S START=$P(ESR,U,(5*SEG)+1),STOP=$P(ESR,U,(5*SEG)+2)
209 S MEAL=$P(ESR,U,(5*SEG)+5)
210 S AMT=$$ELAPSE^PRSPESR2(MEAL,START,STOP)
211 S X=$P(AMT,":",2) S X=$S(X=30:5,X=15:25,X=45:75,1:0)
212 S AMT=+$P(AMT,":",1)_"."_X
213 Q AMT
Note: See TracBrowser for help on using the repository browser.