Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: PRSASR1

PRSASR1.m

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