source: WorldVistAEHR/trunk/r/PAID-PRS/PRSPSAP1.m@ 619

Last change on this file since 619 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR

File size: 5.5 KB
Line 
1PRSPSAP1 ;WOIFO/JAH - part time physician, supervisory approvals ;10/22/04
2 ;;4.0;PAID;**93**;Sep 21, 1995;Build 7
3 ;;Per VHA Directive 2004-038, this routine should not be modified.
4 Q
5HDRESR(PRSIEN,PPI,LINES) ; Display a Supervisor Header
6 ; PRSIEN - users 450 number
7 ; PPI - what pay period
8 N CO,NM,SSN,TL,PPE,PPTXT,INCD
9 Q:(PRSIEN'>0)
10 S C0=^PRSPC(PRSIEN,0)
11 S NM=$P(C0,U,1)
12 S SSN=$P(C0,U,9),SSN="XXX-XX-"_$E(SSN,6,9)
13 S TL=$P(C0,"^",8),TL="T&L: "_TL
14 I $G(PPI)>0 S PPE=$P($G(^PRST(458,PPI,0)),U)
15 I $G(PPE)="" S PPE="?????"
16 S PPTXT="Pay Per: "_PPE
17 S INCD=$$INCESRS^PRSPESR3(PRSIEN,PPI)
18 S INCD="Incomplete Days: "_INCD
19 W @IOF," VA TIME & ATTENDANCE SYSTEM"
20 W !,PPTXT,?20,"Supervisory Review for Part Time Physicians in "_TL
21 W !,$E(NM,1,30),?32,SSN,?56,INCD
22 W ! D COLHDRS
23 W ! F I=1:1:(IOM-1) W "-"
24 S LINES=7
25 Q
26COLHDRS ; JUST THE COLUMN HEADERS
27 W !,"Item",?8,"Date",?17,"Scheduled Tour",?36,"Work/Leave Posted"
28 W ?61,"Hours",?67,"Meal",?73,"Status"
29 Q
30PUSH(PPI,PRSIEN,PRSD,CNT) ; ADD record to approval list
31 ; set up a xref on the day. This enables quick access to the
32 ; day number when the pick list has 4 items spread over the
33 ; pay period. (e.g. the first item is day 4, the 2nd item
34 ; is day 12, etc.)
35 ;
36 N NM
37 ; Set up name x-ref for alphabetical review
38 S NM=$P($G(^PRSPC(PRSIEN,0)),U)
39 S ^TMP($J,"PRSPSAP",PRSIEN,PPI,PRSD,0)=""
40 S ^TMP($J,"PRSPSAP","B",NM,PRSIEN)=""
41 S ^TMP($J,"PRSPSAP",PRSIEN,PPI,"B",CNT)=PRSD
42 Q
43GETESR(ESR,PPI,PRSIEN,PRSD) ; GET ESR RELATED DATA
44 ; RETURN DATA IN ESR ARRAY BY REFERENCE
45 ;
46 N PRSN1,TOD,LSGN,METHOD,PRSN4
47 S PRSN1=$G(^PRST(458,PPI,"E",PRSIEN,"D",PRSD,1)) ; tour segmts node
48 S PRSN4=$G(^PRST(458,PPI,"E",PRSIEN,"D",PRSD,4)) ; 2ND tour segmts node
49 S TOD=$P($G(^PRST(458,PPI,"E",PRSIEN,"D",PRSD,0)),U,2)
50 S ESR("TOD")=TOD
51 S ESR("TODEXT")=$$GETTOUR^PRSPESR3(PRSIEN,PRSD,TOD,PRSN1,PRSN4)
52 S ESR("TOD2")=$P($G(^PRST(458,PPI,"E",PRSIEN,"D",PRSD,0)),U,13)
53 S ESR("WORK")=$G(^PRST(458,PPI,"E",PRSIEN,"D",PRSD,5))
54 I $P(ESR("WORK"),U)="" D
55 .; get ESR DAY LAST SIGN METHOD
56 . S LSGN=$P($G(^PRST(458,PPI,"E",PRSIEN,"D",PRSD,7)),U,3)
57 . I LSGN'>0 S LSGN=1
58 . S METHOD=$$EXTERNAL^DILFD(458.02,149,"",LSGN,)
59 . S ESR("WORK")="No work:signed-"_METHOD
60 S ESR("RMK")=$P($G(^PRST(458,PPI,"E",PRSIEN,"D",PRSD,6)),U)
61 S ESR("ML")=$P($G(^PRST(457.1,TOD,0)),U,3)
62 ; esr status must be SIGNED initially to appear in this option
63 S ESR("STAT")=$P($G(^PRST(458,PPI,"E",PRSIEN,"D",PRSD,7)),"^",1)
64 Q
65 ;
66ASALIST(OUT) ; ADD record to approval list
67 ;
68 N PRSIEN,PPI,PRSD,MOVEON,OUT,ACT,ESRDTS,NM
69 ;
70 ; MOVEON : flag to indicate superV is done with this PTP's pp ESR.
71 ;
72 S OUT=0
73 S (ACT,NM)=""
74 F S NM=$O(^TMP($J,"PRSPSAP","B",NM)) Q:NM=""!OUT D
75 . S PRSIEN=$O(^TMP($J,"PRSPSAP","B",NM,0))
76 . I PRSIEN'>0 S OUT=1 Q
77 . S PPI=0
78 . F S PPI=$O(^TMP($J,"PRSPSAP",PRSIEN,PPI)) Q:PPI'>0!OUT D
79 ..;
80 ..; REWORK THIS EMPLOYEE UNTIL WE'RE DONE
81 ..;
82 .. S MOVEON=0
83 .. F D Q:MOVEON
84 ... D DISPLAY^PRSPSAPU(PRSIEN,PPI)
85 ... D ESRDTS^PRSPSAPU(.ESRDTS,PRSIEN,PPI)
86 ... S ACT=$$GETACT^PRSPSAP(.ESRDTS,PRSIEN,PPI)
87 ...; if user hit return and all days are marked w/status then moveon
88 ... I ACT="" S MOVEON=$$MOVEON(PRSIEN,PPI) Q
89 ...; did user type a caret to abort?
90 ... I ACT=0 S (OUT,MOVEON)=1 Q
91 ...; either mark a single day or mark remaining unmarked
92 ...; days depending on ACT
93 ... ; ^ at second prompt should redisplay esr period
94 ... Q:ACT<0
95 ...; mark the action on the day
96 ... D MARK^PRSPSAP3(ACT,PRSIEN,PPI)
97 Q
98HDROPT ; MAIN OPTION HEADING
99 W:$E(IOST,1,2)="C-" @IOF
100 N TAB,TITLE
101 S TITLE="SUPERVISOR'S APPROVAL FOR PT PHYSICIAN'S ELECTRONIC SUBSIDIARY RECORDS"
102 S TAB=IOM-$L(TITLE)/2
103 W !?26,"VA TIME & ATTENDANCE SYSTEM",!?TAB,TITLE
104 Q
105ANYACT(ACTCNT) ; RETURN NUMBER OF ESR DAILY ACTIONS TO UPDATE
106 ; THIS IS A COUNT OF ALL THE RESUBMITS AND APPROVES
107 ;
108 N PRSIEN,PPI,PRSD,ACT
109 S (ACTCNT,ACTCNT("R"),ACTCNT("A"),ACTCNT("B"),ACTCNT("N"))=0
110 S PRSIEN=0
111 F S PRSIEN=$O(^TMP($J,"PRSPSAP",PRSIEN)) Q:PRSIEN'>0 D
112 . S PPI=0
113 . F S PPI=$O(^TMP($J,"PRSPSAP",PRSIEN,PPI)) Q:PPI'>0 D
114 .. S PRSD=0
115 .. F S PRSD=$O(^TMP($J,"PRSPSAP",PRSIEN,PPI,PRSD)) Q:PRSD'>0 D
116 ... S ACT=$G(^TMP($J,"PRSPSAP",PRSIEN,PPI,PRSD,1))
117 ... I ACT="A" S ACTCNT=ACTCNT+1,ACTCNT("A")=ACTCNT("A")+1 Q
118 ... I ACT="R" S ACTCNT=ACTCNT+1,ACTCNT("R")=ACTCNT("R")+1 Q
119 ... I ACT="B" S ACTCNT("B")=ACTCNT("B")+1 Q
120 ... S ACTCNT("N")=ACTCNT("N")+1
121 Q
122MARKCNT(MC,PRSIEN,PPI) ; return items marked AND total items in MC array
123 ; MC = items marked with any status
124 ; MC(1) = available items to mark count
125 ;
126 N ACT,PRSD
127 S (MC,MC(1))=0
128 Q:(PRSIEN'>0)!(PPI'>0)
129 S PRSD=0
130 F S PRSD=$O(^TMP($J,"PRSPSAP",PRSIEN,PPI,PRSD)) Q:PRSD'>0 D
131 . S ACT=$G(^TMP($J,"PRSPSAP",PRSIEN,PPI,PRSD,1))
132 . ; increment the counter for days marked by the supervisor already
133 . I "^A^B^R^"[(U_ACT_U) S MC(1)=MC(1)+1
134 . S MC=MC+1
135 Q
136 ;
137MOVEON(PRSIEN,PPI) ; return users choice (MOVE ON OR REDISPLAY CURR PTP)
138 ; return 0 for abort
139 ; if the number of days available for approval matches the number
140 ; of days that have some status marked then we will not ask the
141 ; user whether they want to move on or not.
142 ;
143 N CT,MOVEON
144 S MOVEON=1
145 D MARKCNT^PRSPSAP1(.CT,PRSIEN,PPI)
146 Q:$G(CT)=$G(CT(1)) MOVEON
147 N DIR,DIRUT
148 S MOVEON=0
149 S DIR(0)="Y"
150 S DIR("?")="Enter NO to continue editing this part-time physician."
151 S DIR("?",1)="Not all days are marked with a status. Answer YES to"
152 S DIR("?",2)="ignore these days and move past this part-time physician."
153 S DIR("A")="Are you done with this employee"
154 D ^DIR
155 S MOVEON=$G(Y)
156 I $G(DIRUT) S MOVEON=1
157 Q MOVEON
Note: See TracBrowser for help on using the repository browser.