source: FOIAVistA/trunk/r/PAID-PRS/PRSPSAPU.m@ 1446

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

initial load of FOIAVistA 6/30/08 version
File size: 6.7 KB
Line 
1PRSPSAPU ;WOIFO/JAH - PT Physician, supervisor approval utils ;01/22/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
5ONEPTP(TLE) ; get one or all ptp's from a TLE
6 ; if the selection hasn't a memo or hasn't an ESR to be approved
7 ; then inform and re-ask
8 ;
9 ; return PRSIEN for successful PTP selection
10 ; return 0 for all PTP's in T&L
11 ; return -1 for abort/timeout
12 ;
13 N ALL,PTP,OUT
14 S (PTP,ALL,OUT)=0
15 F D Q:(OUT!(PTP>0)!(ALL))
16 . S PTP=$$ALL1PTP(TLE)
17 . I PTP=0 S ALL=1 Q ; all ptp's were selected
18 . I PTP<0 S OUT=1 Q ; user uparrow or timeout
19 . I PTP>0,'$D(^PRST(458.7,"B",PTP)) W !!,"There are no Service Level Memoranda on file for ",$P(^PRSPC(PTP,0),U) S PTP=0
20 . I PTP>0,'$D(^PRST(458,"ASA",PTP)) W !!,"There are no daily ESR's pending approval for ",$P(^PRSPC(PTP,0),U) S PTP=0
21 I ALL S PTP=0
22 I OUT S PTP=-1
23 Q PTP
24 ;
25ALL1PTP(TLE) ; ask for one part time physician from a TLE or ALL
26 Q:TLE'>0
27 N DIC,PRSIEN,D,Y,DUOUT,DTOUT
28 S PRSIEN=""
29 S DIC("A")="Select an EMPLOYEE or press RETURN for ALL: "
30 S DIC(0)="AEQM"
31 S DIC="^PRSPC("
32 S DIC("S")="I $P(^(0),""^"",8)=TLE"
33 ; start look up with ATL xref
34 S D="ATL"_TLE
35 W !
36 D IX^DIC
37 ;
38 ; user hit return for all (return 0)
39 I Y=-1,'($D(DUOUT)!$D(DTOUT)) D
40 . S PRSIEN=0
41 E D
42 . S PRSIEN=+Y
43 Q PRSIEN
44 ;
45UPESRST(PPI,PRSIEN,PRSD) ;update ESR DAILY STATUS
46 N DIE,DR,DA
47 S DA(2)=$G(PPI),DA(1)=$G(PRSIEN),DA=$G(PRSD)
48 S DR="146///SIGNED;149///MANUAL POST"
49 S DIE="^PRST(458,"_DA(2)_",""E"","_DA(1)_",""D"","
50 D ^DIE
51 Q
52ESRDTS(ESRDTS,PRSIEN,PPI) ; Return signed dates from PTP's ESR
53 ; return array ESRDTS subscripted sequentially from 1
54 ; ESRDTS(1) = Tue 2-NOV-04
55 ; ESRDTS(2) = Fri 5-NOV-04
56 N PRSD,ITEMS,PRSDTS
57 S PRSDTS=$G(^PRST(458,PPI,2))
58 S (PRSD,ITEMS)=0
59 F S PRSD=$O(^TMP($J,"PRSPSAP",PRSIEN,PPI,PRSD)) Q:PRSD'>0 D
60 . S ITEMS=ITEMS+1
61 . S ESRDTS(ITEMS)=PRSD_U_$P(PRSDTS,U,PRSD)
62 Q
63DISPLAY(PRSIEN,PPI,CNT) ;display PPI signed esr days for super review/action
64 ; RETURN array CNT
65 ; CNT = count of days
66 ; CNT(1)= days w/status from supervisor during this option
67 ; PGLNS = lines on current page
68 ; DYLNS = lines in a day
69 ;
70 N I,PRSD,ESRDTS,ESEG,ESR,PGLNS,DAYLNS,OUT
71 D HDRESR^PRSPSAP1(PRSIEN,PPI,.PGLNS)
72 ;
73 D ESRDTS^PRSPSAPU(.ESRDTS,PRSIEN,PPI)
74 S (PRSD,CNT,CNT(1),OUT)=0
75 F S PRSD=$O(^TMP($J,"PRSPSAP",PRSIEN,PPI,PRSD)) Q:PRSD'>0!(OUT) D
76 . I $Y>(IOSL-6) S OUT=$$ASK^PRSLIB00() D HDRESR^PRSPSAP1(PRSIEN,PPI,.PGLNS)
77 . Q:OUT
78 . D GETESR^PRSPSAP1(.ESR,PPI,PRSIEN,PRSD)
79 . S CNT=CNT+1
80 . W !,CNT
81 . D DAY(.DAYLNS,ESRDTS(CNT),.ESR,PRSIEN,PPI)
82 . S PGLNS=PGLNS+DAYLNS
83 Q
84 ;
85DAY(LN,EXTDAY,ESR,PRSIEN,PPI) ; write a day, return # of lines.
86 N STE,ESEG,REMARKS,START,STOP,MEAL,HOURS,STATUSI,LCNT
87 S LN=0
88 S HOURS=""
89 W ?3,$P(EXTDAY,U,2)
90 W ?17,ESR("TODEXT")
91 ; if tour is too wide for column move down a line
92 I $L(ESR("TODEXT"))>16 W ! S LN=LN+1
93 ;
94 F ESEG=1:5:31 Q:($P(ESR("WORK"),U,ESEG)="") D
95 . I ESEG>1 W !
96 .; start
97 . S START=$P(ESR("WORK"),U,ESEG)
98 . S STOP=$P(ESR("WORK"),U,ESEG+1)
99 . S MEAL=$P(ESR("WORK"),U,ESEG+4)
100 . W ?33,START
101 . I START'["No work:" D
102 .. W "-"
103 .. S HOURS=$$ELAPSE^PRSPESR2(MEAL,START,STOP)
104 .; stop
105 . W STOP
106 .; type of time
107 . W ?49,$$TTE($P(ESR("WORK"),U,ESEG+2))
108 .; remarks - use 458.02 to convert to external
109 . S REMARKS=$P(ESR("WORK"),U,ESEG+3)
110 . I REMARKS>0 D
111 .. S LN=LN+1
112 .. W !,?34,"Remarks: ",$$EXTERNAL^DILFD(458.02,44,"",REMARKS)
113 .; hours and meal
114 . W ?61,HOURS,?68,MEAL
115 ; display PTP remarks (if any)
116 I ESR("RMK")]"" D
117 . W !,?2,"Physician Remarks: "
118 . D WRAP(.LCNT,ESR("RMK"),21,66)
119 . S LN=LN+LCNT
120 S STATUSI=$G(^TMP($J,"PRSPSAP",PRSIEN,PPI,+EXTDAY,1))
121 W ?72,$$STATUSE(STATUSI)
122 Q
123GETDAY(ESRDY,ESRDTS,ESR,CNT,PRSIEN,PPI) ; RETURN write a day IN ESRDY ARRAY
124 N BLANKS,LN,ESEG,START
125 S LN=1
126 S BLANKS=" "
127 S ESRDY(LN)=" "_$P(ESRDTS(CNT),U,2)
128 S ESRDY(LN)=$E(ESRDY(LN)_BLANKS,1,18)_ESR("TODEXT")
129 ; if tour is too wide for the column move down a line for the work
130 I $L(ESR("TODEXT"))>16 S LN=LN+1,ESRDY(LN)=""
131 ;
132 F ESEG=1:5:31 Q:($P(ESR("WORK"),U,ESEG)="") D
133 . I ESEG>1 W !
134 .; start
135 . S START=$P(ESR("WORK"),U,ESEG)
136 . S ESRDY(LN)=$E(ESRDY(LN)_BLANKS,1,35)_START
137 . I START'["No work-signed by" S ESRDY(LN)=ESRDY(LN)_"-"
138 .; stop
139 . S ESRDY(LN)=ESRDY(LN)_$P(ESR("WORK"),U,ESEG+1)
140 .; type of time
141 . S ESRDY(LN)=$E(ESRDY(LN)_BLANKS,1,51)_$$TTE($P(ESR("WORK"),U,ESEG+2))
142 .; remarks
143 . S ESRDY(LN)=$E(ESRDY(LN)_BLANKS,1,54)_$P(ESR("WORK"),U,ESEG+3)
144 .; meal
145 . S ESRDY(LN)=$E(ESRDY(LN)_BLANKS,1,68)_$P(ESR("WORK"),U,ESEG+4)
146 . S ST=$$STATUSE($G(^TMP($J,"PRSPSAP",PRSIEN,PPI,+ESRDTS(CNT),1)))
147 . S ESRDY(LN)=$E(ESRDY(LN),1,71)_ST
148 . S LN=LN+1,ESRDY(LN)=""
149 Q
150 ;
151TTE(CODE) ; return external type of time
152 N K
153 Q:$G(CODE)="" CODE
154 S K=$O(^PRST(457.3,"B",CODE,0))
155 Q $P($G(^PRST(457.3,+K,0)),"^",2)
156 ;
157STATUSE(ST) ; return external form of supervisor action status
158 S ST=$G(ST)
159 Q $S(ST="B":"Bypass",ST="R":"Resubmit",ST="A":"Approved",1:"")
160 ;
161CLRTCDY(PPI,PRSIEN,PRSD,EST) ;function true (1) for success otherwise 0
162 ; clear a timecard day (2,3,10 nodes) if status is (T) timekeeper
163 ; clear work, posting status and remove approved status from ESR day.
164 ; INPUT: PPI,PRSIEN,PRSD: package standard
165 ; EST : optional, valid ESR DAILY STATUS internal value
166 ;
167 Q:($G(PPI)'>0)!($G(PRSIEN)'>0)!($G(PRSD)'>0) 0
168 Q:'$D(^PRST(458,PPI,"E",PRSIEN,"D",PRSD,0)) 0
169 N TCSTAT
170 S TCSTAT=$$TCSTAT^PRSPSAP2(PPI,PRSIEN)
171 Q:$G(TCSTAT)'="T" 0
172 ;
173 ; kill the timecard work nodes
174 K ^PRST(458,PPI,"E",PRSIEN,"D",PRSD,2),^(3),^(10)
175 ;
176 ; ONLY if a valid ESR daily status is passed then set it
177 N VALID
178 D CHK^DIE(458.02,146,"",$G(EST),.VALID)
179 Q:VALID["^" 1
180 ;
181 N IENS,PRSFDA
182 S IENS=PRSD_","_PRSIEN_","_PPI_","
183 S PRSFDA(458.02,IENS,146)=EST
184 D FILE^DIE("","PRSFDA")
185 D MSG^DIALOG()
186 Q 1
187 ;
188WRAP(LNS,STR,TAB,WID) ; format a long message string to break lines at words
189 ; TAB is left margin
190 ; WID is right margin
191 ; return LNS number of lines it took to write
192 N WORD,I,WC,COLW,W1,W2
193 S WC=0,WORD=""
194 S COLW=WID-TAB+1
195 W ?$G(TAB)
196 S LNS=1
197 F I=1:1:$L(STR," ") D
198 . S WORD=$P(STR," ",I)
199 . Q:WORD=""
200 .; break words longer than the width of the column
201 . F Q:($L(WORD)<(COLW+1)) D
202 .. S W1=$E(WORD,1,COLW-1)_"-"
203 .. S W2=$E(WORD,COLW,$L(WORD))
204 .. S WORD=W1 D WW
205 .. S WORD=W2
206 . D WW
207 Q
208WW ; Write Word
209 I ($X+$L(WORD))>WID D
210 . I WC>0 W !,?$G(TAB) S LNS=LNS+1,WC=0
211 W WORD," " S WC=WC+1
212 Q
213 ;
214 ;
215 ;===============================================================
216 ;
217AMT(START,STOP,MEAL) ; return decimal hours between times
218 ; times are in PAID timecard work node format. (e.g. 04:30P )
219 N AMT,X
220 S AMT=$$ELAPSE^PRSPESR2(MEAL,START,STOP)
221 S X=$P(AMT,":",2) S X=$S(X=30:5,X=15:25,X=45:75,1:0)
222 S AMT=+$P(AMT,":",1)_"."_X
223 Q AMT
Note: See TracBrowser for help on using the repository browser.