source: WorldVistAEHR/trunk/r/PAID-PRS/PRSASR1.m@ 634

PRSASR1 ;HISC/MGD - Display VCS, Fee, ED ;04/19/05
 ;;4.0;PAID;**6,21,82,93**;Sep 21, 1995;Build 7
 ;;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,1,3),"-",$E(X,4,5),"-",$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