Changeset 623 for WorldVistAEHR/trunk/r/PAID-PRS/PRSASR1.m
- Timestamp:
- Dec 4, 2009, 12:11:15 AM (14 years ago)
- File:
-
- 1 edited
-
WorldVistAEHR/trunk/r/PAID-PRS/PRSASR1.m (modified) (1 diff)
Legend:
- Unmodified
- Added
- Removed
-
WorldVistAEHR/trunk/r/PAID-PRS/PRSASR1.m
r613 r623 1 PRSASR1 ;WCIOFO/JAH - Display VCS, Fee, ED ;02/20/082 ;;4.0;PAID;**6,21,82,93,116**;Sep 21, 1995;Build 23 3 4 VCS 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 ED 28 29 30 31 32 33 34 35 LD 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 LDHDR 80 81 82 83 84 85 86 87 88 LDHOLD 89 90 91 92 93 94 95 I X W ?68,$E(X),"XX-XX-",$E(X,6,9)96 97 98 99 100 PTP(PRSIEN,PPI) 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 AMT(ESR) 205 206 207 208 209 210 211 212 213 1 PRSASR1 ;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. 4 VCS ; 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 27 ED ; 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 ; 35 LD ; 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 ; 79 LDHDR ; 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 ; 88 LDHOLD ; 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 ; 100 PTP(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 ; 204 AMT(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 TracChangeset
for help on using the changeset viewer.
