PRSAENE ; HISC/REL-Display Employee Entitlement ;3/21/94 13:44
;;4.0;PAID;;Sep 21, 1995
S PRSTLV=7 D ^PRSAUTL G:TLI<1 EX
E1 K DIC S DIC("A")="Select EMPLOYEE: ",DIC("S")="I $P(^(0),""^"",8)=TLE",DIC(0)="AEQM",DIC="^PRSPC(",D="ATL"_TLE W ! D IX^DIC S DFN=+Y K DIC G:DFN<1 EX
D ^PRSAENT I ENT="" W !!?5,"No Entitlement Table entry was found for this Employee." G E1
W ! K IOP,%ZIS S %ZIS("A")="Select Device: ",%ZIS="MQ" D ^%ZIS K %ZIS,IOP G:POP EX
I $D(IO("Q")) S PRSAPGM="Q1^PRSAENE",PRSALST="DFN^ENT" D QUE^PRSAUTL G EX
U IO D Q1 D ^%ZISC K %ZIS,IOP G EX
Q1 ; List Entitlement for Employee
W:$E(IOST,1,2)="C-" @IOF W !?28,"EMPLOYEE PAY ENTITLEMENTS"
S X=$G(^PRSPC(DFN,0)) W !,$P(X,"^",1) S X=$P(X,"^",9) I X W ?67,$E(X,1,3),"-",$E(X,4,5),"-",$E(X,6,9)
W ! D Q2^PRSAENX
I $E(IOST,1,2)="C-" R !!,"Press RETURN to Continue. ",X:DTIME
Q
EX G KILL^XUSCLEAN
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRSAENE 880 printed Nov 22, 2024@17:33:30 Page 2
PRSAENE ; HISC/REL-Display Employee Entitlement ;3/21/94 13:44
+1 ;;4.0;PAID;;Sep 21, 1995
+2 SET PRSTLV=7
DO ^PRSAUTL
if TLI<1
GOTO EX
E1 KILL DIC
SET DIC("A")="Select EMPLOYEE: "
SET DIC("S")="I $P(^(0),""^"",8)=TLE"
SET DIC(0)="AEQM"
SET DIC="^PRSPC("
SET D="ATL"_TLE
WRITE !
DO IX^DIC
SET DFN=+Y
KILL DIC
if DFN<1
GOTO EX
+1 DO ^PRSAENT
IF ENT=""
WRITE !!?5,"No Entitlement Table entry was found for this Employee."
GOTO E1
+2 WRITE !
KILL IOP,%ZIS
SET %ZIS("A")="Select Device: "
SET %ZIS="MQ"
DO ^%ZIS
KILL %ZIS,IOP
if POP
GOTO EX
+3 IF $DATA(IO("Q"))
SET PRSAPGM="Q1^PRSAENE"
SET PRSALST="DFN^ENT"
DO QUE^PRSAUTL
GOTO EX
+4 USE IO
DO Q1
DO ^%ZISC
KILL %ZIS,IOP
GOTO EX
Q1 ; List Entitlement for Employee
+1 if $EXTRACT(IOST,1,2)="C-"
WRITE @IOF
WRITE !?28,"EMPLOYEE PAY ENTITLEMENTS"
+2 SET X=$GET(^PRSPC(DFN,0))
WRITE !,$PIECE(X,"^",1)
SET X=$PIECE(X,"^",9)
IF X
WRITE ?67,$EXTRACT(X,1,3),"-",$EXTRACT(X,4,5),"-",$EXTRACT(X,6,9)
+3 WRITE !
DO Q2^PRSAENX
+4 IF $EXTRACT(IOST,1,2)="C-"
READ !!,"Press RETURN to Continue. ",X:DTIME
+5 QUIT
EX GOTO KILL^XUSCLEAN
