- 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 Jan 18, 2025@03:29:32 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