source: WorldVistAEHR/trunk/r/PAID-PRS/PRSPESR.m@ 949

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

initial load of WorldVistAEHR
File size: 7.4 KB
Line 
1PRSPESR ;WOIFO/JAH - part-time physicians ESR Edit ;11/16/04
2 ;;4.0;PAID;**93**;Sep 21, 1995;Build 7
3 ;;Per VHA Directive 2004-038, this routine should not be modified.
4 ;
5 ;Allow PTP employee w/ a memorandum to review memo status
6 ;then edit, update, and sign daily ESRs.
7 ;call from option-"Electronic Subsidiary Record".
8 Q
9 ;
10MAIN ; main entry point called from ESR edit option
11 N PICKLIST,PRSIEN,OUT,PLIST,PICK
12 ;
13 ;get users PRSIEN
14 S PRSIEN=$$PRSIEN^PRSPUT2(1)
15 Q:PRSIEN'>0
16 ;
17 ;While PTP is not done continue
18 ;
19 S OUT=0
20 F D Q:OUT
21 .; BUILD OPTION PICK LIST--MEMO ACTIONS, PRIOR, CURRENT AND NEXT PP ESRs
22 .;
23 .;
24 . K PLIST
25 . D BLDPICK(.PLIST,PRSIEN)
26 .;
27 . W @IOF,!
28 .; get out if there's nothing in the list.
29 . I '$D(PLIST) D Q
30 .. W !,"No ESR records available.",!!!
31 .. S OUT=$$ASK^PRSLIB00(1)
32 .. S OUT=1
33 .; get users choice of action
34 . S PICK=$$CHOICE(.PLIST)
35 . I PICK=0 S OUT=1 Q
36 . I $P(PLIST(PICK),U)="M" D MEMO(PRSIEN,PLIST(PICK)) ;### CALL MEMO OPTION
37 . I "NCP"[$P(PLIST(PICK),U) D
38 .. ;Make sure we have a signature code before continuing
39 .. I '$$ESIGC^PRSPUT2(1) W !! S OUT=$$ASK^PRSLIB00(1) Q
40 .. ;
41 .. D ESR(PRSIEN,$P(PLIST(PICK),U,2),$P(PLIST(PICK),U,3),.OUT)
42 ;
43 Q
44BLDPICK(PL,PRSIEN) ; Build option pick list with memo, prior ESR,
45 ; current ESR and next ESR actions in the PL array
46 ;PPE,I - current Pay period (E)xternal (I)nternal entry #
47 ;NXPPE
48 ;PI - picklist counter/array subscript
49 ;MAI - memo action counter
50 ;AMIEN - active memo ien for a prior pay period
51 ;Get any actions required for Memorandum.
52 N PI,PPE,NXPPE,MIEN,MAI,PPDT1,AMIEN,MTXT,RANGE,FR,TO,PRTXT
53 S PI=0
54 ; get array of memos with status reconcile started
55 ; this may need to be replaced with API call ###
56 D GETMEMOS(.MIEN,PRSIEN,3)
57 I $G(MIEN(0))>0 D
58 . S MAI=0
59 . F S MAI=$O(MIEN(MAI)) Q:MAI'>0 D
60 .. Q:$P($G(^PRST(458.7,MAI,2)),U)>0
61 .. S PI=PI+1,PL(PI)=$$BLDMACT(MAI,MIEN(MAI))
62 ;
63 ;Travel ESR status xref (<4) )for incomplete ESR days
64 ;
65 S PRTXT="Edit ESR for PRIOR pay period "
66 S PPE=""
67 F S PPE=$O(^PRST(458,"AEA",PRSIEN,PPE)) Q:PPE="" D
68 . S PPI=$O(^PRST(458,"B",PPE,0))
69 . Q:PPI'>0
70 .;### call to active memo API to determine if pp should be edited
71 .; Get 1st day of pp
72 . D NX^PRSAPPU S PPDT1=D1
73 . S AMIEN=+$$MIEN^PRSPUT1(PRSIEN,PPDT1)
74 . I AMIEN>0 D
75 .. S PI=PI+1
76 .. S RANGE=$G(^PRST(458,PPI,2))
77 .. S FR=$P(RANGE,U,1),TO=$P(RANGE,U,14)
78 .. S MTXT=PRTXT_PPE_" ["_FR_" - "_TO_"]"
79 .. S PL(PI)="P^"_PPI_"^"_AMIEN_U_MTXT
80 ;
81 ; current pay period to list, overwrite PI array if current
82 ; pay period is also a prior pay period selection already
83 N PPE,PPI,PP4Y,DAY,D1,PPDT1,AMIEN,OVRITE
84 S (PPDT1,D1)=DT D PP^PRSAPPU
85 I PPI'="" D
86 . S OVRITE=$$PPICHK(.PL,PPI)
87 . I OVRITE>0 S PI=OVRITE
88 . E S PI=PI+1
89 . S AMIEN=+$$MIEN^PRSPUT1(PRSIEN,PPDT1)
90 . I AMIEN>0 D
91 .. S RANGE=$G(^PRST(458,PPI,2))
92 .. S FR=$P(RANGE,U,1),TO=$P(RANGE,U,14)
93 .. S MTXT="Edit ESR for CURRENT pay period "_PPE_" ["_FR_" - "_TO_"]"
94 .. S PL(PI)="C^"_PPI_U_AMIEN_U_MTXT
95 ;
96 ; add next pay period to list if open and covered by memo
97 S PPE=$E($$NXTPP^PRSAPPU(PPE),3,7)
98 D NX^PRSAPPU S PPDT1=D1
99 I $D(^PRST(458,"B",PPE)) D
100 . S PPI=$O(^PRST(458,"B",PPE,0))
101 . S AMIEN=+$$MIEN^PRSPUT1(PRSIEN,PPDT1)
102 . I AMIEN>0 D
103 .. S OVRITE=$$PPICHK(.PL,PPI)
104 .. I OVRITE>0 S PI=OVRITE
105 .. E S PI=PI+1
106 .. S RANGE=$G(^PRST(458,PPI,2))
107 .. S FR=$P(RANGE,U,1),TO=$P(RANGE,U,14)
108 .. S MTXT="Edit ESR for NEXT pay period "_PPE_" ["_FR_" - "_TO_"]"
109 .. S PL(PI)="N^"_PPI_"^"_AMIEN_U_MTXT
110 ;
111 Q
112 ;
113PPICHK(PRIARY,PPCH) ; Check if Current or next is already in prior array
114 ; RETURN PPI IF FOUND
115 N FOUND,PRNODE
116 S FOUND=0,PRNODE=99
117 F S PRNODE=$O(PRIARY(PRNODE),-1) Q:(PRNODE'>0)!(FOUND>0) D
118 . I PPCH=$P($G(PRIARY(PRNODE)),U,2) S FOUND=PRNODE
119 Q FOUND
120 ;
121BLDMACT(MIEN,ZNODE) ;with zero node of memo build the item screen
122 ; Sample appearance for menu item
123 N SDT,EDT,TDT,Y,MENUTXT
124 S MENUTXT="M^"_MIEN_"^^Reconcile Prior Memorandum from "
125 ; Reconcile Prior Memorandum from JUL 2004 TO JUL 2005
126 S SDT=$P(ZNODE,U),EDT=$P(ZNODE,U,2),TDT=$P(ZNODE,U,3)
127 I $G(TDT)>0,($G(TDT)<$G(EDT)) S EDT=TDT
128 S Y=SDT D DD^%DT S SDT=Y
129 S Y=EDT D DD^%DT S EDT=Y
130 S MENUTXT=MENUTXT_SDT_" TO "_EDT
131 Q MENUTXT
132CHOICE(PL,DEF) ; return users choice from array of items in PL
133 ; return 0 for abort
134 N ITEM,ICNT,DIR,DIRUT
135 S ICNT=0
136 I $G(DEF)>0,($G(PL(DEF))'="") D
137 . S DIR("B")=DEF
138 S ITEM=0
139 F S ITEM=$O(PL(ITEM)) Q:ITEM'>0 D
140 . S DIR("A",ITEM)=ITEM_". "_$P($G(PL(ITEM)),U,4)
141 . S ICNT=ICNT+1
142 S DIR(0)="NO^1:"_ICNT_":0"
143 S DIR("A")="Select an Item "
144 D ^DIR
145 S PICK=+$G(Y)
146 I $G(DIRUT) S PICK=0
147 Q PICK
148 ;
149GETMEMOS(MIEN,PRSIEN,MSTAT) ; Return IEN subscripted array of
150 ; memorandums in a single status (MSTAT)
151 ; INPUT: EMPLOYEE IEN (PRSIEN)
152 ; STATUS OF MEMORANDUM desired (MSTAT)
153 ; 1:NOT STARTED; 2:ACTIVE; 3:RECONCILIATION STARTED;
154 ; 4:RECONCILED;
155 ; OUTPUT: returns MIEN array as follows:
156 ; MIEN(0) = 0 when no reconcile actions:
157 ; OR
158 ; MIEN(0) = integer # of memos that requires reconcile action:
159 ; MIEN(IEN 1)=start date^end date^termination date
160 ; MIEN(IEN n)=start date n ^end date n ^termination date n
161 N ZNODE,TDT,TMPMIEN
162 S MIEN(0)=0
163 Q:$G(MSTAT)'>0!($G(PRSIEN)'>0)
164 S TMPMIEN=0
165 F S TMPMIEN=$O(^PRST(458.7,"AST",PRSIEN,MSTAT,TMPMIEN)) Q:TMPMIEN'>0 D
166 . S ZNODE=$G(^PRST(458.7,TMPMIEN,0))
167 . S TDT=$P($G(^PRST(458.7,TMPMIEN,4)),U)
168 . S MIEN(TMPMIEN)=$P(ZNODE,U,2)_"^"_$P(ZNODE,U,3)_"^"_TDT
169 . S MIEN(0)=MIEN(0)+1
170 Q
171 ;
172MEMO(PRSIEN,LIST) ; CALL OPTION TO RECONCILE A MEMO
173 ;INPUT : PRSIEN-user 450 ien, LIST-pick list array item for memo
174 N OUT,MIEN
175 S MIEN=$P(LIST,U,2)
176 D MAIN^PRSPSRC(PRSIEN,MIEN)
177 S OUT=$$ASK^PRSLIB00()
178 Q
179ESR(PRSIEN,PPI,MIEN,OUT) ; DISPLAY PAY PERIOD AND ASK USER TO PICK A DAY
180 ; WHEN THEY PICK A DAY CALL code to start up a ScreenMan
181 ; form for the day record
182 N ESRDAY
183 S OUT=0
184 F D Q:(ESRDAY'>0)
185 . W @IOF
186 . D WSS(PRSIEN,PPI,MIEN)
187 . S ESRDAY=$$WHICHDAY(PPI,PRSIEN)
188 . I $$CANPOST(PPI,PRSIEN,ESRDAY,1) D ESRFRM^PRSPESR1(PRSIEN,PPI,ESRDAY)
189 I ESRDAY<0 S OUT=1
190 Q
191CANPOST(PPI,PRSIEN,PRSD,SHMSG) ; Can this day be posted by a PTP?
192 ; i show message set to 1 then show message on can't post
193 N CANPOST
194 S CANPOST=0
195 Q:$G(PRSD)'>0 CANPOST
196 N TCSTAT,DUM,ESRSTAT,TCSTAT,TOUR
197 S CANPOST=1
198 ;
199 S TOUR=$P($G(^PRST(458,PPI,"E",PRSIEN,"D",PRSD,0)),U,2)
200 I TOUR'>0 S CANPOST=0 D Q CANPOST
201 . I 'CANPOST&($G(SHMSG)>0) D
202 .. W @IOF,!!!,"A Tour of Duty must be entered first. Please contact your timekeeper.",!!
203 .. S DUM=$$ASK^PRSLIB00(1)
204 ;
205 S ESRSTAT=$$GETSTAT^PRSPESR1(PRSIEN,PPI,PRSD)
206 S TCSTAT=$$TCSTAT^PRSPSAP2(PPI,PRSIEN)
207 I TCSTAT'="T" S CANPOST=(ESRSTAT<5) D
208 . I 'CANPOST&($G(SHMSG)>0) D
209 .. W @IOF,!!!,"Only select days with status 'Not Started, 'Pending', 'Signed', or 'Resubmit'."
210 .. W !,"To edit approved days or days off, contact your Time and Leave Supervisor.",!!
211 .. S DUM=$$ASK^PRSLIB00(1)
212 Q CANPOST
213 ;
214WSS(PRSIEN,PPI,MIEN) ; WORK SUMMARY SCREEN
215 N SCRTTL
216 S SCRTTL="Work Summary Screen for Part Time VA Physician "
217 D HDR^PRSPUT1(PRSIEN,SCRTTL,,,PPI)
218 D MEM^PRSPUT1(PRSIEN,MIEN)
219 D AL^PRSPUT3(PRSIEN,)
220 D ESRSTAT^PRSPUT2(PRSIEN,PPI)
221 Q
222WHICHDAY(PPI,PRSIEN,DEF) ; ASK USER TO SELECT A PAY PERIOD DAY
223 ; return 0 for abort OR -1 for double abort "^^"
224 N DIR,DIRUT,TCSTAT,I
225 S DIR(0)="NO^1:14:0"
226 I $G(DEF)>0 S DIR("B")=DEF
227 S DIR("A")="Select day "
228 D ^DIR
229 I $G(DIRUT) D
230 . S PICK=$S($G(Y)["^^":-1,1:0)
231 E D
232 . S PICK=$G(Y)
233 Q PICK
234 Q
Note: See TracBrowser for help on using the repository browser.