- PRSAPPP ; HISC/REL-Payroll Process Prior PP ;5/31/95 10:00
- ;;4.0;PAID;**114,132**;Sep 21, 1995;Build 13
- ;;Per VHA Directive 2004-038, this routine should not be modified.
- S PRSTLV=7
- W:$E(IOST,1,2)="C-" @IOF W !?26,"VA TIME & ATTENDANCE SYSTEM"
- W !?26,"PRIOR PAY PERIOD CORRECTIONS"
- R0 R !!,"Select T&L Unit (or ALL): ",X:DTIME G:'$T!("^"[X) EX S X=$TR(X,"al","AL") I X="ALL" S TLE=""
- E K DIC S DIC="^PRST(455.5,",DIC(0)="EMQ" D ^DIC G EX:$D(DTOUT),R0:Y<1 S TLE=$P(Y,"^",2)
- W ! K IOP,%ZIS S %ZIS("A")="Select Device: ",%ZIS="MQ" D ^%ZIS K %ZIS,IOP G:POP EX
- I $D(IO("Q")) S PRSAPGM="Q1^PRSAPPP",PRSALST="TLE" D QUE^PRSAUTL G EX
- U IO D Q1 D ^%ZISC K %ZIS,IOP G EX
- Q1 ; Process List
- D NOW^%DTC S DTP=% D DTP S (PG,QT)=0 S LNE="" S $P(LNE,"-",80)=""
- F DFN=0:0 S DFN=$O(^PRST(458,"AXA",DFN)) Q:DFN<1 D CHK I L1 F PPI=0:0 S PPI=$O(^PRST(458,"AXA",DFN,PPI)) Q:PPI<1 F AUN=0:0 S AUN=$O(^PRST(458,"AXA",DFN,PPI,AUN)) Q:AUN<1 D PROC G:QT Q2
- Q2 Q
- PROC ; Process
- D HDR Q:QT S PPE=$P($G(^PRST(458,PPI,0)),"^",1) D HDR^PRSADP1 W !,LNE
- S X0=$G(^PRST(458,PPI,"E",DFN,"X",AUN,0)),TYP=$P(X0,"^",4)
- D TM:TYP="T",VC:TYP="V",HZ:TYP="H"
- I $D(^PRST(458,PPI,"E",DFN,"X",AUN,7)) W !!,"Change Remarks: ",^(7)
- D:$E(IOST,1,2)="C-" CLR Q
- TM ; Process Time/Tour Change
- W !?29,"* * * Prior Data * * *" S IFN=AUN S DAY=$P($G(^PRST(458,PPI,"E",DFN,"X",IFN,1)),"^",1),DTE=$P($G(^PRST(458,PPI,2)),"^",+DAY) D GET,DIS^PRSAPPQ
- W !,LNE W !?27,"* * * Corrected Data * * *" S IFN=AUN+1 D GET D DIS^PRSAPPQ
- W !,LNE Q
- VC ; Process VCS Sales Change
- W !?29,"* * * Prior Data * * *" S IFN=AUN D GET S Z=AUR(1) D VCS^PRSAPPQ
- W !,LNE W !?27,"* * * Corrected Data * * *" S IFN=AUN+1 D GET S Z=AUR(1) D VCS^PRSAPPQ
- W !,LNE Q
- HZ ; Process Hazard Change
- W !?29,"* * * Prior Data * * *" S IFN=AUN D GET S Z=AUR(1) D ED^PRSAPPQ
- W !,LNE W !?27,"* * * Corrected Data * * *" S IFN=AUN+1 D GET S Z=AUR(1) D ED^PRSAPPQ
- W !,LNE Q
- GET ; get prior data array of node x
- K AUR S AUC=0 I '$D(^PRST(458,PPI,"E",DFN,"X",IFN)) S IFN=$O(^(IFN)) I IFN<1 S AUC=1 G G1
- I $P($G(^PRST(458,PPI,"E",DFN,"X",IFN,0)),"^",4)'=TYP S IFN=IFN+1 G GET
- I TYP="T",$P($G(^PRST(458,PPI,"E",DFN,"X",IFN,1)),"^",1)'=DAY S IFN=IFN+1 G GET
- F L1=1:1:$S(TYP="T":6,1:1) S AUR(L1)=$G(^PRST(458,PPI,"E",DFN,"X",IFN,L1))
- ;get the prior telework tour and hours
- I TYP="T" S AUR(8)=$G(^PRST(458,PPI,"E",DFN,"X",IFN,8))
- QUIT
- ;get current data array of node day #
- G1 I TYP'="T" G G2
- S L2=0 F L1=0,1,2,10,3,4,8 S L2=L2+1,AUR(L2)=$G(^PRST(458,PPI,"E",DFN,"D",DAY,L1))
- QUIT
- G2 I TYP="H" S AUR(1)=$G(^PRST(458,PPI,"E",DFN,4))
- I TYP="V" S AUR(1)=$G(^PRST(458,PPI,"E",DFN,2))
- Q
- CHK ; Screen Employee for Selected T&L
- S L1=1 Q:TLE="" S:$P($G(^PRSPC(DFN,0)),"^",8)'=TLE L1=0 Q
- CLR ; Clear Entries
- R !!,"Clear Correction? ",X:DTIME S:'$T!(X["^") QT=1 Q:QT S X=$TR(X,"yesno","YESNO")
- I $P("YES",X,1)'="",$P("NO",X,1)'="" W *7," Answer YES or NO" G CLR
- I X'?1"Y".E Q
- D NOW^%DTC S $P(^PRST(458,PPI,"E",DFN,"X",AUN,0),"^",5,7)="P^"_DUZ_"^"_%
- K ^PRST(458,"AXA",DFN,PPI,AUN)
- W " ... done." Q
- HDR ; Display Header
- W:'($E(IOST,1,2)'="C-"&'PG) @IOF S PG=PG+1 Q:$E(IOST,1,2)="C-"
- W !?26,"VA TIME & ATTENDANCE SYSTEM",?72,"Page ",PG
- W !?26,"PRIOR PAY PERIOD CORRECTIONS"
- W !!?(80-$L(DTP)\2),DTP Q
- DTP ; Printable Date/Time
- S %=DTP,DTP=$J(+$E(DTP,6,7),2)_"-"_$P("Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec"," ",+$E(DTP,4,5))_"-"_$E(DTP,2,3)
- S:%#1 %=+$E(%_"0",9,10)_"^"_$E(%_"000",11,12),DTP=DTP_$J($S(%>12:%-12,1:+%),3)_":"_$P(%,"^",2)_$S(%<12:"am",%<24:"pm",1:"m") K % Q
- EX G KILL^XUSCLEAN
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRSAPPP 3598 printed Feb 18, 2025@23:50:26 Page 2
- PRSAPPP ; HISC/REL-Payroll Process Prior PP ;5/31/95 10:00
- +1 ;;4.0;PAID;**114,132**;Sep 21, 1995;Build 13
- +2 ;;Per VHA Directive 2004-038, this routine should not be modified.
- +3 SET PRSTLV=7
- +4 if $EXTRACT(IOST,1,2)="C-"
- WRITE @IOF
- WRITE !?26,"VA TIME & ATTENDANCE SYSTEM"
- +5 WRITE !?26,"PRIOR PAY PERIOD CORRECTIONS"
- R0 READ !!,"Select T&L Unit (or ALL): ",X:DTIME
- if '$TEST!("^"[X)
- GOTO EX
- SET X=$TRANSLATE(X,"al","AL")
- IF X="ALL"
- SET TLE=""
- +1 IF '$TEST
- KILL DIC
- SET DIC="^PRST(455.5,"
- SET DIC(0)="EMQ"
- DO ^DIC
- if $DATA(DTOUT)
- GOTO EX
- if Y<1
- GOTO R0
- SET TLE=$PIECE(Y,"^",2)
- +2 WRITE !
- KILL IOP,%ZIS
- SET %ZIS("A")="Select Device: "
- SET %ZIS="MQ"
- DO ^%ZIS
- KILL %ZIS,IOP
- if POP
- GOTO EX
- +3 IF $DATA(IO("Q"))
- SET PRSAPGM="Q1^PRSAPPP"
- SET PRSALST="TLE"
- DO QUE^PRSAUTL
- GOTO EX
- +4 USE IO
- DO Q1
- DO ^%ZISC
- KILL %ZIS,IOP
- GOTO EX
- Q1 ; Process List
- +1 DO NOW^%DTC
- SET DTP=%
- DO DTP
- SET (PG,QT)=0
- SET LNE=""
- SET $PIECE(LNE,"-",80)=""
- +2 FOR DFN=0:0
- SET DFN=$ORDER(^PRST(458,"AXA",DFN))
- if DFN<1
- QUIT
- DO CHK
- IF L1
- FOR PPI=0:0
- SET PPI=$ORDER(^PRST(458,"AXA",DFN,PPI))
- if PPI<1
- QUIT
- FOR AUN=0:0
- SET AUN=$ORDER(^PRST(458,"AXA",DFN,PPI,AUN))
- if AUN<1
- QUIT
- DO PROC
- if QT
- GOTO Q2
- Q2 QUIT
- PROC ; Process
- +1 DO HDR
- if QT
- QUIT
- SET PPE=$PIECE($GET(^PRST(458,PPI,0)),"^",1)
- DO HDR^PRSADP1
- WRITE !,LNE
- +2 SET X0=$GET(^PRST(458,PPI,"E",DFN,"X",AUN,0))
- SET TYP=$PIECE(X0,"^",4)
- +3 if TYP="T"
- DO TM
- if TYP="V"
- DO VC
- if TYP="H"
- DO HZ
- +4 IF $DATA(^PRST(458,PPI,"E",DFN,"X",AUN,7))
- WRITE !!,"Change Remarks: ",^(7)
- +5 if $EXTRACT(IOST,1,2)="C-"
- DO CLR
- QUIT
- TM ; Process Time/Tour Change
- +1 WRITE !?29,"* * * Prior Data * * *"
- SET IFN=AUN
- SET DAY=$PIECE($GET(^PRST(458,PPI,"E",DFN,"X",IFN,1)),"^",1)
- SET DTE=$PIECE($GET(^PRST(458,PPI,2)),"^",+DAY)
- DO GET
- DO DIS^PRSAPPQ
- +2 WRITE !,LNE
- WRITE !?27,"* * * Corrected Data * * *"
- SET IFN=AUN+1
- DO GET
- DO DIS^PRSAPPQ
- +3 WRITE !,LNE
- QUIT
- VC ; Process VCS Sales Change
- +1 WRITE !?29,"* * * Prior Data * * *"
- SET IFN=AUN
- DO GET
- SET Z=AUR(1)
- DO VCS^PRSAPPQ
- +2 WRITE !,LNE
- WRITE !?27,"* * * Corrected Data * * *"
- SET IFN=AUN+1
- DO GET
- SET Z=AUR(1)
- DO VCS^PRSAPPQ
- +3 WRITE !,LNE
- QUIT
- HZ ; Process Hazard Change
- +1 WRITE !?29,"* * * Prior Data * * *"
- SET IFN=AUN
- DO GET
- SET Z=AUR(1)
- DO ED^PRSAPPQ
- +2 WRITE !,LNE
- WRITE !?27,"* * * Corrected Data * * *"
- SET IFN=AUN+1
- DO GET
- SET Z=AUR(1)
- DO ED^PRSAPPQ
- +3 WRITE !,LNE
- QUIT
- GET ; get prior data array of node x
- +1 KILL AUR
- SET AUC=0
- IF '$DATA(^PRST(458,PPI,"E",DFN,"X",IFN))
- SET IFN=$ORDER(^(IFN))
- IF IFN<1
- SET AUC=1
- GOTO G1
- +2 IF $PIECE($GET(^PRST(458,PPI,"E",DFN,"X",IFN,0)),"^",4)'=TYP
- SET IFN=IFN+1
- GOTO GET
- +3 IF TYP="T"
- IF $PIECE($GET(^PRST(458,PPI,"E",DFN,"X",IFN,1)),"^",1)'=DAY
- SET IFN=IFN+1
- GOTO GET
- +4 FOR L1=1:1:$SELECT(TYP="T":6,1:1)
- SET AUR(L1)=$GET(^PRST(458,PPI,"E",DFN,"X",IFN,L1))
- +5 ;get the prior telework tour and hours
- +6 IF TYP="T"
- SET AUR(8)=$GET(^PRST(458,PPI,"E",DFN,"X",IFN,8))
- +7 QUIT
- +8 ;get current data array of node day #
- G1 IF TYP'="T"
- GOTO G2
- +1 SET L2=0
- FOR L1=0,1,2,10,3,4,8
- SET L2=L2+1
- SET AUR(L2)=$GET(^PRST(458,PPI,"E",DFN,"D",DAY,L1))
- +2 QUIT
- G2 IF TYP="H"
- SET AUR(1)=$GET(^PRST(458,PPI,"E",DFN,4))
- +1 IF TYP="V"
- SET AUR(1)=$GET(^PRST(458,PPI,"E",DFN,2))
- +2 QUIT
- CHK ; Screen Employee for Selected T&L
- +1 SET L1=1
- if TLE=""
- QUIT
- if $PIECE($GET(^PRSPC(DFN,0)),"^",8)'=TLE
- SET L1=0
- QUIT
- CLR ; Clear Entries
- +1 READ !!,"Clear Correction? ",X:DTIME
- if '$TEST!(X["^")
- SET QT=1
- if QT
- QUIT
- SET X=$TRANSLATE(X,"yesno","YESNO")
- +2 IF $PIECE("YES",X,1)'=""
- IF $PIECE("NO",X,1)'=""
- WRITE *7," Answer YES or NO"
- GOTO CLR
- +3 IF X'?1"Y".E
- QUIT
- +4 DO NOW^%DTC
- SET $PIECE(^PRST(458,PPI,"E",DFN,"X",AUN,0),"^",5,7)="P^"_DUZ_"^"_%
- +5 KILL ^PRST(458,"AXA",DFN,PPI,AUN)
- +6 WRITE " ... done."
- QUIT
- HDR ; Display Header
- +1 if '($EXTRACT(IOST,1,2)'="C-"&'PG)
- WRITE @IOF
- SET PG=PG+1
- if $EXTRACT(IOST,1,2)="C-"
- QUIT
- +2 WRITE !?26,"VA TIME & ATTENDANCE SYSTEM",?72,"Page ",PG
- +3 WRITE !?26,"PRIOR PAY PERIOD CORRECTIONS"
- +4 WRITE !!?(80-$LENGTH(DTP)\2),DTP
- QUIT
- DTP ; Printable Date/Time
- +1 SET %=DTP
- SET DTP=$JUSTIFY(+$EXTRACT(DTP,6,7),2)_"-"_$PIECE("Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec"," ",+$EXTRACT(DTP,4,5))_"-"_$EXTRACT(DTP,2,3)
- +2 if %#1
- SET %=+$EXTRACT(%_"0",9,10)_"^"_$EXTRACT(%_"000",11,12)
- SET DTP=DTP_$JUSTIFY($SELECT(%>12:%-12,1:+%),3)_":"_$PIECE(%,"^",2)_$SELECT(%<12:"am",%<24:"pm",1:"m")
- KILL %
- QUIT
- EX GOTO KILL^XUSCLEAN