PRSALDA ;HISC/MGD-Labor Distribution Audit ;02/13/2007
;;4.0;PAID;**82,109,110**;Sep 21, 1995;Build 7
;;Per VHA Directive 2004-038, this routine should not be modified.
Q
TL W @IOF
S PRSTLV=3 D ^PRSAUTL G:TLI<1 EX
W !
;
PP ;select pay period
K DIC S DIC="^PRST(458,",DIC(0)="AEMQZ"
D ^DIC
I Y'>0 D EX Q
S PPI=+Y,PPNAME=$P(^PRST(458,PPI,0),U,1)
;
D2 W !!,"Would you like to review the Labor Distributions "
W !,"in alphabetical order"
S %=1 D YN^DICN
Q:%=-1
I %=0 D G D2
. W !!,"Answer YES if you want the Labor Distribution and any changes"
. W !,"that have occurred during the selected Pay Period for all"
. W !,"employees."
I %=1 D D EX Q
. D DVC
. I POP Q
. Q
I %=2 D EMP D EX Q
D EX
Q
;
DVC N PRSALST,PRSAPGM,PRTC S PRTC=""
W ! K IOP,%ZIS S %ZIS("A")="Select Device: ",%ZIS="MQ"
D ^%ZIS K %ZIS,IOP
Q:POP
I $D(IO("Q")) D Q
. S PRSAPGM="LOOP^PRSALDA",PRSALST="TLE^PPE^PPI^PPNAME"
. D QUE^PRSAUTL
U IO D LOOP
; pause screen when employee to prevent scroll (other users prompted)
; I $E(IOST,1,2)="C-",'QT,PRSTLV=1,'$D(DIRUT) S PG=PG+1 D H1
D ^%ZISC K %ZIS,IOP
Q
;
LOOP N DASH,PRTC
S LP=1,NN="",PRTC="",$P(DASH,"-",80)=""
F S NN=$O(^PRSPC("ATL"_TLE,NN)) Q:NN="" D Q:PRTC=0
. F DFN=0:0 S DFN=$O(^PRSPC("ATL"_TLE,NN,DFN)) Q:DFN<1 D LD Q:PRTC=0
Q:PRTC=0
D:$E(IOST,1)="C" CHECK
D:$E(IOST,1)'="C" ^%ZISC
Q
;
EMP W @IOF
K DIC
S DIC("A")="Select EMPLOYEE: ",DIC(0)="AEQM",DIC="^PRSPC("
W ! D ^DIC S DFN=+Y K DIC G:DFN<1 EX
I DFN<1 D EX Q
W ! K IOP,%ZIS S %ZIS("A")="Select Device: ",%ZIS="MQ"
D ^%ZIS K %ZIS,IOP
I POP D EX Q
U IO
D LD
D:$E(IOST,1)'="C" ^%ZISC
G EMP
Q
LD ; Display changes to the Labor Distribution Codes within the Pay
; Period.
;
N I,LDAUD,LDCC,LDCCB,LDCCEX,LDCODE,LDCODNUM,LDCNT,LDDATA,LDDIS
N LDDOA,LDFCP,LDHOLD,LDPCT,LDTOI,Y S PRTC=""
S NAME=$$GET1^DIQ(450,DFN,.01,"E")
I $E(IOST,1)="C" W @IOF
D LDHDR
W !!,"Current Labor Distribution Values:"
S LDDOA=$$GET1^DIQ(450,DFN,756,"E")
S LDCCB=$$GET1^DIQ(450,DFN,755,"E")
S LDTOI=$$GET1^DIQ(450,DFN,755.1,"E")
S LDTOI=$S(LDTOI="I":"INITIAL",LDTOI="E":"EDIT & UPDATE",LDTOI="T":"TRANSFER",LDTOI="P":"PAYROLL",1:"")
W !,LDDOA,?24,LDCCB,?61,LDTOI
F LDDIS=1:1:4 D Q:PRTC=0
. S LDDATA=$G(^PRSPC(DFN,"LD",LDDIS,0))
. S LDCODE=$P(LDDATA,U,2),LDPCT=$P(LDDATA,U,3)
. S LDCC=$P(LDDATA,U,4),LDFCP=$P(LDDATA,U,5)
. S Y=LDCC,SUB454="CC" D OT^PRSDUTIL K SUB454
. S LDCCEX=$E(Y,1,30)
. W !,"Code",LDDIS,": ",LDCODE,?15
. I LDPCT>0 W $J(LDPCT,3,2)
. W ?24,LDCC
. I LDCC'="" W " - ",LDCCEX
. W ?70,LDFCP
; Check for changes within the Pay Period.
S LDCNT="A"
S LDCNT=$O(^PRST(458,PPI,"E",DFN,"LDAUD",LDCNT),-1)
I 'LDCNT D Q
. W !!,"There were no Labor Distribution changes for this employee"
. W !,"during the Pay Period: ",PPNAME,".",!!
. I $E(IOST,1)="C" D PRTC
F I=LDCNT:-1:1 D Q:PRTC=0
. W !!,"Previous Change # ",I
. S IENS=I_","_DFN_","_PPI_","
. S LDDOA=$$GET1^DIQ(458.1105,IENS,1,"E")
. S LDCCB=$$GET1^DIQ(458.1105,IENS,2,"E")
. S LDTOI=$$GET1^DIQ(458.1105,IENS,3,"E")
. S LDTOI=$S(LDTOI="I":"INITIAL",LDTOI="E":"EDIT & UPDATE",LDTOI="T":"TRANSFER",LDTOI="P":"PAYROLL",1:"")
. W !,LDDOA,?24,LDCCB,?61,LDTOI
. F PRSLD=1:1:4 D Q:PRTC=0
. . S IENS=PRSLD_","_LDCNT_","_DFN_","_PPI_","
. . S LDCODE=$$GET1^DIQ(458.11054,IENS,1)
. . S LDPCT=$$GET1^DIQ(458.11054,IENS,2)
. . S LDCC=$$GET1^DIQ(458.11054,IENS,3)
. . S Y=LDCC,SUB454="CC"
. . D OT^PRSDUTIL K SUB454
. . S LDCCEX=$E(Y,1,30)
. . S LDFCP=$$GET1^DIQ(458.11054,IENS,4)
. . W !,"Code",PRSLD,": ",LDCODE,?15
. . I LDPCT>0 W $J(LDPCT,3,2)
. . W ?24,LDCC
. . I LDCC'="" W " - ",LDCCEX
. . W ?70,LDFCP
. I I'=1 D CHECK
. Q:PRTC=0
. I PRTC&(I'=1) W @IOF D LDHDR S PRTC=""
. I I=1&($E(IOST,1)="C") D PRTC
Q
;
LDHDR ;Labor Distribution Header information
;
N TAB,DASH
S TAB=($L(NAME)\2),$P(DASH,"-",80)=""
W $J(NAME,40+TAB)
W !?15,"Labor Distribution Changes within the Pay Period:"
W !,"Date/Time",?24,"Changed by",?61,"Type of Interface"
W !,"Code",?14,"Percent",?24,"Cost Center - Description"
W ?65,"Fund Ctrl Pt"
W !,DASH
Q
;
LDHOLD ; Pause of more LD changes that will fit on 1 screen.
;
S LDHOLD=$$ASK^PRSLIB00(1)
S X=$G(^PRSPC(DFN,0))
W !,@IOF,?3,$P(X,"^",1)
S X=$P(X,"^",9)
I X W ?68,$E(X,1,3),"-",$E(X,4,5),"-",$E(X,6,9)
W !,DASH
D LDHDR
Q
;
CHECK I $E(IOST,1)="C",$Y>(IOSL-7) D PRTC
Q
;
PRTC W ! K DIR,DIRUT,DIROUT,DTOUT,DUOUT
S DIR(0)="E",DIR("A")="Press RETURN to continue" D ^DIR S PRTC=Y
S:$D(DIRUT) PRTC=0
Q
;
EX K DFN,DIC,IEN,IENS,IOFSAV,LP,NAME,NN,POP,PPI,PPNAME,PRSLD,PRSTLV
K TLE,TLI,X,%
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRSALDA 4719 printed Apr 09, 2024@21:28:30 Page 2
PRSALDA ;HISC/MGD-Labor Distribution Audit ;02/13/2007
+1 ;;4.0;PAID;**82,109,110**;Sep 21, 1995;Build 7
+2 ;;Per VHA Directive 2004-038, this routine should not be modified.
+3 QUIT
TL WRITE @IOF
+1 SET PRSTLV=3
DO ^PRSAUTL
if TLI<1
GOTO EX
+2 WRITE !
+3 ;
PP ;select pay period
+1 KILL DIC
SET DIC="^PRST(458,"
SET DIC(0)="AEMQZ"
+2 DO ^DIC
+3 IF Y'>0
DO EX
QUIT
+4 SET PPI=+Y
SET PPNAME=$PIECE(^PRST(458,PPI,0),U,1)
+5 ;
D2 WRITE !!,"Would you like to review the Labor Distributions "
+1 WRITE !,"in alphabetical order"
+2 SET %=1
DO YN^DICN
+3 if %=-1
QUIT
+4 IF %=0
Begin DoDot:1
+5 WRITE !!,"Answer YES if you want the Labor Distribution and any changes"
+6 WRITE !,"that have occurred during the selected Pay Period for all"
+7 WRITE !,"employees."
End DoDot:1
GOTO D2
+8 IF %=1
Begin DoDot:1
+9 DO DVC
+10 IF POP
QUIT
+11 QUIT
End DoDot:1
DO EX
QUIT
+12 IF %=2
DO EMP
DO EX
QUIT
+13 DO EX
+14 QUIT
+15 ;
DVC NEW PRSALST,PRSAPGM,PRTC
SET PRTC=""
+1 WRITE !
KILL IOP,%ZIS
SET %ZIS("A")="Select Device: "
SET %ZIS="MQ"
+2 DO ^%ZIS
KILL %ZIS,IOP
+3 if POP
QUIT
+4 IF $DATA(IO("Q"))
Begin DoDot:1
+5 SET PRSAPGM="LOOP^PRSALDA"
SET PRSALST="TLE^PPE^PPI^PPNAME"
+6 DO QUE^PRSAUTL
End DoDot:1
QUIT
+7 USE IO
DO LOOP
+8 ; pause screen when employee to prevent scroll (other users prompted)
+9 ; I $E(IOST,1,2)="C-",'QT,PRSTLV=1,'$D(DIRUT) S PG=PG+1 D H1
+10 DO ^%ZISC
KILL %ZIS,IOP
+11 QUIT
+12 ;
LOOP NEW DASH,PRTC
+1 SET LP=1
SET NN=""
SET PRTC=""
SET $PIECE(DASH,"-",80)=""
+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
DO LD
if PRTC=0
QUIT
End DoDot:1
if PRTC=0
QUIT
+4 if PRTC=0
QUIT
+5 if $EXTRACT(IOST,1)="C"
DO CHECK
+6 if $EXTRACT(IOST,1)'="C"
DO ^%ZISC
+7 QUIT
+8 ;
EMP WRITE @IOF
+1 KILL DIC
+2 SET DIC("A")="Select EMPLOYEE: "
SET DIC(0)="AEQM"
SET DIC="^PRSPC("
+3 WRITE !
DO ^DIC
SET DFN=+Y
KILL DIC
if DFN<1
GOTO EX
+4 IF DFN<1
DO EX
QUIT
+5 WRITE !
KILL IOP,%ZIS
SET %ZIS("A")="Select Device: "
SET %ZIS="MQ"
+6 DO ^%ZIS
KILL %ZIS,IOP
+7 IF POP
DO EX
QUIT
+8 USE IO
+9 DO LD
+10 if $EXTRACT(IOST,1)'="C"
DO ^%ZISC
+11 GOTO EMP
+12 QUIT
LD ; Display changes to the Labor Distribution Codes within the Pay
+1 ; Period.
+2 ;
+3 NEW I,LDAUD,LDCC,LDCCB,LDCCEX,LDCODE,LDCODNUM,LDCNT,LDDATA,LDDIS
+4 NEW LDDOA,LDFCP,LDHOLD,LDPCT,LDTOI,Y
SET PRTC=""
+5 SET NAME=$$GET1^DIQ(450,DFN,.01,"E")
+6 IF $EXTRACT(IOST,1)="C"
WRITE @IOF
+7 DO LDHDR
+8 WRITE !!,"Current Labor Distribution Values:"
+9 SET LDDOA=$$GET1^DIQ(450,DFN,756,"E")
+10 SET LDCCB=$$GET1^DIQ(450,DFN,755,"E")
+11 SET LDTOI=$$GET1^DIQ(450,DFN,755.1,"E")
+12 SET LDTOI=$SELECT(LDTOI="I":"INITIAL",LDTOI="E":"EDIT & UPDATE",LDTOI="T":"TRANSFER",LDTOI="P":"PAYROLL",1:"")
+13 WRITE !,LDDOA,?24,LDCCB,?61,LDTOI
+14 FOR LDDIS=1:1:4
Begin DoDot:1
+15 SET LDDATA=$GET(^PRSPC(DFN,"LD",LDDIS,0))
+16 SET LDCODE=$PIECE(LDDATA,U,2)
SET LDPCT=$PIECE(LDDATA,U,3)
+17 SET LDCC=$PIECE(LDDATA,U,4)
SET LDFCP=$PIECE(LDDATA,U,5)
+18 SET Y=LDCC
SET SUB454="CC"
DO OT^PRSDUTIL
KILL SUB454
+19 SET LDCCEX=$EXTRACT(Y,1,30)
+20 WRITE !,"Code",LDDIS,": ",LDCODE,?15
+21 IF LDPCT>0
WRITE $JUSTIFY(LDPCT,3,2)
+22 WRITE ?24,LDCC
+23 IF LDCC'=""
WRITE " - ",LDCCEX
+24 WRITE ?70,LDFCP
End DoDot:1
if PRTC=0
QUIT
+25 ; Check for changes within the Pay Period.
+26 SET LDCNT="A"
+27 SET LDCNT=$ORDER(^PRST(458,PPI,"E",DFN,"LDAUD",LDCNT),-1)
+28 IF 'LDCNT
Begin DoDot:1
+29 WRITE !!,"There were no Labor Distribution changes for this employee"
+30 WRITE !,"during the Pay Period: ",PPNAME,".",!!
+31 IF $EXTRACT(IOST,1)="C"
DO PRTC
End DoDot:1
QUIT
+32 FOR I=LDCNT:-1:1
Begin DoDot:1
+33 WRITE !!,"Previous Change # ",I
+34 SET IENS=I_","_DFN_","_PPI_","
+35 SET LDDOA=$$GET1^DIQ(458.1105,IENS,1,"E")
+36 SET LDCCB=$$GET1^DIQ(458.1105,IENS,2,"E")
+37 SET LDTOI=$$GET1^DIQ(458.1105,IENS,3,"E")
+38 SET LDTOI=$SELECT(LDTOI="I":"INITIAL",LDTOI="E":"EDIT & UPDATE",LDTOI="T":"TRANSFER",LDTOI="P":"PAYROLL",1:"")
+39 WRITE !,LDDOA,?24,LDCCB,?61,LDTOI
+40 FOR PRSLD=1:1:4
Begin DoDot:2
+41 SET IENS=PRSLD_","_LDCNT_","_DFN_","_PPI_","
+42 SET LDCODE=$$GET1^DIQ(458.11054,IENS,1)
+43 SET LDPCT=$$GET1^DIQ(458.11054,IENS,2)
+44 SET LDCC=$$GET1^DIQ(458.11054,IENS,3)
+45 SET Y=LDCC
SET SUB454="CC"
+46 DO OT^PRSDUTIL
KILL SUB454
+47 SET LDCCEX=$EXTRACT(Y,1,30)
+48 SET LDFCP=$$GET1^DIQ(458.11054,IENS,4)
+49 WRITE !,"Code",PRSLD,": ",LDCODE,?15
+50 IF LDPCT>0
WRITE $JUSTIFY(LDPCT,3,2)
+51 WRITE ?24,LDCC
+52 IF LDCC'=""
WRITE " - ",LDCCEX
+53 WRITE ?70,LDFCP
End DoDot:2
if PRTC=0
QUIT
+54 IF I'=1
DO CHECK
+55 if PRTC=0
QUIT
+56 IF PRTC&(I'=1)
WRITE @IOF
DO LDHDR
SET PRTC=""
+57 IF I=1&($EXTRACT(IOST,1)="C")
DO PRTC
End DoDot:1
if PRTC=0
QUIT
+58 QUIT
+59 ;
LDHDR ;Labor Distribution Header information
+1 ;
+2 NEW TAB,DASH
+3 SET TAB=($LENGTH(NAME)\2)
SET $PIECE(DASH,"-",80)=""
+4 WRITE $JUSTIFY(NAME,40+TAB)
+5 WRITE !?15,"Labor Distribution Changes within the Pay Period:"
+6 WRITE !,"Date/Time",?24,"Changed by",?61,"Type of Interface"
+7 WRITE !,"Code",?14,"Percent",?24,"Cost Center - Description"
+8 WRITE ?65,"Fund Ctrl Pt"
+9 WRITE !,DASH
+10 QUIT
+11 ;
LDHOLD ; Pause of more LD changes that will fit on 1 screen.
+1 ;
+2 SET LDHOLD=$$ASK^PRSLIB00(1)
+3 SET X=$GET(^PRSPC(DFN,0))
+4 WRITE !,@IOF,?3,$PIECE(X,"^",1)
+5 SET X=$PIECE(X,"^",9)
+6 IF X
WRITE ?68,$EXTRACT(X,1,3),"-",$EXTRACT(X,4,5),"-",$EXTRACT(X,6,9)
+7 WRITE !,DASH
+8 DO LDHDR
+9 QUIT
+10 ;
CHECK IF $EXTRACT(IOST,1)="C"
IF $Y>(IOSL-7)
DO PRTC
+1 QUIT
+2 ;
PRTC WRITE !
KILL DIR,DIRUT,DIROUT,DTOUT,DUOUT
+1 SET DIR(0)="E"
SET DIR("A")="Press RETURN to continue"
DO ^DIR
SET PRTC=Y
+2 if $DATA(DIRUT)
SET PRTC=0
+3 QUIT
+4 ;
EX KILL DFN,DIC,IEN,IENS,IOFSAV,LP,NAME,NN,POP,PPI,PPNAME,PRSLD,PRSTLV
+1 KILL TLE,TLI,X,%
+2 QUIT
