282 lines
9.1 KiB
Mathematica
282 lines
9.1 KiB
Mathematica
PRSPUT3 ;WOIFO/MGD,JAH - PART TIME PHYSICIAN UTILITIES #1 ;03/23/07
|
|
;;4.0;PAID;**93,112**;Sep 21, 1995;Build 54
|
|
;;Per VHA Directive 2004-038, this routine should not be modified.
|
|
;
|
|
;Utilities for Part Time Physician patch PRS*4.0*93.
|
|
;
|
|
PTP(PRSIEN) ;Check for potential PTP (has a memo on file)
|
|
; input PRSIEN = employee IEN (file 450)
|
|
; result = 1 or 0, true (1) if employee has any memos on file
|
|
Q $S($O(^PRST(458.7,"B",PRSIEN,0)):1,1:0)
|
|
;
|
|
;-----------------------------------------------------------------------
|
|
; Display PTP AL info
|
|
; Input: PRSIEN - IEN of PT Physician
|
|
; ARRAY - Array where leave info is stored. (Optional) If not
|
|
; specified, no array is created.
|
|
; INDEX - Index to start array. (optional) set to 1 if not spec
|
|
; Output: 2 line summary-current AL bal, fut reqs and potential loss.
|
|
;-----------------------------------------------------------------------
|
|
AL(PRSIEN,ARRAY,INDEX) ;
|
|
Q:'PRSIEN
|
|
I $G(INDEX)="",($G(ARRAY)'="") D INDEX^PRSPUT1
|
|
N AINC,ALBAL,ALTBL,APALHRS,EOLYD,LVG,TEXT,X,X1,X2,Y,MAYLOSE,LDPINV
|
|
;
|
|
; Max Carryover
|
|
S MAXOVER=240
|
|
;
|
|
; current AL bal
|
|
S ALBAL=$P($G(^PRSPC(PRSIEN,"ANNUAL")),U,3)
|
|
;
|
|
; last day of curr leave yr
|
|
S EOLYD=$$GETLDOYR()
|
|
;
|
|
; last day proc from 459 & inverse
|
|
S LDP=$P($G(^PRST(458,$O(^PRST(458,"AB",$O(^PRST(459,"AB",""),-1),0)),1)),U,14)
|
|
S LDPINV=9999999-LDP
|
|
;
|
|
; future al approved (ranges from LastDayProcessed459-EndOfLeaveYear)
|
|
; This is an estimate since we count all hrs for reqs that begin in
|
|
; the current yr but cross into next
|
|
S APALHRS=$$GETAPALH(PRSIEN,LDPINV,EOLYD)
|
|
;
|
|
; accrual from last pp proc to EOY
|
|
S ACCRUAL=$$GETACCRU(PRSIEN,EOLYD,LDP)
|
|
;
|
|
; potential loss
|
|
S MAYLOSE=$$GETLOSE(APALHRS,ALBAL,ACCRUAL,MAXOVER)
|
|
;
|
|
; Display
|
|
S TEXT=""
|
|
D A1^PRSPUT1 ; Blank line
|
|
S TEXT="AL Bal: "_$J(ALBAL,6,2)
|
|
S $E(TEXT,17)="",TEXT=TEXT_"Approved future AL thru Leave Year: "
|
|
S TEXT=TEXT_$J(APALHRS,6,2)
|
|
S $E(TEXT,60)="",TEXT=TEXT_"Max carryover: "_MAXOVER
|
|
D A1^PRSPUT1 ; Line #1
|
|
S Y=EOLYD
|
|
D DD^%DT
|
|
S TEXT="Potential AL hours to be lost by "_Y_" excluding Approved AL: "
|
|
S TEXT=TEXT_MAYLOSE
|
|
D A1^PRSPUT1 ; Line #2
|
|
K INDEX
|
|
Q
|
|
;
|
|
GETACCRU(PRSIEN,EOLYD,LDP) ; Calculate AL accrucal from last day of
|
|
; pp processed in 459 (LDP) to end of leave year (EOLYD)
|
|
;
|
|
N CO,LVG,NH,DB,AINC,X1,X2,INC
|
|
;
|
|
S C0=$G(^PRSPC(PRSIEN,0)),LVG=$P(C0,"^",15),NH=+$P(C0,"^",16)
|
|
S DB=$P(C0,"^",10),AINC=""
|
|
Q:LVG'?1N!("123"'[LVG) 0
|
|
I LVG=1 D ; Leave Group 1
|
|
. S AINC=$S(DB=1:4,1:NH+AINC/20\1)
|
|
I LVG=2 D ; Leave Group 2
|
|
. S AINC=$S(DB=1:6,1:NH+AINC/13\1)
|
|
I LVG=3 D ; Leave Group 3
|
|
. S AINC=$S(DB=1:8,1:NH+AINC/10\1)
|
|
S X1=EOLYD,X2=LDP
|
|
D ^%DTC
|
|
S INC=X+13\14*AINC
|
|
Q INC
|
|
;
|
|
GETLOSE(APALHRS,ALBAL,ACCRUAL,MAXOVER) ; Calculate potential hours to be lost
|
|
N ALTBL
|
|
S ALTBL=ALBAL+ACCRUAL-MAXOVER-APALHRS
|
|
Q $S(ALTBL<0:0,1:ALTBL)
|
|
;
|
|
GETLDOYR() ; Calculate last day of the last pp of current year (EOLY)
|
|
N X,I,X1,X2,NEXTYR,PRSYRDT
|
|
S PRSYRDT=$P($T(DAT^PRSAPPU),";;",2)
|
|
F I=1:1 S NEXTYR=$P(PRSYRDT,",",I) Q:NEXTYR>DT!(NEXTYR="")
|
|
I NEXTYR="" Q DT
|
|
S X1=NEXTYR,X2=-1
|
|
D C^%DTC
|
|
Q X
|
|
;
|
|
GETAPALH(PRSIEN,PPPIN,EOLYD) ; Approved AL hrs
|
|
;
|
|
N APALHRS,EOLYDINV,LREND,LRIEN,LRSTRT,LRDATA
|
|
;
|
|
S APALHRS=0 ; COUNTER-APproved Annual Leave HouR
|
|
S EOLYDINV=9999999-EOLYD
|
|
;
|
|
; use inverse dt to loop chrono from future requests to recent ones
|
|
; Quit when end date hits last proc pp. Don't include canceled & other
|
|
; leave type reqs from AD index.
|
|
;
|
|
S LREND=0
|
|
F S LREND=$O(^PRST(458.1,"AD",PRSIEN,LREND)) Q:(LREND'>0)!(LREND>PPPIN) D
|
|
. S LRIEN=0
|
|
. F S LRIEN=$O(^PRST(458.1,"AD",PRSIEN,LREND,LRIEN)) Q:LRIEN'>0 D
|
|
. . S LRSTRT=^PRST(458.1,"AD",PRSIEN,LREND,LRIEN)
|
|
. . S LRSTRT=9999999-LRSTRT
|
|
. . ;
|
|
. . ; skip if lv doesn't start in range-last pp proc to EOLY
|
|
. . Q:LRSTRT'<PPPIN!(LRSTRT'>EOLYDINV)
|
|
. . ; skip if not AL or App
|
|
. . S LRDATA=$G(^PRST(458.1,LRIEN,0))
|
|
. . Q:$P(LRDATA,U,7)'="AL"!($P(LRDATA,U,9)'="A")
|
|
. . S APALHRS=APALHRS+$P(LRDATA,U,15)
|
|
Q APALHRS
|
|
;
|
|
;-----------------------------------------------------------------------
|
|
; Utility updates ESR Status and autopost any holidays
|
|
;
|
|
; Input:
|
|
; PPI - The internal entry number of the PP
|
|
; PRSIEN - The internal entry number of the PT Phy
|
|
; DAY - (optional) If passed in the specific date (1-14) that
|
|
; needs to be updated. If a specific date is not
|
|
; passed in all 14 days will be reviewed and updated
|
|
; as necessary.
|
|
;
|
|
; HOL and PDT need to be set by calling ^PRSAPPH prior to making this
|
|
; call.
|
|
;
|
|
ESRUPDT(PPI,PRSIEN,DAY) ;
|
|
;
|
|
N END,HTOUR,IENS,MT,PRSFDA,START,STATUS,STOP,TOUR
|
|
S DAY=$G(DAY,"")
|
|
S START=$S(DAY:DAY,1:1)
|
|
S END=$S(DAY:DAY,1:14)
|
|
F DAY=START:1:END D
|
|
. S TOUR=$P($G(^PRST(458,PPI,"E",PRSIEN,"D",DAY,0)),U,2)
|
|
. S STATUS=$S(TOUR>1:1,1:6)
|
|
. S IENS=DAY_","_PRSIEN_","_PPI_","
|
|
. K PRSFDA
|
|
. S PRSFDA(458.02,IENS,146)=STATUS
|
|
. I $D(HOL($P(PDT,U,DAY))) D
|
|
. . S HTOUR=$G(^PRST(458,PPI,"E",PRSIEN,"D",DAY,1))
|
|
. . Q:HTOUR=""
|
|
. . S MT=$P($G(^PRST(458,PPI,"E",PRSIEN,"D",DAY,0)),U,2)
|
|
. . S MT=$P($G(^PRST(457.1,MT,0)),U,3)
|
|
. . F I=0:1:6 Q:$P(HTOUR,U,(3*I)+1)="" D
|
|
. . . S START=$P(HTOUR,U,(3*I)+1),STOP=$P(HTOUR,U,(3*I)+2)
|
|
. . . S PRSFDA(458.02,IENS,110+(5*I))=START
|
|
. . . S PRSFDA(458.02,IENS,111+(5*I))=STOP
|
|
. . . S PRSFDA(458.02,IENS,112+(5*I))="HX"
|
|
. . S PRSFDA(458.02,IENS,146)=4 ; ESR DAILY STATUS = SIGNED
|
|
. . S PRSFDA(458.02,IENS,101)="" ; Reset timecard status to unposted.
|
|
. . S PRSFDA(458.02,IENS,114)=MT ; Meal time for 1st segment
|
|
. . S PRSFDA(458.02,IENS,147)=$$NOW^XLFDT() ; Date/Time stamp
|
|
. . S PRSFDA(458.02,IENS,149)=4 ; ESR Signed by Holiday
|
|
. D UPDATE^DIE("","PRSFDA","IENS"),MSG^DIALOG()
|
|
Q
|
|
;
|
|
MEMCPP(MIEN) ; Memo Certified PP
|
|
; This utility determine the last certified PP and the number of
|
|
; certified PPs for a given memo.
|
|
; input
|
|
; MIEN - internal entry number of a memo in file 458.7
|
|
; returns a string value
|
|
; = last certified PP (external value)^number of certified PPs
|
|
; example "05-01^3"
|
|
;
|
|
N LASTPP,MPPIEN,PPC,PRSX
|
|
I '$G(MIEN) Q "^"
|
|
;
|
|
S LASTPP="" ; last PP
|
|
S PPC=0 ; pp counter
|
|
; loop thru PPs in memo
|
|
S MPPIEN=0 F S MPPIEN=$O(^PRST(458.7,MIEN,9,MPPIEN)) Q:'MPPIEN D
|
|
. S PRSX=$G(^PRST(458.7,MIEN,9,MPPIEN,0))
|
|
. Q:$P(PRSX,U,2)="" ; REG HOURS is null so PP never certified
|
|
. S LASTPP=$P(PRSX,U,1)
|
|
. S PPC=PPC+1
|
|
;
|
|
Q LASTPP_"^"_PPC
|
|
;
|
|
PP8BAMT(PPAMT,PPI,PRSIEN) ; array TIMEAMTS passed by reference
|
|
; subscripted w/ types of time CODE and type of time activity
|
|
; from PRS8VW2 table. This routine sets each node of TIMEAMTS array
|
|
; to the total hours (week one and two) in the pp
|
|
; for that type of time activity.
|
|
;
|
|
; SAMPLE CALL:
|
|
; S TAMTS("WP","Leave Without Pay")="" D PP8BTOT(.TAMTS,PPI,PRSIEN)
|
|
;
|
|
; SAMPLE RETURN ARRAY
|
|
; TAMTS("WP","Leave Without Pay")=12.5
|
|
;
|
|
N TT,STR8B,TC,TA,WK1CD,WK2CD,AMT1,AMT2
|
|
S STR8B=$$GET8B(PPI,PRSIEN)
|
|
S TC=""
|
|
F S TC=$O(PPAMT(TC)) Q:TC="" D
|
|
. S TA=""
|
|
. F S TA=$O(PPAMT(TC,TA)) Q:TA="" D
|
|
.. S WK1CD=$$WKTT(TC,TA,1)
|
|
.. S WK2CD=$$WKTT(TC,TA,2)
|
|
.. S AMT1=$$EXTR8BT(STR8B,WK1CD)
|
|
.. S AMT2=$$EXTR8BT(STR8B,WK2CD)
|
|
.. S PPAMT(TC,TA)=AMT1+AMT2
|
|
Q
|
|
GET8B(PPI,PRSIEN) ; get 8b from 5 node unless corrected timecard
|
|
; has been done then we need to recompute 8B
|
|
N S8B
|
|
I $$CORRECT(PPI,PRSIEN) D
|
|
. N DFN,PY,VAL
|
|
.; new variables used BY callers to this API because the decomp
|
|
.; kills everything in its path.
|
|
. N QT,PP,%,C0,CNT,CT,D,DAY,HDR,I,K,MEAL,SSN,ST,TT,TYP,X,X1,Y,Y1,Z,ML,Z0,Z1
|
|
. S DFN=PRSIEN
|
|
. S PY=PPI
|
|
. D ONE^PRS8
|
|
. S S8B=$E($G(VAL),33,999)
|
|
E D
|
|
. S S8B=$E($G(^PRST(458,PPI,"E",PRSIEN,5)),33,999)
|
|
Q S8B
|
|
CORRECT(PPI,PRSIEN) ; return true if any corrected timecards exist for
|
|
;this emp's pp that were approved by the final level supr apprl
|
|
N CORRECT,STATUS,TCD
|
|
S CORRECT=0
|
|
Q:($G(PPI)'>0)!($G(PRSIEN)'>0)
|
|
S TCD=0
|
|
F S TCD=$O(^PRST(458,PPI,"E",PRSIEN,"X",TCD)) Q:TCD'>0!(CORRECT) D
|
|
. S STATUS=$P($G(^PRST(458,PPI,"E",PRSIEN,"X",TCD,0)),U,5)
|
|
. I STATUS="P"!(STATUS="S") S CORRECT=1
|
|
Q CORRECT
|
|
EXTR8BT(S,T) ; EXTRACT THE 8B TYPE OF TIME FROM THE STUB AND RETURN THE
|
|
; AMOUNT OF TIME FROM WEEK ONE AND TWO FOR THIS TYPE OF TIME
|
|
; INPUT: S-8B STUB
|
|
; T-TYPE OF TIME TO FIND ^ LENGTH OF DATA IN 8B
|
|
N AMT,LEN,POS,QH,HRS
|
|
S AMT="0.0"
|
|
S POS=$F(S,$P(T,U))
|
|
I POS D
|
|
. S LEN=$P(T,U,2)
|
|
. S AMT=$E(S,POS,POS-1+LEN)
|
|
. S HRS=+$E(AMT,1,LEN-1)
|
|
. S QH=+$E(AMT,LEN,LEN)
|
|
. S QH=$S(QH=1:".25",QH=2:".5",QH=3:".75",1:".0")
|
|
. S AMT=HRS_QH
|
|
Q AMT
|
|
;
|
|
WKTT(T,TA,WK) ; GET 8B STRING TIMECODE FOR WEEK ONE OR TWO AND LENGTH OF
|
|
; THE DATA IN THE 8B STRING
|
|
; Input:
|
|
; T- type of time code from file 457.3
|
|
; TA-time activity from the table in PRS8VW2 (e.g. Leave Without Pay)
|
|
; WK-1 or 2 for the desired timecode week
|
|
;
|
|
S WK=$S($G(WK)=2:2,1:1)
|
|
Q:$G(T)=""
|
|
N TCH1,TTEXT,CHKLN,I,FOUND,E,TTABLE,CHUNK,TABLEI,WKTTCODE
|
|
S FOUND=0
|
|
;
|
|
S TCH1=$E(T,1,1)
|
|
D E2^PRS8VW
|
|
S CHKLN=$P($T(@(TCH1)+0^PRS8VW2),";;",2)
|
|
F I=1:1:$L(CHKLN,"^") D Q:FOUND
|
|
. S CHUNK=$P(CHKLN,U,I)
|
|
. S TABLEI=$P(CHUNK,":",2)
|
|
. S WKTTCODE=TCH1_$P(CHUNK,":")
|
|
. S TTABLE=$P($T(TYP+TABLEI^PRS8VW2),";;",2)
|
|
. I TTABLE=TA,$F(E(WK),WKTTCODE) D
|
|
.. S FOUND=1
|
|
..; When found in PRS8VW2 table return code and length
|
|
.. S WKTTCODE=WKTTCODE_U_$P(CHUNK,":",3)
|
|
I 'FOUND S WKTTCODE=0
|
|
Q WKTTCODE
|