Changeset 623 for WorldVistAEHR/trunk/r/PAID-PRS/PRSPUT3.m
- Timestamp:
- Dec 4, 2009, 12:11:15 AM (14 years ago)
- File:
-
- 1 edited
-
WorldVistAEHR/trunk/r/PAID-PRS/PRSPUT3.m (modified) (1 diff)
Legend:
- Unmodified
- Added
- Removed
-
WorldVistAEHR/trunk/r/PAID-PRS/PRSPUT3.m
r613 r623 1 PRSPUT3 ;WOIFO/MGD,JAH - PART TIME PHYSICIAN UTILITIES #1 ;03/23/072 ;;4.0;PAID;**93,112**;Sep 21, 1995;Build 54 3 4 5 6 7 PTP(PRSIEN) 8 9 10 11 12 13 14 15 16 17 18 19 20 AL(PRSIEN,ARRAY,INDEX) 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 GETACCRU(PRSIEN,EOLYD,LDP) 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 GETLOSE(APALHRS,ALBAL,ACCRUAL,MAXOVER) 85 86 87 88 89 GETLDOYR() 90 91 92 93 94 95 96 97 98 GETAPALH(PRSIEN,PPPIN,EOLYD) 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 ESRUPDT(PPI,PRSIEN,DAY) 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 MEMCPP(MIEN) 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 PP8BAMT(PPAMT,PPI,PRSIEN) 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 GET8B(PPI,PRSIEN) 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 CORRECT(PPI,PRSIEN) 231 232 233 234 235 236 237 238 239 240 EXTR8BT(S,T) 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 WKTT(T,TA,WK) 257 258 259 260 261 262 263 264 265 266 267 268 269 270 S CHKLN=$P($T(@(TCH1)+0^PRS8VW2),";;",2)271 272 273 274 275 276 277 278 279 280 281 1 PRSPUT3 ;WOIFO/MGD,JAH - PART TIME PHYSICIAN UTILITIES #1 ;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 ; 5 ;Utilities for Part Time Physician patch PRS*4.0*93. 6 ; 7 PTP(PRSIEN) ;Check for potential PTP (has a memo on file) 8 ; input PRSIEN = employee IEN (file 450) 9 ; result = 1 or 0, true (1) if employee has any memos on file 10 Q $S($O(^PRST(458.7,"B",PRSIEN,0)):1,1:0) 11 ; 12 ;----------------------------------------------------------------------- 13 ; Display PTP AL info 14 ; Input: PRSIEN - IEN of PT Physician 15 ; ARRAY - Array where leave info is stored. (Optional) If not 16 ; specified, no array is created. 17 ; INDEX - Index to start array. (optional) set to 1 if not spec 18 ; Output: 2 line summary-current AL bal, fut reqs and potential loss. 19 ;----------------------------------------------------------------------- 20 AL(PRSIEN,ARRAY,INDEX) ; 21 Q:'PRSIEN 22 I $G(INDEX)="",($G(ARRAY)'="") D INDEX^PRSPUT1 23 N AINC,ALBAL,ALTBL,APALHRS,EOLYD,LVG,TEXT,X,X1,X2,Y,MAYLOSE,LDPINV 24 ; 25 ; Max Carryover 26 S MAXOVER=240 27 ; 28 ; current AL bal 29 S ALBAL=$P($G(^PRSPC(PRSIEN,"ANNUAL")),U,3) 30 ; 31 ; last day of curr leave yr 32 S EOLYD=$$GETLDOYR() 33 ; 34 ; last day proc from 459 & inverse 35 S LDP=$P($G(^PRST(458,$O(^PRST(458,"AB",$O(^PRST(459,"AB",""),-1),0)),1)),U,14) 36 S LDPINV=9999999-LDP 37 ; 38 ; future al approved (ranges from LastDayProcessed459-EndOfLeaveYear) 39 ; This is an estimate since we count all hrs for reqs that begin in 40 ; the current yr but cross into next 41 S APALHRS=$$GETAPALH(PRSIEN,LDPINV,EOLYD) 42 ; 43 ; accrual from last pp proc to EOY 44 S ACCRUAL=$$GETACCRU(PRSIEN,EOLYD,LDP) 45 ; 46 ; potential loss 47 S MAYLOSE=$$GETLOSE(APALHRS,ALBAL,ACCRUAL,MAXOVER) 48 ; 49 ; Display 50 S TEXT="" 51 D A1^PRSPUT1 ; Blank line 52 S TEXT="AL Bal: "_$J(ALBAL,6,2) 53 S $E(TEXT,17)="",TEXT=TEXT_"Approved future AL thru Leave Year: " 54 S TEXT=TEXT_$J(APALHRS,6,2) 55 S $E(TEXT,60)="",TEXT=TEXT_"Max carryover: "_MAXOVER 56 D A1^PRSPUT1 ; Line #1 57 S Y=EOLYD 58 D DD^%DT 59 S TEXT="Potential AL hours to be lost by "_Y_" excluding Approved AL: " 60 S TEXT=TEXT_MAYLOSE 61 D A1^PRSPUT1 ; Line #2 62 K INDEX 63 Q 64 ; 65 GETACCRU(PRSIEN,EOLYD,LDP) ; Calculate AL accrucal from last day of 66 ; pp processed in 459 (LDP) to end of leave year (EOLYD) 67 ; 68 N CO,LVG,NH,DB,AINC,X1,X2,INC 69 ; 70 S C0=$G(^PRSPC(PRSIEN,0)),LVG=$P(C0,"^",15),NH=+$P(C0,"^",16) 71 S DB=$P(C0,"^",10),AINC="" 72 Q:LVG'?1N!("123"'[LVG) 0 73 I LVG=1 D ; Leave Group 1 74 . S AINC=$S(DB=1:4,1:NH+AINC/20\1) 75 I LVG=2 D ; Leave Group 2 76 . S AINC=$S(DB=1:6,1:NH+AINC/13\1) 77 I LVG=3 D ; Leave Group 3 78 . S AINC=$S(DB=1:8,1:NH+AINC/10\1) 79 S X1=EOLYD,X2=LDP 80 D ^%DTC 81 S INC=X+13\14*AINC 82 Q INC 83 ; 84 GETLOSE(APALHRS,ALBAL,ACCRUAL,MAXOVER) ; Calculate potential hours to be lost 85 N ALTBL 86 S ALTBL=ALBAL+ACCRUAL-MAXOVER-APALHRS 87 Q $S(ALTBL<0:0,1:ALTBL) 88 ; 89 GETLDOYR() ; Calculate last day of the last pp of current year (EOLY) 90 N X,I,X1,X2,NEXTYR,PRSYRDT 91 S PRSYRDT=$P($T(DAT^PRSAPPU),";;",2) 92 F I=1:1 S NEXTYR=$P(PRSYRDT,",",I) Q:NEXTYR>DT!(NEXTYR="") 93 I NEXTYR="" Q DT 94 S X1=NEXTYR,X2=-1 95 D C^%DTC 96 Q X 97 ; 98 GETAPALH(PRSIEN,PPPIN,EOLYD) ; Approved AL hrs 99 ; 100 N APALHRS,EOLYDINV,LREND,LRIEN,LRSTRT,LRDATA 101 ; 102 S APALHRS=0 ; COUNTER-APproved Annual Leave HouR 103 S EOLYDINV=9999999-EOLYD 104 ; 105 ; use inverse dt to loop chrono from future requests to recent ones 106 ; Quit when end date hits last proc pp. Don't include canceled & other 107 ; leave type reqs from AD index. 108 ; 109 S LREND=0 110 F S LREND=$O(^PRST(458.1,"AD",PRSIEN,LREND)) Q:(LREND'>0)!(LREND>PPPIN) D 111 . S LRIEN=0 112 . F S LRIEN=$O(^PRST(458.1,"AD",PRSIEN,LREND,LRIEN)) Q:LRIEN'>0 D 113 . . S LRSTRT=^PRST(458.1,"AD",PRSIEN,LREND,LRIEN) 114 . . S LRSTRT=9999999-LRSTRT 115 . . ; 116 . . ; skip if lv doesn't start in range-last pp proc to EOLY 117 . . Q:LRSTRT'<PPPIN!(LRSTRT'>EOLYDINV) 118 . . ; skip if not AL or App 119 . . S LRDATA=$G(^PRST(458.1,LRIEN,0)) 120 . . Q:$P(LRDATA,U,7)'="AL"!($P(LRDATA,U,9)'="A") 121 . . S APALHRS=APALHRS+$P(LRDATA,U,15) 122 Q APALHRS 123 ; 124 ;----------------------------------------------------------------------- 125 ; Utility updates ESR Status and autopost any holidays 126 ; 127 ; Input: 128 ; PPI - The internal entry number of the PP 129 ; PRSIEN - The internal entry number of the PT Phy 130 ; DAY - (optional) If passed in the specific date (1-14) that 131 ; needs to be updated. If a specific date is not 132 ; passed in all 14 days will be reviewed and updated 133 ; as necessary. 134 ; 135 ; HOL and PDT need to be set by calling ^PRSAPPH prior to making this 136 ; call. 137 ; 138 ESRUPDT(PPI,PRSIEN,DAY) ; 139 ; 140 N END,HTOUR,IENS,MT,PRSFDA,START,STATUS,STOP,TOUR 141 S DAY=$G(DAY,"") 142 S START=$S(DAY:DAY,1:1) 143 S END=$S(DAY:DAY,1:14) 144 F DAY=START:1:END D 145 . S TOUR=$P($G(^PRST(458,PPI,"E",PRSIEN,"D",DAY,0)),U,2) 146 . S STATUS=$S(TOUR>1:1,1:6) 147 . S IENS=DAY_","_PRSIEN_","_PPI_"," 148 . K PRSFDA 149 . S PRSFDA(458.02,IENS,146)=STATUS 150 . I $D(HOL($P(PDT,U,DAY))) D 151 . . S HTOUR=$G(^PRST(458,PPI,"E",PRSIEN,"D",DAY,1)) 152 . . Q:HTOUR="" 153 . . S MT=$P($G(^PRST(458,PPI,"E",PRSIEN,"D",DAY,0)),U,2) 154 . . S MT=$P($G(^PRST(457.1,MT,0)),U,3) 155 . . F I=0:1:6 Q:$P(HTOUR,U,(3*I)+1)="" D 156 . . . S START=$P(HTOUR,U,(3*I)+1),STOP=$P(HTOUR,U,(3*I)+2) 157 . . . S PRSFDA(458.02,IENS,110+(5*I))=START 158 . . . S PRSFDA(458.02,IENS,111+(5*I))=STOP 159 . . . S PRSFDA(458.02,IENS,112+(5*I))="HX" 160 . . S PRSFDA(458.02,IENS,146)=4 ; ESR DAILY STATUS = SIGNED 161 . . S PRSFDA(458.02,IENS,101)="" ; Reset timecard status to unposted. 162 . . S PRSFDA(458.02,IENS,114)=MT ; Meal time for 1st segment 163 . . S PRSFDA(458.02,IENS,147)=$$NOW^XLFDT() ; Date/Time stamp 164 . . S PRSFDA(458.02,IENS,149)=4 ; ESR Signed by Holiday 165 . D UPDATE^DIE("","PRSFDA","IENS"),MSG^DIALOG() 166 Q 167 ; 168 MEMCPP(MIEN) ; Memo Certified PP 169 ; This utility determine the last certified PP and the number of 170 ; certified PPs for a given memo. 171 ; input 172 ; MIEN - internal entry number of a memo in file 458.7 173 ; returns a string value 174 ; = last certified PP (external value)^number of certified PPs 175 ; example "05-01^3" 176 ; 177 N LASTPP,MPPIEN,PPC,PRSX 178 I '$G(MIEN) Q "^" 179 ; 180 S LASTPP="" ; last PP 181 S PPC=0 ; pp counter 182 ; loop thru PPs in memo 183 S MPPIEN=0 F S MPPIEN=$O(^PRST(458.7,MIEN,9,MPPIEN)) Q:'MPPIEN D 184 . S PRSX=$G(^PRST(458.7,MIEN,9,MPPIEN,0)) 185 . Q:$P(PRSX,U,2)="" ; REG HOURS is null so PP never certified 186 . S LASTPP=$P(PRSX,U,1) 187 . S PPC=PPC+1 188 ; 189 Q LASTPP_"^"_PPC 190 ; 191 PP8BAMT(PPAMT,PPI,PRSIEN) ; array TIMEAMTS passed by reference 192 ; subscripted w/ types of time CODE and type of time activity 193 ; from PRS8VW2 table. This routine sets each node of TIMEAMTS array 194 ; to the total hours (week one and two) in the pp 195 ; for that type of time activity. 196 ; 197 ; SAMPLE CALL: 198 ; S TAMTS("WP","Leave Without Pay")="" D PP8BTOT(.TAMTS,PPI,PRSIEN) 199 ; 200 ; SAMPLE RETURN ARRAY 201 ; TAMTS("WP","Leave Without Pay")=12.5 202 ; 203 N TT,STR8B,TC,TA,WK1CD,WK2CD,AMT1,AMT2 204 S STR8B=$$GET8B(PPI,PRSIEN) 205 S TC="" 206 F S TC=$O(PPAMT(TC)) Q:TC="" D 207 . S TA="" 208 . F S TA=$O(PPAMT(TC,TA)) Q:TA="" D 209 .. S WK1CD=$$WKTT(TC,TA,1) 210 .. S WK2CD=$$WKTT(TC,TA,2) 211 .. S AMT1=$$EXTR8BT(STR8B,WK1CD) 212 .. S AMT2=$$EXTR8BT(STR8B,WK2CD) 213 .. S PPAMT(TC,TA)=AMT1+AMT2 214 Q 215 GET8B(PPI,PRSIEN) ; get 8b from 5 node unless corrected timecard 216 ; has been done then we need to recompute 8B 217 N S8B 218 I $$CORRECT(PPI,PRSIEN) D 219 . N DFN,PY,VAL 220 .; new variables used BY callers to this API because the decomp 221 .; kills everything in its path. 222 . N QT,PP,%,C0,CNT,CT,D,DAY,HDR,I,K,MEAL,SSN,ST,TT,TYP,X,X1,Y,Y1,Z,ML,Z0,Z1 223 . S DFN=PRSIEN 224 . S PY=PPI 225 . D ONE^PRS8 226 . S S8B=$E($G(VAL),33,999) 227 E D 228 . S S8B=$E($G(^PRST(458,PPI,"E",PRSIEN,5)),33,999) 229 Q S8B 230 CORRECT(PPI,PRSIEN) ; return true if any corrected timecards exist for 231 ;this emp's pp that were approved by the final level supr apprl 232 N CORRECT,STATUS,TCD 233 S CORRECT=0 234 Q:($G(PPI)'>0)!($G(PRSIEN)'>0) 235 S TCD=0 236 F S TCD=$O(^PRST(458,PPI,"E",PRSIEN,"X",TCD)) Q:TCD'>0!(CORRECT) D 237 . S STATUS=$P($G(^PRST(458,PPI,"E",PRSIEN,"X",TCD,0)),U,5) 238 . I STATUS="P"!(STATUS="S") S CORRECT=1 239 Q CORRECT 240 EXTR8BT(S,T) ; EXTRACT THE 8B TYPE OF TIME FROM THE STUB AND RETURN THE 241 ; AMOUNT OF TIME FROM WEEK ONE AND TWO FOR THIS TYPE OF TIME 242 ; INPUT: S-8B STUB 243 ; T-TYPE OF TIME TO FIND ^ LENGTH OF DATA IN 8B 244 N AMT,LEN,POS,QH,HRS 245 S AMT="0.0" 246 S POS=$F(S,$P(T,U)) 247 I POS D 248 . S LEN=$P(T,U,2) 249 . S AMT=$E(S,POS,POS-1+LEN) 250 . S HRS=+$E(AMT,1,LEN-1) 251 . S QH=+$E(AMT,LEN,LEN) 252 . S QH=$S(QH=1:".25",QH=2:".5",QH=3:".75",1:".0") 253 . S AMT=HRS_QH 254 Q AMT 255 ; 256 WKTT(T,TA,WK) ; GET 8B STRING TIMECODE FOR WEEK ONE OR TWO AND LENGTH OF 257 ; THE DATA IN THE 8B STRING 258 ; Input: 259 ; T- type of time code from file 457.3 260 ; TA-time activity from the table in PRS8VW2 (e.g. Leave Without Pay) 261 ; WK-1 or 2 for the desired timecode week 262 ; 263 S WK=$S($G(WK)=2:2,1:1) 264 Q:$G(T)="" 265 N TCH1,TTEXT,CHKLN,I,FOUND,E,TTABLE,CHUNK,TABLEI,WKTTCODE 266 S FOUND=0 267 ; 268 S TCH1=$E(T,1,1) 269 D E2^PRS8VW 270 S CHKLN=$P($T(@(TCH1)+0^PRS8VW1),";;",2) 271 F I=1:1:$L(CHKLN,"^") D Q:FOUND 272 . S CHUNK=$P(CHKLN,U,I) 273 . S TABLEI=$P(CHUNK,":",2) 274 . S WKTTCODE=TCH1_$P(CHUNK,":") 275 . S TTABLE=$P($T(TYP+TABLEI^PRS8VW2),";;",2) 276 . I TTABLE=TA,$F(E(WK),WKTTCODE) D 277 .. S FOUND=1 278 ..; When found in PRS8VW2 table return code and length 279 .. S WKTTCODE=WKTTCODE_U_$P(CHUNK,":",3) 280 I 'FOUND S WKTTCODE=0 281 Q WKTTCODE
Note:
See TracChangeset
for help on using the changeset viewer.
