PRSPSAP2 ;WOIFO/JAH - Supervisor Approve-update pt phys timecard ;7/26/05
;;4.0;PAID;**93**;Sep 21, 1995;Build 7
;;Per VHA Directive 2004-038, this routine should not be modified.
Q
TRANSACT ; TRANSfer ACTions to the database
; loop thru temp and update the time card and the ESR day stats
N ACT,PRSIEN,PPI,PRSD
S PRSIEN=""
F S PRSIEN=$O(^TMP($J,"PRSPSAP",PRSIEN)) Q:PRSIEN'>0 D
. S PPI=0
. F S PPI=$O(^TMP($J,"PRSPSAP",PRSIEN,PPI)) Q:PPI'>0 D
.. S PRSD=0
.. F S PRSD=$O(^TMP($J,"PRSPSAP",PRSIEN,PPI,PRSD)) Q:PRSD'>0 D
... S ACT=$G(^TMP($J,"PRSPSAP",PRSIEN,PPI,PRSD,1))
...; Ignore ESR days that the superV skipped or bypassed.
... Q:(ACT="")!(ACT="B")
...;
...; set ESR day status to resubmit and add remarks
... I ACT="R" D
.... S REM=$G(^TMP($J,"PRSPSAP",PRSIEN,PPI,PRSD,2))
.... D UPESR(PRSIEN,PPI,PRSD,ACT,REM)
... E D
....; try to update the timecard and the ESR
.... N CAN S (CAN("CB"),CAN("AE"))=0
.... D UPTCARD(.CAN,PRSIEN,PPI,PRSD)
.... I CAN("AE") D UPESR(PRSIEN,PPI,PRSD,ACT,"")
.... I CAN("CB") D PTP^PRSASR1(PRSIEN,PPI)
Q
UPESR(PRSIEN,PPI,PRSD,ACT,REM) ; update ESR with either Resubmit OR Approve
N PRSFDA,IENS
;
; update ESR status and display any filing errors
;
S IENS=PRSD_","_PRSIEN_","_PPI_","
S PRSFDA(458.02,IENS,146)=$S(ACT="A":"APPROVED",1:"RESUBMIT")
I $G(REM)'="" S PRSFDA(458.02,IENS,148)=REM
D FILE^DIE("E","PRSFDA")
D MSG^DIALOG()
Q
;
UPTCARD(CAN,PRSIEN,PPI,PRSD) ; UPDATE A TIME CARD
; WITH ESR LEAVE EXCEPTIONS AND HOLIDAY X
; Return CAN by reference.
; CAN("AE") "CAN APPROVE ESR" is set to true if the ESR can be
; approved. i.e. timecard status is T-timekeep or there's
; no affect on the timecard
; CAN("CB") "CAN CALL BANK" is set to true when a call should be
; made to the hours bank API (PTP^PRSASR1).
; Calling routines must consider the order in which
; to APPROVE ESR and CALL HOURS BANK since the API
; PTP^PRSASR, will only count hrs with an approved status.
;
;458.02 (DAY MULTIPLE)
; FIELD: 10 TOUR LAST POSTED BY^P200
; identifies last person to post a tour for employee
; 101 POSTING STATUS^S^T:TIMEKEEPER POSTED;
; P:PAYROLL REVIEWED;X:TRANSMITTED;
; 102 TIMEKEEPER POSTING^P200'^VA(200,
; 103 TK DATE/TIME ENTERED^DATE
; 104 POSTING TYPE^S^1:WORKED ENTIRE TOUR;
; 2:ABSENT ENTIRE TOUR;3:IRREGULAR TOUR;
N TCN,ESRN,POST,PSTDT,POSTER,PTYPE
N TCSTAT,DYSTAT,DUMB,POSTYPE,TOD,EARY,ERRORS
S (CAN("CB"),CAN("AE"))=0
;get the raw posting from the ESR
S ESRN=$G(^PRST(458,PPI,"E",PRSIEN,"D",PRSD,5))
; day signed on ESR with no work OR get the work segments
I $P(ESRN,U)'="" S ESRN=$$GETAPTM(ESRN)
;get the timecard node
S TCN=$G(^PRST(458,PPI,"E",PRSIEN,"D",PRSD,2))
S POST=$G(^PRST(458,PPI,"E",PRSIEN,"D",PRSD,10))
S PSTDT=$P(POST,U)
S DYSTAT=$P(POST,U,2)
S POSTER=$P(POST,U,3)
S POSTYPE=$P(POST,U,4)
; if the timecard is still with timekeep it can be updated.
S TCSTAT=$$TCSTAT(PPI,PRSIEN)
I TCSTAT="T" D
. S CAN("AE")=1,CAN("CB")=0
. D EDTCARD(PPI,PRSIEN,PRSD,ESRN)
E D
. ;if timecard is in a payroll or transmit we can check
. ; for any affect to TimeCard from the ESR. If none
.; we can update the ESR to approved and we should make a
.; a call to the hours bank after ESR is set to apporved
.; the hours bank and quit
.; otherwise we have to either return timecard or do corrcted timecard
.;
.; If timecard has no postings and ESR has no exceptions
.; the ESR can be approved since no change to timecard is necessary
. I ESRN=""&(TCN="") S (CAN("AE"),CAN("CB"))=1 Q
.;
.; if ESR matches Timecard, update ESR no Timecard update necessary
. D CMPESRTC^PRSPSAP3(.ERRORS,.EARY,"","",PPI,PRSIEN,PRSD)
. I ERRORS=0 S (CAN("AE"),CAN("CB"))=1 Q
. I "^P^X^"["^"_TCSTAT_"^" S (CAN("AE"),CAN("CB"))=0 D Q
.. D CANTPOST^PRSPSAP3(.EARY,TCSTAT,PPI,PRSIEN,PRSD,ESRN)
.. S DUMB=$$ASK^PRSLIB00(1)
Q
EDTCARD(PPI,PRSIEN,PRSD,ESRN) ; edit the timecard
;
N EDTSTR,CLEAR,POSTTIME,PRSFDA,IENS
;
; if there's no work, no leave or only RG then ptp gets credit for
; entire day, otherwise we have some exceptions. If the physician
; used leave the entire day then don't post meal and set ptype=2
;
S CLEAR=$$CLRTCDY^PRSPSAPU(PPI,PRSIEN,PRSD,5)
S PTYPE=$S($P(ESRN,U)="":1,1:3)
I PTYPE=3 D
. I $$ABSENT(ESRN,PPI,PRSIEN,PRSD) S PTYPE=2
. S TCN=$$ESR2TC(ESRN,PTYPE)
.; update the timecard with a global set
. S ^PRST(458,PPI,"E",PRSIEN,"D",PRSD,2)=TCN
;
; update timecard status
N %,X,%I,%H D NOW^%DTC S POSTTIME=%
;
; update timecard status and display any filing errors
;
S IENS=PRSD_","_PRSIEN_","_PPI_","
S PRSFDA(458.02,IENS,101)="T"
S PRSFDA(458.02,IENS,102)=DUZ
S PRSFDA(458.02,IENS,103)=POSTTIME
S PRSFDA(458.02,IENS,104)=PTYPE
D FILE^DIE("","PRSFDA")
D MSG^DIALOG()
Q
;
ESR2TC(ESRN,PT) ;CONVERT ESR DATA TO TIMECARD FORMAT
;
N ESR2TC,TCS,I,TSEG,ST,EN,TT,RE,ML,TCN
;
S TCN=""
F I=1:5:31 D
. S TSEG=$P(ESRN,U,I,I+4)
. S ST=$P(TSEG,U)
. Q:ST=""
. S EN=$P(TSEG,U,2)
. S TT=$P(TSEG,U,3)
. S RE=$P(TSEG,U,4)
. S ML=$P(TSEG,U,5)
.; if meal posted remove it from leave end time
. I (PT=3)&(ML>0) S EN=$$ENDML(EN,ML)
. S:$G(TCN)'="" TCN=TCN_"^"
. S TCS=ST_U_EN_U_TT_U_RE
. S TCN=TCN_TCS
; REMOVE A TRAILING UPARROW GENERATED BY NULL REMARKS CODE
I $E(TCN,$L(TCN))=U S TCN=$E(TCN,1,$L(TCN)-1)
Q TCN
;
;
ABSENT(ESRN,PPI,PRSIEN,PRSD) ;return true if the ESR posting matches all
; the tour start and stop times and uses only one type of leave and
; the meal matches the tours meal.
; i.e. ESR posting equivalent to absent entire tour question.
;
N TR1,TR2,TR1ML,TR2ML,TRMEAL,LASTTT,MULTITT,NODE0,RETURN,TCT
N TCS,I,TSEG,ST,EN,TT,ML,TCTOUR,ESRTOUR
;
S (ESRTOUR,LASTTT)="",(MULTITT,ML,RETURN)=0
F I=1:5:31 D
. S TSEG=$P(ESRN,U,I,I+4)
. S ST=$P(TSEG,U)
. Q:ST=""
. S EN=$P(TSEG,U,2)
. S TT=$P(TSEG,U,3)
. I LASTTT="" D
.. S LASTTT=TT
. E D
.. I LASTTT'=TT S MULTITT=1
. S ML=ML+$P(TSEG,U,5)
. S:$G(ESRTOUR)'="" ESRTOUR=ESRTOUR_"^"
. S TCS=ST_U_EN
. S ESRTOUR=ESRTOUR_TCS
; REMOVE A TRAILING UPARROW GENERATED BY NULL REMARKS CODE
I $E(ESRTOUR,$L(ESRTOUR))=U S ESRTOUR=$E(ESRTOUR,1,$L(ESRTOUR)-1)
;
;
S TCT=$G(^PRST(458,PPI,"E",PRSIEN,"D",PRSD,1))
S NODE0=$G(^PRST(458,PPI,"E",PRSIEN,"D",PRSD,0))
S (TR1ML,TR2ML)=0
S TR1=$P(NODE0,U,2) I TR1>0 S TR1ML=$P($G(^PRST(457.1,TR1,0)),U,3)
S TR2=$P(NODE0,U,15) I TR2>0 S TR2ML=$P($G(^PRST(457.1,TR2,0)),U,3)
S TRMEAL=TR1ML+TR2ML
S TCTOUR=""
F I=1:3:31 D
. S TSEG=$P(TCT,U,I,I+4)
. S ST=$P(TSEG,U)
. Q:ST=""
. S EN=$P(TSEG,U,2)
. S:$G(TCTOUR)'="" TCTOUR=TCTOUR_"^"
. S TCS=ST_U_EN
. S TCTOUR=TCTOUR_TCS
I (TCTOUR=ESRTOUR)&('MULTITT)&(TRMEAL=ML) S RETURN=1
Q RETURN
;
ENDML(END,MEAL) ;GET AN END TIME AND DEDUCT THE MEAL FROM IT
;
N X
; quit if we aint gots a good enought end time.
Q:($G(END)'?2N.P.2N.A)&(END'="MID")&(END'="NOON") $G(END)
S END=$$TWENTY4^PRSPESR2(END)
S END=$E(END,1,2)_":"_$E(END,3,4)
S END=$$MEALCUT(END,MEAL)
; Convert back to form stored in 458 start stop times
S X=END D ^PRSATIM S END=X
Q END
;
MEALCUT(HHMM,MEAL) ;Subtract meal time from the end time
; (subtract a 15 minute increment from length of time
; in hh:mm format, i.e. hh:mm - mm
;
N X,Y,DECR,OBJ,I,HH,MM
S MM=$P(HHMM,":",2) ; get minutes
; quit minutes or meal not quarter hours
Q:(MM#15'=0&(+MM)!((MEAL#15)'=0&(+MEAL))) HHMM
; get hours
S HH=$P(HHMM,":")
;
; convert segment minutes and meal to a digit.
;
S X=MM D MEALIN^PRSPESR2 S OBJ=X
S X=$G(MEAL) D MEALIN^PRSPESR2 S DECR=X
I OBJ=0 S OBJ=4
F I=1:1:DECR D
. I OBJ=4 D
.. I +HH=0 D
... S HH=23
.. E D
... S HH="0"_(+HH-1) S HH=$E(HH,$L(HH)-1,$L(HH))
. S OBJ=$S(OBJ=4:3,OBJ=3:2,OBJ=2:1,OBJ=1:4)
S MM=$S(OBJ=1:15,OBJ=2:30,OBJ=3:45,1:"00")
;
Q HH_MM
;
TCSTAT(PPI,PRSIEN) ; get timecard status
Q:(PPI'>0)!(PRSIEN'>0) 0
Q $P($G(^PRST(458,PPI,"E",PRSIEN,0)),U,2)
;
GETAPTM(WORK) ; return the work node with only the time that should
; be posted to a PTP's timecard
; INPUT: WORK : ESR work node
; RETURN ESRN : ESR node with only time applicable to PTP's
;
N I,TSEG
S TCN=""
F I=1:5:31 D
. S TSEG=$P(WORK,U,I,I+4)
. S TT=$P(TSEG,U,3)
. Q:TSEG="^^^^"!("^HX^AL^AA^DL^ML^RL^SL^CB^AD^WP^TR^TV^"'[(U_TT_U))
. S TCN=TCN_TSEG_"^"
Q TCN
;
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRSPSAP2 8848 printed Apr 09, 2024@21:31:54 Page 2
PRSPSAP2 ;WOIFO/JAH - Supervisor Approve-update pt phys timecard ;7/26/05
+1 ;;4.0;PAID;**93**;Sep 21, 1995;Build 7
+2 ;;Per VHA Directive 2004-038, this routine should not be modified.
+3 QUIT
TRANSACT ; TRANSfer ACTions to the database
+1 ; loop thru temp and update the time card and the ESR day stats
+2 NEW ACT,PRSIEN,PPI,PRSD
+3 SET PRSIEN=""
+4 FOR
SET PRSIEN=$ORDER(^TMP($JOB,"PRSPSAP",PRSIEN))
if PRSIEN'>0
QUIT
Begin DoDot:1
+5 SET PPI=0
+6 FOR
SET PPI=$ORDER(^TMP($JOB,"PRSPSAP",PRSIEN,PPI))
if PPI'>0
QUIT
Begin DoDot:2
+7 SET PRSD=0
+8 FOR
SET PRSD=$ORDER(^TMP($JOB,"PRSPSAP",PRSIEN,PPI,PRSD))
if PRSD'>0
QUIT
Begin DoDot:3
+9 SET ACT=$GET(^TMP($JOB,"PRSPSAP",PRSIEN,PPI,PRSD,1))
+10 ; Ignore ESR days that the superV skipped or bypassed.
+11 if (ACT="")!(ACT="B")
QUIT
+12 ;
+13 ; set ESR day status to resubmit and add remarks
+14 IF ACT="R"
Begin DoDot:4
+15 SET REM=$GET(^TMP($JOB,"PRSPSAP",PRSIEN,PPI,PRSD,2))
+16 DO UPESR(PRSIEN,PPI,PRSD,ACT,REM)
End DoDot:4
+17 IF '$TEST
Begin DoDot:4
+18 ; try to update the timecard and the ESR
+19 NEW CAN
SET (CAN("CB"),CAN("AE"))=0
+20 DO UPTCARD(.CAN,PRSIEN,PPI,PRSD)
+21 IF CAN("AE")
DO UPESR(PRSIEN,PPI,PRSD,ACT,"")
+22 IF CAN("CB")
DO PTP^PRSASR1(PRSIEN,PPI)
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+23 QUIT
UPESR(PRSIEN,PPI,PRSD,ACT,REM) ; update ESR with either Resubmit OR Approve
+1 NEW PRSFDA,IENS
+2 ;
+3 ; update ESR status and display any filing errors
+4 ;
+5 SET IENS=PRSD_","_PRSIEN_","_PPI_","
+6 SET PRSFDA(458.02,IENS,146)=$SELECT(ACT="A":"APPROVED",1:"RESUBMIT")
+7 IF $GET(REM)'=""
SET PRSFDA(458.02,IENS,148)=REM
+8 DO FILE^DIE("E","PRSFDA")
+9 DO MSG^DIALOG()
+10 QUIT
+11 ;
UPTCARD(CAN,PRSIEN,PPI,PRSD) ; UPDATE A TIME CARD
+1 ; WITH ESR LEAVE EXCEPTIONS AND HOLIDAY X
+2 ; Return CAN by reference.
+3 ; CAN("AE") "CAN APPROVE ESR" is set to true if the ESR can be
+4 ; approved. i.e. timecard status is T-timekeep or there's
+5 ; no affect on the timecard
+6 ; CAN("CB") "CAN CALL BANK" is set to true when a call should be
+7 ; made to the hours bank API (PTP^PRSASR1).
+8 ; Calling routines must consider the order in which
+9 ; to APPROVE ESR and CALL HOURS BANK since the API
+10 ; PTP^PRSASR, will only count hrs with an approved status.
+11 ;
+12 ;458.02 (DAY MULTIPLE)
+13 ; FIELD: 10 TOUR LAST POSTED BY^P200
+14 ; identifies last person to post a tour for employee
+15 ; 101 POSTING STATUS^S^T:TIMEKEEPER POSTED;
+16 ; P:PAYROLL REVIEWED;X:TRANSMITTED;
+17 ; 102 TIMEKEEPER POSTING^P200'^VA(200,
+18 ; 103 TK DATE/TIME ENTERED^DATE
+19 ; 104 POSTING TYPE^S^1:WORKED ENTIRE TOUR;
+20 ; 2:ABSENT ENTIRE TOUR;3:IRREGULAR TOUR;
+21 NEW TCN,ESRN,POST,PSTDT,POSTER,PTYPE
+22 NEW TCSTAT,DYSTAT,DUMB,POSTYPE,TOD,EARY,ERRORS
+23 SET (CAN("CB"),CAN("AE"))=0
+24 ;get the raw posting from the ESR
+25 SET ESRN=$GET(^PRST(458,PPI,"E",PRSIEN,"D",PRSD,5))
+26 ; day signed on ESR with no work OR get the work segments
+27 IF $PIECE(ESRN,U)'=""
SET ESRN=$$GETAPTM(ESRN)
+28 ;get the timecard node
+29 SET TCN=$GET(^PRST(458,PPI,"E",PRSIEN,"D",PRSD,2))
+30 SET POST=$GET(^PRST(458,PPI,"E",PRSIEN,"D",PRSD,10))
+31 SET PSTDT=$PIECE(POST,U)
+32 SET DYSTAT=$PIECE(POST,U,2)
+33 SET POSTER=$PIECE(POST,U,3)
+34 SET POSTYPE=$PIECE(POST,U,4)
+35 ; if the timecard is still with timekeep it can be updated.
+36 SET TCSTAT=$$TCSTAT(PPI,PRSIEN)
+37 IF TCSTAT="T"
Begin DoDot:1
+38 SET CAN("AE")=1
SET CAN("CB")=0
+39 DO EDTCARD(PPI,PRSIEN,PRSD,ESRN)
End DoDot:1
+40 IF '$TEST
Begin DoDot:1
+41 ;if timecard is in a payroll or transmit we can check
+42 ; for any affect to TimeCard from the ESR. If none
+43 ; we can update the ESR to approved and we should make a
+44 ; a call to the hours bank after ESR is set to apporved
+45 ; the hours bank and quit
+46 ; otherwise we have to either return timecard or do corrcted timecard
+47 ;
+48 ; If timecard has no postings and ESR has no exceptions
+49 ; the ESR can be approved since no change to timecard is necessary
+50 IF ESRN=""&(TCN="")
SET (CAN("AE"),CAN("CB"))=1
QUIT
+51 ;
+52 ; if ESR matches Timecard, update ESR no Timecard update necessary
+53 DO CMPESRTC^PRSPSAP3(.ERRORS,.EARY,"","",PPI,PRSIEN,PRSD)
+54 IF ERRORS=0
SET (CAN("AE"),CAN("CB"))=1
QUIT
+55 IF "^P^X^"["^"_TCSTAT_"^"
SET (CAN("AE"),CAN("CB"))=0
Begin DoDot:2
+56 DO CANTPOST^PRSPSAP3(.EARY,TCSTAT,PPI,PRSIEN,PRSD,ESRN)
+57 SET DUMB=$$ASK^PRSLIB00(1)
End DoDot:2
QUIT
End DoDot:1
+58 QUIT
EDTCARD(PPI,PRSIEN,PRSD,ESRN) ; edit the timecard
+1 ;
+2 NEW EDTSTR,CLEAR,POSTTIME,PRSFDA,IENS
+3 ;
+4 ; if there's no work, no leave or only RG then ptp gets credit for
+5 ; entire day, otherwise we have some exceptions. If the physician
+6 ; used leave the entire day then don't post meal and set ptype=2
+7 ;
+8 SET CLEAR=$$CLRTCDY^PRSPSAPU(PPI,PRSIEN,PRSD,5)
+9 SET PTYPE=$SELECT($PIECE(ESRN,U)="":1,1:3)
+10 IF PTYPE=3
Begin DoDot:1
+11 IF $$ABSENT(ESRN,PPI,PRSIEN,PRSD)
SET PTYPE=2
+12 SET TCN=$$ESR2TC(ESRN,PTYPE)
+13 ; update the timecard with a global set
+14 SET ^PRST(458,PPI,"E",PRSIEN,"D",PRSD,2)=TCN
End DoDot:1
+15 ;
+16 ; update timecard status
+17 NEW %,X,%I,%H
DO NOW^%DTC
SET POSTTIME=%
+18 ;
+19 ; update timecard status and display any filing errors
+20 ;
+21 SET IENS=PRSD_","_PRSIEN_","_PPI_","
+22 SET PRSFDA(458.02,IENS,101)="T"
+23 SET PRSFDA(458.02,IENS,102)=DUZ
+24 SET PRSFDA(458.02,IENS,103)=POSTTIME
+25 SET PRSFDA(458.02,IENS,104)=PTYPE
+26 DO FILE^DIE("","PRSFDA")
+27 DO MSG^DIALOG()
+28 QUIT
+29 ;
ESR2TC(ESRN,PT) ;CONVERT ESR DATA TO TIMECARD FORMAT
+1 ;
+2 NEW ESR2TC,TCS,I,TSEG,ST,EN,TT,RE,ML,TCN
+3 ;
+4 SET TCN=""
+5 FOR I=1:5:31
Begin DoDot:1
+6 SET TSEG=$PIECE(ESRN,U,I,I+4)
+7 SET ST=$PIECE(TSEG,U)
+8 if ST=""
QUIT
+9 SET EN=$PIECE(TSEG,U,2)
+10 SET TT=$PIECE(TSEG,U,3)
+11 SET RE=$PIECE(TSEG,U,4)
+12 SET ML=$PIECE(TSEG,U,5)
+13 ; if meal posted remove it from leave end time
+14 IF (PT=3)&(ML>0)
SET EN=$$ENDML(EN,ML)
+15 if $GET(TCN)'=""
SET TCN=TCN_"^"
+16 SET TCS=ST_U_EN_U_TT_U_RE
+17 SET TCN=TCN_TCS
End DoDot:1
+18 ; REMOVE A TRAILING UPARROW GENERATED BY NULL REMARKS CODE
+19 IF $EXTRACT(TCN,$LENGTH(TCN))=U
SET TCN=$EXTRACT(TCN,1,$LENGTH(TCN)-1)
+20 QUIT TCN
+21 ;
+22 ;
ABSENT(ESRN,PPI,PRSIEN,PRSD) ;return true if the ESR posting matches all
+1 ; the tour start and stop times and uses only one type of leave and
+2 ; the meal matches the tours meal.
+3 ; i.e. ESR posting equivalent to absent entire tour question.
+4 ;
+5 NEW TR1,TR2,TR1ML,TR2ML,TRMEAL,LASTTT,MULTITT,NODE0,RETURN,TCT
+6 NEW TCS,I,TSEG,ST,EN,TT,ML,TCTOUR,ESRTOUR
+7 ;
+8 SET (ESRTOUR,LASTTT)=""
SET (MULTITT,ML,RETURN)=0
+9 FOR I=1:5:31
Begin DoDot:1
+10 SET TSEG=$PIECE(ESRN,U,I,I+4)
+11 SET ST=$PIECE(TSEG,U)
+12 if ST=""
QUIT
+13 SET EN=$PIECE(TSEG,U,2)
+14 SET TT=$PIECE(TSEG,U,3)
+15 IF LASTTT=""
Begin DoDot:2
+16 SET LASTTT=TT
End DoDot:2
+17 IF '$TEST
Begin DoDot:2
+18 IF LASTTT'=TT
SET MULTITT=1
End DoDot:2
+19 SET ML=ML+$PIECE(TSEG,U,5)
+20 if $GET(ESRTOUR)'=""
SET ESRTOUR=ESRTOUR_"^"
+21 SET TCS=ST_U_EN
+22 SET ESRTOUR=ESRTOUR_TCS
End DoDot:1
+23 ; REMOVE A TRAILING UPARROW GENERATED BY NULL REMARKS CODE
+24 IF $EXTRACT(ESRTOUR,$LENGTH(ESRTOUR))=U
SET ESRTOUR=$EXTRACT(ESRTOUR,1,$LENGTH(ESRTOUR)-1)
+25 ;
+26 ;
+27 SET TCT=$GET(^PRST(458,PPI,"E",PRSIEN,"D",PRSD,1))
+28 SET NODE0=$GET(^PRST(458,PPI,"E",PRSIEN,"D",PRSD,0))
+29 SET (TR1ML,TR2ML)=0
+30 SET TR1=$PIECE(NODE0,U,2)
IF TR1>0
SET TR1ML=$PIECE($GET(^PRST(457.1,TR1,0)),U,3)
+31 SET TR2=$PIECE(NODE0,U,15)
IF TR2>0
SET TR2ML=$PIECE($GET(^PRST(457.1,TR2,0)),U,3)
+32 SET TRMEAL=TR1ML+TR2ML
+33 SET TCTOUR=""
+34 FOR I=1:3:31
Begin DoDot:1
+35 SET TSEG=$PIECE(TCT,U,I,I+4)
+36 SET ST=$PIECE(TSEG,U)
+37 if ST=""
QUIT
+38 SET EN=$PIECE(TSEG,U,2)
+39 if $GET(TCTOUR)'=""
SET TCTOUR=TCTOUR_"^"
+40 SET TCS=ST_U_EN
+41 SET TCTOUR=TCTOUR_TCS
End DoDot:1
+42 IF (TCTOUR=ESRTOUR)&('MULTITT)&(TRMEAL=ML)
SET RETURN=1
+43 QUIT RETURN
+44 ;
ENDML(END,MEAL) ;GET AN END TIME AND DEDUCT THE MEAL FROM IT
+1 ;
+2 NEW X
+3 ; quit if we aint gots a good enought end time.
+4 if ($GET(END)'?2N.P.2N.A)&(END'="MID")&(END'="NOON")
QUIT $GET(END)
+5 SET END=$$TWENTY4^PRSPESR2(END)
+6 SET END=$EXTRACT(END,1,2)_":"_$EXTRACT(END,3,4)
+7 SET END=$$MEALCUT(END,MEAL)
+8 ; Convert back to form stored in 458 start stop times
+9 SET X=END
DO ^PRSATIM
SET END=X
+10 QUIT END
+11 ;
MEALCUT(HHMM,MEAL) ;Subtract meal time from the end time
+1 ; (subtract a 15 minute increment from length of time
+2 ; in hh:mm format, i.e. hh:mm - mm
+3 ;
+4 NEW X,Y,DECR,OBJ,I,HH,MM
+5 ; get minutes
SET MM=$PIECE(HHMM,":",2)
+6 ; quit minutes or meal not quarter hours
+7 if (MM#15'=0&(+MM)!((MEAL#15)'=0&(+MEAL)))
QUIT HHMM
+8 ; get hours
+9 SET HH=$PIECE(HHMM,":")
+10 ;
+11 ; convert segment minutes and meal to a digit.
+12 ;
+13 SET X=MM
DO MEALIN^PRSPESR2
SET OBJ=X
+14 SET X=$GET(MEAL)
DO MEALIN^PRSPESR2
SET DECR=X
+15 IF OBJ=0
SET OBJ=4
+16 FOR I=1:1:DECR
Begin DoDot:1
+17 IF OBJ=4
Begin DoDot:2
+18 IF +HH=0
Begin DoDot:3
+19 SET HH=23
End DoDot:3
+20 IF '$TEST
Begin DoDot:3
+21 SET HH="0"_(+HH-1)
SET HH=$EXTRACT(HH,$LENGTH(HH)-1,$LENGTH(HH))
End DoDot:3
End DoDot:2
+22 SET OBJ=$SELECT(OBJ=4:3,OBJ=3:2,OBJ=2:1,OBJ=1:4)
End DoDot:1
+23 SET MM=$SELECT(OBJ=1:15,OBJ=2:30,OBJ=3:45,1:"00")
+24 ;
+25 QUIT HH_MM
+26 ;
TCSTAT(PPI,PRSIEN) ; get timecard status
+1 if (PPI'>0)!(PRSIEN'>0)
QUIT 0
+2 QUIT $PIECE($GET(^PRST(458,PPI,"E",PRSIEN,0)),U,2)
+3 ;
GETAPTM(WORK) ; return the work node with only the time that should
+1 ; be posted to a PTP's timecard
+2 ; INPUT: WORK : ESR work node
+3 ; RETURN ESRN : ESR node with only time applicable to PTP's
+4 ;
+5 NEW I,TSEG
+6 SET TCN=""
+7 FOR I=1:5:31
Begin DoDot:1
+8 SET TSEG=$PIECE(WORK,U,I,I+4)
+9 SET TT=$PIECE(TSEG,U,3)
+10 if TSEG="^^^^"!("^HX^AL^AA^DL^ML^RL^SL^CB^AD^WP^TR^TV^"'[(U_TT_U))
QUIT
+11 SET TCN=TCN_TSEG_"^"
End DoDot:1
+12 QUIT TCN
+13 ;
+14 ;
