| [613] | 1 | PRSPESR ;WOIFO/JAH - part-time physicians ESR Edit ;11/16/04
|
|---|
| 2 | ;;4.0;PAID;**93**;Sep 21, 1995;Build 7
|
|---|
| 3 | ;;Per VHA Directive 2004-038, this routine should not be modified.
|
|---|
| 4 | ;
|
|---|
| 5 | ;Allow PTP employee w/ a memorandum to review memo status
|
|---|
| 6 | ;then edit, update, and sign daily ESRs.
|
|---|
| 7 | ;call from option-"Electronic Subsidiary Record".
|
|---|
| 8 | Q
|
|---|
| 9 | ;
|
|---|
| 10 | MAIN ; main entry point called from ESR edit option
|
|---|
| 11 | N PICKLIST,PRSIEN,OUT,PLIST,PICK
|
|---|
| 12 | ;
|
|---|
| 13 | ;get users PRSIEN
|
|---|
| 14 | S PRSIEN=$$PRSIEN^PRSPUT2(1)
|
|---|
| 15 | Q:PRSIEN'>0
|
|---|
| 16 | ;
|
|---|
| 17 | ;While PTP is not done continue
|
|---|
| 18 | ;
|
|---|
| 19 | S OUT=0
|
|---|
| 20 | F D Q:OUT
|
|---|
| 21 | .; BUILD OPTION PICK LIST--MEMO ACTIONS, PRIOR, CURRENT AND NEXT PP ESRs
|
|---|
| 22 | .;
|
|---|
| 23 | .;
|
|---|
| 24 | . K PLIST
|
|---|
| 25 | . D BLDPICK(.PLIST,PRSIEN)
|
|---|
| 26 | .;
|
|---|
| 27 | . W @IOF,!
|
|---|
| 28 | .; get out if there's nothing in the list.
|
|---|
| 29 | . I '$D(PLIST) D Q
|
|---|
| 30 | .. W !,"No ESR records available.",!!!
|
|---|
| 31 | .. S OUT=$$ASK^PRSLIB00(1)
|
|---|
| 32 | .. S OUT=1
|
|---|
| 33 | .; get users choice of action
|
|---|
| 34 | . S PICK=$$CHOICE(.PLIST)
|
|---|
| 35 | . I PICK=0 S OUT=1 Q
|
|---|
| 36 | . I $P(PLIST(PICK),U)="M" D MEMO(PRSIEN,PLIST(PICK)) ;### CALL MEMO OPTION
|
|---|
| 37 | . I "NCP"[$P(PLIST(PICK),U) D
|
|---|
| 38 | .. ;Make sure we have a signature code before continuing
|
|---|
| 39 | .. I '$$ESIGC^PRSPUT2(1) W !! S OUT=$$ASK^PRSLIB00(1) Q
|
|---|
| 40 | .. ;
|
|---|
| 41 | .. D ESR(PRSIEN,$P(PLIST(PICK),U,2),$P(PLIST(PICK),U,3),.OUT)
|
|---|
| 42 | ;
|
|---|
| 43 | Q
|
|---|
| 44 | BLDPICK(PL,PRSIEN) ; Build option pick list with memo, prior ESR,
|
|---|
| 45 | ; current ESR and next ESR actions in the PL array
|
|---|
| 46 | ;PPE,I - current Pay period (E)xternal (I)nternal entry #
|
|---|
| 47 | ;NXPPE
|
|---|
| 48 | ;PI - picklist counter/array subscript
|
|---|
| 49 | ;MAI - memo action counter
|
|---|
| 50 | ;AMIEN - active memo ien for a prior pay period
|
|---|
| 51 | ;Get any actions required for Memorandum.
|
|---|
| 52 | N PI,PPE,NXPPE,MIEN,MAI,PPDT1,AMIEN,MTXT,RANGE,FR,TO,PRTXT
|
|---|
| 53 | S PI=0
|
|---|
| 54 | ; get array of memos with status reconcile started
|
|---|
| 55 | ; this may need to be replaced with API call ###
|
|---|
| 56 | D GETMEMOS(.MIEN,PRSIEN,3)
|
|---|
| 57 | I $G(MIEN(0))>0 D
|
|---|
| 58 | . S MAI=0
|
|---|
| 59 | . F S MAI=$O(MIEN(MAI)) Q:MAI'>0 D
|
|---|
| 60 | .. Q:$P($G(^PRST(458.7,MAI,2)),U)>0
|
|---|
| 61 | .. S PI=PI+1,PL(PI)=$$BLDMACT(MAI,MIEN(MAI))
|
|---|
| 62 | ;
|
|---|
| 63 | ;Travel ESR status xref (<4) )for incomplete ESR days
|
|---|
| 64 | ;
|
|---|
| 65 | S PRTXT="Edit ESR for PRIOR pay period "
|
|---|
| 66 | S PPE=""
|
|---|
| 67 | F S PPE=$O(^PRST(458,"AEA",PRSIEN,PPE)) Q:PPE="" D
|
|---|
| 68 | . S PPI=$O(^PRST(458,"B",PPE,0))
|
|---|
| 69 | . Q:PPI'>0
|
|---|
| 70 | .;### call to active memo API to determine if pp should be edited
|
|---|
| 71 | .; Get 1st day of pp
|
|---|
| 72 | . D NX^PRSAPPU S PPDT1=D1
|
|---|
| 73 | . S AMIEN=+$$MIEN^PRSPUT1(PRSIEN,PPDT1)
|
|---|
| 74 | . I AMIEN>0 D
|
|---|
| 75 | .. S PI=PI+1
|
|---|
| 76 | .. S RANGE=$G(^PRST(458,PPI,2))
|
|---|
| 77 | .. S FR=$P(RANGE,U,1),TO=$P(RANGE,U,14)
|
|---|
| 78 | .. S MTXT=PRTXT_PPE_" ["_FR_" - "_TO_"]"
|
|---|
| 79 | .. S PL(PI)="P^"_PPI_"^"_AMIEN_U_MTXT
|
|---|
| 80 | ;
|
|---|
| 81 | ; current pay period to list, overwrite PI array if current
|
|---|
| 82 | ; pay period is also a prior pay period selection already
|
|---|
| 83 | N PPE,PPI,PP4Y,DAY,D1,PPDT1,AMIEN,OVRITE
|
|---|
| 84 | S (PPDT1,D1)=DT D PP^PRSAPPU
|
|---|
| 85 | I PPI'="" D
|
|---|
| 86 | . S OVRITE=$$PPICHK(.PL,PPI)
|
|---|
| 87 | . I OVRITE>0 S PI=OVRITE
|
|---|
| 88 | . E S PI=PI+1
|
|---|
| 89 | . S AMIEN=+$$MIEN^PRSPUT1(PRSIEN,PPDT1)
|
|---|
| 90 | . I AMIEN>0 D
|
|---|
| 91 | .. S RANGE=$G(^PRST(458,PPI,2))
|
|---|
| 92 | .. S FR=$P(RANGE,U,1),TO=$P(RANGE,U,14)
|
|---|
| 93 | .. S MTXT="Edit ESR for CURRENT pay period "_PPE_" ["_FR_" - "_TO_"]"
|
|---|
| 94 | .. S PL(PI)="C^"_PPI_U_AMIEN_U_MTXT
|
|---|
| 95 | ;
|
|---|
| 96 | ; add next pay period to list if open and covered by memo
|
|---|
| 97 | S PPE=$E($$NXTPP^PRSAPPU(PPE),3,7)
|
|---|
| 98 | D NX^PRSAPPU S PPDT1=D1
|
|---|
| 99 | I $D(^PRST(458,"B",PPE)) D
|
|---|
| 100 | . S PPI=$O(^PRST(458,"B",PPE,0))
|
|---|
| 101 | . S AMIEN=+$$MIEN^PRSPUT1(PRSIEN,PPDT1)
|
|---|
| 102 | . I AMIEN>0 D
|
|---|
| 103 | .. S OVRITE=$$PPICHK(.PL,PPI)
|
|---|
| 104 | .. I OVRITE>0 S PI=OVRITE
|
|---|
| 105 | .. E S PI=PI+1
|
|---|
| 106 | .. S RANGE=$G(^PRST(458,PPI,2))
|
|---|
| 107 | .. S FR=$P(RANGE,U,1),TO=$P(RANGE,U,14)
|
|---|
| 108 | .. S MTXT="Edit ESR for NEXT pay period "_PPE_" ["_FR_" - "_TO_"]"
|
|---|
| 109 | .. S PL(PI)="N^"_PPI_"^"_AMIEN_U_MTXT
|
|---|
| 110 | ;
|
|---|
| 111 | Q
|
|---|
| 112 | ;
|
|---|
| 113 | PPICHK(PRIARY,PPCH) ; Check if Current or next is already in prior array
|
|---|
| 114 | ; RETURN PPI IF FOUND
|
|---|
| 115 | N FOUND,PRNODE
|
|---|
| 116 | S FOUND=0,PRNODE=99
|
|---|
| 117 | F S PRNODE=$O(PRIARY(PRNODE),-1) Q:(PRNODE'>0)!(FOUND>0) D
|
|---|
| 118 | . I PPCH=$P($G(PRIARY(PRNODE)),U,2) S FOUND=PRNODE
|
|---|
| 119 | Q FOUND
|
|---|
| 120 | ;
|
|---|
| 121 | BLDMACT(MIEN,ZNODE) ;with zero node of memo build the item screen
|
|---|
| 122 | ; Sample appearance for menu item
|
|---|
| 123 | N SDT,EDT,TDT,Y,MENUTXT
|
|---|
| 124 | S MENUTXT="M^"_MIEN_"^^Reconcile Prior Memorandum from "
|
|---|
| 125 | ; Reconcile Prior Memorandum from JUL 2004 TO JUL 2005
|
|---|
| 126 | S SDT=$P(ZNODE,U),EDT=$P(ZNODE,U,2),TDT=$P(ZNODE,U,3)
|
|---|
| 127 | I $G(TDT)>0,($G(TDT)<$G(EDT)) S EDT=TDT
|
|---|
| 128 | S Y=SDT D DD^%DT S SDT=Y
|
|---|
| 129 | S Y=EDT D DD^%DT S EDT=Y
|
|---|
| 130 | S MENUTXT=MENUTXT_SDT_" TO "_EDT
|
|---|
| 131 | Q MENUTXT
|
|---|
| 132 | CHOICE(PL,DEF) ; return users choice from array of items in PL
|
|---|
| 133 | ; return 0 for abort
|
|---|
| 134 | N ITEM,ICNT,DIR,DIRUT
|
|---|
| 135 | S ICNT=0
|
|---|
| 136 | I $G(DEF)>0,($G(PL(DEF))'="") D
|
|---|
| 137 | . S DIR("B")=DEF
|
|---|
| 138 | S ITEM=0
|
|---|
| 139 | F S ITEM=$O(PL(ITEM)) Q:ITEM'>0 D
|
|---|
| 140 | . S DIR("A",ITEM)=ITEM_". "_$P($G(PL(ITEM)),U,4)
|
|---|
| 141 | . S ICNT=ICNT+1
|
|---|
| 142 | S DIR(0)="NO^1:"_ICNT_":0"
|
|---|
| 143 | S DIR("A")="Select an Item "
|
|---|
| 144 | D ^DIR
|
|---|
| 145 | S PICK=+$G(Y)
|
|---|
| 146 | I $G(DIRUT) S PICK=0
|
|---|
| 147 | Q PICK
|
|---|
| 148 | ;
|
|---|
| 149 | GETMEMOS(MIEN,PRSIEN,MSTAT) ; Return IEN subscripted array of
|
|---|
| 150 | ; memorandums in a single status (MSTAT)
|
|---|
| 151 | ; INPUT: EMPLOYEE IEN (PRSIEN)
|
|---|
| 152 | ; STATUS OF MEMORANDUM desired (MSTAT)
|
|---|
| 153 | ; 1:NOT STARTED; 2:ACTIVE; 3:RECONCILIATION STARTED;
|
|---|
| 154 | ; 4:RECONCILED;
|
|---|
| 155 | ; OUTPUT: returns MIEN array as follows:
|
|---|
| 156 | ; MIEN(0) = 0 when no reconcile actions:
|
|---|
| 157 | ; OR
|
|---|
| 158 | ; MIEN(0) = integer # of memos that requires reconcile action:
|
|---|
| 159 | ; MIEN(IEN 1)=start date^end date^termination date
|
|---|
| 160 | ; MIEN(IEN n)=start date n ^end date n ^termination date n
|
|---|
| 161 | N ZNODE,TDT,TMPMIEN
|
|---|
| 162 | S MIEN(0)=0
|
|---|
| 163 | Q:$G(MSTAT)'>0!($G(PRSIEN)'>0)
|
|---|
| 164 | S TMPMIEN=0
|
|---|
| 165 | F S TMPMIEN=$O(^PRST(458.7,"AST",PRSIEN,MSTAT,TMPMIEN)) Q:TMPMIEN'>0 D
|
|---|
| 166 | . S ZNODE=$G(^PRST(458.7,TMPMIEN,0))
|
|---|
| 167 | . S TDT=$P($G(^PRST(458.7,TMPMIEN,4)),U)
|
|---|
| 168 | . S MIEN(TMPMIEN)=$P(ZNODE,U,2)_"^"_$P(ZNODE,U,3)_"^"_TDT
|
|---|
| 169 | . S MIEN(0)=MIEN(0)+1
|
|---|
| 170 | Q
|
|---|
| 171 | ;
|
|---|
| 172 | MEMO(PRSIEN,LIST) ; CALL OPTION TO RECONCILE A MEMO
|
|---|
| 173 | ;INPUT : PRSIEN-user 450 ien, LIST-pick list array item for memo
|
|---|
| 174 | N OUT,MIEN
|
|---|
| 175 | S MIEN=$P(LIST,U,2)
|
|---|
| 176 | D MAIN^PRSPSRC(PRSIEN,MIEN)
|
|---|
| 177 | S OUT=$$ASK^PRSLIB00()
|
|---|
| 178 | Q
|
|---|
| 179 | ESR(PRSIEN,PPI,MIEN,OUT) ; DISPLAY PAY PERIOD AND ASK USER TO PICK A DAY
|
|---|
| 180 | ; WHEN THEY PICK A DAY CALL code to start up a ScreenMan
|
|---|
| 181 | ; form for the day record
|
|---|
| 182 | N ESRDAY
|
|---|
| 183 | S OUT=0
|
|---|
| 184 | F D Q:(ESRDAY'>0)
|
|---|
| 185 | . W @IOF
|
|---|
| 186 | . D WSS(PRSIEN,PPI,MIEN)
|
|---|
| 187 | . S ESRDAY=$$WHICHDAY(PPI,PRSIEN)
|
|---|
| 188 | . I $$CANPOST(PPI,PRSIEN,ESRDAY,1) D ESRFRM^PRSPESR1(PRSIEN,PPI,ESRDAY)
|
|---|
| 189 | I ESRDAY<0 S OUT=1
|
|---|
| 190 | Q
|
|---|
| 191 | CANPOST(PPI,PRSIEN,PRSD,SHMSG) ; Can this day be posted by a PTP?
|
|---|
| 192 | ; i show message set to 1 then show message on can't post
|
|---|
| 193 | N CANPOST
|
|---|
| 194 | S CANPOST=0
|
|---|
| 195 | Q:$G(PRSD)'>0 CANPOST
|
|---|
| 196 | N TCSTAT,DUM,ESRSTAT,TCSTAT,TOUR
|
|---|
| 197 | S CANPOST=1
|
|---|
| 198 | ;
|
|---|
| 199 | S TOUR=$P($G(^PRST(458,PPI,"E",PRSIEN,"D",PRSD,0)),U,2)
|
|---|
| 200 | I TOUR'>0 S CANPOST=0 D Q CANPOST
|
|---|
| 201 | . I 'CANPOST&($G(SHMSG)>0) D
|
|---|
| 202 | .. W @IOF,!!!,"A Tour of Duty must be entered first. Please contact your timekeeper.",!!
|
|---|
| 203 | .. S DUM=$$ASK^PRSLIB00(1)
|
|---|
| 204 | ;
|
|---|
| 205 | S ESRSTAT=$$GETSTAT^PRSPESR1(PRSIEN,PPI,PRSD)
|
|---|
| 206 | S TCSTAT=$$TCSTAT^PRSPSAP2(PPI,PRSIEN)
|
|---|
| 207 | I TCSTAT'="T" S CANPOST=(ESRSTAT<5) D
|
|---|
| 208 | . I 'CANPOST&($G(SHMSG)>0) D
|
|---|
| 209 | .. W @IOF,!!!,"Only select days with status 'Not Started, 'Pending', 'Signed', or 'Resubmit'."
|
|---|
| 210 | .. W !,"To edit approved days or days off, contact your Time and Leave Supervisor.",!!
|
|---|
| 211 | .. S DUM=$$ASK^PRSLIB00(1)
|
|---|
| 212 | Q CANPOST
|
|---|
| 213 | ;
|
|---|
| 214 | WSS(PRSIEN,PPI,MIEN) ; WORK SUMMARY SCREEN
|
|---|
| 215 | N SCRTTL
|
|---|
| 216 | S SCRTTL="Work Summary Screen for Part Time VA Physician "
|
|---|
| 217 | D HDR^PRSPUT1(PRSIEN,SCRTTL,,,PPI)
|
|---|
| 218 | D MEM^PRSPUT1(PRSIEN,MIEN)
|
|---|
| 219 | D AL^PRSPUT3(PRSIEN,)
|
|---|
| 220 | D ESRSTAT^PRSPUT2(PRSIEN,PPI)
|
|---|
| 221 | Q
|
|---|
| 222 | WHICHDAY(PPI,PRSIEN,DEF) ; ASK USER TO SELECT A PAY PERIOD DAY
|
|---|
| 223 | ; return 0 for abort OR -1 for double abort "^^"
|
|---|
| 224 | N DIR,DIRUT,TCSTAT,I
|
|---|
| 225 | S DIR(0)="NO^1:14:0"
|
|---|
| 226 | I $G(DEF)>0 S DIR("B")=DEF
|
|---|
| 227 | S DIR("A")="Select day "
|
|---|
| 228 | D ^DIR
|
|---|
| 229 | I $G(DIRUT) D
|
|---|
| 230 | . S PICK=$S($G(Y)["^^":-1,1:0)
|
|---|
| 231 | E D
|
|---|
| 232 | . S PICK=$G(Y)
|
|---|
| 233 | Q PICK
|
|---|
| 234 | Q
|
|---|
