PRSATL ; HISC/REL-Edit/Display T&L Unit ;3/4/1998
;;4.0;PAID;**38**;Sep 21, 1995
EDIT ; Enter/Edit T&L Unit
D HDR K DIC
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
S DA=+Y,DDSFILE=455.5,DR="[PRSA TL EDIT]" D ^DDS K DS G EDIT
DISP ; Display T&L Unit
D HDR K DIC
S DIC="^PRST(455.5,",DIC(0)="AEQM",DIC("A")="Select T&L Unit: " D ^DIC K DIC G:Y'>0 EX
S DA=+Y,DDSFILE=455.5,DR="[PRSA TL DISP]" D ^DDS K DS G DISP
EMP ; Change T&L for an Employee
K DIC S DIC("A")="Select EMPLOYEE: ",DIC(0)="AEQM",(DIC,DIE)="^PRSPC(" W ! D ^DIC S DFN=+Y K DIC
I DFN<1 G EX
S OLD=$P($G(^PRSPC(DFN,0)),"^",8)
S DA=DFN,DR=7 D ^DIE I $P($G(^PRSPC(DFN,0)),"^",8)=OLD G EMP
S PPI=$P(^PRST(458,0),"^",3)
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
S PPI=PPI-1
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
SUP ; Set ASX cross-reference for Supervisor (Obsolete with PRS*4*38)
;S SSN=$P($G(^VA(200,DA,1)),"^",9),STL=""
;I SSN'="" S DFN=$O(^PRSPC("SSN",SSN,0)),STL=$P($G(^PRSPC(+DFN,0)),"^",8)
;F I9=0:0 S I9=$O(^PRST(455.5,"AS",DA,I9)) Q:I9<1 I DA(1)'=I9 D
;.S CTL=$P($G(^PRST(455.5,I9,"S",DA,0)),"^",2)
;.I CTL'="",CTL'=STL,'$D(^PRST(455.5,"ASX",CTL,DA)) S ^PRST(455.5,"ASX",CTL,DA)=""
;.Q
;I X'=STL,'$D(^PRST(455.5,"ASX",X,DA)) S ^PRST(455.5,"ASX",X,DA)=""
Q
ASX ; List ASX Entries and re-index
S PRSTLV=7 D ^PRSAUTL I TLI<1 G EX
W !!,"Employees outside of this T&L who are Certified by this T&L:",!
S (CNT,DA)=0 F S DA=$O(^PRST(455.5,"ASX",TLE,DA)) Q:'DA D
. S SSN=$P($G(^VA(200,DA,1)),U,9) Q:SSN=""
. S DFN=$O(^PRSPC("SSN",SSN,0)) Q:'DFN
. Q:$P($G(^PRSPC(DFN,0)),U,8)=TLE ; don't list if user in T&L
. W !,?4,$P($G(^VA(200,DA,0)),U,1)
. S CNT=CNT+1
W:'CNT !," No Employees outside of this T&L are Certified by this T&L."
W ! S DIR(0)="E",DIR("A")="Press RETURN to continue" D ^DIR K DIR
; the following lines have been commented out by patch PRS*4*38. The
; x-ref should not be casually deleted since certification and approval
; options rely on its existance.
; If necessary IRM can rebuild x-ref via FileMan options.
;K DIR S DIR("A")="Do you wish to Re-Build this Index? ",DIR(0)="YA"
;S DIR("B")="No" W ! D ^DIR K DIR G:'Y EX
;K ^PRST(455.5,"ASX")
; loop thru T&Ls
;S DA(1)=0 F S DA(1)=$O(^PRST(455.5,DA(1))) Q:'DA(1) D
;. S DIK="^PRST(455.5,"_DA(1)_",""S"",",DIK(1)="1^ASX"
;. D ENALL^DIK ; rebuilds xref for all entries in supervisor subfile
K CNT,DA,DFN,DIK,DIR,SSN,TLE,TLI
Q
HDR ; Header
W:$E(IOST,1,2)="C-" @IOF W !?26,"VA TIME & ATTENDANCE SYSTEM",!!?31,"TIME & LEAVE UNIT",!!! Q
EX G KILL^XUSCLEAN
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRSATL 2762 printed Apr 09, 2024@21:30:47 Page 2
PRSATL ; HISC/REL-Edit/Display T&L Unit ;3/4/1998
+1 ;;4.0;PAID;**38**;Sep 21, 1995
EDIT ; Enter/Edit T&L Unit
+1 DO HDR
KILL DIC
+2 SET DIC="^PRST(455.5,"
SET DIC(0)="AEQLM"
SET DLAYGO=455.5
SET DIC("A")="Select T&L Unit: "
DO ^DIC
KILL DIC
if Y'>0
GOTO EX
+3 SET DA=+Y
SET DDSFILE=455.5
SET DR="[PRSA TL EDIT]"
DO ^DDS
KILL DS
GOTO EDIT
DISP ; Display T&L Unit
+1 DO HDR
KILL DIC
+2 SET DIC="^PRST(455.5,"
SET DIC(0)="AEQM"
SET DIC("A")="Select T&L Unit: "
DO ^DIC
KILL DIC
if Y'>0
GOTO EX
+3 SET DA=+Y
SET DDSFILE=455.5
SET DR="[PRSA TL DISP]"
DO ^DDS
KILL DS
GOTO DISP
EMP ; Change T&L for an Employee
+1 KILL DIC
SET DIC("A")="Select EMPLOYEE: "
SET DIC(0)="AEQM"
SET (DIC,DIE)="^PRSPC("
WRITE !
DO ^DIC
SET DFN=+Y
KILL DIC
+2 IF DFN<1
GOTO EX
+3 SET OLD=$PIECE($GET(^PRSPC(DFN,0)),"^",8)
+4 SET DA=DFN
SET DR=7
DO ^DIE
IF $PIECE($GET(^PRSPC(DFN,0)),"^",8)=OLD
GOTO EMP
+5 SET PPI=$PIECE(^PRST(458,0),"^",3)
+6 IF $PIECE($GET(^PRST(458,PPI,"E",DFN,0)),"^",2)="P"
KILL ^(5)
DO ONE^PRS8
SET ^PRST(458,PPI,"E",DFN,5)=VAL
GOTO EMP
+7 SET PPI=PPI-1
+8 IF $PIECE($GET(^PRST(458,PPI,"E",DFN,0)),"^",2)="P"
KILL ^(5)
DO ONE^PRS8
SET ^PRST(458,PPI,"E",DFN,5)=VAL
+9 GOTO EMP
SUP ; Set ASX cross-reference for Supervisor (Obsolete with PRS*4*38)
+1 ;S SSN=$P($G(^VA(200,DA,1)),"^",9),STL=""
+2 ;I SSN'="" S DFN=$O(^PRSPC("SSN",SSN,0)),STL=$P($G(^PRSPC(+DFN,0)),"^",8)
+3 ;F I9=0:0 S I9=$O(^PRST(455.5,"AS",DA,I9)) Q:I9<1 I DA(1)'=I9 D
+4 ;.S CTL=$P($G(^PRST(455.5,I9,"S",DA,0)),"^",2)
+5 ;.I CTL'="",CTL'=STL,'$D(^PRST(455.5,"ASX",CTL,DA)) S ^PRST(455.5,"ASX",CTL,DA)=""
+6 ;.Q
+7 ;I X'=STL,'$D(^PRST(455.5,"ASX",X,DA)) S ^PRST(455.5,"ASX",X,DA)=""
+8 QUIT
ASX ; List ASX Entries and re-index
+1 SET PRSTLV=7
DO ^PRSAUTL
IF TLI<1
GOTO EX
+2 WRITE !!,"Employees outside of this T&L who are Certified by this T&L:",!
+3 SET (CNT,DA)=0
FOR
SET DA=$ORDER(^PRST(455.5,"ASX",TLE,DA))
if 'DA
QUIT
Begin DoDot:1
+4 SET SSN=$PIECE($GET(^VA(200,DA,1)),U,9)
if SSN=""
QUIT
+5 SET DFN=$ORDER(^PRSPC("SSN",SSN,0))
if 'DFN
QUIT
+6 ; don't list if user in T&L
if $PIECE($GET(^PRSPC(DFN,0)),U,8)=TLE
QUIT
+7 WRITE !,?4,$PIECE($GET(^VA(200,DA,0)),U,1)
+8 SET CNT=CNT+1
End DoDot:1
+9 if 'CNT
WRITE !," No Employees outside of this T&L are Certified by this T&L."
+10 WRITE !
SET DIR(0)="E"
SET DIR("A")="Press RETURN to continue"
DO ^DIR
KILL DIR
+11 ; the following lines have been commented out by patch PRS*4*38. The
+12 ; x-ref should not be casually deleted since certification and approval
+13 ; options rely on its existance.
+14 ; If necessary IRM can rebuild x-ref via FileMan options.
+15 ;K DIR S DIR("A")="Do you wish to Re-Build this Index? ",DIR(0)="YA"
+16 ;S DIR("B")="No" W ! D ^DIR K DIR G:'Y EX
+17 ;K ^PRST(455.5,"ASX")
+18 ; loop thru T&Ls
+19 ;S DA(1)=0 F S DA(1)=$O(^PRST(455.5,DA(1))) Q:'DA(1) D
+20 ;. S DIK="^PRST(455.5,"_DA(1)_",""S"",",DIK(1)="1^ASX"
+21 ;. D ENALL^DIK ; rebuilds xref for all entries in supervisor subfile
+22 KILL CNT,DA,DFN,DIK,DIR,SSN,TLE,TLI
+23 QUIT
HDR ; Header
+1 if $EXTRACT(IOST,1,2)="C-"
WRITE @IOF
WRITE !?26,"VA TIME & ATTENDANCE SYSTEM",!!?31,"TIME & LEAVE UNIT",!!!
QUIT
EX GOTO KILL^XUSCLEAN
