source: FOIAVistA/trunk/r/PAID-PRS/PRSATL.m@ 1397

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

initial load of FOIAVistA 6/30/08 version
File size: 2.6 KB
Line 
1PRSATL ; HISC/REL-Edit/Display T&L Unit ;3/4/1998
2 ;;4.0;PAID;**38**;Sep 21, 1995
3EDIT ; Enter/Edit T&L Unit
4 D HDR K DIC
5 S DIC="^PRST(455.5,",DIC(0)="AEQLM",DLAYGO=455.5,DIC("A")="Select T&L Unit: " D ^DIC K DIC G:Y'>0 EX
6 S DA=+Y,DDSFILE=455.5,DR="[PRSA TL EDIT]" D ^DDS K DS G EDIT
7DISP ; Display T&L Unit
8 D HDR K DIC
9 S DIC="^PRST(455.5,",DIC(0)="AEQM",DIC("A")="Select T&L Unit: " D ^DIC K DIC G:Y'>0 EX
10 S DA=+Y,DDSFILE=455.5,DR="[PRSA TL DISP]" D ^DDS K DS G DISP
11EMP ; Change T&L for an Employee
12 K DIC S DIC("A")="Select EMPLOYEE: ",DIC(0)="AEQM",(DIC,DIE)="^PRSPC(" W ! D ^DIC S DFN=+Y K DIC
13 I DFN<1 G EX
14 S OLD=$P($G(^PRSPC(DFN,0)),"^",8)
15 S DA=DFN,DR=7 D ^DIE I $P($G(^PRSPC(DFN,0)),"^",8)=OLD G EMP
16 S PPI=$P(^PRST(458,0),"^",3)
17 I $P($G(^PRST(458,PPI,"E",DFN,0)),"^",2)="P" K ^(5) D ONE^PRS8 S ^PRST(458,PPI,"E",DFN,5)=VAL G EMP
18 S PPI=PPI-1
19 I $P($G(^PRST(458,PPI,"E",DFN,0)),"^",2)="P" K ^(5) D ONE^PRS8 S ^PRST(458,PPI,"E",DFN,5)=VAL
20 G EMP
21SUP ; Set ASX cross-reference for Supervisor (Obsolete with PRS*4*38)
22 ;S SSN=$P($G(^VA(200,DA,1)),"^",9),STL=""
23 ;I SSN'="" S DFN=$O(^PRSPC("SSN",SSN,0)),STL=$P($G(^PRSPC(+DFN,0)),"^",8)
24 ;F I9=0:0 S I9=$O(^PRST(455.5,"AS",DA,I9)) Q:I9<1 I DA(1)'=I9 D
25 ;.S CTL=$P($G(^PRST(455.5,I9,"S",DA,0)),"^",2)
26 ;.I CTL'="",CTL'=STL,'$D(^PRST(455.5,"ASX",CTL,DA)) S ^PRST(455.5,"ASX",CTL,DA)=""
27 ;.Q
28 ;I X'=STL,'$D(^PRST(455.5,"ASX",X,DA)) S ^PRST(455.5,"ASX",X,DA)=""
29 Q
30ASX ; List ASX Entries and re-index
31 S PRSTLV=7 D ^PRSAUTL I TLI<1 G EX
32 W !!,"Employees outside of this T&L who are Certified by this T&L:",!
33 S (CNT,DA)=0 F S DA=$O(^PRST(455.5,"ASX",TLE,DA)) Q:'DA D
34 . S SSN=$P($G(^VA(200,DA,1)),U,9) Q:SSN=""
35 . S DFN=$O(^PRSPC("SSN",SSN,0)) Q:'DFN
36 . Q:$P($G(^PRSPC(DFN,0)),U,8)=TLE ; don't list if user in T&L
37 . W !,?4,$P($G(^VA(200,DA,0)),U,1)
38 . S CNT=CNT+1
39 W:'CNT !," No Employees outside of this T&L are Certified by this T&L."
40 W ! S DIR(0)="E",DIR("A")="Press RETURN to continue" D ^DIR K DIR
41 ; the following lines have been commented out by patch PRS*4*38. The
42 ; x-ref should not be casually deleted since certification and approval
43 ; options rely on its existance.
44 ; If necessary IRM can rebuild x-ref via FileMan options.
45 ;K DIR S DIR("A")="Do you wish to Re-Build this Index? ",DIR(0)="YA"
46 ;S DIR("B")="No" W ! D ^DIR K DIR G:'Y EX
47 ;K ^PRST(455.5,"ASX")
48 ; loop thru T&Ls
49 ;S DA(1)=0 F S DA(1)=$O(^PRST(455.5,DA(1))) Q:'DA(1) D
50 ;. S DIK="^PRST(455.5,"_DA(1)_",""S"",",DIK(1)="1^ASX"
51 ;. D ENALL^DIK ; rebuilds xref for all entries in supervisor subfile
52 K CNT,DA,DFN,DIK,DIR,SSN,TLE,TLI
53 Q
54HDR ; Header
55 W:$E(IOST,1,2)="C-" @IOF W !?26,"VA TIME & ATTENDANCE SYSTEM",!!?31,"TIME & LEAVE UNIT",!!! Q
56EX G KILL^XUSCLEAN
Note: See TracBrowser for help on using the repository browser.