source: FOIAVistA/trunk/r/PAID-PRS/PRSPUT1.m@ 1800

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

initial load of FOIAVistA 6/30/08 version
File size: 8.6 KB
Line 
1PRSPUT1 ;WOIFO/MGD - PART TIME PHYSICIAN UTILITIES #1 ;05/17/05
2 ;;4.0;PAID;**93**;Sep 21, 1995;Build 7
3 ;;Per VHA Directive 2004-038, this routine should not be modified.
4 ;
5 ;The following routine contains various utilities for the Part Time
6 ;Physician functionality that was added as part of patch PRS*4.0*93.
7 ;
8 ;----------------------------------------------------------------------
9 ; Determine the IEN of the PT Physician's memorandum if any for the
10 ; current date or the date specified in the MDAT parameter.
11 ; Input: PTPIEN - IEN of the PT Physician
12 ; MDAT - Optional - date within memorandum in FileMan format
13 ;
14 ; Output: IEN^STATUS
15 ; IEN - of the PT Phy's memorandum in the #458.7 file or 0
16 ; STATUS - of the memorandum
17 ;-----------------------------------------------------------------------
18MIEN(PRSIEN,MDAT) ;
19 Q:'PRSIEN 0_"^"
20 N ENDAT,MDATA,QUIT,STATUS,STDAT,TDAT,MIEN
21 S MDAT=$G(MDAT,DT)
22 S (MIEN,QUIT)=0
23 F S MIEN=$O(^PRST(458.7,"B",PRSIEN,MIEN)) Q:'MIEN D Q:QUIT
24 . S MDATA=$G(^PRST(458.7,MIEN,0))
25 . S STDAT=$P(MDATA,U,2) ; START DATE OF MEMORANDUM
26 . S ENDAT=$P(MDATA,U,3) ; END DATE OF MEMORANDUM
27 . S STATUS=$P(MDATA,U,6) ; STATUS OF MEMORANDUM
28 . S TDAT=$P($G(^PRST(458.7,MIEN,4)),U,1) ; TERMINATION DATE
29 . I TDAT D
30 . . I TDAT<ENDAT S ENDAT=TDAT
31 . I MDAT'<STDAT,MDAT'>ENDAT S QUIT=1
32 I MIEN="" S MIEN=0,STATUS=0
33 Q MIEN_"^"_STATUS
34 ;
35 ;-----------------------------------------------------------------------
36 ;Display information on a PT Physician's memoranda
37 ; Input: PRSIEN - IEN of the PT Physician.
38 ; SCRTTL - Title for the screen.
39 ; ARRAY - The array where the message to be printed will be
40 ; stored. (optional) If not specified, no array will
41 ; be created.
42 ; INDEX - The index where the array will start. (optional) This
43 ; will be set to 1 if no index is passed.
44 ; PPI - Optional: IEN of the desired PP. If supplied, the
45 ; external format will be displayed on line
46 ;
47 ; Output: VA header, screen title and 10 fields to identify the PT Phy
48 ; Array with the same data if the ARRAY parameter is passed.
49 ;-----------------------------------------------------------------------
50HDR(PRSIEN,SCRTTL,ARRAY,INDEX,PPI) ;
51 Q:'PRSIEN
52 S SCRTTL=$G(SCRTTL,"")
53 S ARRAY=$G(ARRAY,"")
54 I $G(INDEX)="",($G(ARRAY)'="") D INDEX
55 N C0,DATE,PPE,SSN,TAB,TEXT,X,YR
56 I $G(PPI)="" D ; If no PPI passed in get last PP in #459
57 . S PPE="A",PPE=$O(^PRST(459,PPE),-1)
58 . S PPE=$P($G(^PRST(459,PPE,0)),U,1)
59 I $G(PPI)>0 S PPE=$P($G(^PRST(458,PPI,0)),U,1)
60 S TEXT="PP:"_PPE,$E(TEXT,26)="",TEXT=TEXT_"VA TIME & ATTENDANCE SYSTEM"
61 D NOW^%DTC
62 S YR=%I(3)+1700,YR=$E(YR,3,4)
63 S DATE=%I(1)_"/"_%I(2)_"/"_YR
64 S $E(TEXT,73)="",TEXT=TEXT_DATE
65 D A1 ; Line #1
66 S TAB=39-($L(SCRTTL)\2)
67 S $E(TEXT,TAB)="",TEXT=TEXT_SCRTTL
68 D A1 ; Line #2
69 S C0=^PRSPC(PRSIEN,0)
70 S TEXT=$P(C0,U,1),$E(TEXT,70)=""
71 S SSN=$P(C0,U,9)
72 S SSN="XXX-XX-"_$E(SSN,6,9)
73 S TEXT=TEXT_SSN
74 D A1 ; Line #3
75 S TEXT="Pay Plan: "_$P(C0,"^",21)_" Duty Basis: "_$P(C0,"^",10)
76 S TEXT=TEXT_" FLSA: "_$P(C0,"^",12)_" Normal Hours: "
77 S TEXT=TEXT_$J($P(C0,"^",16),3)_" Comp/Flex: "
78 S TEXT=TEXT_$P($G(^PRSPC(PRSIEN,1)),"^",7)
79 D A1 ; Line #4
80 S TEXT="T&L: "_$P(C0,"^",8),$E(TEXT,69)=""
81 S TEXT=TEXT_"Station: "_$P(C0,"^",7)
82 D A1 ; Line #5
83 K INDEX,%I
84 Q
85 ;
86 ;-----------------------------------------------------------------------
87 ; Display information on a PT Physician's memoranda
88 ; Input: PRSIEN - IEN of the PT Physician
89 ; MIEN - IEN of the PT Phy's memorandum in #458.7
90 ; ARRAY - The array where the message to be printed will be
91 ; stored. (Optional) If not specified, no array will
92 ; be created.
93 ; INDEX - The index where the array will start. (optional) This
94 ; will be set to 1 if no index is passed.
95 ; HRSCO - Carrryover Hours from a prior memorandum. (optional)
96 ;
97 ; Output: 4 line summary of the PT Phy's current memorandum
98 ; Array with the same data if the ARRAY parameter is passed.
99 ;-----------------------------------------------------------------------
100MEM(PRSIEN,MIEN,ARRAY,INDEX,HRSCO) ;
101 Q:'PRSIEN&('MIEN)
102 I $G(INDEX)="",($G(ARRAY)'="") D INDEX
103 N AHRS,AHTCM,COHRS,DATA,EDAT,ENDDAT,HRSWK,HTSHBW,I,IEN458,LASTDAY,LASTPP
104 N LASTPPE,LPPP,NPHRS,OTHRS,POHC,POMC,POT,PPP,QUIT,TAB,TDAT,TDATEX,TEXT
105 N THRSWK,TTEXT,WPHRS
106 ; Load 0 node from #458.7. Quit if it doesn't exist
107 S DATA=$G(^PRST(458.7,MIEN,0))
108 Q:DATA=""
109 ; Determine last PP processed
110 S LASTPP="A"
111 S LASTPP=$O(^PRST(459,LASTPP),-1)
112 Q:'LASTPP
113 S LASTPPE=$P(^PRST(459,LASTPP,0),U,1)
114 S IEN458="",IEN458=$O(^PRST(458,"B",LASTPPE,IEN458))
115 Q:'IEN458
116 S LASTDAY=$P($G(^PRST(458,IEN458,2)),U,14)
117 S TTEXT="Memorandum & Leave Status thru PP "_LASTPPE_" Ending "_LASTDAY
118 S TAB=40-($L(TTEXT)\2)
119 S $E(TEXT,TAB)="",TEXT=TEXT_TTEXT
120 D A1 ; Line #1
121 S Y=$P(DATA,U,2) ; START DATE
122 D DD^%DT
123 S STDAT=Y
124 S (EDAT,Y)=$P(DATA,U,3) ; END DATE
125 D DD^%DT
126 S ENDDAT=Y
127 ; Check for Termination
128 S (TDAT,Y)=+$G(^PRST(458.7,MIEN,4))
129 D DD^%DT
130 S TDATEX=Y ; Termination Date External
131 S AHRS=$P(DATA,U,4) ; AGREED HOURS
132 S COHRS=$P(DATA,U,9) ; CARRYOVER HOURS
133 S HRSCO=$G(HRSCO,0) ; HRS CARRIED OVER FROM PRIOR MEMO
134 S NPHRS=$P(DATA,U,12) ; NON-PAY HOURS
135 S WPHRS=$P(DATA,U,13) ; WITHOUT PAY HOURS
136 S THRSWK=0.00 ; TOTAL HOURS WORKED
137 S POMC=0.00 ; PERCENTAGE OF MEMORANDA COMPLETED
138 S POHC=0.00 ; PERCENTAGE OF HOURS COMPLETED
139 S AHTCM=0.00 ; AVERAGE HOURS TO COMPLETE MEMORANDUM
140 S POT=0.00 ; % OFF TARGET
141 S OTHRS=0.00 ; OFF TARGET HOURS
142 S HRSWK=0.00 ; HRS TOTAL FROM WORKED PAY PERIODS
143 ;
144 S $E(TEXT,2)="",TEXT=TEXT_"Start Date: "_STDAT
145 S $E(TEXT,29,31)="| ",TEXT=TEXT_"Agreed Hours: "_$J(AHRS,7,2)
146 S $E(TEXT,55,57)="| ",TEXT=TEXT_" LWOP Hrs: "_$J(WPHRS,7,2)
147 D A1 ; Line #2
148 ;
149 S LPPP=$$MEMCPP^PRSPUT3(MIEN)
150 S PPP=$P(LPPP,U,2),LPPP=$P(LPPP,U,1)
151 ; Check to see if last PP certified in #458 is in #459
152 I LPPP'="",'$D(^PRST(459,"B",LPPP)) S PPP=PPP-1
153 ; Loop to determine the total hours worked from multiple
154 F I=1:1:PPP D
155 . S HRSWK=HRSWK+$$GET1^DIQ(458.701,I_","_MIEN_",",1)
156 S THRSWK=HRSWK+COHRS+HRSCO ; Adjust for carryover hours
157 ; Hrs That Should Have Been Worked - has any NP and WP included
158 S HTSHBW=((AHRS/26)*PPP)-NPHRS-WPHRS
159 S OTHRS=THRSWK-HTSHBW
160 S POHC=THRSWK/(AHRS-NPHRS-WPHRS)*100 ; Adjust % or Hrs Completed
161 ; Only calculate the following if memo has started and not ended
162 I PPP,PPP<26 D
163 . I HTSHBW'=THRSWK D ; PTP has worked more or less than Ave Hrs/PP
164 . . I THRSWK'<(AHRS-NPHRS-WPHRS) S AHTCM=0
165 . . I THRSWK<(AHRS-NPHRS-WPHRS) S AHTCM=AHRS-THRSWK-NPHRS-WPHRS/(26-PPP)
166 . . S POT=(AHRS/26*PPP)-WPHRS-NPHRS
167 . . S POT=THRSWK-POT/POT,POT=POT*100
168 . I HTSHBW=THRSWK D ; PTP has worked exactly Ave Hrs/PP
169 . . S AHTCM=AHRS-THRSWK-WPHRS-NPHRS/(26-PPP)
170 . . S POT=0
171 I PPP=26 D ; Memo has ended
172 . S AHTCM=0
173 . S POT=(AHRS/26*PPP)-WPHRS-NPHRS
174 . S POT=THRSWK-POT/POT,POT=POT*100
175 I PPP=0 D ; 1st PP hasn't been processed
176 . S AHTCM=AHRS-COHRS/26
177 . S POT=0
178 I TDAT D
179 . S $E(TEXT,2)="",TEXT=TEXT_"TERMINATED: "_TDATEX
180 I TDAT=0 S $E(TEXT,4)="",TEXT=TEXT_"End Date: "_ENDDAT
181 S $E(TEXT,29,31)="| ",TEXT=TEXT_"Hours Worked: "_$J(HRSWK,7,2)
182 S $E(TEXT,55,57)="| ",TEXT=TEXT_" Non Pay Hrs: "_$J(NPHRS,7,2)
183 D A1 ; Line #3
184 ;
185 S POMC=PPP_" of 26 PP = "_$J(100*(PPP/26),6,2)_"%"
186 I PPP<10 S $E(TEXT,6)="",TEXT=TEXT_POMC
187 I PPP>9 S $E(TEXT,5)="",TEXT=TEXT_POMC
188 S $E(TEXT,29,30)="| "
189 S TEXT=TEXT_"Carryover Hrs: "_$J($S(HRSCO:HRSCO,1:COHRS),7,2)
190 S $E(TEXT,55,57)="| ",TEXT=TEXT_"Off Target Hrs: "_$J(OTHRS,7,2)
191 D A1 ; Line #4
192 ;
193 S TEXT="% Hrs Completed = "_$J(POHC,6,2)_"%"
194 S $E(TEXT,29,31)="| ",TEXT=TEXT_" Total Hrs: "
195 S TEXT=TEXT_$J(THRSWK,7,2)
196 S $E(TEXT,55,57)="| ",TEXT=TEXT_" Off Target %: "_$J(POT,7,2)
197 D A1 ; Line #5
198 ;
199 I PPP<26 D
200 . S TEXT=(AHRS-NPHRS-WPHRS)-THRSWK,TEXT=TEXT/(26-PPP)
201 . S TEXT=$FN(TEXT,"",2)
202 . S TEXT=" Agreement will be met by averaging "_TEXT
203 . S TEXT=TEXT_" Hrs/PP during remainder of memo."
204 ;
205 I PPP=26 D
206 . S $E(TEXT,30)="",TEXT=TEXT_"This memorandum has ended"
207 ;
208 I TDAT D
209 . I LPPP'="" D
210 . . S LPPP=$O(^PRST(458,"B",LPPP,0))
211 . . S LPPP=$P($G(^PRST(458,LPPP,1)),U,14)
212 . . I TDAT'>LPPP D Q
213 . . . S TEXT="",$E(TEXT,30)="",TEXT=TEXT_"This memorandum has ended"
214 ;
215 D A1 ; Line #6
216 K INDEX,Y
217 Q
218 ;
219A1 ; Set TEXT into the array
220 ;
221 N A1
222 W !,TEXT
223 I $G(ARRAY)'="" D
224 . S A1="S "_ARRAY_INDEX_")="_""""_TEXT_""""
225 . X A1
226 . S INDEX=INDEX+1
227 S TEXT=""
228 Q
229 ;
230INDEX ; Get last index in array if not passed in
231 ;
232 S INDEX="S INDEX=$O("_ARRAY_"""A""),-1)"
233 X INDEX
234 I 'INDEX S INDEX=1 Q
235 I INDEX S INDEX=INDEX+1
236 Q
Note: See TracBrowser for help on using the repository browser.