source: WorldVistAEHR/trunk/r/PAID-PRS/PRSPDM.m@ 1166

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

initial load of WorldVistAEHR

File size: 7.3 KB
Line 
1PRSPDM ; HISC/MGD - DISPLAY PT PHYSICIAN MEMORANDUM ;06/28/05
2 ;;4.0;PAID;**93**;Sep 21, 1995;Build 7
3 ;;Per VHA Directive 2004-038, this routine should not be modified.
4PAY ; Payroll Entry
5 S PRSTLV=7
6 D TOP ; print header
7P1 K DIC S DIC("A")="Select EMPLOYEE: ",DIC(0)="AEQM",DIC="^PRSPC("
8 W ! D ^DIC S (DFN,PRSIEN)=+Y K DIC G:DFN<1 EX
9 S TLE=$P($G(^PRSPC(DFN,0)),"^",8)
10 S DIC="^PRST(458,",DIC(0)="AEQM",DIC("A")="Select PAY PERIOD: "
11 W ! D ^DIC K DIC G:Y<1 EX
12 S PPI=+Y
13 S PPE=$P(Y,U,2)
14 D L1 ;ask device
15 G P1 ;ask for employee again
16 ;====================================================================
17TK ; TimeKeeper Entry
18 S PRSTLV=2 G T0
19 ;====================================================================
20SUP ; Supervisor Entry
21 S PRSTLV=3
22T0 D TOP ; print header
23 D ^PRSAUTL G:TLI<1 EX
24T1 K DIC S DIC("A")="Select EMPLOYEE: ",DIC(0)="AEQM",DIC="^PRSPC("
25 S DIC("S")="I $P(^(0),""^"",8)=TLE" S D="ATL"_TLE W ! D IX^DIC
26 S (DFN,PRSIEN)=+Y K DIC G:DFN<1 EX
27 S %DT="AEPX",%DT("A")="Posting Date: " W ! D ^%DT
28 G:Y<1 EX
29 S D1=Y S Y=$G(^PRST(458,"AD",D1)),PPI=$P(Y,"^",1)
30 G EX:PPI<1
31 S PPE=$P($G(^PRST(458,PPI,0)),U,1)
32 D L1 ;ask device
33 ;
34 G T1 ;ask for employee again
35 ;====================================================================
36EMP ; Employee Entry
37 S PRSTLV=1 D TOP S DFN="",SSN=$P($G(^VA(200,DUZ,1)),"^",9)
38 I SSN'="" S DFN=$O(^PRSPC("SSN",SSN,0)),PRSIEN=DFN
39 I 'DFN W !!,*7,"Your SSN was not found in both the New Person & Employee File!" G EX
40 S TLE=$P($G(^PRSPC(DFN,0)),"^",8)
41 S %DT="AEPX",%DT("A")="Posting Date: ",%DT(0)=3040101 W ! D ^%DT
42 G:Y<1 EX
43 S D1=Y S Y=$G(^PRST(458,"AD",D1)),PPI=$P(Y,"^",1)
44 G EX:PPI<1
45 S PPE=$P($G(^PRST(458,PPI,0)),U,1)
46 D L1 G EX
47 ;====================================================================
48TOP W:$E(IOST,1,2)="C-" @IOF W !?26,"VA TIME & ATTENDANCE SYSTEM"
49 W !?25,"DISPLAY PT PHYSICIAN MEMORANDA" Q
50L1 W ! K IOP,%ZIS S %ZIS("A")="Select Device: ",%ZIS="MQ"
51 D ^%ZIS K %ZIS,IOP
52 Q:POP
53 I $D(IO("Q")) D Q
54 . S PRSAPGM="DIS^PRSPDM",PRSALST="PRSIEN^TLE^PPE^PPI"
55 . D QUE^PRSAUTL
56 U IO D DIS
57 ; pause screen when employee to prevent scroll (other users prompted)
58 I $E(IOST,1,2)="C-",'QT,PRSTLV=1,'$D(DIRUT) S PG=PG+1 D H1
59 D ^%ZISC K %ZIS,IOP Q
60 ;====================================================================
61DIS ; Display Memorandum
62 ;
63 S PDT=$G(^PRST(458,PPI,2)),DAY1=$P($G(^PRST(458,PPI,1)),U,1)
64 S STAT=$P($G(^PRST(458,PPI,"E",PRSIEN,0)),"^",2)
65 S MIEN=+$$MIEN^PRSPUT1(PRSIEN,DAY1),(PG,QT)=0
66 I 'MIEN D Q
67 . W !!,"The employee did not have a memorandum during the date specified."
68 ;
69DISPLAY ; Display memorandum information
70 W:$E(IOST,1,2)="C-" @IOF
71 S SCRTTL="DISPLAY PT PHYSICIAN MEMORANDA"
72 S ARRAY="^TMP($J,""PRSPDM"",",INDEX=1
73 D HDR^PRSPUT1(PRSIEN,SCRTTL,ARRAY,INDEX,PPI)
74 D MEM^PRSPUT1(PRSIEN,MIEN,ARRAY)
75 D AL^PRSPUT3(PRSIEN,ARRAY)
76 D PPSUM^PRSPUT2(PRSIEN,MIEN,ARRAY)
77 Q:$D(DIRUT)
78 I $E(IOST,1,2)="C-" D
79 . S DIR(0)="E",DIR("A")="Press RETURN to continue" D ^DIR K DIR
80 . I '$D(DIRUT) W @IOF
81 Q:$D(DIRUT)
82 ;
83ESRCHK ; Check for any incomplete ESR within the memoranda.
84 ;
85 S QUIT=0
86 S PPIT=+$G(^PRST(458.7,MIEN,4)),PPIT=+$G(^PRST(458,"AD",PPIT))
87 F I=1:1:26 D
88 . S PPE=$P($G(^PRST(458.7,MIEN,9,I,0)),U)
89 . I PPE="" S ^TMP($J,"INCESR","NO DATA")="" S QUIT=1 Q
90 . S PPI=$O(^PRST(458,"B",PPE,0))
91 . Q:'PPI
92 . I PPIT,PPIT<PPI Q ; Don't display PP ESR beyond termination of memo
93 . F DAY=1:1:14 D Q:QUIT
94 . . S ESRSTAT=$P($G(^PRST(458,PPI,"E",PRSIEN,"D",DAY,7)),U,1)
95 . . I ESRSTAT<5 S ^TMP($J,"INCESR",PPE)="",QUIT=1
96 ;
97 ; List any PP exceptions
98 I $D(^TMP($J,"INCESR")) D
99 . S INDEX=INDEX+1
100 . S TEXT=""
101 . D A1^PRSPUT1,A1^PRSPUT1 ; Blank Lines
102 . S TEXT="The following Pay Periods have days with incomplete daily ESRs: "
103 . D A1^PRSPUT1
104 . S (PPE,PPEX)=""
105 . S TEXT="" D A1^PRSPUT1 ; Blank Line
106 . F S PPE=$O(^TMP($J,"INCESR",PPE)) Q:PPE="" D
107 . . S PPEX=$S(PPEX="":PPE,1:PPEX_", "_PPE)
108 . S TEXT=PPEX
109 I '$D(^TMP($J,"INCESR")) D
110 . S TEXT=" There are no pay periods with incomplete daily ESRs."
111 D A1^PRSPUT1
112 K ^TMP($J,"INCESR")
113 ;
114 ; Load and display any HR Initial comments
115 I PRSTLV'=1 D
116 . S MESSAGE=$G(^PRST(458.7,MIEN,1))
117 . Q:MESSAGE=""
118 . S TEXT=""
119 . D A1^PRSPUT1 ; Blank Line
120 . F J=1:1:3 D
121 . . S HEADER=$S(J=1:"HR Initial Comments: ",1:"")
122 . . D TEXT(HEADER,.MESSAGE)
123 . . D A1^PRSPUT1
124 . I $Y>(IOSL-5) D PSE Q:$D(DIRUT)
125 ;
126 ; Load and display Termination information if any
127 I PRSTLV'=1 D
128 . S DATA4=$G(^PRST(458.7,MIEN,4))
129 . S TDAT=$P(DATA4,U,1),TERMBY=$P(DATA4,U,2),TERMDT=$P(DATA4,U,3)
130 . I TDAT'="" D
131 . . S Y=TDAT
132 . . D DD^%DT
133 . . S TDAT=Y
134 . . I TDAT'="" D
135 . . . S TEXT=""
136 . . . D A1^PRSPUT1 ; Blank Line
137 . . . S TEXT=" Termination date: "_TDAT
138 . . . D A1^PRSPUT1
139 . ;
140 . I TERMBY'="" D
141 . . S TERMBY=$P($G(^VA(200,TERMBY,0)),U,1)
142 . . S TEXT=" Terminated by: "_TERMBY
143 . . D A1^PRSPUT1
144 . ;
145 . I TERMDT'="" D
146 . . S Y=TERMDT
147 . . D DD^%DT
148 . . S TERMDT=Y
149 . . I TERMDT'="" D
150 . . . S TEXT="Date/Time Terminated: "_TERMDT
151 . . . D A1^PRSPUT1
152 . I $Y>(IOSL-5) D PSE Q:$D(DIRUT)
153 . ;
154 . S MESSAGE=$G(^PRST(458.7,MIEN,4.1))
155 . Q:MESSAGE=""
156 . S TEXT=""
157 . D A1^PRSPUT1 ; Blank Line
158 . F J=1:1:3 D
159 . . S HEADER=$S(J=1:"HR's Termination Comments: ",1:"")
160 . . D TEXT(HEADER,.MESSAGE)
161 . . D A1^PRSPUT1
162 . I $Y>(IOSL-5) D PSE Q:$D(DIRUT)
163 ;
164 ; Load and display PTP's reconciliation choice and comments
165 S DATA2=$G(^PRST(458.7,MIEN,2))
166 S PTPRC=$P(DATA2,U,1),MESSAGE=$P(DATA2,U,2)
167 I PTPRC'="" D
168 . S TEXT=""
169 . D A1^PRSPUT1 ; Blank Line
170 . S TEXT=$$EXTERNAL^DILFD(458.7,17,"",PTPRC)
171 . S TEXT=" PTP's Reconciliation Choice: "_TEXT
172 . D A1^PRSPUT1
173 I MESSAGE'="" D
174 . F J=1:1:3 D
175 . . S HEADER=$S(J=1:"PTP's Reconciliation Comments: ",1:"")
176 . . D TEXT(HEADER,.MESSAGE)
177 . . D A1^PRSPUT1
178 ;
179 ; Load and display HR's reconciliation info and comments
180 I PRSTLV'=1 D
181 . I $Y>(IOSL-7) D PSE Q:$D(DIRUT)
182 . S DATA3=$G(^PRST(458.7,MIEN,3))
183 . S RECONBY=$P(DATA3,U,1),RECONDAT=$P(DATA3,U,2)
184 . I RECONBY'="" D
185 . . S TEXT=""
186 . . D A1^PRSPUT1 ; Blank Line
187 . . S RECONBY=$P($G(^VA(200,RECONBY,0)),U,1)
188 . . S TEXT="Reconciled by: "_RECONBY
189 . . D A1^PRSPUT1
190 . I $Y>(IOSL-5) D PSE Q:$D(DIRUT)
191 . I RECONDAT'="" D
192 . . S Y=RECONDAT
193 . . D DD^%DT
194 . . S RECONDAT=Y
195 . . I RECONDAT'="" D
196 . . . S TEXT="Reconciled on: "_RECONDAT
197 . . . D A1^PRSPUT1
198 . I $Y>(IOSL-7) D PSE Q:$D(DIRUT)
199 ;
200 ; HR Reconciliation Comments
201 I PRSTLV'=1 D
202 . S MESSAGE=$G(^PRST(458.7,MIEN,3.1))
203 . Q:MESSAGE=""
204 . S TEXT=""
205 . D A1^PRSPUT1 ; Blank Line
206 . F J=1:1:3 D
207 . . S HEADER=$S(J=1:"HR's Reconciliation Comments: ",1:"")
208 . . D TEXT(HEADER,.MESSAGE)
209 . . D A1^PRSPUT1
210 Q
211 ;
212PSE ; Pause for screen breaks
213 Q:$E(IOST,1,2)'="C-"
214 W !
215 S DIR(0)="E",DIR("A")="Press RETURN to continue" D ^DIR K DIR
216 W @IOF
217 Q
218 ;
219H1 I PG,$E(IOST,1,2)="C-" R !!,"Press RETURN to Continue.",X:DTIME S:'$T!(X["^") QT=1
220 S PG=PG+1
221 Q
222 ;
223TEXT(HEADER,MESSAGE) ;
224 N BREAK
225 S BREAK=0
226 I $L(HEADER)+$L(MESSAGE)<80 D Q
227 . S TEXT=HEADER_MESSAGE
228 . S MESSAGE=""
229 F I=(80-$L(HEADER)):-1:0 D Q:BREAK
230 . Q:$E(MESSAGE,I)'=" "
231 . S TEXT=HEADER_$E(MESSAGE,1,I)
232 . S MESSAGE=$E(MESSAGE,I+1,999)
233 . S BREAK=1
234 Q
235 ;
236EX ; Clean up variables
237 K ARRAY,D,D1,DASH,DATA0,DATA2,DATA3,DATA4,DAY
238 K DAY1,DFN,DIRUT,ESRSTAT,HRS,I,ICOM,IDAYS,INDEX,J,HEADER,MESSAGE
239 K MIEN,MT,PDT,PG,POP,PPE,PPEX,PPI,PPIT,PRSALST,PRSAPGM,PRSIEN,PRSTLV
240 K PTPRC,PTPRCOM,PTPRMKS,QUIT,QT,RC,RCEX,RECONBY,RECONDAT,SCRTTL,SEG
241 K SSN,START,STAT,STATEX,STOP,T1,T1EX,TDAT,TERMBY,TERMDT,TEXT,TLI,TLE
242 K TLSCREEN,TOT,TOTEX,X,Y,%DT,%ZIS
243 Q
Note: See TracBrowser for help on using the repository browser.