source: WorldVistAEHR/trunk/r/PAID-PRS/PRSAPPO.m@ 895

Last change on this file since 895 was 623, checked in by George Lilly, 15 years ago

revised back to 6/30/08 version
File size: 3.1 KB
Line 
1PRSAPPO ; HISC/MGD - Open New Pay Period ;03/15/06
2 ;;4.0;PAID;**93**;Sep 21, 1995;Build 7
3 ;;Per VHA Directive 2004-038, this routine should not be modified.
4 S PPI=$P(^PRST(458,0),"^",3),PPE=$P(^PRST(458,PPI,0),"^",1)
5 D NX^PRSAPPU S X1=D1,X2=14 D C^%DTC S D1=X
6 S X1=DT,X2=7 D C^%DTC I D1>X W *7,!!,"You cannot open a Pay Period more than 7 days in advance!" G EX
7 D PP^PRSAPPU S X=D1 D DTP^PRSAPPU
8A1 W !!,"Do you wish to Open Pay Period ",PPE," beginning ",Y," ? "
9 R X:DTIME G:'$T!(X["^") EX S:X="" X="*" S X=$TR(X,"yesno","YESNO")
10 I $P("YES",X,1)'="",$P("NO",X,1)'="" W !?5,*7,"Answer YES or NO" G A1
11 G:$E(X,1)'="Y" EX
12 I $D(^PRST(458,"B",PPE)) W !!,*7,"That Pay Period is already open!" G EX
13 K DIC,DD,DO S DIC="^PRST(458,",DIC(0)="L",DLAYGO=458,X=PPE D FILE^DICN G:Y<1 EX
14 K DIC,DLAYGO S PPI=+Y,PPIP=PPI-1
15A2 I PPIP,'$D(^PRST(458,PPIP)) S PPIP=PPIP-1 G A2
16 ; Generate dates
17 S Y1=D1 F K=1:1:13 S X2=K,X1=D1 D C^%DTC S Y1=Y1_"^"_X
18 S Y2="" F K=1:1:14 S X=$P(Y1,"^",K) D DTP^PRSAPPU S Y=$P("Sat Sun Mon Tue Wed Thu Fri"," ",K#7+1)_" "_Y S $P(Y2,"^",K)=Y
19 S ^PRST(458,PPI,1)=Y1,^(2)=Y2
20 F K=1:1:14 S X=$P(Y1,"^",K),^PRST(458,"AD",X)=PPI_"^"_K
21A3 S ^PRST(458,PPI,"E",0)="^458.01P^^" D NOW^%DTC S NOW=% D ^PRSAPPH
22 W !!,"Moving Current Employees into Pay Period ... " S N=0
23 N MDAT,MIEN,PRSIEN
24 S ATL="ATL00" F S ATL=$O(^PRSPC(ATL)) Q:ATL'?1"ATL".E S TLE=$E(ATL,4,6),NAM="" F S NAM=$O(^PRSPC(ATL,NAM)) Q:NAM="" F DFN=0:0 S DFN=$O(^PRSPC(ATL,NAM,DFN)) Q:DFN<1 D
25 .Q:$D(^PRST(458,PPI,"E",DFN,"D",14,0))
26 .I $P($G(^PRSPC(DFN,"LWOP")),"^",1)="Y" Q
27 .I $P($G(^PRSPC(DFN,1)),"^",20)="Y" Q
28 .I $P($G(^PRSPC(DFN,1)),"^",33)'="N" Q
29 .S PRSIEN=DFN,MDAT=$P(PDT,U,1)
30 .S MIEN=$$MIEN^PRSPUT1(PRSIEN,MDAT)
31 .D MOV I $D(HOL),'MIEN S TT="HX",DUP=0 D E^PRSAPPH
32 .;
33 .; Call to Autopost PT Phy Leave
34 .I $G(MIEN) D PLPP^PRSPLVA(PRSIEN,PPI)
35 .;
36 .; Call to autopost PT Phy Extended Absence
37 .I $G(MIEN) D PEAPP^PRSPEAA(PRSIEN,PPI)
38 .S N=N+1 W:N#100=0 "." Q
39 S $P(^PRST(458,PPI,"E",0),"^",3,4)=N_"^"_N W !!,N," Employee Records created.",!
40EX G KILL^XUSCLEAN
41RES ; Re-start/Re-open a Pay Period
42 S PPI=$P(^PRST(458,0),"^",3),PPIP=PPI-1 G A3
43MOV ; Create PP entry for Employee
44 I '$D(^PRST(458,PPI,"E",DFN,0)) S ^(0)=DFN_"^T" D
45 .S CPI=$G(^PRST(458,PPIP,"E",DFN,0))
46 .S CPI=$S($P(CPI,"^",7)'="":$P(CPI,"^",7),$P(CPI,"^",6)'="":$P(CPI,"^",6),1:$P($G(^PRSPC(DFN,1)),"^",7))
47 .S:CPI="" CPI=0 S $P(^PRST(458,PPI,"E",DFN,0),"^",6)=CPI Q
48 I '$D(^PRST(458,PPI,"E",DFN,"D",0)) S ^(0)="^458.02^14^14"
49 ;
50 ; if there's a PTP memo and this is the 1st PP for the memo then
51 ; set the memo status to Active
52 I $G(MIEN),($P($G(^PRST(458.7,+MIEN,9,1,0)),U,1)=$P($G(^PRST(458,PPI,0)),U,1)) D
53 . N IENS,PRSFDA
54 . S IENS=+MIEN_","
55 . S PRSFDA(458.7,IENS,5)=2 ; 2:ACTIVE
56 . D FILE^DIE("","PRSFDA")
57 . K PRSFDA
58 ;
59 F DAY=1:1:14 I '$P($G(^PRST(458,PPI,"E",DFN,"D",DAY,0)),"^",2) D
60 . D M1
61 . ; Update Daily ESR and post Holiday Excused
62 . I MIEN D ESRUPDT^PRSPUT3(PPI,DFN,DAY)
63 Q
64 ;
65M1 ; Set a day
66 S Z=$G(^PRST(458,PPIP,"E",DFN,"D",DAY,0)),TD=$P(Z,"^",2) I $P(Z,"^",3) S TD=$P(Z,"^",4)
67 S X=$G(^PRST(457.1,+TD,1)),TDH=$P($G(^(0)),"^",6)
68 S ^PRST(458,PPI,"E",DFN,"D",DAY,0)=DAY_"^"_TD S:TDH'="" $P(^(0),"^",8)=TDH S:X'="" ^(1)=X
69 Q
Note: See TracBrowser for help on using the repository browser.