Changeset 623 for WorldVistAEHR/trunk/r/PAID-PRS/PRSAPPO.m
- Timestamp:
- Dec 4, 2009, 12:11:15 AM (14 years ago)
- File:
-
- 1 edited
-
WorldVistAEHR/trunk/r/PAID-PRS/PRSAPPO.m (modified) (1 diff)
Legend:
- Unmodified
- Added
- Removed
-
WorldVistAEHR/trunk/r/PAID-PRS/PRSAPPO.m
r613 r623 1 PRSAPPO ; HISC/MGD - Open New Pay Period ;07/30/07 2 ;;4.0;PAID;**93,112**;Sep 21, 1995;Build 54 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 8 A1 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 15 A2 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 21 A3 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 C0=^PRSPC(DFN,0) 30 .I $P(C0,U,10)=2,$P(C0,U,16)=80 S NAWS="9Mo AWS",CT9=$G(CT9)+1 31 .I $P(C0,U,10)=1,$P(C0,U,16)=72 S NAWS="36/40 AWS",CT36=$G(CT36)+1 32 .S PRSIEN=DFN,MDAT=$P(PDT,U,1) 33 .S MIEN=$$MIEN^PRSPUT1(PRSIEN,MDAT) 34 .D MOV I $D(HOL),'MIEN S TT="HX",DUP=0 D E^PRSAPPH 35 .; 36 .; Call to Autopost PT Phy Leave 37 .I $G(MIEN) D PLPP^PRSPLVA(PRSIEN,PPI) 38 .; 39 .; Call to Autopost PT Phy Extended Absence 40 .I $G(MIEN) D PEAPP^PRSPEAA(PRSIEN,PPI) 41 .S N=N+1 W:N#100=0 "." Q 42 ;SEND A MESSAGE WHEN A 9 MONTH AWS NURSE IS ACTIVATED AT A SITE 43 I +$G(NAWS) D 44 .I $G(CT9) S TMP(1)=CT9_" 9 month AWS nurse(s) set up" 45 .I $G(CT36) S TMP(2)=CT36_" 36/40 AWS nurse(s) set up" 46 .S S=$$KSP^XUPARAM("INST")_"," D FIND^DIC(456,,,"Q",+S) 47 .S IND=$S($D(^TMP("DILIST",$J,0)):+^(0),1:$O(^PRST(456,0))) 48 .S CM9=$$GET1^DIQ(456,IND,2),CM36=$$GET1^DIQ(456,IND,4) 49 .S MAX=$$GET1^DIQ(456,IND,3) N FDA,DIERR 50 .I $G(CT9),CM9<MAX S FDA(456,IND_",",2)=CM9+1 51 .I $G(CT36),CM36<MAX S FDA(456,IND_",",4)=CM36+1 52 .Q:'$D(FDA) D FILE^DIE("","FDA"),MSG^DIALOG() 53 .S S=$$GET1^DIQ(4,+S,99)_" "_$$GET1^DIQ(4,+S,100),XMTEXT="TMP(" 54 .S TMP(3)="At "_S,XMDUZ=.5,XMY("VHAOIPAIDETANAWSBULLETIN@VA.GOV")="" 55 .S XMSUB=+S_" 36/40, 9 month AWS nurse(s) deployed PRS*4.0*112" 56 .D ^XMD K TMP 57 S $P(^PRST(458,PPI,"E",0),"^",3,4)=N_"^"_N W !!,N," Employee Records created.",! 58 EX G KILL^XUSCLEAN 59 RES ; Re-start/Re-open a Pay Period 60 S PPI=$P(^PRST(458,0),"^",3),PPIP=PPI-1 G A3 61 MOV ; Create PP entry for Employee 62 I '$D(^PRST(458,PPI,"E",DFN,0)) S ^(0)=DFN_"^T" D 63 .S CPI=$G(^PRST(458,PPIP,"E",DFN,0)) 64 .S CPI=$S($P(CPI,"^",7)'="":$P(CPI,"^",7),$P(CPI,"^",6)'="":$P(CPI,"^",6),1:$P($G(^PRSPC(DFN,1)),"^",7)) 65 .S:CPI="" CPI=0 S $P(^PRST(458,PPI,"E",DFN,0),"^",6)=CPI Q 66 I '$D(^PRST(458,PPI,"E",DFN,"D",0)) S ^(0)="^458.02^14^14" 67 ; 68 ; if there's a PTP memo and this is the 1st PP for the memo then 69 ; set the memo status to Active 70 I $G(MIEN),($P($G(^PRST(458.7,+MIEN,9,1,0)),U,1)=$P($G(^PRST(458,PPI,0)),U,1)) D 71 . N IENS,PRSFDA 72 . S IENS=+MIEN_"," 73 . S PRSFDA(458.7,IENS,5)=2 ; 2:ACTIVE 74 . D FILE^DIE("","PRSFDA") 75 . K PRSFDA 76 ; 77 F DAY=1:1:14 I '$P($G(^PRST(458,PPI,"E",DFN,"D",DAY,0)),"^",2) D 78 . D M1 79 . ; Update Daily ESR and post Holiday Excused 80 . I MIEN D ESRUPDT^PRSPUT3(PPI,DFN,DAY) 81 Q 82 ; 83 M1 ; Set a day 84 S Z=$G(^PRST(458,PPIP,"E",DFN,"D",DAY,0)),TD=$P(Z,"^",2) I $P(Z,"^",3) S TD=$P(Z,"^",4) 85 S X=$G(^PRST(457.1,+TD,1)),TDH=$P($G(^(0)),"^",6) 86 S ^PRST(458,PPI,"E",DFN,"D",DAY,0)=DAY_"^"_TD S:TDH'="" $P(^(0),"^",8)=TDH S:X'="" ^(1)=X 87 Q 1 PRSAPPO ; 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 8 A1 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 15 A2 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 21 A3 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.",! 40 EX G KILL^XUSCLEAN 41 RES ; Re-start/Re-open a Pay Period 42 S PPI=$P(^PRST(458,0),"^",3),PPIP=PPI-1 G A3 43 MOV ; 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 ; 65 M1 ; 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 TracChangeset
for help on using the changeset viewer.
