- PRSASR1 ;WCIOFO/JAH - Display VCS, Fee, ED ;02/20/08
- ;;4.0;PAID;**6,21,82,93,116**;Sep 21, 1995;Build 23
- ;;Per VHA Directive 2004-038, this routine should not be modified.
- VCS ; Display VCS Sales/Fee Basis
- ;
- N OLDPP
- S PAYP=$P($G(^PRSPC(DFN,0)),"^",21)
- ; Check the pay plan for the pay period we are dealing with
- ; in case it's a previous pay period where an employee
- ; had a different pay plan.
- ; 1st put pay period in YY-PP format 4 call 2 lookup old pay plan.
- ;Only check if called from option Display employee pay period PPERIOD
- ;will be defined.
- I $G(PPERIOD) D
- .;S PPERIOD=$S(Y["-":$P(Y,"^",2),1:$P(^PRST(458,$P(Y,"^"),0),"^"))
- .S OLDPP=$$OLDPP^PRS8UT(PPERIOD,DFN)
- .I OLDPP'=0,(OLDPP'=PAYP) D
- .. S PAYP=OLDPP
- .. W !,"Employee is NOT currently under this pay plan."
- ;
- W !!?30,$S(PAYP="F":"Fee Basis Appointee",1:"VCS Commission Sales")
- W !!?13,"Sun Mon Tue Wed Thu Fri Sat",!
- 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)
- 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)
- I PAYP="F" W !! F K=19:1:21 S Z1=$P(Z,"^",K) W "Total ",$P("Hours Days Procedures"," ",K-18),": ",Z1," "
- Q
- ED ; Display Envir. Diff.
- W !!?26,"Environmental Differentials",!
- 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."
- I Y'="" W !,"Week 1: ",Y
- 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."
- I Y'="" W !,"Week 2: ",Y
- Q
- ;
- LD ; Display changes to the Labor Distribution Codes within the Pay
- ; Period.
- ;
- N DASH,DESC,IENS,LDCC,LDCCB,LDCCEX,LDCODE,LDCNT,LDDOA,LDFCP
- N LDHOLD,LDPCT,LDTOI,PRSLD,Y
- S $P(DASH,"-",80)=""
- W !
- D LDHOLD
- W !,"Current Labor Distribution Values:"
- S LDDOA=$$GET1^DIQ(450,DFN,756,"E")
- S LDCCB=$$GET1^DIQ(450,DFN,755,"E")
- S LDTOI=$$GET1^DIQ(450,DFN,755.1,"E")
- W !,LDDOA,?24,LDCCB,?61,LDTOI
- F PRSLD=1:1:4 D
- . S LDCODE=$$GET1^DIQ(450.0757,PRSLD_","_DFN,1)
- . S LDPCT=$$GET1^DIQ(450.0757,PRSLD_","_DFN,2)
- . S LDCC=$$GET1^DIQ(450.0757,PRSLD_","_DFN,3)
- . S Y=LDCC,SUB454="CC"
- . D OT^PRSDUTIL K SUB454
- . S LDCCEX=$E(Y,1,30)
- . S LDFCP=$$GET1^DIQ(450.0757,PRSLD_","_DFN,4)
- . W !,"Code",PRSLD,": ",LDCODE,?12,LDPCT,?24,LDCC," - ",LDCCEX,?70,LDFCP
- ;
- W !!,"The previous Labor Distribution Values:"
- S LDCNT="A"
- S LDCNT=$O(^PRST(458,PPI,"E",DFN,"LDAUD",LDCNT),-1)
- Q:'LDCNT
- S IENS=LDCNT_","_DFN_","_PPI_","
- S LDDOA=$$GET1^DIQ(458.1105,IENS,1,"E")
- S LDCCB=$$GET1^DIQ(458.1105,IENS,2,"E")
- S LDTOI=$$GET1^DIQ(458.1105,IENS,3,"E")
- W !,LDDOA,?24,LDCCB,?61,LDTOI
- F PRSLD=1:1:4 D
- . S IENS=PRSLD_","_LDCNT_","_DFN_","_PPI_","
- . S LDCODE=$$GET1^DIQ(458.11054,IENS,1)
- . S LDPCT=$$GET1^DIQ(458.11054,IENS,2)
- . S LDCC=$$GET1^DIQ(458.11054,IENS,3)
- . S Y=LDCC,SUB454="CC"
- . D OT^PRSDUTIL K SUB454
- . S LDCCEX=$E(Y,1,30)
- . S LDFCP=$$GET1^DIQ(458.11054,IENS,4)
- . W !,"Code",PRSLD,": ",LDCODE,?12,LDPCT,?24,LDCC," - ",LDCCEX,?70,LDFCP
- Q
- ;
- LDHDR ; Labor Distribution Header information
- ;
- W !?15,"Labor Distribution Changes within the Pay Period:"
- W !,"Date/Time",?24,"Changed by",?61,"Type of Interface"
- W !,"Code",?12,"Percent",?24,"Cost Center - Description"
- W ?65,"Fund Ctrl Pt"
- W !,DASH
- Q
- ;
- LDHOLD ; Pause of more LD changes that will fit on 1 screen.
- ;
- N X
- S LDHOLD=$$ASK^PRSLIB00(1)
- S X=$G(^PRSPC(DFN,0))
- W !,@IOF,?3,$P(X,"^",1)
- S X=$P(X,"^",9)
- I X W ?68,$E(X),"XX-XX-",$E(X,6,9)
- W !,DASH
- D LDHDR
- Q
- ;
- PTP(PRSIEN,PPI) ; Updates hours credited for PT Phys w/ Memorandums
- ; This API can be used for initial and subsequent calculation
- ; of the PTP's ESR.
- ; algorithm for this API follows:
- ; 1. Grab copy of currently stored pay period hours
- ; 2. Look at ESR/timecard data to recalculate pay period hours
- ; 3. Calculate net difference between 1 and 2
- ; 4. update current pay period with new pp totals from (2) above
- ; 5. add net diff (3) to memo totals
- ;
- N AHRS,AHTCM,AMT,COHRS,DIFFNP,DIFFRG,DIFFWP,INPH,ITHP,ITHW,IWPH
- N MDAT,MDATA,MEAL,MIEN,MPPIEN,POHC,POT,PPC,PPE
- N PPHRS,PPNP,PPWP,PRSX,START,STOP,THP,TOT,TOTAL,TOTNP,TOTWP
- S MDAT=$P($G(^PRST(458,PPI,1)),U,1)
- S MIEN=+$$MIEN^PRSPUT1(PRSIEN,MDAT)
- Q:'MIEN ; Not a PTP w/ memo
- S PPE=$P($G(^PRST(458,PPI,0)),U,1)
- ;
- ; Locate this PP in the PTP's memorandum
- S MPPIEN=$O(^PRST(458.7,MIEN,9,"B",PPE,0))
- Q:'MPPIEN ; PP not found within memo (###exception message)
- ;
- ;get the current values for this pay period under the memo.
- S PRSX=$G(^PRST(458.7,MIEN,9,MPPIEN,0))
- S PPHRS=+$P(PRSX,U,2) ; Actual hours of work credited
- S PPNP=+$P(PRSX,U,3) ; Actual hours of Non Pay
- S PPWP=+$P(PRSX,U,4) ; Actual hours of LWOP
- K PRSX
- ;
- ; Load the memo totals
- S MDATA=$G(^PRST(458.7,MIEN,0))
- S AHRS=+$P(MDATA,U,4) ; Agreed Hours
- S COHRS=+$P(MDATA,U,9) ; Carryover Hours
- S ITHW=+$P(MDATA,U,10) ; Initial Total Hours Worked
- S ITHP=+$P(MDATA,U,11) ; Initial Total Hours Paid
- S INPH=+$P(MDATA,U,12) ; Initial Non-Pay Hours
- S IWPH=+$P(MDATA,U,13) ; Initial Without Pay Hours
- S (AHTCM,DIFFRG,DIFFNP,DIFFWP)=0
- ;
- ; Get Non pay and Leave without pay times from 8b string or recalc.
- N TAMTS
- S TAMTS("WP","Leave Without Pay")=""
- S TAMTS("NP","Non-Pay Time")=""
- D PP8BAMT^PRSPUT3(.TAMTS,PPI,PRSIEN)
- S TOTAL("WP")=$G(TAMTS("WP","Leave Without Pay"))
- S TOTAL("NP")=$G(TAMTS("NP","Non-Pay Time"))
- S DIFFNP=TOTAL("NP")-PPNP
- S DIFFWP=TOTAL("WP")-PPWP
- ;
- ; Loop thru day and ESR segments looking for leave and RG time
- N DAY,ESR,RGCODES,SEG,TOT
- S RGCODES="AA,AD,AL,CB,CP,DL,HX,ML,RG,RL,SL,TR,TV"
- S TOTAL("RG")=0
- F DAY=1:1:14 D
- . ; only add totals for supervisor approved days
- . Q:$$GETSTAT^PRSPESR1(PRSIEN,PPI,DAY)'=5
- . S ESR=$G(^PRST(458,PPI,"E",PRSIEN,"D",DAY,5))
- . Q:ESR=""
- . F SEG=0:1:6 Q:$P(ESR,U,(5*SEG)+3)="" D
- . . S TOT=$P(ESR,U,(5*SEG)+3)
- . . ; Types Of Time that might have been worked in week 1
- . . I RGCODES[TOT D Q
- . . . S TOTAL("RG")=TOTAL("RG")+$$AMT(ESR)
- ;
- ; Checks for Regular Time
- S DIFFRG=TOTAL("RG")-PPHRS
- ; determine number of memo pay periods that have been certified
- S PRSX=$$MEMCPP^PRSPUT3(MIEN)
- S PPC=$P(PRSX,U,2)+$S(PPE]$P(PRSX,U):1,1:0)
- ;
- ; Update pp totals with current calculated values
- K IEN4587,PRSFDA
- S IEN4587=MIEN_","
- S PRSFDA(458.701,MPPIEN_","_IEN4587,1)=TOTAL("RG") ; PP new REG hrs
- S PRSFDA(458.701,MPPIEN_","_IEN4587,2)=TOTAL("NP") ; PP new NP hrs
- S PRSFDA(458.701,MPPIEN_","_IEN4587,3)=TOTAL("WP") ; PP new WP hrs
- ;
- ; update memo grand totals with differences found
- S TOTNP=INPH+DIFFNP
- S TOTWP=IWPH+DIFFWP
- S PRSFDA(458.7,IEN4587,11)=TOTNP ; NP hrs
- S PRSFDA(458.7,IEN4587,12)=TOTWP ; WP hrs
- S PRSFDA(458.7,IEN4587,9)=ITHW+DIFFRG ; tot hrs worked (all creditable)
- ;
- ; If this is the first time the PP has been processed PPHRS will be null
- ; so add the average hrs/pp, otherwise this count has already been added
- S THP=ITHP+$S(PPHRS="":AHRS/26,1:0)
- S PRSFDA(458.7,IEN4587,10)=$FN(THP-DIFFNP-DIFFWP,"",2) ; tot hrs paid
- S PRSFDA(458.7,IEN4587,13)=$FN(PPC/26,"",2) ; % of memo completed
- ; % OF HOURS COMPLETED
- S POHC=$FN((ITHW+COHRS+DIFFRG)/(AHRS-TOTNP-TOTWP),"",2)
- S PRSFDA(458.7,IEN4587,14)=POHC
- ;
- ; ave hrs/pp to complete mem (if certifying last pay period then then
- ; you're out of pay periods so use 0.00 to report how many more hours)
- S AHTCM=$S(PPC>25:"0.00",1:$FN((AHRS-(ITHW+COHRS+DIFFRG)/(26-PPC)),"",2))
- S PRSFDA(458.7,IEN4587,15)=AHTCM
- ; % off target
- S POT=((AHRS/26)*PPC)-TOTNP-TOTWP
- S POT=(ITHW+COHRS+DIFFRG)-POT/POT,POT=POT*100,POT=$FN(POT,"",2)
- S PRSFDA(458.7,IEN4587,16)=POT
- D FILE^DIE("","PRSFDA")
- Q
- ;
- AMT(ESR) ; Return hours elapsed for time segment in decimal format
- ; deduct meal
- ; e.g. AMT=2.5 (2 hours 30 min)
- N START,STOP,MEAL,AMT,X
- S START=$P(ESR,U,(5*SEG)+1),STOP=$P(ESR,U,(5*SEG)+2)
- S MEAL=$P(ESR,U,(5*SEG)+5)
- S AMT=$$ELAPSE^PRSPESR2(MEAL,START,STOP)
- S X=$P(AMT,":",2) S X=$S(X=30:5,X=15:25,X=45:75,1:0)
- S AMT=+$P(AMT,":",1)_"."_X
- Q AMT
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRSASR1 8177 printed Feb 18, 2025@23:50:52 Page 2
- PRSASR1 ;WCIOFO/JAH - Display VCS, Fee, ED ;02/20/08
- +1 ;;4.0;PAID;**6,21,82,93,116**;Sep 21, 1995;Build 23
- +2 ;;Per VHA Directive 2004-038, this routine should not be modified.
- VCS ; Display VCS Sales/Fee Basis
- +1 ;
- +2 NEW OLDPP
- +3 SET PAYP=$PIECE($GET(^PRSPC(DFN,0)),"^",21)
- +4 ; Check the pay plan for the pay period we are dealing with
- +5 ; in case it's a previous pay period where an employee
- +6 ; had a different pay plan.
- +7 ; 1st put pay period in YY-PP format 4 call 2 lookup old pay plan.
- +8 ;Only check if called from option Display employee pay period PPERIOD
- +9 ;will be defined.
- +10 IF $GET(PPERIOD)
- Begin DoDot:1
- +11 ;S PPERIOD=$S(Y["-":$P(Y,"^",2),1:$P(^PRST(458,$P(Y,"^"),0),"^"))
- +12 SET OLDPP=$$OLDPP^PRS8UT(PPERIOD,DFN)
- +13 IF OLDPP'=0
- IF (OLDPP'=PAYP)
- Begin DoDot:2
- +14 SET PAYP=OLDPP
- +15 WRITE !,"Employee is NOT currently under this pay plan."
- End DoDot:2
- End DoDot:1
- +16 ;
- +17 WRITE !!?30,$SELECT(PAYP="F":"Fee Basis Appointee",1:"VCS Commission Sales")
- +18 WRITE !!?13,"Sun Mon Tue Wed Thu Fri Sat",!
- +19 WRITE !,"Week 1"
- SET L1=1
- FOR K=1:1:7
- SET L1=L1+10
- SET Z1=$PIECE(Z,"^",K)
- IF Z1'=""
- WRITE ?L1,$JUSTIFY(Z1,7,2)
- +20 WRITE !,"Week 2"
- SET L1=1
- FOR K=8:1:14
- SET L1=L1+10
- SET Z1=$PIECE(Z,"^",K)
- IF Z1'=""
- WRITE ?L1,$JUSTIFY(Z1,7,2)
- +21 IF PAYP="F"
- WRITE !!
- FOR K=19:1:21
- SET Z1=$PIECE(Z,"^",K)
- WRITE "Total ",$PIECE("Hours Days Procedures"," ",K-18),": ",Z1," "
- +22 QUIT
- ED ; Display Envir. Diff.
- +1 WRITE !!?26,"Environmental Differentials",!
- +2 SET Y=""
- FOR K=1:2:5
- SET Z1=$PIECE(Z,"^",K)
- if 'Z1
- QUIT
- if Y'=""
- SET Y=Y_"; "
- SET Y=Y_$PIECE($GET(^PRST(457.6,+Z1,0)),"^",1)_" "_$PIECE(Z,"^",K+1)_" Hrs."
- +3 IF Y'=""
- WRITE !,"Week 1: ",Y
- +4 SET Y=""
- FOR K=7:2:11
- SET Z1=$PIECE(Z,"^",K)
- if 'Z1
- QUIT
- if Y'=""
- SET Y=Y_"; "
- SET Y=Y_$PIECE($GET(^PRST(457.6,+Z1,0)),"^",1)_" "_$PIECE(Z,"^",K+1)_" Hrs."
- +5 IF Y'=""
- WRITE !,"Week 2: ",Y
- +6 QUIT
- +7 ;
- LD ; Display changes to the Labor Distribution Codes within the Pay
- +1 ; Period.
- +2 ;
- +3 NEW DASH,DESC,IENS,LDCC,LDCCB,LDCCEX,LDCODE,LDCNT,LDDOA,LDFCP
- +4 NEW LDHOLD,LDPCT,LDTOI,PRSLD,Y
- +5 SET $PIECE(DASH,"-",80)=""
- +6 WRITE !
- +7 DO LDHOLD
- +8 WRITE !,"Current Labor Distribution Values:"
- +9 SET LDDOA=$$GET1^DIQ(450,DFN,756,"E")
- +10 SET LDCCB=$$GET1^DIQ(450,DFN,755,"E")
- +11 SET LDTOI=$$GET1^DIQ(450,DFN,755.1,"E")
- +12 WRITE !,LDDOA,?24,LDCCB,?61,LDTOI
- +13 FOR PRSLD=1:1:4
- Begin DoDot:1
- +14 SET LDCODE=$$GET1^DIQ(450.0757,PRSLD_","_DFN,1)
- +15 SET LDPCT=$$GET1^DIQ(450.0757,PRSLD_","_DFN,2)
- +16 SET LDCC=$$GET1^DIQ(450.0757,PRSLD_","_DFN,3)
- +17 SET Y=LDCC
- SET SUB454="CC"
- +18 DO OT^PRSDUTIL
- KILL SUB454
- +19 SET LDCCEX=$EXTRACT(Y,1,30)
- +20 SET LDFCP=$$GET1^DIQ(450.0757,PRSLD_","_DFN,4)
- +21 WRITE !,"Code",PRSLD,": ",LDCODE,?12,LDPCT,?24,LDCC," - ",LDCCEX,?70,LDFCP
- End DoDot:1
- +22 ;
- +23 WRITE !!,"The previous Labor Distribution Values:"
- +24 SET LDCNT="A"
- +25 SET LDCNT=$ORDER(^PRST(458,PPI,"E",DFN,"LDAUD",LDCNT),-1)
- +26 if 'LDCNT
- QUIT
- +27 SET IENS=LDCNT_","_DFN_","_PPI_","
- +28 SET LDDOA=$$GET1^DIQ(458.1105,IENS,1,"E")
- +29 SET LDCCB=$$GET1^DIQ(458.1105,IENS,2,"E")
- +30 SET LDTOI=$$GET1^DIQ(458.1105,IENS,3,"E")
- +31 WRITE !,LDDOA,?24,LDCCB,?61,LDTOI
- +32 FOR PRSLD=1:1:4
- Begin DoDot:1
- +33 SET IENS=PRSLD_","_LDCNT_","_DFN_","_PPI_","
- +34 SET LDCODE=$$GET1^DIQ(458.11054,IENS,1)
- +35 SET LDPCT=$$GET1^DIQ(458.11054,IENS,2)
- +36 SET LDCC=$$GET1^DIQ(458.11054,IENS,3)
- +37 SET Y=LDCC
- SET SUB454="CC"
- +38 DO OT^PRSDUTIL
- KILL SUB454
- +39 SET LDCCEX=$EXTRACT(Y,1,30)
- +40 SET LDFCP=$$GET1^DIQ(458.11054,IENS,4)
- +41 WRITE !,"Code",PRSLD,": ",LDCODE,?12,LDPCT,?24,LDCC," - ",LDCCEX,?70,LDFCP
- End DoDot:1
- +42 QUIT
- +43 ;
- LDHDR ; Labor Distribution Header information
- +1 ;
- +2 WRITE !?15,"Labor Distribution Changes within the Pay Period:"
- +3 WRITE !,"Date/Time",?24,"Changed by",?61,"Type of Interface"
- +4 WRITE !,"Code",?12,"Percent",?24,"Cost Center - Description"
- +5 WRITE ?65,"Fund Ctrl Pt"
- +6 WRITE !,DASH
- +7 QUIT
- +8 ;
- LDHOLD ; Pause of more LD changes that will fit on 1 screen.
- +1 ;
- +2 NEW X
- +3 SET LDHOLD=$$ASK^PRSLIB00(1)
- +4 SET X=$GET(^PRSPC(DFN,0))
- +5 WRITE !,@IOF,?3,$PIECE(X,"^",1)
- +6 SET X=$PIECE(X,"^",9)
- +7 IF X
- WRITE ?68,$EXTRACT(X),"XX-XX-",$EXTRACT(X,6,9)
- +8 WRITE !,DASH
- +9 DO LDHDR
- +10 QUIT
- +11 ;
- PTP(PRSIEN,PPI) ; Updates hours credited for PT Phys w/ Memorandums
- +1 ; This API can be used for initial and subsequent calculation
- +2 ; of the PTP's ESR.
- +3 ; algorithm for this API follows:
- +4 ; 1. Grab copy of currently stored pay period hours
- +5 ; 2. Look at ESR/timecard data to recalculate pay period hours
- +6 ; 3. Calculate net difference between 1 and 2
- +7 ; 4. update current pay period with new pp totals from (2) above
- +8 ; 5. add net diff (3) to memo totals
- +9 ;
- +10 NEW AHRS,AHTCM,AMT,COHRS,DIFFNP,DIFFRG,DIFFWP,INPH,ITHP,ITHW,IWPH
- +11 NEW MDAT,MDATA,MEAL,MIEN,MPPIEN,POHC,POT,PPC,PPE
- +12 NEW PPHRS,PPNP,PPWP,PRSX,START,STOP,THP,TOT,TOTAL,TOTNP,TOTWP
- +13 SET MDAT=$PIECE($GET(^PRST(458,PPI,1)),U,1)
- +14 SET MIEN=+$$MIEN^PRSPUT1(PRSIEN,MDAT)
- +15 ; Not a PTP w/ memo
- if 'MIEN
- QUIT
- +16 SET PPE=$PIECE($GET(^PRST(458,PPI,0)),U,1)
- +17 ;
- +18 ; Locate this PP in the PTP's memorandum
- +19 SET MPPIEN=$ORDER(^PRST(458.7,MIEN,9,"B",PPE,0))
- +20 ; PP not found within memo (###exception message)
- if 'MPPIEN
- QUIT
- +21 ;
- +22 ;get the current values for this pay period under the memo.
- +23 SET PRSX=$GET(^PRST(458.7,MIEN,9,MPPIEN,0))
- +24 ; Actual hours of work credited
- SET PPHRS=+$PIECE(PRSX,U,2)
- +25 ; Actual hours of Non Pay
- SET PPNP=+$PIECE(PRSX,U,3)
- +26 ; Actual hours of LWOP
- SET PPWP=+$PIECE(PRSX,U,4)
- +27 KILL PRSX
- +28 ;
- +29 ; Load the memo totals
- +30 SET MDATA=$GET(^PRST(458.7,MIEN,0))
- +31 ; Agreed Hours
- SET AHRS=+$PIECE(MDATA,U,4)
- +32 ; Carryover Hours
- SET COHRS=+$PIECE(MDATA,U,9)
- +33 ; Initial Total Hours Worked
- SET ITHW=+$PIECE(MDATA,U,10)
- +34 ; Initial Total Hours Paid
- SET ITHP=+$PIECE(MDATA,U,11)
- +35 ; Initial Non-Pay Hours
- SET INPH=+$PIECE(MDATA,U,12)
- +36 ; Initial Without Pay Hours
- SET IWPH=+$PIECE(MDATA,U,13)
- +37 SET (AHTCM,DIFFRG,DIFFNP,DIFFWP)=0
- +38 ;
- +39 ; Get Non pay and Leave without pay times from 8b string or recalc.
- +40 NEW TAMTS
- +41 SET TAMTS("WP","Leave Without Pay")=""
- +42 SET TAMTS("NP","Non-Pay Time")=""
- +43 DO PP8BAMT^PRSPUT3(.TAMTS,PPI,PRSIEN)
- +44 SET TOTAL("WP")=$GET(TAMTS("WP","Leave Without Pay"))
- +45 SET TOTAL("NP")=$GET(TAMTS("NP","Non-Pay Time"))
- +46 SET DIFFNP=TOTAL("NP")-PPNP
- +47 SET DIFFWP=TOTAL("WP")-PPWP
- +48 ;
- +49 ; Loop thru day and ESR segments looking for leave and RG time
- +50 NEW DAY,ESR,RGCODES,SEG,TOT
- +51 SET RGCODES="AA,AD,AL,CB,CP,DL,HX,ML,RG,RL,SL,TR,TV"
- +52 SET TOTAL("RG")=0
- +53 FOR DAY=1:1:14
- Begin DoDot:1
- +54 ; only add totals for supervisor approved days
- +55 if $$GETSTAT^PRSPESR1(PRSIEN,PPI,DAY)'=5
- QUIT
- +56 SET ESR=$GET(^PRST(458,PPI,"E",PRSIEN,"D",DAY,5))
- +57 if ESR=""
- QUIT
- +58 FOR SEG=0:1:6
- if $PIECE(ESR,U,(5*SEG)+3)=""
- QUIT
- Begin DoDot:2
- +59 SET TOT=$PIECE(ESR,U,(5*SEG)+3)
- +60 ; Types Of Time that might have been worked in week 1
- +61 IF RGCODES[TOT
- Begin DoDot:3
- +62 SET TOTAL("RG")=TOTAL("RG")+$$AMT(ESR)
- End DoDot:3
- QUIT
- End DoDot:2
- End DoDot:1
- +63 ;
- +64 ; Checks for Regular Time
- +65 SET DIFFRG=TOTAL("RG")-PPHRS
- +66 ; determine number of memo pay periods that have been certified
- +67 SET PRSX=$$MEMCPP^PRSPUT3(MIEN)
- +68 SET PPC=$PIECE(PRSX,U,2)+$SELECT(PPE]$PIECE(PRSX,U):1,1:0)
- +69 ;
- +70 ; Update pp totals with current calculated values
- +71 KILL IEN4587,PRSFDA
- +72 SET IEN4587=MIEN_","
- +73 ; PP new REG hrs
- SET PRSFDA(458.701,MPPIEN_","_IEN4587,1)=TOTAL("RG")
- +74 ; PP new NP hrs
- SET PRSFDA(458.701,MPPIEN_","_IEN4587,2)=TOTAL("NP")
- +75 ; PP new WP hrs
- SET PRSFDA(458.701,MPPIEN_","_IEN4587,3)=TOTAL("WP")
- +76 ;
- +77 ; update memo grand totals with differences found
- +78 SET TOTNP=INPH+DIFFNP
- +79 SET TOTWP=IWPH+DIFFWP
- +80 ; NP hrs
- SET PRSFDA(458.7,IEN4587,11)=TOTNP
- +81 ; WP hrs
- SET PRSFDA(458.7,IEN4587,12)=TOTWP
- +82 ; tot hrs worked (all creditable)
- SET PRSFDA(458.7,IEN4587,9)=ITHW+DIFFRG
- +83 ;
- +84 ; If this is the first time the PP has been processed PPHRS will be null
- +85 ; so add the average hrs/pp, otherwise this count has already been added
- +86 SET THP=ITHP+$SELECT(PPHRS="":AHRS/26,1:0)
- +87 ; tot hrs paid
- SET PRSFDA(458.7,IEN4587,10)=$FNUMBER(THP-DIFFNP-DIFFWP,"",2)
- +88 ; % of memo completed
- SET PRSFDA(458.7,IEN4587,13)=$FNUMBER(PPC/26,"",2)
- +89 ; % OF HOURS COMPLETED
- +90 SET POHC=$FNUMBER((ITHW+COHRS+DIFFRG)/(AHRS-TOTNP-TOTWP),"",2)
- +91 SET PRSFDA(458.7,IEN4587,14)=POHC
- +92 ;
- +93 ; ave hrs/pp to complete mem (if certifying last pay period then then
- +94 ; you're out of pay periods so use 0.00 to report how many more hours)
- +95 SET AHTCM=$SELECT(PPC>25:"0.00",1:$FNUMBER((AHRS-(ITHW+COHRS+DIFFRG)/(26-PPC)),"",2))
- +96 SET PRSFDA(458.7,IEN4587,15)=AHTCM
- +97 ; % off target
- +98 SET POT=((AHRS/26)*PPC)-TOTNP-TOTWP
- +99 SET POT=(ITHW+COHRS+DIFFRG)-POT/POT
- SET POT=POT*100
- SET POT=$FNUMBER(POT,"",2)
- +100 SET PRSFDA(458.7,IEN4587,16)=POT
- +101 DO FILE^DIE("","PRSFDA")
- +102 QUIT
- +103 ;
- AMT(ESR) ; Return hours elapsed for time segment in decimal format
- +1 ; deduct meal
- +2 ; e.g. AMT=2.5 (2 hours 30 min)
- +3 NEW START,STOP,MEAL,AMT,X
- +4 SET START=$PIECE(ESR,U,(5*SEG)+1)
- SET STOP=$PIECE(ESR,U,(5*SEG)+2)
- +5 SET MEAL=$PIECE(ESR,U,(5*SEG)+5)
- +6 SET AMT=$$ELAPSE^PRSPESR2(MEAL,START,STOP)
- +7 SET X=$PIECE(AMT,":",2)
- SET X=$SELECT(X=30:5,X=15:25,X=45:75,1:0)
- +8 SET AMT=+$PIECE(AMT,":",1)_"."_X
- +9 QUIT AMT