source: WorldVistAEHR/trunk/r/PAID-PRS/PRSPDESR.m@ 1464

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

initial load of WorldVistAEHR
File size: 4.9 KB
Line 
1PRSPDESR ; HISC/MGD - Display PT Phy ESR ;05/01/05
2 ;;4.0;PAID;**93**;Sep 21, 1995;Build 7
3 ;;Per VHA Directive 2004-038, this routine should not be modified.
4PAY ; Payroll Entry
5 S PRSTLV=7
6 D TOP ; print header
7P1 K DIC S DIC("A")="Select EMPLOYEE: ",DIC(0)="AEQM",DIC="^PRSPC("
8 W ! D ^DIC S PRSIEN=+Y K DIC G:PRSIEN<1 EX
9 S TLE=$P($G(^PRSPC(PRSIEN,0)),"^",8)
10 S DIC="^PRST(458,",DIC(0)="AEQM",DIC("A")="Select PAY PERIOD: "
11 W ! D ^DIC K DIC G:Y<1 EX
12 S PPI=+Y
13 S PPE=$P(Y,U,2)
14 D L1 ;ask device
15 G P1 ;ask for employee again
16 ;
17TK ; TimeKeeper Entry
18 S PRSTLV=2 G T0
19 ;
20SUP ; Supervisor Entry
21 S PRSTLV=3
22T0 D TOP ; print header
23 D ^PRSAUTL G:TLI<1 EX
24T1 K DIC S DIC("A")="Select EMPLOYEE: ",DIC(0)="AEQM",DIC="^PRSPC("
25 S DIC("S")="I $P(^(0),""^"",8)=TLE" S D="ATL"_TLE W ! D IX^DIC
26 S PRSIEN=+Y K DIC G:PRSIEN<1 EX
27 S %DT="AEPX",%DT("A")="Posting Date: ",%DT(0)=3041001 W ! D ^%DT
28 G:Y<1 EX
29 S D1=Y S Y=$G(^PRST(458,"AD",D1)),PPI=$P(Y,"^",1)
30 G EX:PPI<1
31 S PPE=$P($G(^PRST(458,PPI,0)),U,1)
32 D L1 ;ask device
33 G T1 ;ask for employee again
34 ;
35EMP ; Employee Entry
36 S PRSTLV=1 D TOP S PRSIEN="",SSN=$P($G(^VA(200,DUZ,1)),"^",9)
37 I SSN'="" S PRSIEN=$O(^PRSPC("SSN",SSN,0))
38 I 'PRSIEN W !!,*7,"Your SSN was not found in both the New Person & Employee File!" G EX
39 S PRSIEN=PRSIEN
40 S TLE=$P($G(^PRSPC(PRSIEN,0)),"^",8)
41 S %DT="AEPX",%DT("A")="Posting Date: ",%DT(0)=3040101 W ! D ^%DT
42 G:Y<1 EX
43 S D1=Y S Y=$G(^PRST(458,"AD",D1)),PPI=$P(Y,"^",1)
44 S MIEN=+$$MIEN^PRSPUT1(PRSIEN,D1)
45 G EX:PPI<1
46 S PPE=$P($G(^PRST(458,PPI,0)),U,1)
47 D L1 G EX
48 ;
49TOP W:$E(IOST,1,2)="C-" @IOF W !?26,"VA TIME & ATTENDANCE SYSTEM"
50 W !?27,"DISPLAY PT PHYSICIAN ESR" Q
51L1 W ! K IOP,%ZIS S %ZIS("A")="Select Device: ",%ZIS="MQ"
52 D ^%ZIS K %ZIS,IOP
53 Q:POP
54 I $D(IO("Q")) D Q
55 . S PRSAPGM="DIS^PRSPDESR",PRSALST="PRSIEN^TLE^PPI^PPE^DATA7"
56 . D QUE^PRSAUTL
57 U IO D DIS
58 I $E(IOST,1,2)="C-",'QT D H1
59 D ^%ZISC K %ZIS,IOP Q
60 ;
61DIS ; Display 14 days
62 ;
63 S PDT=$G(^PRST(458,PPI,2)),STAT=$P($G(^PRST(458,PPI,"E",PRSIEN,0)),"^",2)
64 S QT=0,DASH="",$P(DASH,"_",80)="_"
65 S IDAYS=0
66 F DAY=1:1:14 D Q:QT
67 . S DATA7=$G(^PRST(458,PPI,"E",PRSIEN,"D",DAY,7))
68 . S STAT=$P(DATA7,U,1) ; ESR Daily Status
69 . I STAT<4 S IDAYS=IDAYS+1
70 D HDR1
71 ; Check to see if the PTP had a memorandum during this PP.
72 S DAY1=$P($G(^PRST(458,PPI,1)),U,1)
73 I +$$MIEN^PRSPUT1(PRSIEN,DAY1)=0 D Q:QT
74 . W !!,"This employee did not have an active Memorandum during this Pay Period."
75 . S QT=1
76 F DAY=1:1:14 D Q:QT
77 . S DATA0=$G(^PRST(458,PPI,"E",PRSIEN,"D",DAY,0))
78 . S DATA5=$G(^PRST(458,PPI,"E",PRSIEN,"D",DAY,5))
79 . S DATA6=$G(^PRST(458,PPI,"E",PRSIEN,"D",DAY,6))
80 . S DATA7=$G(^PRST(458,PPI,"E",PRSIEN,"D",DAY,7))
81 . S T1=$P(DATA0,U,2) ; Tour #1
82 . S T1EX=$S(T1:$P($G(^PRST(457.1,T1,0)),U,1),1:"") ; Tour #1 External
83 . S STAT=$P(DATA7,U,1) ; ESR Daily Status
84 . S STATEX=$$EXTERNAL^DILFD(458.02,146,"",STAT)
85 . W !,$P(PDT,U,DAY),?14,$J(T1,4)," ",T1EX,?68," ",STATEX
86 . S T2=$P(DATA0,U,13) ; Tour #2
87 . I T2 D
88 . . S T2EX=$S(T2:$P($G(^PRST(457.1,T2,0)),U,1),1:"") ; Tour #2 External
89 . . W !?14,$J(T2,4)," ",T2EX
90 . S EDLSM=$P(DATA7,U,3) ; ESR DAY LAST SIGN METHOD
91 . I EDLSM=2 S STATEX=STATEX_" - EA" ; Posted by Extended Absence
92 . S QUIT=0
93 . F SEG=1:5:31 D:$Y>(IOSL-3) HDR Q:QT!(QUIT) D Q:QT!(QUIT)
94 . . S START=$P(DATA5,U,SEG)
95 . . I START="",SEG>1 S QUIT=1
96 . . Q:START=""
97 . . S STOP=$P(DATA5,U,SEG+1),TOT=$P(DATA5,U,SEG+2)
98 . . S TOTEX=""
99 . . I TOT'="" D
100 . . . S TOTEX=$O(^PRST(457.3,"B",TOT,0))
101 . . . S TOTEX=$E($P($G(^PRST(457.3,TOTEX,0)),U,2),1,14)
102 . . . S TOTEX=TOT_" "_TOTEX
103 . . S RC=$P(DATA5,U,SEG+3),MT=$P(DATA5,U,SEG+4)
104 . . S HRS=$$ELAPSE^PRSPESR2(MT,START,STOP)
105 . . W !?21,START,"-",STOP,?36,TOTEX,?56,$J(MT,2)," ",$J(HRS,5)
106 . . D:$Y>(IOSL-3) HDR
107 . . Q:QT!(QUIT)
108 . . I RC'="" D Q:QT!(QUIT)
109 . . . S RCEX=$P($G(^PRST(457.4,RC,0)),U,4)
110 . . . W !?38,RCEX
111 . . . D:$Y>(IOSL-3) HDR
112 . . Q:QT!(QUIT)
113 . Q:QT
114 . ;
115 . ; Display any PTP or Supervisor Remarks
116 . S PTPRMKS=$P(DATA6,U,1) ; PTP Remarks
117 . I PTPRMKS'="" D Q:QT!(QUIT)
118 . . W !," PTP Remarks: ",PTPRMKS
119 . . D:$Y>(IOSL-3) HDR
120 . S SUPRMKS=$P(DATA6,U,2) ; Supervisor Remarks
121 . I SUPRMKS'="" D Q:QT!(QUIT)
122 . . W !," Sup Remarks: ",SUPRMKS
123 . . D:$Y>(IOSL-3) HDR
124 Q
125 ;====================================================================
126HDR ; Display Header
127 D H1 Q:QT W @IOF
128HDR1 S SCRTTL="PT PHYSICIAN ESR FOR PP "_PPE
129 D HDR^PRSPUT1(PRSIEN,SCRTTL,,,PPI)
130 W !?30,"Incomplete Days: "_$J(IDAYS,2)
131 W !,"Day",?14,"Tour Description",?69,"Status"
132 W !?21,"Postings",?36,"Time Code",?55,"Meal Hours"
133 W !?38,"Remarks Code"
134 W !,DASH
135 Q
136 ;
137H1 I $E(IOST,1,2)="C-" D
138 . W !
139 . S DIR(0)="E",DIR("A")="Press RETURN to continue"
140 . D ^DIR K DIR
141 . I $D(DIRUT) S QT=1
142 Q
143EX ; Clean up variables
144 K D,D1,DASH,DATA0,DATA5,DATA6,DATA7,DAY,DAY1,DIRUT,EDLSM,HRS,IDAYS
145 K MIEN,MT,PDT,POP,PPE,PPI,PRSALST,PRSAPGM,PRSIEN,PRSTLV,PTPRMKS,QUIT
146 K QT,RC,RCEX,SCRTTL,SEG,SSN,START,STAT,STATEX,SUPRMKS,STOP,T1,T1EX
147 K T2,T2EX,TLE,TLI,TLSCREEN,TOT,TOTEX,X,Y,%DT,%ZIS
148 Q
Note: See TracBrowser for help on using the repository browser.