PRSPESR ;WOIFO/JAH - part-time physicians ESR Edit ;11/16/04
;;4.0;PAID;**93**;Sep 21, 1995;Build 7
;;Per VHA Directive 2004-038, this routine should not be modified.
;
;Allow PTP employee w/ a memorandum to review memo status
;then edit, update, and sign daily ESRs.
;call from option-"Electronic Subsidiary Record".
Q
;
MAIN ; main entry point called from ESR edit option
N PICKLIST,PRSIEN,OUT,PLIST,PICK
;
;get users PRSIEN
S PRSIEN=$$PRSIEN^PRSPUT2(1)
Q:PRSIEN'>0
;
;While PTP is not done continue
;
S OUT=0
F D Q:OUT
.; BUILD OPTION PICK LIST--MEMO ACTIONS, PRIOR, CURRENT AND NEXT PP ESRs
.;
.;
. K PLIST
. D BLDPICK(.PLIST,PRSIEN)
.;
. W @IOF,!
.; get out if there's nothing in the list.
. I '$D(PLIST) D Q
.. W !,"No ESR records available.",!!!
.. S OUT=$$ASK^PRSLIB00(1)
.. S OUT=1
.; get users choice of action
. S PICK=$$CHOICE(.PLIST)
. I PICK=0 S OUT=1 Q
. I $P(PLIST(PICK),U)="M" D MEMO(PRSIEN,PLIST(PICK)) ;### CALL MEMO OPTION
. I "NCP"[$P(PLIST(PICK),U) D
.. ;Make sure we have a signature code before continuing
.. I '$$ESIGC^PRSPUT2(1) W !! S OUT=$$ASK^PRSLIB00(1) Q
.. ;
.. D ESR(PRSIEN,$P(PLIST(PICK),U,2),$P(PLIST(PICK),U,3),.OUT)
;
Q
BLDPICK(PL,PRSIEN) ; Build option pick list with memo, prior ESR,
; current ESR and next ESR actions in the PL array
;PPE,I - current Pay period (E)xternal (I)nternal entry #
;NXPPE
;PI - picklist counter/array subscript
;MAI - memo action counter
;AMIEN - active memo ien for a prior pay period
;Get any actions required for Memorandum.
N PI,PPE,NXPPE,MIEN,MAI,PPDT1,AMIEN,MTXT,RANGE,FR,TO,PRTXT
S PI=0
; get array of memos with status reconcile started
; this may need to be replaced with API call ###
D GETMEMOS(.MIEN,PRSIEN,3)
I $G(MIEN(0))>0 D
. S MAI=0
. F S MAI=$O(MIEN(MAI)) Q:MAI'>0 D
.. Q:$P($G(^PRST(458.7,MAI,2)),U)>0
.. S PI=PI+1,PL(PI)=$$BLDMACT(MAI,MIEN(MAI))
;
;Travel ESR status xref (<4) )for incomplete ESR days
;
S PRTXT="Edit ESR for PRIOR pay period "
S PPE=""
F S PPE=$O(^PRST(458,"AEA",PRSIEN,PPE)) Q:PPE="" D
. S PPI=$O(^PRST(458,"B",PPE,0))
. Q:PPI'>0
.;### call to active memo API to determine if pp should be edited
.; Get 1st day of pp
. D NX^PRSAPPU S PPDT1=D1
. S AMIEN=+$$MIEN^PRSPUT1(PRSIEN,PPDT1)
. I AMIEN>0 D
.. S PI=PI+1
.. S RANGE=$G(^PRST(458,PPI,2))
.. S FR=$P(RANGE,U,1),TO=$P(RANGE,U,14)
.. S MTXT=PRTXT_PPE_" ["_FR_" - "_TO_"]"
.. S PL(PI)="P^"_PPI_"^"_AMIEN_U_MTXT
;
; current pay period to list, overwrite PI array if current
; pay period is also a prior pay period selection already
N PPE,PPI,PP4Y,DAY,D1,PPDT1,AMIEN,OVRITE
S (PPDT1,D1)=DT D PP^PRSAPPU
I PPI'="" D
. S OVRITE=$$PPICHK(.PL,PPI)
. I OVRITE>0 S PI=OVRITE
. E S PI=PI+1
. S AMIEN=+$$MIEN^PRSPUT1(PRSIEN,PPDT1)
. I AMIEN>0 D
.. S RANGE=$G(^PRST(458,PPI,2))
.. S FR=$P(RANGE,U,1),TO=$P(RANGE,U,14)
.. S MTXT="Edit ESR for CURRENT pay period "_PPE_" ["_FR_" - "_TO_"]"
.. S PL(PI)="C^"_PPI_U_AMIEN_U_MTXT
;
; add next pay period to list if open and covered by memo
S PPE=$E($$NXTPP^PRSAPPU(PPE),3,7)
D NX^PRSAPPU S PPDT1=D1
I $D(^PRST(458,"B",PPE)) D
. S PPI=$O(^PRST(458,"B",PPE,0))
. S AMIEN=+$$MIEN^PRSPUT1(PRSIEN,PPDT1)
. I AMIEN>0 D
.. S OVRITE=$$PPICHK(.PL,PPI)
.. I OVRITE>0 S PI=OVRITE
.. E S PI=PI+1
.. S RANGE=$G(^PRST(458,PPI,2))
.. S FR=$P(RANGE,U,1),TO=$P(RANGE,U,14)
.. S MTXT="Edit ESR for NEXT pay period "_PPE_" ["_FR_" - "_TO_"]"
.. S PL(PI)="N^"_PPI_"^"_AMIEN_U_MTXT
;
Q
;
PPICHK(PRIARY,PPCH) ; Check if Current or next is already in prior array
; RETURN PPI IF FOUND
N FOUND,PRNODE
S FOUND=0,PRNODE=99
F S PRNODE=$O(PRIARY(PRNODE),-1) Q:(PRNODE'>0)!(FOUND>0) D
. I PPCH=$P($G(PRIARY(PRNODE)),U,2) S FOUND=PRNODE
Q FOUND
;
BLDMACT(MIEN,ZNODE) ;with zero node of memo build the item screen
; Sample appearance for menu item
N SDT,EDT,TDT,Y,MENUTXT
S MENUTXT="M^"_MIEN_"^^Reconcile Prior Memorandum from "
; Reconcile Prior Memorandum from JUL 2004 TO JUL 2005
S SDT=$P(ZNODE,U),EDT=$P(ZNODE,U,2),TDT=$P(ZNODE,U,3)
I $G(TDT)>0,($G(TDT)<$G(EDT)) S EDT=TDT
S Y=SDT D DD^%DT S SDT=Y
S Y=EDT D DD^%DT S EDT=Y
S MENUTXT=MENUTXT_SDT_" TO "_EDT
Q MENUTXT
CHOICE(PL,DEF) ; return users choice from array of items in PL
; return 0 for abort
N ITEM,ICNT,DIR,DIRUT
S ICNT=0
I $G(DEF)>0,($G(PL(DEF))'="") D
. S DIR("B")=DEF
S ITEM=0
F S ITEM=$O(PL(ITEM)) Q:ITEM'>0 D
. S DIR("A",ITEM)=ITEM_". "_$P($G(PL(ITEM)),U,4)
. S ICNT=ICNT+1
S DIR(0)="NO^1:"_ICNT_":0"
S DIR("A")="Select an Item "
D ^DIR
S PICK=+$G(Y)
I $G(DIRUT) S PICK=0
Q PICK
;
GETMEMOS(MIEN,PRSIEN,MSTAT) ; Return IEN subscripted array of
; memorandums in a single status (MSTAT)
; INPUT: EMPLOYEE IEN (PRSIEN)
; STATUS OF MEMORANDUM desired (MSTAT)
; 1:NOT STARTED; 2:ACTIVE; 3:RECONCILIATION STARTED;
; 4:RECONCILED;
; OUTPUT: returns MIEN array as follows:
; MIEN(0) = 0 when no reconcile actions:
; OR
; MIEN(0) = integer # of memos that requires reconcile action:
; MIEN(IEN 1)=start date^end date^termination date
; MIEN(IEN n)=start date n ^end date n ^termination date n
N ZNODE,TDT,TMPMIEN
S MIEN(0)=0
Q:$G(MSTAT)'>0!($G(PRSIEN)'>0)
S TMPMIEN=0
F S TMPMIEN=$O(^PRST(458.7,"AST",PRSIEN,MSTAT,TMPMIEN)) Q:TMPMIEN'>0 D
. S ZNODE=$G(^PRST(458.7,TMPMIEN,0))
. S TDT=$P($G(^PRST(458.7,TMPMIEN,4)),U)
. S MIEN(TMPMIEN)=$P(ZNODE,U,2)_"^"_$P(ZNODE,U,3)_"^"_TDT
. S MIEN(0)=MIEN(0)+1
Q
;
MEMO(PRSIEN,LIST) ; CALL OPTION TO RECONCILE A MEMO
;INPUT : PRSIEN-user 450 ien, LIST-pick list array item for memo
N OUT,MIEN
S MIEN=$P(LIST,U,2)
D MAIN^PRSPSRC(PRSIEN,MIEN)
S OUT=$$ASK^PRSLIB00()
Q
ESR(PRSIEN,PPI,MIEN,OUT) ; DISPLAY PAY PERIOD AND ASK USER TO PICK A DAY
; WHEN THEY PICK A DAY CALL code to start up a ScreenMan
; form for the day record
N ESRDAY
S OUT=0
F D Q:(ESRDAY'>0)
. W @IOF
. D WSS(PRSIEN,PPI,MIEN)
. S ESRDAY=$$WHICHDAY(PPI,PRSIEN)
. I $$CANPOST(PPI,PRSIEN,ESRDAY,1) D ESRFRM^PRSPESR1(PRSIEN,PPI,ESRDAY)
I ESRDAY<0 S OUT=1
Q
CANPOST(PPI,PRSIEN,PRSD,SHMSG) ; Can this day be posted by a PTP?
; i show message set to 1 then show message on can't post
N CANPOST
S CANPOST=0
Q:$G(PRSD)'>0 CANPOST
N TCSTAT,DUM,ESRSTAT,TCSTAT,TOUR
S CANPOST=1
;
S TOUR=$P($G(^PRST(458,PPI,"E",PRSIEN,"D",PRSD,0)),U,2)
I TOUR'>0 S CANPOST=0 D Q CANPOST
. I 'CANPOST&($G(SHMSG)>0) D
.. W @IOF,!!!,"A Tour of Duty must be entered first. Please contact your timekeeper.",!!
.. S DUM=$$ASK^PRSLIB00(1)
;
S ESRSTAT=$$GETSTAT^PRSPESR1(PRSIEN,PPI,PRSD)
S TCSTAT=$$TCSTAT^PRSPSAP2(PPI,PRSIEN)
I TCSTAT'="T" S CANPOST=(ESRSTAT<5) D
. I 'CANPOST&($G(SHMSG)>0) D
.. W @IOF,!!!,"Only select days with status 'Not Started, 'Pending', 'Signed', or 'Resubmit'."
.. W !,"To edit approved days or days off, contact your Time and Leave Supervisor.",!!
.. S DUM=$$ASK^PRSLIB00(1)
Q CANPOST
;
WSS(PRSIEN,PPI,MIEN) ; WORK SUMMARY SCREEN
N SCRTTL
S SCRTTL="Work Summary Screen for Part Time VA Physician "
D HDR^PRSPUT1(PRSIEN,SCRTTL,,,PPI)
D MEM^PRSPUT1(PRSIEN,MIEN)
D AL^PRSPUT3(PRSIEN,)
D ESRSTAT^PRSPUT2(PRSIEN,PPI)
Q
WHICHDAY(PPI,PRSIEN,DEF) ; ASK USER TO SELECT A PAY PERIOD DAY
; return 0 for abort OR -1 for double abort "^^"
N DIR,DIRUT,TCSTAT,I
S DIR(0)="NO^1:14:0"
I $G(DEF)>0 S DIR("B")=DEF
S DIR("A")="Select day "
D ^DIR
I $G(DIRUT) D
. S PICK=$S($G(Y)["^^":-1,1:0)
E D
. S PICK=$G(Y)
Q PICK
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRSPESR 7782 printed Dec 13, 2024@02:28:03 Page 2
PRSPESR ;WOIFO/JAH - part-time physicians ESR Edit ;11/16/04
+1 ;;4.0;PAID;**93**;Sep 21, 1995;Build 7
+2 ;;Per VHA Directive 2004-038, this routine should not be modified.
+3 ;
+4 ;Allow PTP employee w/ a memorandum to review memo status
+5 ;then edit, update, and sign daily ESRs.
+6 ;call from option-"Electronic Subsidiary Record".
+7 QUIT
+8 ;
MAIN ; main entry point called from ESR edit option
+1 NEW PICKLIST,PRSIEN,OUT,PLIST,PICK
+2 ;
+3 ;get users PRSIEN
+4 SET PRSIEN=$$PRSIEN^PRSPUT2(1)
+5 if PRSIEN'>0
QUIT
+6 ;
+7 ;While PTP is not done continue
+8 ;
+9 SET OUT=0
+10 FOR
Begin DoDot:1
+11 ; BUILD OPTION PICK LIST--MEMO ACTIONS, PRIOR, CURRENT AND NEXT PP ESRs
+12 ;
+13 ;
+14 KILL PLIST
+15 DO BLDPICK(.PLIST,PRSIEN)
+16 ;
+17 WRITE @IOF,!
+18 ; get out if there's nothing in the list.
+19 IF '$DATA(PLIST)
Begin DoDot:2
+20 WRITE !,"No ESR records available.",!!!
+21 SET OUT=$$ASK^PRSLIB00(1)
+22 SET OUT=1
End DoDot:2
QUIT
+23 ; get users choice of action
+24 SET PICK=$$CHOICE(.PLIST)
+25 IF PICK=0
SET OUT=1
QUIT
+26 ;### CALL MEMO OPTION
IF $PIECE(PLIST(PICK),U)="M"
DO MEMO(PRSIEN,PLIST(PICK))
+27 IF "NCP"[$PIECE(PLIST(PICK),U)
Begin DoDot:2
+28 ;Make sure we have a signature code before continuing
+29 IF '$$ESIGC^PRSPUT2(1)
WRITE !!
SET OUT=$$ASK^PRSLIB00(1)
QUIT
+30 ;
+31 DO ESR(PRSIEN,$PIECE(PLIST(PICK),U,2),$PIECE(PLIST(PICK),U,3),.OUT)
End DoDot:2
End DoDot:1
if OUT
QUIT
+32 ;
+33 QUIT
BLDPICK(PL,PRSIEN) ; Build option pick list with memo, prior ESR,
+1 ; current ESR and next ESR actions in the PL array
+2 ;PPE,I - current Pay period (E)xternal (I)nternal entry #
+3 ;NXPPE
+4 ;PI - picklist counter/array subscript
+5 ;MAI - memo action counter
+6 ;AMIEN - active memo ien for a prior pay period
+7 ;Get any actions required for Memorandum.
+8 NEW PI,PPE,NXPPE,MIEN,MAI,PPDT1,AMIEN,MTXT,RANGE,FR,TO,PRTXT
+9 SET PI=0
+10 ; get array of memos with status reconcile started
+11 ; this may need to be replaced with API call ###
+12 DO GETMEMOS(.MIEN,PRSIEN,3)
+13 IF $GET(MIEN(0))>0
Begin DoDot:1
+14 SET MAI=0
+15 FOR
SET MAI=$ORDER(MIEN(MAI))
if MAI'>0
QUIT
Begin DoDot:2
+16 if $PIECE($GET(^PRST(458.7,MAI,2)),U)>0
QUIT
+17 SET PI=PI+1
SET PL(PI)=$$BLDMACT(MAI,MIEN(MAI))
End DoDot:2
End DoDot:1
+18 ;
+19 ;Travel ESR status xref (<4) )for incomplete ESR days
+20 ;
+21 SET PRTXT="Edit ESR for PRIOR pay period "
+22 SET PPE=""
+23 FOR
SET PPE=$ORDER(^PRST(458,"AEA",PRSIEN,PPE))
if PPE=""
QUIT
Begin DoDot:1
+24 SET PPI=$ORDER(^PRST(458,"B",PPE,0))
+25 if PPI'>0
QUIT
+26 ;### call to active memo API to determine if pp should be edited
+27 ; Get 1st day of pp
+28 DO NX^PRSAPPU
SET PPDT1=D1
+29 SET AMIEN=+$$MIEN^PRSPUT1(PRSIEN,PPDT1)
+30 IF AMIEN>0
Begin DoDot:2
+31 SET PI=PI+1
+32 SET RANGE=$GET(^PRST(458,PPI,2))
+33 SET FR=$PIECE(RANGE,U,1)
SET TO=$PIECE(RANGE,U,14)
+34 SET MTXT=PRTXT_PPE_" ["_FR_" - "_TO_"]"
+35 SET PL(PI)="P^"_PPI_"^"_AMIEN_U_MTXT
End DoDot:2
End DoDot:1
+36 ;
+37 ; current pay period to list, overwrite PI array if current
+38 ; pay period is also a prior pay period selection already
+39 NEW PPE,PPI,PP4Y,DAY,D1,PPDT1,AMIEN,OVRITE
+40 SET (PPDT1,D1)=DT
DO PP^PRSAPPU
+41 IF PPI'=""
Begin DoDot:1
+42 SET OVRITE=$$PPICHK(.PL,PPI)
+43 IF OVRITE>0
SET PI=OVRITE
+44 IF '$TEST
SET PI=PI+1
+45 SET AMIEN=+$$MIEN^PRSPUT1(PRSIEN,PPDT1)
+46 IF AMIEN>0
Begin DoDot:2
+47 SET RANGE=$GET(^PRST(458,PPI,2))
+48 SET FR=$PIECE(RANGE,U,1)
SET TO=$PIECE(RANGE,U,14)
+49 SET MTXT="Edit ESR for CURRENT pay period "_PPE_" ["_FR_" - "_TO_"]"
+50 SET PL(PI)="C^"_PPI_U_AMIEN_U_MTXT
End DoDot:2
End DoDot:1
+51 ;
+52 ; add next pay period to list if open and covered by memo
+53 SET PPE=$EXTRACT($$NXTPP^PRSAPPU(PPE),3,7)
+54 DO NX^PRSAPPU
SET PPDT1=D1
+55 IF $DATA(^PRST(458,"B",PPE))
Begin DoDot:1
+56 SET PPI=$ORDER(^PRST(458,"B",PPE,0))
+57 SET AMIEN=+$$MIEN^PRSPUT1(PRSIEN,PPDT1)
+58 IF AMIEN>0
Begin DoDot:2
+59 SET OVRITE=$$PPICHK(.PL,PPI)
+60 IF OVRITE>0
SET PI=OVRITE
+61 IF '$TEST
SET PI=PI+1
+62 SET RANGE=$GET(^PRST(458,PPI,2))
+63 SET FR=$PIECE(RANGE,U,1)
SET TO=$PIECE(RANGE,U,14)
+64 SET MTXT="Edit ESR for NEXT pay period "_PPE_" ["_FR_" - "_TO_"]"
+65 SET PL(PI)="N^"_PPI_"^"_AMIEN_U_MTXT
End DoDot:2
End DoDot:1
+66 ;
+67 QUIT
+68 ;
PPICHK(PRIARY,PPCH) ; Check if Current or next is already in prior array
+1 ; RETURN PPI IF FOUND
+2 NEW FOUND,PRNODE
+3 SET FOUND=0
SET PRNODE=99
+4 FOR
SET PRNODE=$ORDER(PRIARY(PRNODE),-1)
if (PRNODE'>0)!(FOUND>0)
QUIT
Begin DoDot:1
+5 IF PPCH=$PIECE($GET(PRIARY(PRNODE)),U,2)
SET FOUND=PRNODE
End DoDot:1
+6 QUIT FOUND
+7 ;
BLDMACT(MIEN,ZNODE) ;with zero node of memo build the item screen
+1 ; Sample appearance for menu item
+2 NEW SDT,EDT,TDT,Y,MENUTXT
+3 SET MENUTXT="M^"_MIEN_"^^Reconcile Prior Memorandum from "
+4 ; Reconcile Prior Memorandum from JUL 2004 TO JUL 2005
+5 SET SDT=$PIECE(ZNODE,U)
SET EDT=$PIECE(ZNODE,U,2)
SET TDT=$PIECE(ZNODE,U,3)
+6 IF $GET(TDT)>0
IF ($GET(TDT)<$GET(EDT))
SET EDT=TDT
+7 SET Y=SDT
DO DD^%DT
SET SDT=Y
+8 SET Y=EDT
DO DD^%DT
SET EDT=Y
+9 SET MENUTXT=MENUTXT_SDT_" TO "_EDT
+10 QUIT MENUTXT
CHOICE(PL,DEF) ; return users choice from array of items in PL
+1 ; return 0 for abort
+2 NEW ITEM,ICNT,DIR,DIRUT
+3 SET ICNT=0
+4 IF $GET(DEF)>0
IF ($GET(PL(DEF))'="")
Begin DoDot:1
+5 SET DIR("B")=DEF
End DoDot:1
+6 SET ITEM=0
+7 FOR
SET ITEM=$ORDER(PL(ITEM))
if ITEM'>0
QUIT
Begin DoDot:1
+8 SET DIR("A",ITEM)=ITEM_". "_$PIECE($GET(PL(ITEM)),U,4)
+9 SET ICNT=ICNT+1
End DoDot:1
+10 SET DIR(0)="NO^1:"_ICNT_":0"
+11 SET DIR("A")="Select an Item "
+12 DO ^DIR
+13 SET PICK=+$GET(Y)
+14 IF $GET(DIRUT)
SET PICK=0
+15 QUIT PICK
+16 ;
GETMEMOS(MIEN,PRSIEN,MSTAT) ; Return IEN subscripted array of
+1 ; memorandums in a single status (MSTAT)
+2 ; INPUT: EMPLOYEE IEN (PRSIEN)
+3 ; STATUS OF MEMORANDUM desired (MSTAT)
+4 ; 1:NOT STARTED; 2:ACTIVE; 3:RECONCILIATION STARTED;
+5 ; 4:RECONCILED;
+6 ; OUTPUT: returns MIEN array as follows:
+7 ; MIEN(0) = 0 when no reconcile actions:
+8 ; OR
+9 ; MIEN(0) = integer # of memos that requires reconcile action:
+10 ; MIEN(IEN 1)=start date^end date^termination date
+11 ; MIEN(IEN n)=start date n ^end date n ^termination date n
+12 NEW ZNODE,TDT,TMPMIEN
+13 SET MIEN(0)=0
+14 if $GET(MSTAT)'>0!($GET(PRSIEN)'>0)
QUIT
+15 SET TMPMIEN=0
+16 FOR
SET TMPMIEN=$ORDER(^PRST(458.7,"AST",PRSIEN,MSTAT,TMPMIEN))
if TMPMIEN'>0
QUIT
Begin DoDot:1
+17 SET ZNODE=$GET(^PRST(458.7,TMPMIEN,0))
+18 SET TDT=$PIECE($GET(^PRST(458.7,TMPMIEN,4)),U)
+19 SET MIEN(TMPMIEN)=$PIECE(ZNODE,U,2)_"^"_$PIECE(ZNODE,U,3)_"^"_TDT
+20 SET MIEN(0)=MIEN(0)+1
End DoDot:1
+21 QUIT
+22 ;
MEMO(PRSIEN,LIST) ; CALL OPTION TO RECONCILE A MEMO
+1 ;INPUT : PRSIEN-user 450 ien, LIST-pick list array item for memo
+2 NEW OUT,MIEN
+3 SET MIEN=$PIECE(LIST,U,2)
+4 DO MAIN^PRSPSRC(PRSIEN,MIEN)
+5 SET OUT=$$ASK^PRSLIB00()
+6 QUIT
ESR(PRSIEN,PPI,MIEN,OUT) ; DISPLAY PAY PERIOD AND ASK USER TO PICK A DAY
+1 ; WHEN THEY PICK A DAY CALL code to start up a ScreenMan
+2 ; form for the day record
+3 NEW ESRDAY
+4 SET OUT=0
+5 FOR
Begin DoDot:1
+6 WRITE @IOF
+7 DO WSS(PRSIEN,PPI,MIEN)
+8 SET ESRDAY=$$WHICHDAY(PPI,PRSIEN)
+9 IF $$CANPOST(PPI,PRSIEN,ESRDAY,1)
DO ESRFRM^PRSPESR1(PRSIEN,PPI,ESRDAY)
End DoDot:1
if (ESRDAY'>0)
QUIT
+10 IF ESRDAY<0
SET OUT=1
+11 QUIT
CANPOST(PPI,PRSIEN,PRSD,SHMSG) ; Can this day be posted by a PTP?
+1 ; i show message set to 1 then show message on can't post
+2 NEW CANPOST
+3 SET CANPOST=0
+4 if $GET(PRSD)'>0
QUIT CANPOST
+5 NEW TCSTAT,DUM,ESRSTAT,TCSTAT,TOUR
+6 SET CANPOST=1
+7 ;
+8 SET TOUR=$PIECE($GET(^PRST(458,PPI,"E",PRSIEN,"D",PRSD,0)),U,2)
+9 IF TOUR'>0
SET CANPOST=0
Begin DoDot:1
+10 IF 'CANPOST&($GET(SHMSG)>0)
Begin DoDot:2
+11 WRITE @IOF,!!!,"A Tour of Duty must be entered first. Please contact your timekeeper.",!!
+12 SET DUM=$$ASK^PRSLIB00(1)
End DoDot:2
End DoDot:1
QUIT CANPOST
+13 ;
+14 SET ESRSTAT=$$GETSTAT^PRSPESR1(PRSIEN,PPI,PRSD)
+15 SET TCSTAT=$$TCSTAT^PRSPSAP2(PPI,PRSIEN)
+16 IF TCSTAT'="T"
SET CANPOST=(ESRSTAT<5)
Begin DoDot:1
+17 IF 'CANPOST&($GET(SHMSG)>0)
Begin DoDot:2
+18 WRITE @IOF,!!!,"Only select days with status 'Not Started, 'Pending', 'Signed', or 'Resubmit'."
+19 WRITE !,"To edit approved days or days off, contact your Time and Leave Supervisor.",!!
+20 SET DUM=$$ASK^PRSLIB00(1)
End DoDot:2
End DoDot:1
+21 QUIT CANPOST
+22 ;
WSS(PRSIEN,PPI,MIEN) ; WORK SUMMARY SCREEN
+1 NEW SCRTTL
+2 SET SCRTTL="Work Summary Screen for Part Time VA Physician "
+3 DO HDR^PRSPUT1(PRSIEN,SCRTTL,,,PPI)
+4 DO MEM^PRSPUT1(PRSIEN,MIEN)
+5 DO AL^PRSPUT3(PRSIEN,)
+6 DO ESRSTAT^PRSPUT2(PRSIEN,PPI)
+7 QUIT
WHICHDAY(PPI,PRSIEN,DEF) ; ASK USER TO SELECT A PAY PERIOD DAY
+1 ; return 0 for abort OR -1 for double abort "^^"
+2 NEW DIR,DIRUT,TCSTAT,I
+3 SET DIR(0)="NO^1:14:0"
+4 IF $GET(DEF)>0
SET DIR("B")=DEF
+5 SET DIR("A")="Select day "
+6 DO ^DIR
+7 IF $GET(DIRUT)
Begin DoDot:1
+8 SET PICK=$SELECT($GET(Y)["^^":-1,1:0)
End DoDot:1
+9 IF '$TEST
Begin DoDot:1
+10 SET PICK=$GET(Y)
End DoDot:1
+11 QUIT PICK
+12 QUIT
