source: WorldVistAEHR/trunk/r/PAID-PRS/PRSPEEM.m@ 789

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

initial load of WorldVistAEHR
File size: 8.7 KB
RevLine 
[613]1PRSPEEM ;HISC/MGD - ESR EXCEPTIONS FOR ENTIRE MEMORANDA ;06/15/05
2 ;;4.0;PAID;**93**;Sep 21, 1995;Build 7
3 ;;Per VHA Directive 2004-038, this routine should not be modified.
4 Q
5PAY ; Payroll Entry
6 S PRSTLV=7,QUITX=0
7 D T0
8 Q
9 ;
10SUP ; Supervisor Entry
11 ;
12 S PRSTLV=3,QUITX=0
13T0 K DIR,^TMP($J,"PRSPEEM"),^TMP($J,"PRSPEEM EMP")
14 D TOP ; print header
15 D OMIT ; Prompt to omit current Pay Period
16 I X="^" D EX Q
17 D TLCHK ; Check for Supervisor of just 1 or mult T&L
18 I MULT>1 D TL
19 I MULT=1 D
20 . S TL="ATL"_TLE
21 . D EMP
22 I '$D(^TMP($J,"PRSPEEM")) W !,"No exceptions found for input criteria." Q
23 D SCRN1
24 D EX
25 ;
26 Q
27OMIT ; Prompt for Omit current pay period
28 S DIR(0)="Y"
29 S DIR("A")="Would you like to omit the current pay period from this report"
30 D ^DIR K DIR
31 S OMIT=Y
32 Q
33 ;
34TLCHK ; Check for Supervisor of just 1 or mult T&L
35 S MULT=0,I=""
36 F S I=$O(^PRST(455.5,"AS",DUZ,I)) Q:'I D
37 . S MULT=MULT+1,TLI=I,TLE=$P(^PRST(455.5,I,0),U,1)
38 Q
39 ;
40TL ; Loop to enter T&Ls and employees
41 N SEL ; local array to hold selected t&ls and employees
42 S QUIT1=0
43 F D Q:QUIT1
44 . D ^PRSAUTL
45 . I 'TLI S QUIT1=1 Q
46 . I $D(SEL(TLI,"A")) D Q
47 .. W !!,?5,"You have already selected all the employees in T&L unit ",$G(TLE),"."
48 .. W !,?5,"Select another T&L OR enter <return> to begin report."
49 . D EMP
50 Q
51 ;
52 ; Loop for individual employees in a T&L
53EMP S QUIT2=0
54 S DIR(0)="SM^A:All PT Physicians in the T&L;I:Individual PT Physicians"
55 S DIR("A")="Enter Choice"
56 D ^DIR K DIR
57 ; Loop for All employee in a T&L
58 I Y="A" D Q
59 . K SEL(TLI) S SEL(TLI,"A")=""
60 . K ^TMP($J,"PRSPEEM",TLI)
61 . S EMP="",TL="ATL"_TLE
62 . F S EMP=$O(^PRSPC(TL,EMP)) Q:EMP="" D
63 . . S PRSIEN=$O(^PRSPC(TL,EMP,0))
64 . . Q:'PRSIEN
65 . . D MEM ; Check for memos w/ status = ACTIVE or RECONCILIATION STARTED
66 . . S QUIT2=1
67 Q:QUIT2
68 ;
69 S PPI=+$G(^PRST(458,"AD",DT)),PRSDT=DT,PTPF=1
70 F D Q:QUIT2
71 . K DIC
72 . S DIC("A")=$S('$D(SEL(TLI)):"Select EMPLOYEE: ",1:"Select Another EMPLOYEE: ")
73 . S DIC(0)="AEQM",DIC="^PRSPC(",D="ATL"_TLE
74 . S DIC("S")="I $P(^(0),""^"",8)=TLE,$D(^PRST(458.7,""B"",+Y)),'$D(SEL(TLI,+Y))"
75 . W !
76 . D IX^DIC S PRSIEN=+Y
77 . I X=""!(X="^") S QUIT2=1 Q
78 . S SEL(TLI,PRSIEN)=""
79 . D MEM
80 Q
81 ;
82MEM ; Check for memos w/ status of ACTIVE (2) or RECONCILIATION STARTED (3)
83 N PPI
84 S MIEN=""
85 F S MIEN=$O(^PRST(458.7,"B",PRSIEN,MIEN)) Q:'MIEN D
86 . S DATA0=$G(^PRST(458.7,MIEN,0))
87 . S STATUS=$P(DATA0,U,6)
88 . Q:STATUS'=2&(STATUS'=3)
89 . S TDAT=$P($G(^PRST(458.7,MIEN,4)),U,1)
90 . I TDAT S TDAT=+$G(^PRST(458,"AD",TDAT)) ; IEN of termination PP
91 . ; Loop to check for any incomplete days in any PP of the memo
92 . S PP=0
93 . F I=1:1:26 S PPE=$P($G(^PRST(458.7,MIEN,9,I,0)),U) Q:PPE="" D
94 . . S PPI=$O(^PRST(458,"B",PPE,0))
95 . . Q:'PPI
96 . . ; If the memo was terminated, only check ESRs up to and
97 . . ; including the Termination Date
98 . . Q:TDAT&(PPI>TDAT) ; Don't look past termination PP
99 . . S PP=PP+1
100 . . S DATA1=$G(^PRST(458,PPI,1)) ; FileMan Dates
101 . . Q:'+$$MIEN^PRSPUT1(PRSIEN,$P(DATA1,U,I))
102 . . F DAY=1:1:14 D
103 . . . S ESRSTAT=$P($G(^PRST(458,PPI,"E",PRSIEN,"D",DAY,7)),U,1)
104 . . . Q:ESRSTAT>3
105 . . . S ESRSTATX=$$EXTERNAL^DILFD(458.02,146,"",ESRSTAT)
106 . . . I ESRSTATX="" S ESRSTATX="UNKNOWN"
107 . . . S Y=$P(DATA1,U,DAY)
108 . . . D DD^%DT
109 . . . S ^TMP($J,"PRSPEEM",TLI,PRSIEN,MIEN,PP,DAY)=Y_U_ESRSTATX
110 . . I $D(^TMP($J,"PRSPEEM",TLI,PRSIEN,MIEN,PP)) D
111 . . . S ^TMP($J,"PRSPEEM",TLI,PRSIEN,MIEN,PP)=PPI_U_PPE
112 . ; if no exceptions found set up first pay pereiod with no data message
113 . I '$D(^TMP($J,"PRSPEEM",TLI,PRSIEN,MIEN)) D
114 .. S PPE=$P($G(^PRST(458.7,MIEN,9,1,0)),U)
115 .. S PPI=$O(^PRST(458,"B",PPE,0))
116 .. S ^TMP($J,"PRSPEEM",TLI,PRSIEN,MIEN,1)=PPI_U_PPE_U_"*"
117 .. S ^TMP($J,"PRSPEEM",TLI,PRSIEN,MIEN,1,0)="no exceptions found fo r entire memo"
118 Q
119 ;
120TOP W:$E(IOST,1,2)="C-" @IOF
121 W !?26,"VA TIME & ATTENDANCE SYSTEM"
122 W !?22,"ESR EXCEPTIONS FOR ENTIRE MEMORANDA",!!
123 Q
124 ;
125TOP1 W:$E(IOST,1,2)="C-" @IOF W !?26,"VA TIME & ATTENDANCE SYSTEM"
126 S SCRTTLX="ESR EXCEPTIONS FOR ENTIRE MEMORANDA"
127 I OMIT S SCRTTLX=SCRTTLX_" - CURRENT PP OMITTED"
128 S $E(SCRTTL,$S(OMIT:12,1:22))=""
129 S SCRTTL=SCRTTL_SCRTTLX
130 W !,SCRTTL
131 Q
132 ;
133SCRN1 ; Loop through employees and display data
134 W:$E(IOST,1,2)="C-" @IOF
135 S TLI="",QUITX=0
136 F S TLI=$O(^TMP($J,"PRSPEEM",TLI)) Q:'TLI D Q:QUITX
137 . S PRSIEN="",INDEX=1
138 . F S PRSIEN=$O(^TMP($J,"PRSPEEM",TLI,PRSIEN)) Q:'PRSIEN D Q:QUITX
139 . . K ^TMP($J,"PRSPEEM EMP") ; Kill temporary employee array
140 . . S MIEN="",(EMPQT,LIST)=0
141 . . F S MIEN=$O(^TMP($J,"PRSPEEM",TLI,PRSIEN,MIEN)) Q:'MIEN D Q:QUITX
142 . . . S PP="",DAYCNT=0
143 . . . F S PP=$O(^TMP($J,"PRSPEEM",TLI,PRSIEN,MIEN,PP)) Q:'PP D Q:QUITX
144 . . . . S DATA=^TMP($J,"PRSPEEM",TLI,PRSIEN,MIEN,PP),LIST=LIST+1
145 . . . . S PPI=$P(DATA,U,1),PPE=$P(DATA,U,2)
146 . . . . S ITEM(LIST)=DATA
147 . . . . I DAYCNT=0 D ; Display header prior to 1st PP in a memo
148 . . . . . S ARRAY="^TMP($J,""PRSPEEM EMP"","
149 . . . . . S SCRTTL="ESR EXCEPTIONS FOR ENTIRE MEMORANDA"
150 . . . . . D HDR^PRSPUT1(PRSIEN,SCRTTL,ARRAY,INDEX,PPI)
151 . . . . . D MEM^PRSPUT1(PRSIEN,MIEN,ARRAY)
152 . . . . . D AL^PRSPUT3(PRSIEN,ARRAY)
153 . . . . . S INDEX="",INDEX=$O(^TMP($J,"PRSPEEM EMP",INDEX),-1)
154 . . . . . S TEXT="",INDEX=INDEX+1
155 . . . . . D A1^PRSPUT1 ; Blank Line
156 . . . . . S TEXT=" # Pay Period Date Status"
157 . . . . . D A1^PRSPUT1
158 . . . . . S TEXT="------------------------------------"
159 . . . . . D A1^PRSPUT1
160 . . . . I $P(DATA,U,3)="*" S TEXT="No exceptions found for entire memo" D A1^PRSPUT1 Q
161 . . . . S TEXT=$J(PP,2),$E(TEXT,5)="",TEXT=TEXT_PPE
162 . . . . F DAY=1:1:14 D Q:QUITX
163 . . . . . Q:'$D(^TMP($J,"PRSPEEM",TLI,PRSIEN,MIEN,PP,DAY))
164 . . . . . S DATA=^TMP($J,"PRSPEEM",TLI,PRSIEN,MIEN,PP,DAY)
165 . . . . . S $E(TEXT,17)="",TEXT=TEXT_$P(DATA,U,1) ; External Date
166 . . . . . S $E(TEXT,31)="",TEXT=TEXT_$P(DATA,U,2) ; External Status
167 . . . . . S DAYCNT=DAYCNT+1
168 . . . . . D A1^PRSPUT1
169 . . . . . I $Y>(IOSL-3) D PSE
170 . . . Q:QUITX
171 . . . S $E(TEXT,31,36)="------",INDEX=INDEX+1
172 . . . D A1^PRSPUT1
173 . . . S $E(TEXT,20)="",TEXT=TEXT_"Total Days: "_DAYCNT
174 . . . D A1^PRSPUT1
175 . . . I $P(DATA,U,3)="*" D
176 . . . . S QUITX=$$ASK^PRSLIB00(1)
177 . . . E D
178 . . . . D ACTION
179 . . . I $E(IOST,1,2)="C-" W @IOF
180 Q
181 ;
182ACTION ; Prompt for action
183 S EMPQT=0
184 F D Q:QUITX!(EMPQT)
185 . S TEXT="(P)rint list, (S)elect Item or press Enter to "
186 . S TEXT=TEXT_"continue to next employee"
187 . W !!,TEXT
188 . W !!,"Enter Choice: "
189 . R CHOICE:DT
190 . S CHOICE=$$UPPER^PRSRUTL(CHOICE)
191 . I CHOICE="" S EMPQT=1 Q ; Go to next employee
192 . I CHOICE="^" S QUITX=1 Q ; Terminate report
193 . I CHOICE'="P"&(CHOICE'="S") D Q
194 . . W !!,"Enter P, S or ^ to Quit or press Enter to continue to next employee."
195 . I CHOICE="P" D Q:EMPQT
196 . . D DVC1
197 . . I POP S EMPQT=1
198 . I CHOICE="S" D
199 . . F D Q:EMPQT!(QUITX)
200 . . . I $E(IOST,1,2)="C-" W @IOF
201 . . . F I=1:1 Q:'$D(ITEM(I)) W !,I,?5,$P(ITEM(I),U,2)
202 . . . W !!,"Select a number between 1 and ",LIST_" : "
203 . . . R ITEM:DT
204 . . . S ITEM=$$UPPER^PRSRUTL(ITEM)
205 . . . I ITEM="" S EMPQT=1 Q ; Go to next employee
206 . . . I ITEM="^" S QUITX=1 Q ; Terminate report
207 . . . Q:'$D(ITEM(ITEM))
208 . . . S PPI=+ITEM(ITEM)
209 . . . D DVC2
210 ;
211 Q
212 ;
213LOOP1 ; Loop to display Summary Screen with list of outstanding ESRs
214 I '$D(^TMP($J,"PRSPEEM EMP")) W !,"No part-time physician ESR Exceptions found for selected criteria." Q
215 S INDX=""
216 F S INDX=$O(^TMP($J,"PRSPEEM EMP",INDX)) Q:'INDX D
217 . S TEXT=^TMP($J,"PRSPEEM EMP",INDX)
218 . W !,TEXT
219 Q
220 ;
221DVC1 ; Display Summary Screen with list of outstanding ESRs
222 W !
223 K IOP,%ZIS
224 S %ZIS("A")="Select Device: ",%ZIS="MQ"
225 D ^%ZIS K %ZIS,IOP
226 Q:POP
227 I $D(IO("Q")) D Q
228 . S ZTRTN="LOOP1^PRSPEEM"
229 . S ZTSAVE("^TMP($J,""PRSPEEM EMP"",")=""
230 . S ZTDESC="PRS PTP EXCEPTS"
231 . D ^%ZTLOAD W !,$S($D(ZTSK):"Request Queued!",1:"Request Canceled!")
232 . K ZTSK,ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE
233 . D HOME^%ZIS
234 U IO D LOOP1
235 D ^%ZISC K %ZIS,IOP
236 D H1 ; pause screen
237 Q
238 ;
239DVC2 ; Display PP ESR
240 W !
241 K IOP,%ZIS
242 S %ZIS("A")="Select Device: ",%ZIS="MQ"
243 D ^%ZIS K %ZIS,IOP
244 Q:POP
245 I $D(IO("Q")) D Q
246 . S ZTRTN="DIS^PRSPDESR"
247 . S ZTSAVE("PRSIEN")="",ZTSAVE("PPI")="",ZTSAVE("PPE")=""
248 . S ZTDESC="PRS PTP DISPLAY ESR"
249 . D ^%ZTLOAD W !,$S($D(ZTSK):"Request Queued!",1:"Request Canceled!")
250 . K ZTSK,ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE
251 . D HOME^%ZIS
252 . N HOLD S HOLD=$$ASK^PRSLIB00(1)
253 U IO D DIS^PRSPDESR
254 D ^%ZISC K %ZIS,IOP
255 D H1 ; pause screen
256 Q
257 ;
258 ;====================================================================
259 ;
260PSE ; Pause for screen breaks
261 W !
262 S DIR(0)="E",DIR("A")="Press RETURN to continue"
263 D ^DIR
264 I X="^" S QUITX=1 Q
265 W @IOF
266 Q
267 ;
268H1 I $E(IOST,1,2)="C-" R !!,"Press RETURN to Continue.",X:DTIME S:'$T!(X["^") QT=1
269 Q
270EX ; Clean up variables
271 K ARRAY,CHOICE,D,DASH,DATA,DATA0,DATA1,DAY,DAYCNT,DFN
272 K EMP,EMPQT,ESRSTAT,ESRSTATX,I,IDAYS,INDEX,INDX,ITEM,LIST,MIEN
273 K MULT,OMIT,POP,PP,PPE,PPI,PRSAPGM,PRSDT,PRSIEN,PRSTLV,PTPF
274 K QT,QUIT1,QUIT2,QUITX,SCRTTL,SCRTTLX,STATUS,TDAT,TEXT,TL,TLE,TLI,X,Y
275 Q
Note: See TracBrowser for help on using the repository browser.