235 lines
7.4 KiB
Mathematica
235 lines
7.4 KiB
Mathematica
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
|