PRSAFEE ; HISC/REL-Fee Basis Appointees ;12/14/00
;;4.0;PAID;**6,64**;Sep 21, 1995
S PRSTLV=2 D ^PRSAUTL G:TLI<1 EX
D1 S %DT="AEPX",%DT("A")="Posting Date: ",%DT("B")="T-1",%DT(0)=-DT W ! D ^%DT
G:Y<1 EX S D1=Y S Y=$G(^PRST(458,"AD",D1)),PPI=$P(Y,"^",1)
I PPI="" W !!,*7,"Pay Period is Not Open Yet!" G EX
N1 D NME G EX:DFN<0,N1:'DFN
I "T"'[STAT W *7,!,"This Employee has already been released to Payroll!" G N1
D POST G N1
NME K DIC S DIC("A")="Select EMPLOYEE: ",DIC("S")="I $P(^(0),""^"",8)=TLE,$D(^PRST(458,PPI,""E"",+Y))",DIC(0)="AEQM",DIC="^PRSPC(",D="ATL"_TLE W ! D IX^DIC S DFN=+Y K DIC
Q:DFN<1 D ^PRSAENT I PP'="F" W !!?5,"Employee is not a Fee Basis Appointee." S DFN=0 Q
S STAT=$P($G(^PRST(458,PPI,"E",DFN,0)),"^",2) Q
POST ; Post Earnings for Pay Period
S DTE=$P($G(^PRST(458,PPI,2)),"^",1)_" to "_$P($G(^(2)),"^",14)
K AUR S AUR(1)=$G(^PRST(458,PPI,"E",DFN,2))
S DDSFILE=458,DDSFILE(1)=458.01,DA(1)=PPI,DA=DFN
S DR="[PRSA FEE POST]" D ^DDS K DS Q:$G(^PRST(458,PPI,"E",DFN,2))=AUR(1)
D NOW^%DTC S NOW=% S $P(^PRST(458,PPI,"E",DFN,2),"^",15,16)=DUZ_"^"_NOW Q
PRP ; Prior Pay Period Update
S PRSTLV=2 D ^PRSAUTL G:TLI<1 EX D NOW^%DTC S DT=%\1,NOW=%
S %DT="AEPX",%DT("A")="Posting Date: ",%DT(0)=-DT W ! D ^%DT
G:Y<1 EX S D1=Y S Y=$G(^PRST(458,"AD",D1)),PPI=$P(Y,"^",1)
I PPI="" W !!,*7,"Pay Period is Not Open Yet!" G EX
D NME G:DFN<1 EX
I "T"[STAT D POST G EX
I STAT'="X" W !!,*7,"Card in Payroll and not transmitted; request return of card." Q
S Z=$G(^PRST(458,PPI,"E",DFN,2))
D POST I $G(^PRST(458,PPI,"E",DFN,2))'=AUR(1) D
.S AUT="V",AUS="R" D ^PRSAUD ; Approve, Notify Payroll
.I $G(AUR(7))["^" K ^PRST(458,PPI,"E",DFN,2) I $D(AUR(1)) D
..S ^PRST(458,PPI,"E",DFN,2)=AUR(1)
G EX
EX G KILL^XUSCLEAN
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRSAFEE 1772 printed Apr 09, 2024@21:32:04 Page 2
PRSAFEE ; HISC/REL-Fee Basis Appointees ;12/14/00
+1 ;;4.0;PAID;**6,64**;Sep 21, 1995
+2 SET PRSTLV=2
DO ^PRSAUTL
if TLI<1
GOTO EX
D1 SET %DT="AEPX"
SET %DT("A")="Posting Date: "
SET %DT("B")="T-1"
SET %DT(0)=-DT
WRITE !
DO ^%DT
+1 if Y<1
GOTO EX
SET D1=Y
SET Y=$GET(^PRST(458,"AD",D1))
SET PPI=$PIECE(Y,"^",1)
+2 IF PPI=""
WRITE !!,*7,"Pay Period is Not Open Yet!"
GOTO EX
N1 DO NME
if DFN<0
GOTO EX
if 'DFN
GOTO N1
+1 IF "T"'[STAT
WRITE *7,!,"This Employee has already been released to Payroll!"
GOTO N1
+2 DO POST
GOTO N1
NME KILL DIC
SET DIC("A")="Select EMPLOYEE: "
SET DIC("S")="I $P(^(0),""^"",8)=TLE,$D(^PRST(458,PPI,""E"",+Y))"
SET DIC(0)="AEQM"
SET DIC="^PRSPC("
SET D="ATL"_TLE
WRITE !
DO IX^DIC
SET DFN=+Y
KILL DIC
+1 if DFN<1
QUIT
DO ^PRSAENT
IF PP'="F"
WRITE !!?5,"Employee is not a Fee Basis Appointee."
SET DFN=0
QUIT
+2 SET STAT=$PIECE($GET(^PRST(458,PPI,"E",DFN,0)),"^",2)
QUIT
POST ; Post Earnings for Pay Period
+1 SET DTE=$PIECE($GET(^PRST(458,PPI,2)),"^",1)_" to "_$PIECE($GET(^(2)),"^",14)
+2 KILL AUR
SET AUR(1)=$GET(^PRST(458,PPI,"E",DFN,2))
+3 SET DDSFILE=458
SET DDSFILE(1)=458.01
SET DA(1)=PPI
SET DA=DFN
+4 SET DR="[PRSA FEE POST]"
DO ^DDS
KILL DS
if $GET(^PRST(458,PPI,"E",DFN,2))=AUR(1)
QUIT
+5 DO NOW^%DTC
SET NOW=%
SET $PIECE(^PRST(458,PPI,"E",DFN,2),"^",15,16)=DUZ_"^"_NOW
QUIT
PRP ; Prior Pay Period Update
+1 SET PRSTLV=2
DO ^PRSAUTL
if TLI<1
GOTO EX
DO NOW^%DTC
SET DT=%\1
SET NOW=%
+2 SET %DT="AEPX"
SET %DT("A")="Posting Date: "
SET %DT(0)=-DT
WRITE !
DO ^%DT
+3 if Y<1
GOTO EX
SET D1=Y
SET Y=$GET(^PRST(458,"AD",D1))
SET PPI=$PIECE(Y,"^",1)
+4 IF PPI=""
WRITE !!,*7,"Pay Period is Not Open Yet!"
GOTO EX
+5 DO NME
if DFN<1
GOTO EX
+6 IF "T"[STAT
DO POST
GOTO EX
+7 IF STAT'="X"
WRITE !!,*7,"Card in Payroll and not transmitted; request return of card."
QUIT
+8 SET Z=$GET(^PRST(458,PPI,"E",DFN,2))
+9 DO POST
IF $GET(^PRST(458,PPI,"E",DFN,2))'=AUR(1)
Begin DoDot:1
+10 ; Approve, Notify Payroll
SET AUT="V"
SET AUS="R"
DO ^PRSAUD
+11 IF $GET(AUR(7))["^"
KILL ^PRST(458,PPI,"E",DFN,2)
IF $DATA(AUR(1))
Begin DoDot:2
+12 SET ^PRST(458,PPI,"E",DFN,2)=AUR(1)
End DoDot:2
End DoDot:1
+13 GOTO EX
EX GOTO KILL^XUSCLEAN
