- 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 Feb 18, 2025@23:51:08 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