PRSPUT3 ;WOIFO/MGD,JAH - PART TIME PHYSICIAN UTILITIES #1 ;06/15/05
 ;;4.0;PAID;**93**;Sep 21, 1995;Build 7
 ;;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^PRS8VW1),";;",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