- 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 Jan 18, 2025@03:24:42 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