PRSALD ;HISC/MGD-Labor Distribution Codes Edit ;06/28/2003
;;4.0;PAID;**82,114,115**;Sep 21, 1995;Build 2
;;Per VHA Directive 2004-038, this routine should not be modified.
;Patch *115 modifies tag POST to display via roll & scroll in place of Screenman view
Q
PAY ; Payroll Entry
N PPERIOD,PRSCNT,PRSDSH,PRSLIN,PRSREC,PRSQUIT
S PRSTLV=7
P1 K DIC S DIC("A")="Select EMPLOYEE: ",DIC(0)="AEQM",DIC="^PRSPC("
W ! D ^DIC S DFN=+Y K DIC G:DFN<1 EX
S TLE=$P($G(^PRSPC(DFN,0)),"^",8)
D POST
G P1
Q
TL ; Timekeeper Entry. Select T & L Unit
N PP,PPE,PPI,PRSTLV,TLI
S PRSTLV=2 D ^PRSAUTL G:TLI<1 EX
;
LASTPP ; Get Last PP received in 459
S PP="A"
S PP=$O(^PRST(459,PP),-1)
S PPE=$P($G(^PRST(459,PP,0)),"^",1)
S PPI=""
S PPI=$O(^PRST(458,"B",PPE,PPI))
S PPE=PPE_" "_$P($G(^PRST(458,PPI,2)),"^",1)_" -> "_$P($G(^PRST(458,PPI,2)),"^",14)
;
NME ; Select individual employee
K DIC S DIC("A")="Select EMPLOYEE: ",DIC("S")="I $P(^(0),""^"",8)=TLE,$D(^PRST(458,PPI,""E"",+Y))",DIC(0)="AEQM",DIC="^PRSPC(",D="ATL"_TLE W ! D IX^DIC S DFN=+Y K DIC
G:DFN<1 EX S GLOB="" D POST D:GLOB]"" UNLOCK^PRSLIB00(GLOB) G NME
;
EX ; Clean up variables and Exit
K D,DA,DDSFILE,DFN,DR,GLOB,LP,NN,TLE,Y,ZS,%
G KILL^XUSCLEAN
;
POST ; Edit & Post Labor Distribution Codes
Q:'DFN
S DA=DFN,PRSDSH="",PRSLIN="",$P(PRSDSH,"-",81)="",$P(PRSLIN,"_",81)=""
;S DDSFILE=450,DR="[PRSA LD POST]"
;D ^DDS K DS Q:'$D(ZS)
;new roll & scroll display for labor dist
S PRSREC=$G(^PRSPC(DFN,0))
W @IOF,$P(PRSREC,U),?26,"VA TIME & ATTENDANCE SYSTEM" S Y=$P(PRSREC,U,9) W ?68,$S(PRSTLV=2&Y:$E(Y)_"XX-XX-"_$E(Y,6,9),PRSTLV=7&Y:$E(Y,1,3)_"-"_$E(Y,4,5)_"-"_$E(Y,6,9),1:"XXX-XX-XXXX")
W !,"Station: ",$P(PRSREC,U,8),?28,"Labor Distribution Codes",?71,"T&L: ",$P(PRSREC,U,8)
W !,?21,$G(PPE)
W !!,?12,"CODE",?24,"PERCENT",?40,"COST CENTER",?59,"FUND CTRL PT",!,PRSDSH
F PRSCNT=1:1:4 S PRSREC=$G(^PRSPC(DA,"LD",PRSCNT,0)) W !,"LD CODE" I PRSREC'="" W ?8,PRSCNT,?12,$P(PRSREC,U,2),?25,$P(PRSREC,U,3),?43,$P(PRSREC,U,4),?64,$P(PRSREC,U,5)
W !!!
F PRSCNT=1:1:4 S PRSREC=$G(^PRSPC(DA,"LD",PRSCNT,0)) W !,"COST CENTER" I PRSREC'="" W ?12,PRSCNT,?14,$P(PRSREC,U,4),?21 D
. S Y=$P(PRSREC,U,4),SUB454="CC" D OT^PRSDUTIL
. K SUB454 S PRSREC=Y
. W PRSREC
W !!,PRSLIN,!!!,"END OF DISPLAY, HIT RETURN TO QUIT" R PRSQUIT:120
W @IOF
Q
;
; The following code will be implemented in Phase 2 of the Labor Dist.
;
D2 ; Select All or individual employee
W !!,"Would you like to edit the Labor Codes in alphabetical order"
S %=1 D YN^DICN I % S LP=% G EX:%=-1,LOOP:%=1,NME
W !!,"Answer YES if you want all RECORDs brought up for which no data"
W !,"has been entered." G D2
Q
;
LOOP ; Loop through all employees in selected T & L
S LP=1,NN=""
F S NN=$O(^PRSPC("ATL"_TLE,NN)) Q:NN="" D
. F DFN=0:0 S DFN=$O(^PRSPC("ATL"_TLE,NN,DFN)) Q:DFN<1 D
. . S GLOB="" D POST D:GLOB]"" UNLOCK^PRSLIB00(GLOB) I 'LP G EX
G EX
Q
;
PP ; Select Pay Period
S DIC="^PRST(458,",DIC(0)="AEQZ",D="B"
D IX^DIC
Q:Y=-1
S PPI=+Y,PPE="PP "_$P(Y,"^",2)_" "
S PPE=PPE_$P($G(^PRST(458,PPI,2)),"^",1)_" -> "_$P($G(^PRST(458,PPI,2)),"^",14)
;
LDOUT ; Convert LABOR DIST CODE EDITED BY field into its external format.
;
I "IETP"'[Y&('+Y) D Q
. S Y="Unknown"
I Y="I" S Y="Initial Download"
I Y="E" S Y="Edit & Update Download"
I Y="T" S Y="Transfer Download"
I Y="P" S Y="Payrun Download"
I +Y D
. S Y=$P($G(^VA(200,Y,0)),"^",1)
. I Y="" S Y="Unknown"
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRSALD 3510 printed Sep 23, 2025@19:59:56 Page 2
PRSALD ;HISC/MGD-Labor Distribution Codes Edit ;06/28/2003
+1 ;;4.0;PAID;**82,114,115**;Sep 21, 1995;Build 2
+2 ;;Per VHA Directive 2004-038, this routine should not be modified.
+3 ;Patch *115 modifies tag POST to display via roll & scroll in place of Screenman view
+4 QUIT
PAY ; Payroll Entry
+1 NEW PPERIOD,PRSCNT,PRSDSH,PRSLIN,PRSREC,PRSQUIT
+2 SET PRSTLV=7
P1 KILL DIC
SET DIC("A")="Select EMPLOYEE: "
SET DIC(0)="AEQM"
SET DIC="^PRSPC("
+1 WRITE !
DO ^DIC
SET DFN=+Y
KILL DIC
if DFN<1
GOTO EX
+2 SET TLE=$PIECE($GET(^PRSPC(DFN,0)),"^",8)
+3 DO POST
+4 GOTO P1
+5 QUIT
TL ; Timekeeper Entry. Select T & L Unit
+1 NEW PP,PPE,PPI,PRSTLV,TLI
+2 SET PRSTLV=2
DO ^PRSAUTL
if TLI<1
GOTO EX
+3 ;
LASTPP ; Get Last PP received in 459
+1 SET PP="A"
+2 SET PP=$ORDER(^PRST(459,PP),-1)
+3 SET PPE=$PIECE($GET(^PRST(459,PP,0)),"^",1)
+4 SET PPI=""
+5 SET PPI=$ORDER(^PRST(458,"B",PPE,PPI))
+6 SET PPE=PPE_" "_$PIECE($GET(^PRST(458,PPI,2)),"^",1)_" -> "_$PIECE($GET(^PRST(458,PPI,2)),"^",14)
+7 ;
NME ; Select individual employee
+1 KILL DIC
SET DIC("A")="Select EMPLOYEE: "
SET DIC("S")="I $P(^(0),""^"",8)=TLE,$D(^PRST(458,PPI,""E"",+Y))"
SET DIC(0)="AEQM"
SET DIC="^PRSPC("
SET D="ATL"_TLE
WRITE !
DO IX^DIC
SET DFN=+Y
KILL DIC
+2 if DFN<1
GOTO EX
SET GLOB=""
DO POST
if GLOB]""
DO UNLOCK^PRSLIB00(GLOB)
GOTO NME
+3 ;
EX ; Clean up variables and Exit
+1 KILL D,DA,DDSFILE,DFN,DR,GLOB,LP,NN,TLE,Y,ZS,%
+2 GOTO KILL^XUSCLEAN
+3 ;
POST ; Edit & Post Labor Distribution Codes
+1 if 'DFN
QUIT
+2 SET DA=DFN
SET PRSDSH=""
SET PRSLIN=""
SET $PIECE(PRSDSH,"-",81)=""
SET $PIECE(PRSLIN,"_",81)=""
+3 ;S DDSFILE=450,DR="[PRSA LD POST]"
+4 ;D ^DDS K DS Q:'$D(ZS)
+5 ;new roll & scroll display for labor dist
+6 SET PRSREC=$GET(^PRSPC(DFN,0))
+7 WRITE @IOF,$PIECE(PRSREC,U),?26,"VA TIME & ATTENDANCE SYSTEM"
SET Y=$PIECE(PRSREC,U,9)
WRITE ?68,$SELECT(PRSTLV=2&Y:$EXTRACT(Y)_"XX-XX-"_$EXTRACT(Y,6,9),PRSTLV=7&Y:$EXTRACT(Y,1,3)_"-"_$EXTRACT(Y,4,5)_"-"_$EXTRACT(Y,6,9),1:"XXX-XX-XXXX")
+8 WRITE !,"Station: ",$PIECE(PRSREC,U,8),?28,"Labor Distribution Codes",?71,"T&L: ",$PIECE(PRSREC,U,8)
+9 WRITE !,?21,$GET(PPE)
+10 WRITE !!,?12,"CODE",?24,"PERCENT",?40,"COST CENTER",?59,"FUND CTRL PT",!,PRSDSH
+11 FOR PRSCNT=1:1:4
SET PRSREC=$GET(^PRSPC(DA,"LD",PRSCNT,0))
WRITE !,"LD CODE"
IF PRSREC'=""
WRITE ?8,PRSCNT,?12,$PIECE(PRSREC,U,2),?25,$PIECE(PRSREC,U,3),?43,$PIECE(PRSREC,U,4),?64,$PIECE(PRSREC,U,5)
+12 WRITE !!!
+13 FOR PRSCNT=1:1:4
SET PRSREC=$GET(^PRSPC(DA,"LD",PRSCNT,0))
WRITE !,"COST CENTER"
IF PRSREC'=""
WRITE ?12,PRSCNT,?14,$PIECE(PRSREC,U,4),?21
Begin DoDot:1
+14 SET Y=$PIECE(PRSREC,U,4)
SET SUB454="CC"
DO OT^PRSDUTIL
+15 KILL SUB454
SET PRSREC=Y
+16 WRITE PRSREC
End DoDot:1
+17 WRITE !!,PRSLIN,!!!,"END OF DISPLAY, HIT RETURN TO QUIT"
READ PRSQUIT:120
+18 WRITE @IOF
+19 QUIT
+20 ;
+21 ; The following code will be implemented in Phase 2 of the Labor Dist.
+22 ;
D2 ; Select All or individual employee
+1 WRITE !!,"Would you like to edit the Labor Codes in alphabetical order"
+2 SET %=1
DO YN^DICN
IF %
SET LP=%
if %=-1
GOTO EX
if %=1
GOTO LOOP
GOTO NME
+3 WRITE !!,"Answer YES if you want all RECORDs brought up for which no data"
+4 WRITE !,"has been entered."
GOTO D2
+5 QUIT
+6 ;
LOOP ; Loop through all employees in selected T & L
+1 SET LP=1
SET NN=""
+2 FOR
SET NN=$ORDER(^PRSPC("ATL"_TLE,NN))
if NN=""
QUIT
Begin DoDot:1
+3 FOR DFN=0:0
SET DFN=$ORDER(^PRSPC("ATL"_TLE,NN,DFN))
if DFN<1
QUIT
Begin DoDot:2
+4 SET GLOB=""
DO POST
if GLOB]""
DO UNLOCK^PRSLIB00(GLOB)
IF 'LP
GOTO EX
End DoDot:2
End DoDot:1
+5 GOTO EX
+6 QUIT
+7 ;
PP ; Select Pay Period
+1 SET DIC="^PRST(458,"
SET DIC(0)="AEQZ"
SET D="B"
+2 DO IX^DIC
+3 if Y=-1
QUIT
+4 SET PPI=+Y
SET PPE="PP "_$PIECE(Y,"^",2)_" "
+5 SET PPE=PPE_$PIECE($GET(^PRST(458,PPI,2)),"^",1)_" -> "_$PIECE($GET(^PRST(458,PPI,2)),"^",14)
+6 ;
LDOUT ; Convert LABOR DIST CODE EDITED BY field into its external format.
+1 ;
+2 IF "IETP"'[Y&('+Y)
Begin DoDot:1
+3 SET Y="Unknown"
End DoDot:1
QUIT
+4 IF Y="I"
SET Y="Initial Download"
+5 IF Y="E"
SET Y="Edit & Update Download"
+6 IF Y="T"
SET Y="Transfer Download"
+7 IF Y="P"
SET Y="Payrun Download"
+8 IF +Y
Begin DoDot:1
+9 SET Y=$PIECE($GET(^VA(200,Y,0)),"^",1)
+10 IF Y=""
SET Y="Unknown"
End DoDot:1
+11 QUIT
