source: WorldVistAEHR/trunk/r/PAID-PRS/PRSALDA.m@ 1261

Last change on this file since 1261 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR
File size: 4.4 KB
RevLine 
[613]1PRSALDA ;HISC/MGD-Labor Distribution Audit ;02/13/2007
2 ;;4.0;PAID;**82,109**;Sep 21, 1995;Build 5
3 ;;Per VHA Directive 2004-038, this routine should not be modified.
4 Q
5TL W @IOF
6 S PRSTLV=3 D ^PRSAUTL G:TLI<1 EX
7 W !
8 ;
9PP ;select pay period
10 K DIC S DIC="^PRST(458,",DIC(0)="AEMQZ"
11 D ^DIC
12 I Y'>0 D EX Q
13 S PPI=+Y,PPNAME=$P(^PRST(458,PPI,0),U,1)
14 ;
15D2 W !!,"Would you like to review the Labor Distributions "
16 W !,"in alphabetical order"
17 S %=1 D YN^DICN
18 Q:%=-1
19 I %=0 D G D2
20 . W !!,"Answer YES if you want the Labor Distribution and any changes"
21 . W !,"that have occurred during the selected Pay Period for all"
22 . W !,"employees."
23 I %=1 D Q
24 . D DVC
25 . I POP D EX Q
26 . Q
27 I %=2 D EMP Q
28 Q
29 ;
30DVC N PRSALST,PRSAPGM,PRTC S PRTC=""
31 W ! K IOP,%ZIS S %ZIS("A")="Select Device: ",%ZIS="MQ"
32 D ^%ZIS K %ZIS,IOP
33 Q:POP
34 I $D(IO("Q")) D Q
35 . S PRSAPGM="LOOP^PRSALDA",PRSALST="TLE^PPE^PPI^PPNAME"
36 . D QUE^PRSAUTL
37 U IO D LOOP
38 ; pause screen when employee to prevent scroll (other users prompted)
39 ; I $E(IOST,1,2)="C-",'QT,PRSTLV=1,'$D(DIRUT) S PG=PG+1 D H1
40 D ^%ZISC K %ZIS,IOP
41 Q
42 ;
43LOOP N DASH,PRTC
44 S LP=1,NN="",PRTC="",$P(DASH,"-",80)=""
45 F S NN=$O(^PRSPC("ATL"_TLE,NN)) Q:NN="" D Q:PRTC=0
46 . F DFN=0:0 S DFN=$O(^PRSPC("ATL"_TLE,NN,DFN)) Q:DFN<1 D LD Q:PRTC=0
47 Q:PRTC=0
48 D:$E(IOST,1)="C" CHECK
49 D:$E(IOST,1)'="C" ^%ZISC
50 Q
51 ;
52EMP W @IOF
53 K DIC
54 S DIC("A")="Select EMPLOYEE: ",DIC(0)="AEQM",DIC="^PRSPC("
55 W ! D ^DIC S DFN=+Y K DIC G:DFN<1 EX
56 I DFN<1 D EX Q
57 W ! K IOP,%ZIS S %ZIS("A")="Select Device: ",%ZIS="MQ"
58 D ^%ZIS K %ZIS,IOP
59 I POP D EX Q
60 U IO
61 D LD
62 D:$E(IOST,1)'="C" ^%ZISC
63 G EMP
64 Q
65LD ; Display changes to the Labor Distribution Codes within the Pay
66 ; Period.
67 ;
68 N I,LDAUD,LDCC,LDCCB,LDCCEX,LDCODE,LDCODNUM,LDCNT,LDDATA,LDDIS
69 N LDDOA,LDFCP,LDHOLD,LDPCT,LDTOI,Y S PRTC=""
70 S NAME=$$GET1^DIQ(450,DFN,.01,"E")
71 I $E(IOST,1)="C" W @IOF
72 D LDHDR
73 W !!,"Current Labor Distribution Values:"
74 S LDDOA=$$GET1^DIQ(450,DFN,756,"E")
75 S LDCCB=$$GET1^DIQ(450,DFN,755,"E")
76 S LDTOI=$$GET1^DIQ(450,DFN,755.1,"E")
77 S LDTOI=$S(LDTOI="I":"INITIAL",LDTOI="E":"EDIT & UPDATE",LDTOI="T":"TRANSFER",LDTOI="P":"PAYROLL",1:"")
78 W !,LDDOA,?24,LDCCB,?61,LDTOI
79 F LDDIS=1:1:4 D Q:PRTC=0
80 . S LDDATA=$G(^PRSPC(DFN,"LD",LDDIS,0))
81 . S LDCODE=$P(LDDATA,U,2),LDPCT=$P(LDDATA,U,3)
82 . S LDCC=$P(LDDATA,U,4),LDFCP=$P(LDDATA,U,5)
83 . S Y=LDCC,SUB454="CC" D OT^PRSDUTIL K SUB454
84 . S LDCCEX=$E(Y,1,30)
85 . W !,"Code",LDDIS,": ",LDCODE,?15
86 . I LDPCT>0 W $J(LDPCT,3,2)
87 . W ?24,LDCC
88 . I LDCC'="" W " - ",LDCCEX
89 . W ?70,LDFCP
90 ; Check for changes within the Pay Period.
91 S LDCNT="A"
92 S LDCNT=$O(^PRST(458,PPI,"E",DFN,"LDAUD",LDCNT),-1)
93 I 'LDCNT D Q
94 . W !!,"There were no Labor Distribution changes for this employee"
95 . W !,"during the Pay Period: ",PPNAME,".",!!
96 . I $E(IOST,1)="C" D PRTC
97 F I=LDCNT:-1:1 D Q:PRTC=0
98 . W !!,"Previous Change # ",I
99 . S IENS=I_","_DFN_","_PPI_","
100 . S LDDOA=$$GET1^DIQ(458.1105,IENS,1,"E")
101 . S LDCCB=$$GET1^DIQ(458.1105,IENS,2,"E")
102 . S LDTOI=$$GET1^DIQ(458.1105,IENS,3,"E")
103 . S LDTOI=$S(LDTOI="I":"INITIAL",LDTOI="E":"EDIT & UPDATE",LDTOI="T":"TRANSFER",LDTOI="P":"PAYROLL",1:"")
104 . W !,LDDOA,?24,LDCCB,?61,LDTOI
105 . F PRSLD=1:1:4 D Q:PRTC=0
106 . . S IENS=PRSLD_","_LDCNT_","_DFN_","_PPI_","
107 . . S LDCODE=$$GET1^DIQ(458.11054,IENS,1)
108 . . S LDPCT=$$GET1^DIQ(458.11054,IENS,2)
109 . . S LDCC=$$GET1^DIQ(458.11054,IENS,3)
110 . . S Y=LDCC,SUB454="CC"
111 . . D OT^PRSDUTIL K SUB454
112 . . S LDCCEX=$E(Y,1,30)
113 . . S LDFCP=$$GET1^DIQ(458.11054,IENS,4)
114 . . W !,"Code",PRSLD,": ",LDCODE,?15
115 . . I LDPCT>0 W $J(LDPCT,3,2)
116 . . W ?24,LDCC
117 . . I LDCC'="" W " - ",LDCCEX
118 . . W ?70,LDFCP
119 . I I'=1 D CHECK
120 . Q:PRTC=0
121 . I PRTC&(I'=1) W @IOF D LDHDR S PRTC=""
122 . I I=1&($E(IOST,1)="C") D PRTC
123 Q
124 ;
125LDHDR ;Labor Distribution Header information
126 ;
127 N TAB,DASH
128 S TAB=($L(NAME)\2),$P(DASH,"-",80)=""
129 W $J(NAME,40+TAB)
130 W !?15,"Labor Distribution Changes within the Pay Period:"
131 W !,"Date/Time",?24,"Changed by",?61,"Type of Interface"
132 W !,"Code",?14,"Percent",?24,"Cost Center - Description"
133 W ?65,"Fund Ctrl Pt"
134 W !,DASH
135 Q
136 ;
137LDHOLD ; Pause of more LD changes that will fit on 1 screen.
138 ;
139 S LDHOLD=$$ASK^PRSLIB00(1)
140 S X=$G(^PRSPC(DFN,0))
141 W !,@IOF,?3,$P(X,"^",1)
142 S X=$P(X,"^",9)
143 I X W ?68,$E(X,1,3),"-",$E(X,4,5),"-",$E(X,6,9)
144 W !,DASH
145 D LDHDR
146 Q
147 ;
148CHECK I $E(IOST,1)="C",$Y>(IOSL-7) D PRTC
149 Q
150 ;
151PRTC W ! K DIR,DIRUT,DIROUT,DTOUT,DUOUT
152 S DIR(0)="E",DIR("A")="Press RETURN to continue" D ^DIR S PRTC=Y
153 S:$D(DIRUT) PRTC=0
154 Q
155 ;
156EX K DFN,DIC,IEN,IENS,IOFSAV,LP,NAME,NN,POP,PPI,PPNAME,PRSLD,PRSTLV
157 K TLE,TLI,X,%
158 Q
Note: See TracBrowser for help on using the repository browser.