Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: PRSPUT3

PRSPUT3.m

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