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