PRSAPPO ; HISC/MGD - Open New Pay Period ;07/30/07
;;4.0;PAID;**93,112,132**;Sep 21, 1995;Build 13
;;Per VHA Directive 2004-038, this routine should not be modified.
S PPI=$P(^PRST(458,0),"^",3),PPE=$P(^PRST(458,PPI,0),"^",1)
D NX^PRSAPPU S X1=D1,X2=14 D C^%DTC S D1=X
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
D PP^PRSAPPU S X=D1 D DTP^PRSAPPU
A1 W !!,"Do you wish to Open Pay Period ",PPE," beginning ",Y," ? "
R X:DTIME G:'$T!(X["^") EX S:X="" X="*" S X=$TR(X,"yesno","YESNO")
I $P("YES",X,1)'="",$P("NO",X,1)'="" W !?5,*7,"Answer YES or NO" G A1
G:$E(X,1)'="Y" EX
I $D(^PRST(458,"B",PPE)) W !!,*7,"That Pay Period is already open!" G EX
K DIC,DD,DO S DIC="^PRST(458,",DIC(0)="L",DLAYGO=458,X=PPE D FILE^DICN G:Y<1 EX
K DIC,DLAYGO S PPI=+Y,PPIP=PPI-1
A2 I PPIP,'$D(^PRST(458,PPIP)) S PPIP=PPIP-1 G A2
; Generate dates
S Y1=D1 F K=1:1:13 S X2=K,X1=D1 D C^%DTC S Y1=Y1_"^"_X
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
S ^PRST(458,PPI,1)=Y1,^(2)=Y2
F K=1:1:14 S X=$P(Y1,"^",K),^PRST(458,"AD",X)=PPI_"^"_K
A3 S ^PRST(458,PPI,"E",0)="^458.01P^^" D NOW^%DTC S NOW=% D ^PRSAPPH
W !!,"Moving Current Employees into Pay Period ... " S N=0
N MDAT,MIEN,PRSIEN
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
.Q:$D(^PRST(458,PPI,"E",DFN,"D",14,0))
.I $P($G(^PRSPC(DFN,"LWOP")),"^",1)="Y" Q
.I $P($G(^PRSPC(DFN,1)),"^",20)="Y" Q
.I $P($G(^PRSPC(DFN,1)),"^",33)'="N" Q
.S C0=^PRSPC(DFN,0)
.I $P(C0,U,10)=2,$P(C0,U,16)=80 S NAWS="9Mo AWS",CT9=$G(CT9)+1
.I $P(C0,U,10)=1,$P(C0,U,16)=72 S NAWS="36/40 AWS",CT36=$G(CT36)+1
.S PRSIEN=DFN,MDAT=$P(PDT,U,1)
.S MIEN=$$MIEN^PRSPUT1(PRSIEN,MDAT)
.D MOV I $D(HOL),'MIEN S TT="HX",DUP=0 D E^PRSAPPH
.;
.; Call to Autopost PT Phy Leave
.I $G(MIEN) D PLPP^PRSPLVA(PRSIEN,PPI)
.;
.; Call to Autopost PT Phy Extended Absence
.I $G(MIEN) D PEAPP^PRSPEAA(PRSIEN,PPI)
.S N=N+1 W:N#100=0 "." Q
;SEND A MESSAGE WHEN A 9 MONTH AWS NURSE IS ACTIVATED AT A SITE
I +$G(NAWS) D
.I $G(CT9) S TMP(1)=CT9_" 9 month AWS nurse(s) set up"
.I $G(CT36) S TMP(2)=CT36_" 36/40 AWS nurse(s) set up"
.S S=$$KSP^XUPARAM("INST")_"," D FIND^DIC(456,,,"Q",+S)
.S IND=$S($D(^TMP("DILIST",$J,0)):+^(0),1:$O(^PRST(456,0)))
.S CM9=$$GET1^DIQ(456,IND,2),CM36=$$GET1^DIQ(456,IND,4)
.S MAX=$$GET1^DIQ(456,IND,3) N FDA,DIERR
.I $G(CT9),CM9<MAX S FDA(456,IND_",",2)=CM9+1
.I $G(CT36),CM36<MAX S FDA(456,IND_",",4)=CM36+1
.Q:'$D(FDA) D FILE^DIE("","FDA"),MSG^DIALOG()
.S S=$$GET1^DIQ(4,+S,99)_" "_$$GET1^DIQ(4,+S,100),XMTEXT="TMP("
.S TMP(3)="At "_S,XMDUZ=.5,XMY("VHAOIPAIDETANAWSBULLETIN@DOMAIN.EXT")=""
.S XMSUB=+S_" 36/40, 9 month AWS nurse(s) deployed PRS*4.0*112"
.D ^XMD K TMP
S $P(^PRST(458,PPI,"E",0),"^",3,4)=N_"^"_N W !!,N," Employee Records created.",!
EX G KILL^XUSCLEAN
RES ; Re-start/Re-open a Pay Period
S PPI=$P(^PRST(458,0),"^",3),PPIP=PPI-1 G A3
MOV ; Create PP entry for Employee
I '$D(^PRST(458,PPI,"E",DFN,0)) S ^(0)=DFN_"^T" D
.S CPI=$G(^PRST(458,PPIP,"E",DFN,0))
.S CPI=$S($P(CPI,"^",7)'="":$P(CPI,"^",7),$P(CPI,"^",6)'="":$P(CPI,"^",6),1:$P($G(^PRSPC(DFN,1)),"^",7))
.S:CPI="" CPI=0 S $P(^PRST(458,PPI,"E",DFN,0),"^",6)=CPI Q
I '$D(^PRST(458,PPI,"E",DFN,"D",0)) S ^(0)="^458.02^14^14"
;
; if there's a PTP memo and this is the 1st PP for the memo then
; set the memo status to Active
I $G(MIEN),($P($G(^PRST(458.7,+MIEN,9,1,0)),U,1)=$P($G(^PRST(458,PPI,0)),U,1)) D
. N IENS,PRSFDA
. S IENS=+MIEN_","
. S PRSFDA(458.7,IENS,5)=2 ; 2:ACTIVE
. D FILE^DIE("","PRSFDA")
. K PRSFDA
;
F DAY=1:1:14 I '$P($G(^PRST(458,PPI,"E",DFN,"D",DAY,0)),"^",2) D
. D M1
. ; Update Daily ESR and post Holiday Excused
. I MIEN D ESRUPDT^PRSPUT3(PPI,DFN,DAY)
Q
;
M1 ; Set a day
N Y
S Z=$G(^PRST(458,PPIP,"E",DFN,"D",DAY,0)),Y=$G(^(8)),TD=$P(Z,"^",2) I $P(Z,"^",3) S TD=$P(Z,"^",4),Y=$P(Y,U,5)
S Y=$P(Y,U),X=$G(^PRST(457.1,+TD,1)),TDH=$P($G(^(0)),"^",6)
S ^PRST(458,PPI,"E",DFN,"D",DAY,0)=DAY_"^"_TD S:TDH'="" $P(^(0),"^",8)=TDH S:X'="" ^(1)=X
;telework tour
I Y]"",$P($$TWE^PRSATE0(DFN),U,2)="Y" S ^PRST(458,PPI,"E",DFN,"D",DAY,8)=Y
QUIT
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRSAPPO 4359 printed Dec 13, 2024@02:23:55 Page 2
PRSAPPO ; HISC/MGD - Open New Pay Period ;07/30/07
+1 ;;4.0;PAID;**93,112,132**;Sep 21, 1995;Build 13
+2 ;;Per VHA Directive 2004-038, this routine should not be modified.
+3 SET PPI=$PIECE(^PRST(458,0),"^",3)
SET PPE=$PIECE(^PRST(458,PPI,0),"^",1)
+4 DO NX^PRSAPPU
SET X1=D1
SET X2=14
DO C^%DTC
SET D1=X
+5 SET X1=DT
SET X2=7
DO C^%DTC
IF D1>X
WRITE *7,!!,"You cannot open a Pay Period more than 7 days in advance!"
GOTO EX
+6 DO PP^PRSAPPU
SET X=D1
DO DTP^PRSAPPU
A1 WRITE !!,"Do you wish to Open Pay Period ",PPE," beginning ",Y," ? "
+1 READ X:DTIME
if '$TEST!(X["^")
GOTO EX
if X=""
SET X="*"
SET X=$TRANSLATE(X,"yesno","YESNO")
+2 IF $PIECE("YES",X,1)'=""
IF $PIECE("NO",X,1)'=""
WRITE !?5,*7,"Answer YES or NO"
GOTO A1
+3 if $EXTRACT(X,1)'="Y"
GOTO EX
+4 IF $DATA(^PRST(458,"B",PPE))
WRITE !!,*7,"That Pay Period is already open!"
GOTO EX
+5 KILL DIC,DD,DO
SET DIC="^PRST(458,"
SET DIC(0)="L"
SET DLAYGO=458
SET X=PPE
DO FILE^DICN
if Y<1
GOTO EX
+6 KILL DIC,DLAYGO
SET PPI=+Y
SET PPIP=PPI-1
A2 IF PPIP
IF '$DATA(^PRST(458,PPIP))
SET PPIP=PPIP-1
GOTO A2
+1 ; Generate dates
+2 SET Y1=D1
FOR K=1:1:13
SET X2=K
SET X1=D1
DO C^%DTC
SET Y1=Y1_"^"_X
+3 SET Y2=""
FOR K=1:1:14
SET X=$PIECE(Y1,"^",K)
DO DTP^PRSAPPU
SET Y=$PIECE("Sat Sun Mon Tue Wed Thu Fri"," ",K#7+1)_" "_Y
SET $PIECE(Y2,"^",K)=Y
+4 SET ^PRST(458,PPI,1)=Y1
SET ^(2)=Y2
+5 FOR K=1:1:14
SET X=$PIECE(Y1,"^",K)
SET ^PRST(458,"AD",X)=PPI_"^"_K
A3 SET ^PRST(458,PPI,"E",0)="^458.01P^^"
DO NOW^%DTC
SET NOW=%
DO ^PRSAPPH
+1 WRITE !!,"Moving Current Employees into Pay Period ... "
SET N=0
+2 NEW MDAT,MIEN,PRSIEN
+3 SET ATL="ATL00"
FOR
SET ATL=$ORDER(^PRSPC(ATL))
if ATL'?1"ATL".E
QUIT
SET TLE=$EXTRACT(ATL,4,6)
SET NAM=""
FOR
SET NAM=$ORDER(^PRSPC(ATL,NAM))
if NAM=""
QUIT
FOR DFN=0:0
SET DFN=$ORDER(^PRSPC(ATL,NAM,DFN))
if DFN<1
QUIT
Begin DoDot:1
+4 if $DATA(^PRST(458,PPI,"E",DFN,"D",14,0))
QUIT
+5 IF $PIECE($GET(^PRSPC(DFN,"LWOP")),"^",1)="Y"
QUIT
+6 IF $PIECE($GET(^PRSPC(DFN,1)),"^",20)="Y"
QUIT
+7 IF $PIECE($GET(^PRSPC(DFN,1)),"^",33)'="N"
QUIT
+8 SET C0=^PRSPC(DFN,0)
+9 IF $PIECE(C0,U,10)=2
IF $PIECE(C0,U,16)=80
SET NAWS="9Mo AWS"
SET CT9=$GET(CT9)+1
+10 IF $PIECE(C0,U,10)=1
IF $PIECE(C0,U,16)=72
SET NAWS="36/40 AWS"
SET CT36=$GET(CT36)+1
+11 SET PRSIEN=DFN
SET MDAT=$PIECE(PDT,U,1)
+12 SET MIEN=$$MIEN^PRSPUT1(PRSIEN,MDAT)
+13 DO MOV
IF $DATA(HOL)
IF 'MIEN
SET TT="HX"
SET DUP=0
DO E^PRSAPPH
+14 ;
+15 ; Call to Autopost PT Phy Leave
+16 IF $GET(MIEN)
DO PLPP^PRSPLVA(PRSIEN,PPI)
+17 ;
+18 ; Call to Autopost PT Phy Extended Absence
+19 IF $GET(MIEN)
DO PEAPP^PRSPEAA(PRSIEN,PPI)
+20 SET N=N+1
if N#100=0
WRITE "."
QUIT
End DoDot:1
+21 ;SEND A MESSAGE WHEN A 9 MONTH AWS NURSE IS ACTIVATED AT A SITE
+22 IF +$GET(NAWS)
Begin DoDot:1
+23 IF $GET(CT9)
SET TMP(1)=CT9_" 9 month AWS nurse(s) set up"
+24 IF $GET(CT36)
SET TMP(2)=CT36_" 36/40 AWS nurse(s) set up"
+25 SET S=$$KSP^XUPARAM("INST")_","
DO FIND^DIC(456,,,"Q",+S)
+26 SET IND=$SELECT($DATA(^TMP("DILIST",$JOB,0)):+^(0),1:$ORDER(^PRST(456,0)))
+27 SET CM9=$$GET1^DIQ(456,IND,2)
SET CM36=$$GET1^DIQ(456,IND,4)
+28 SET MAX=$$GET1^DIQ(456,IND,3)
NEW FDA,DIERR
+29 IF $GET(CT9)
IF CM9<MAX
SET FDA(456,IND_",",2)=CM9+1
+30 IF $GET(CT36)
IF CM36<MAX
SET FDA(456,IND_",",4)=CM36+1
+31 if '$DATA(FDA)
QUIT
DO FILE^DIE("","FDA")
DO MSG^DIALOG()
+32 SET S=$$GET1^DIQ(4,+S,99)_" "_$$GET1^DIQ(4,+S,100)
SET XMTEXT="TMP("
+33 SET TMP(3)="At "_S
SET XMDUZ=.5
SET XMY("VHAOIPAIDETANAWSBULLETIN@DOMAIN.EXT")=""
+34 SET XMSUB=+S_" 36/40, 9 month AWS nurse(s) deployed PRS*4.0*112"
+35 DO ^XMD
KILL TMP
End DoDot:1
+36 SET $PIECE(^PRST(458,PPI,"E",0),"^",3,4)=N_"^"_N
WRITE !!,N," Employee Records created.",!
EX GOTO KILL^XUSCLEAN
RES ; Re-start/Re-open a Pay Period
+1 SET PPI=$PIECE(^PRST(458,0),"^",3)
SET PPIP=PPI-1
GOTO A3
MOV ; Create PP entry for Employee
+1 IF '$DATA(^PRST(458,PPI,"E",DFN,0))
SET ^(0)=DFN_"^T"
Begin DoDot:1
+2 SET CPI=$GET(^PRST(458,PPIP,"E",DFN,0))
+3 SET CPI=$SELECT($PIECE(CPI,"^",7)'="":$PIECE(CPI,"^",7),$PIECE(CPI,"^",6)'="":$PIECE(CPI,"^",6),1:$PIECE($GET(^PRSPC(DFN,1)),"^",7))
+4 if CPI=""
SET CPI=0
SET $PIECE(^PRST(458,PPI,"E",DFN,0),"^",6)=CPI
QUIT
End DoDot:1
+5 IF '$DATA(^PRST(458,PPI,"E",DFN,"D",0))
SET ^(0)="^458.02^14^14"
+6 ;
+7 ; if there's a PTP memo and this is the 1st PP for the memo then
+8 ; set the memo status to Active
+9 IF $GET(MIEN)
IF ($PIECE($GET(^PRST(458.7,+MIEN,9,1,0)),U,1)=$PIECE($GET(^PRST(458,PPI,0)),U,1))
Begin DoDot:1
+10 NEW IENS,PRSFDA
+11 SET IENS=+MIEN_","
+12 ; 2:ACTIVE
SET PRSFDA(458.7,IENS,5)=2
+13 DO FILE^DIE("","PRSFDA")
+14 KILL PRSFDA
End DoDot:1
+15 ;
+16 FOR DAY=1:1:14
IF '$PIECE($GET(^PRST(458,PPI,"E",DFN,"D",DAY,0)),"^",2)
Begin DoDot:1
+17 DO M1
+18 ; Update Daily ESR and post Holiday Excused
+19 IF MIEN
DO ESRUPDT^PRSPUT3(PPI,DFN,DAY)
End DoDot:1
+20 QUIT
+21 ;
M1 ; Set a day
+1 NEW Y
+2 SET Z=$GET(^PRST(458,PPIP,"E",DFN,"D",DAY,0))
SET Y=$GET(^(8))
SET TD=$PIECE(Z,"^",2)
IF $PIECE(Z,"^",3)
SET TD=$PIECE(Z,"^",4)
SET Y=$PIECE(Y,U,5)
+3 SET Y=$PIECE(Y,U)
SET X=$GET(^PRST(457.1,+TD,1))
SET TDH=$PIECE($GET(^(0)),"^",6)
+4 SET ^PRST(458,PPI,"E",DFN,"D",DAY,0)=DAY_"^"_TD
if TDH'=""
SET $PIECE(^(0),"^",8)=TDH
if X'=""
SET ^(1)=X
+5 ;telework tour
+6 IF Y]""
IF $PIECE($$TWE^PRSATE0(DFN),U,2)="Y"
SET ^PRST(458,PPI,"E",DFN,"D",DAY,8)=Y
+7 QUIT
