PRSA8BNH ;WOIFO/JAH - Tour Hours vs 8B Norm Hrs Report ;12/28/07
;;4.0;PAID;**116,110**;Sep 21, 1995;Build 7
;;Per VHA Directive 2004-038, this routine should not be modified.
Q
; Search for 8b normal hours that don't match tours
; look in timecard 8B node for normal hours otherwise use 450
;
PAYROLL ;prompt for T&L's--set's up payroll all T&L's
N PRSTLV,FORWHO
S PRSTLV=7
S FORWHO="for Payroll"
D MAIN
Q
;
TIMEKEEP ; entry point sets up timekeeper T&L variable for PRSAUTL call
N PRSTLV,FORWHO S PRSTLV=2,FORWHO="for Timekeeper"
D MAIN
Q
;
SUPERV ; sets up supervisor for T&L lookup
N PRSTLV,FORWHO S PRSTLV=3,FORWHO="for T&A Supervisor"
D MAIN
Q
;
MAIN ;
N DIR,DIRUT,TLS,Y,PPI,PPE,NOTOUR,NOTCARD,PPRANGE,DAILYHRS,EP,SP,SDT,EDT
S TLS=1
S DIR(0)="Y"
S DIR("B")="Y"
S DIR("A")="All T&L's"
D ^DIR
Q:$D(DIRUT)
I +Y=1 S TLS="ALL"
I TLS=1 D
. D ^PRSAUTL
Q:TLS=1&($G(TLI)="")
;
S PPI=$$GETPP^PRSA8BNI()
Q:PPI'>0
S PPE=$P($G(^PRST(458,PPI,0)),U)
S SDT=$P($G(^PRST(458,PPI,2)),U)
S EDT=$P($G(^PRST(458,PPI,2)),U,14)
S SP=$L(SDT," ")
S EP=$L(EDT," ")
S PPRANGE=$P(SDT," ",SP)_" thru "_$P(EDT," ",EP)
;
; ask user to include employees with no timecard at all.
S NOTCARD=$$NOTCARD^PRSA8BNI()
Q:NOTCARD<0
;
; ask user to include employees with no tour of duty entered
S NOTOUR=$$NOTOURS^PRSA8BNI()
Q:NOTOUR<0
;
; ask user to include employees daily tour hours
S DAILYHRS=$$DAILYHRS^PRSA8BNI()
Q:DAILYHRS<0
;
;
N %ZIS,POP,IOP
S %ZIS="MQ"
D ^%ZIS
Q:POP
I $D(IO("Q")) D
. K IO("Q")
. N ZTDESC,ZTRTN,ZTSAVE
. S ZTDESC="PAID REPORT: TOUR HOURS DON'T MATCH 8B NORMAL"
. S ZTRTN="TOUR8B^PRSA8BNH"
. S ZTSAVE("PRSTLV")=""
. S ZTSAVE("TLE")=""
. S ZTSAVE("PPI")=""
. S ZTSAVE("PPE")=""
. S ZTSAVE("TLS")=""
. S ZTSAVE("NOTOUR")=""
. S ZTSAVE("NOTCARD")=""
. S ZTSAVE("DAILYHRS")=""
. S ZTSAVE("PPRANGE")=""
. S ZTSAVE("FORWHO")=""
. D ^%ZTLOAD
. I $D(ZTSK) S ZTREQ="@"
E D
. D TOUR8B
K PRSTLV
D ^%ZISC K %ZIS,IOP
Q
;
TOUR8B ;
U IO
N OUT,TLECNT,TSTAMP,Y,%,%I,GRANDTOT,PG,ATL
D NOW^%DTC S Y=% D DD^%DT S TSTAMP=$P(Y,":",1,2)
S (TLECNT,OUT,GRANDTOT,PG)=0
I TLS="ALL" D
. N TLI,TLE
. S ATL="ATL"
. F S ATL=$O(^PRSPC(ATL)) Q:ATL>"ATLVCS"!OUT D
.. S TLE=$E(ATL,4,6)
.. Q:TLE=""
.. S TLI=$O(^PRST(455.5,"B",TLE,0))
.. Q:TLI'>0
..; skip T&L's supervisors and timekeepers don't have access too
.. Q:(PRSTLV=2)&('$D(^PRST(455.5,"AT",DUZ,TLI)))
.. Q:(PRSTLV=3)&('$D(^PRST(455.5,"AS",DUZ,TLI)))
.. I TLECNT=0 D HDR^PRSA8BNI(.PG,TSTAMP,0,FORWHO,PPE,PPRANGE)
.. D LOOPTL(.OUT,.GRANDTOT,TLE,PPI,TSTAMP)
.. S TLECNT=TLECNT+1
E D
. D HDR^PRSA8BNI(.PG,TSTAMP,0,FORWHO,PPE,PPRANGE)
. D LOOPTL(.OUT,.GRANDTOT,TLE,PPI,TSTAMP)
. S TLECNT=TLECNT+1
D REPDONE^PRSA8BNI(OUT,TLECNT,TSTAMP,DAILYHRS,GRANDTOT)
Q
;
LOOPTL(OUT,TOT,TLE,PPI,TSTAMP) ; LOOP THROUGH T&L
N COUNT,NN,PRSIEN,EMPNODE,PRSENAME,HRS,EMPND1,SEPIND,WEEKHRS,PRSD,PRSSN
K ERRORS
S (COUNT,OUT)=0
S NN=""
F S NN=$O(^PRSPC("ATL"_TLE,NN)) Q:NN="" D
. F PRSIEN=0:0 S PRSIEN=$O(^PRSPC("ATL"_TLE,NN,PRSIEN)) Q:PRSIEN<1!(OUT) D
..; skip Extended LWOP or anyone without a timecard
.. Q:'NOTCARD&($G(^PRST(458,PPI,"E",PRSIEN,0))="")
.. Q:'NOTOUR&($P($G(^PRST(458,PPI,"E",PRSIEN,"D",1,0)),U,2)="")
.. S EMPNODE=$G(^PRSPC(PRSIEN,0))
.. S EMPND1=$G(^PRSPC(PRSIEN,1))
.. S SEPIND=$P(EMPND1,U,33)
.. Q:EMPNODE=""!(SEPIND="Y")
.. I '$$HRSMATCH^PRSATPE(PPI,PRSIEN) D
... S COUNT=COUNT+1
... S GRANDTOT=GRANDTOT+1
... S ERRORS(PRSIEN)=""
I COUNT>0 D
. I DAILYHRS,$Y>(IOSL-12) S OUT=$$RET^PRSA8BNI(TSTAMP) Q:OUT
. I 'DAILYHRS,$Y>(IOSL-7) S OUT=$$RET^PRSA8BNI(TSTAMP) Q:OUT
. W !!,?12,"T & L UNIT: "_TLE," ",COUNT," mismatches found."
. S PRSIEN=""
. F S PRSIEN=$O(ERRORS(PRSIEN)) Q:PRSIEN'>0!OUT D
.. S WEEKHRS=$$GETHOURS^PRSA8BNI(PPI,PRSIEN)
.. S PRSENAME=$P($G(^PRSPC(PRSIEN,0)),U)
.. S PRSSN=$P($G(^PRSPC(PRSIEN,0)),U,9)
.. S PRSSN=$S(PRSTLV=7:$E(PRSSN,1,3)_"-"_$E(PRSSN,4,5),PRSTLV'<2:$E(PRSSN,1)_"XX-XX",1:"XXX-XX")_"-"_$E(PRSSN,6,9)
.. I DAILYHRS,$Y>(IOSL-10) S OUT=$$RET^PRSA8BNI(TSTAMP) Q:OUT
.. I 'DAILYHRS,$Y>(IOSL-5) S OUT=$$RET^PRSA8BNI(TSTAMP) Q:OUT
.. D EMPINFO^PRSA8BNI(PRSENAME,PRSSN,WEEKHRS)
..; show the actual tour hours for each day
.. I DAILYHRS D
... N HRS,I
... D TOURHRS^PRSARC07(.HRS,PPI,PRSIEN)
... I $Y>(IOSL-8) S OUT=$$RET^PRSA8BNI(TSTAMP) Q:OUT D EMPINFO^PRSA8BNI(PRSENAME,PRSSN,WEEKHRS)
... D TRHDR^PRSA8BNI
... F PRSD=1:1:7 D Q:OUT
.... I $Y>(IOSL-4) S OUT=$$RET^PRSA8BNI(TSTAMP) Q:OUT D EMPINFO^PRSA8BNI(PRSENAME,PRSSN,WEEKHRS),TRHDR^PRSA8BNI
.... Q:OUT
.... D TOURDISP(PPI,PRSIEN,PRSD,.HRS)
.. Q:OUT
.. I $Y>(IOSL-5) S OUT=$$RET^PRSA8BNI(TSTAMP) Q:OUT
Q
TOURDISP(PPI,PRSIEN,PRSD,HRS) ;
N Y1,Y2,Y4,Y5,DTE,TD1C1,TD1C2,L2,L3,TD2C1,TD2C2
S TD1C1=$P($G(^PRST(458,PPI,"E",PRSIEN,"D",PRSD,0)),"^",2),Y1=$G(^(1)),Y4=$G(^(4))
S TD2C1=$P($G(^PRST(458,PPI,"E",PRSIEN,"D",PRSD,0)),"^",13)
I Y1="" S Y1=$S(TD1C1=1:"Day Off",TD1C1=2:"Day Tour",TD1C1=3!(TD1C1=4):"Intermittent",1:"")
S TD1C2=$P($G(^PRST(458,PPI,"E",PRSIEN,"D",PRSD+7,0)),"^",2),Y2=$G(^(1)),Y5=$G(^(4))
S TD2C2=$P($G(^PRST(458,PPI,"E",PRSIEN,"D",PRSD+7,0)),"^",13)
I Y2="" S Y2=$S(TD1C2=1:"Day Off",TD1C2=2:"Day Tour",TD1C2=3!(TD1C2=4):"Intermittent",1:"")
S DTE=$P("Sun Mon Tue Wed Thu Fri Sat"," ",PRSD)
W !?7,DTE S (L2,L3)=0
I Y1="",Y2="" Q
;
S0 ; Set Schedule Array
N A1,L1,B
F L1=1:3:19 D
. S A1=$P(Y1,"^",L1) Q:A1=""
. S L2=L2+1,Y1(L2)=A1
. S:$P(Y1,"^",L1+1)'="" Y1(L2)=Y1(L2)_"-"_$P(Y1,"^",L1+1)
. I L1=1 D
.. N DAYHRS S DAYHRS=$J($P(HRS(PRSD),U,2),5,2)
.. S B=$E(" ",1,20-$L(DAYHRS)-$L(Y1(L2)))
.. S Y1(L2)=$J(TD1C1,5,0)_" "_Y1(L2)_B_DAYHRS
. E D
.. S Y1(L2)=" "_Y1(L2)
. I $P(Y1,"^",L1+2)'="" D
.. S L2=L2+1
.. S Y1(L2)=" "_$P($G(^PRST(457.2,+$P(Y1,"^",L1+2),0)),"^",1)
G:Y4="" S1
F L1=1:3:19 D
. S A1=$P(Y4,"^",L1) Q:A1=""
. S L2=L2+1
. S Y1(L2)=A1
. S:$P(Y4,"^",L1+1)'="" Y1(L2)=Y1(L2)_"-"_$P(Y4,"^",L1+1)
. I L1=1 D
.. S Y1(L2)=$J(TD2C1,5,0)_" "_Y1(L2)
. E D
.. S Y1(L2)=" "_Y1(L2)
. I $P(Y4,"^",L1+2)'="" D
.. S L2=L2+1
.. S Y1(L2)=" "_$P($G(^PRST(457.2,+$P(Y4,"^",L1+2),0)),"^",1)
;
S1 ; Set Schedule Array
F L1=1:3:19 D
. S A1=$P(Y2,"^",L1) Q:A1=""
. S L3=L3+1
. S Y2(L3)=A1
. S:$P(Y2,"^",L1+1)'="" Y2(L3)=Y2(L3)_"-"_$P(Y2,"^",L1+1)
. I L1=1 D
.. N DAYHRS S DAYHRS=$J($P(HRS(PRSD+7),U,2),5,2)
.. S B=$E(" ",1,20-$L(DAYHRS)-$L(Y2(L3)))
.. S Y2(L3)=$J(TD1C2,5,0)_" "_Y2(L3)_B_DAYHRS
. E D
.. S Y2(L3)=" "_Y2(L3)
. I $P(Y2,"^",L1+2)'="" D
.. S L3=L3+1
.. S Y2(L3)=" "_$P($G(^PRST(457.2,+$P(Y2,"^",L1+2),0)),"^",1)
;
G:Y5="" S2
;
F L1=1:3:19 D
. S A1=$P(Y5,"^",L1) Q:A1=""
. S L3=L3+1,Y2(L3)=A1
. S:$P(Y5,"^",L1+1)'="" Y2(L3)=Y2(L3)_"-"_$P(Y5,"^",L1+1)
. I L1=1 D
.. S Y2(L3)=$J(TD2C2,5,0)_" "_Y2(L3)
. E D
.. S Y2(L3)=" "_Y2(L3)
. I $P(Y5,"^",L1+2)'="" D
.. S L3=L3+1
.. S Y2(L3)=" "_$P($G(^PRST(457.2,+$P(Y5,"^",L1+2),0)),"^",1)
;
S2 ;
N K
F K=1:1 Q:'$D(Y1(K))&'$D(Y2(K)) D
. W:K>1 ! W:$D(Y1(K)) ?12,Y1(K) W:$D(Y2(K)) ?47,Y2(K)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRSA8BNH 7497 printed Oct 16, 2024@18:23:55 Page 2
PRSA8BNH ;WOIFO/JAH - Tour Hours vs 8B Norm Hrs Report ;12/28/07
+1 ;;4.0;PAID;**116,110**;Sep 21, 1995;Build 7
+2 ;;Per VHA Directive 2004-038, this routine should not be modified.
+3 QUIT
+4 ; Search for 8b normal hours that don't match tours
+5 ; look in timecard 8B node for normal hours otherwise use 450
+6 ;
PAYROLL ;prompt for T&L's--set's up payroll all T&L's
+1 NEW PRSTLV,FORWHO
+2 SET PRSTLV=7
+3 SET FORWHO="for Payroll"
+4 DO MAIN
+5 QUIT
+6 ;
TIMEKEEP ; entry point sets up timekeeper T&L variable for PRSAUTL call
+1 NEW PRSTLV,FORWHO
SET PRSTLV=2
SET FORWHO="for Timekeeper"
+2 DO MAIN
+3 QUIT
+4 ;
SUPERV ; sets up supervisor for T&L lookup
+1 NEW PRSTLV,FORWHO
SET PRSTLV=3
SET FORWHO="for T&A Supervisor"
+2 DO MAIN
+3 QUIT
+4 ;
MAIN ;
+1 NEW DIR,DIRUT,TLS,Y,PPI,PPE,NOTOUR,NOTCARD,PPRANGE,DAILYHRS,EP,SP,SDT,EDT
+2 SET TLS=1
+3 SET DIR(0)="Y"
+4 SET DIR("B")="Y"
+5 SET DIR("A")="All T&L's"
+6 DO ^DIR
+7 if $DATA(DIRUT)
QUIT
+8 IF +Y=1
SET TLS="ALL"
+9 IF TLS=1
Begin DoDot:1
+10 DO ^PRSAUTL
End DoDot:1
+11 if TLS=1&($GET(TLI)="")
QUIT
+12 ;
+13 SET PPI=$$GETPP^PRSA8BNI()
+14 if PPI'>0
QUIT
+15 SET PPE=$PIECE($GET(^PRST(458,PPI,0)),U)
+16 SET SDT=$PIECE($GET(^PRST(458,PPI,2)),U)
+17 SET EDT=$PIECE($GET(^PRST(458,PPI,2)),U,14)
+18 SET SP=$LENGTH(SDT," ")
+19 SET EP=$LENGTH(EDT," ")
+20 SET PPRANGE=$PIECE(SDT," ",SP)_" thru "_$PIECE(EDT," ",EP)
+21 ;
+22 ; ask user to include employees with no timecard at all.
+23 SET NOTCARD=$$NOTCARD^PRSA8BNI()
+24 if NOTCARD<0
QUIT
+25 ;
+26 ; ask user to include employees with no tour of duty entered
+27 SET NOTOUR=$$NOTOURS^PRSA8BNI()
+28 if NOTOUR<0
QUIT
+29 ;
+30 ; ask user to include employees daily tour hours
+31 SET DAILYHRS=$$DAILYHRS^PRSA8BNI()
+32 if DAILYHRS<0
QUIT
+33 ;
+34 ;
+35 NEW %ZIS,POP,IOP
+36 SET %ZIS="MQ"
+37 DO ^%ZIS
+38 if POP
QUIT
+39 IF $DATA(IO("Q"))
Begin DoDot:1
+40 KILL IO("Q")
+41 NEW ZTDESC,ZTRTN,ZTSAVE
+42 SET ZTDESC="PAID REPORT: TOUR HOURS DON'T MATCH 8B NORMAL"
+43 SET ZTRTN="TOUR8B^PRSA8BNH"
+44 SET ZTSAVE("PRSTLV")=""
+45 SET ZTSAVE("TLE")=""
+46 SET ZTSAVE("PPI")=""
+47 SET ZTSAVE("PPE")=""
+48 SET ZTSAVE("TLS")=""
+49 SET ZTSAVE("NOTOUR")=""
+50 SET ZTSAVE("NOTCARD")=""
+51 SET ZTSAVE("DAILYHRS")=""
+52 SET ZTSAVE("PPRANGE")=""
+53 SET ZTSAVE("FORWHO")=""
+54 DO ^%ZTLOAD
+55 IF $DATA(ZTSK)
SET ZTREQ="@"
End DoDot:1
+56 IF '$TEST
Begin DoDot:1
+57 DO TOUR8B
End DoDot:1
+58 KILL PRSTLV
+59 DO ^%ZISC
KILL %ZIS,IOP
+60 QUIT
+61 ;
TOUR8B ;
+1 USE IO
+2 NEW OUT,TLECNT,TSTAMP,Y,%,%I,GRANDTOT,PG,ATL
+3 DO NOW^%DTC
SET Y=%
DO DD^%DT
SET TSTAMP=$PIECE(Y,":",1,2)
+4 SET (TLECNT,OUT,GRANDTOT,PG)=0
+5 IF TLS="ALL"
Begin DoDot:1
+6 NEW TLI,TLE
+7 SET ATL="ATL"
+8 FOR
SET ATL=$ORDER(^PRSPC(ATL))
if ATL>"ATLVCS"!OUT
QUIT
Begin DoDot:2
+9 SET TLE=$EXTRACT(ATL,4,6)
+10 if TLE=""
QUIT
+11 SET TLI=$ORDER(^PRST(455.5,"B",TLE,0))
+12 if TLI'>0
QUIT
+13 ; skip T&L's supervisors and timekeepers don't have access too
+14 if (PRSTLV=2)&('$DATA(^PRST(455.5,"AT",DUZ,TLI)))
QUIT
+15 if (PRSTLV=3)&('$DATA(^PRST(455.5,"AS",DUZ,TLI)))
QUIT
+16 IF TLECNT=0
DO HDR^PRSA8BNI(.PG,TSTAMP,0,FORWHO,PPE,PPRANGE)
+17 DO LOOPTL(.OUT,.GRANDTOT,TLE,PPI,TSTAMP)
+18 SET TLECNT=TLECNT+1
End DoDot:2
End DoDot:1
+19 IF '$TEST
Begin DoDot:1
+20 DO HDR^PRSA8BNI(.PG,TSTAMP,0,FORWHO,PPE,PPRANGE)
+21 DO LOOPTL(.OUT,.GRANDTOT,TLE,PPI,TSTAMP)
+22 SET TLECNT=TLECNT+1
End DoDot:1
+23 DO REPDONE^PRSA8BNI(OUT,TLECNT,TSTAMP,DAILYHRS,GRANDTOT)
+24 QUIT
+25 ;
LOOPTL(OUT,TOT,TLE,PPI,TSTAMP) ; LOOP THROUGH T&L
+1 NEW COUNT,NN,PRSIEN,EMPNODE,PRSENAME,HRS,EMPND1,SEPIND,WEEKHRS,PRSD,PRSSN
+2 KILL ERRORS
+3 SET (COUNT,OUT)=0
+4 SET NN=""
+5 FOR
SET NN=$ORDER(^PRSPC("ATL"_TLE,NN))
if NN=""
QUIT
Begin DoDot:1
+6 FOR PRSIEN=0:0
SET PRSIEN=$ORDER(^PRSPC("ATL"_TLE,NN,PRSIEN))
if PRSIEN<1!(OUT)
QUIT
Begin DoDot:2
+7 ; skip Extended LWOP or anyone without a timecard
+8 if 'NOTCARD&($GET(^PRST(458,PPI,"E",PRSIEN,0))="")
QUIT
+9 if 'NOTOUR&($PIECE($GET(^PRST(458,PPI,"E",PRSIEN,"D",1,0)),U,2)="")
QUIT
+10 SET EMPNODE=$GET(^PRSPC(PRSIEN,0))
+11 SET EMPND1=$GET(^PRSPC(PRSIEN,1))
+12 SET SEPIND=$PIECE(EMPND1,U,33)
+13 if EMPNODE=""!(SEPIND="Y")
QUIT
+14 IF '$$HRSMATCH^PRSATPE(PPI,PRSIEN)
Begin DoDot:3
+15 SET COUNT=COUNT+1
+16 SET GRANDTOT=GRANDTOT+1
+17 SET ERRORS(PRSIEN)=""
End DoDot:3
End DoDot:2
End DoDot:1
+18 IF COUNT>0
Begin DoDot:1
+19 IF DAILYHRS
IF $Y>(IOSL-12)
SET OUT=$$RET^PRSA8BNI(TSTAMP)
if OUT
QUIT
+20 IF 'DAILYHRS
IF $Y>(IOSL-7)
SET OUT=$$RET^PRSA8BNI(TSTAMP)
if OUT
QUIT
+21 WRITE !!,?12,"T & L UNIT: "_TLE," ",COUNT," mismatches found."
+22 SET PRSIEN=""
+23 FOR
SET PRSIEN=$ORDER(ERRORS(PRSIEN))
if PRSIEN'>0!OUT
QUIT
Begin DoDot:2
+24 SET WEEKHRS=$$GETHOURS^PRSA8BNI(PPI,PRSIEN)
+25 SET PRSENAME=$PIECE($GET(^PRSPC(PRSIEN,0)),U)
+26 SET PRSSN=$PIECE($GET(^PRSPC(PRSIEN,0)),U,9)
+27 SET PRSSN=$SELECT(PRSTLV=7:$EXTRACT(PRSSN,1,3)_"-"_$EXTRACT(PRSSN,4,5),PRSTLV'<2:$EXTRACT(PRSSN,1)_"XX-XX",1:"XXX-XX")_"-"_$EXTRACT(PRSSN,6,9)
+28 IF DAILYHRS
IF $Y>(IOSL-10)
SET OUT=$$RET^PRSA8BNI(TSTAMP)
if OUT
QUIT
+29 IF 'DAILYHRS
IF $Y>(IOSL-5)
SET OUT=$$RET^PRSA8BNI(TSTAMP)
if OUT
QUIT
+30 DO EMPINFO^PRSA8BNI(PRSENAME,PRSSN,WEEKHRS)
+31 ; show the actual tour hours for each day
+32 IF DAILYHRS
Begin DoDot:3
+33 NEW HRS,I
+34 DO TOURHRS^PRSARC07(.HRS,PPI,PRSIEN)
+35 IF $Y>(IOSL-8)
SET OUT=$$RET^PRSA8BNI(TSTAMP)
if OUT
QUIT
DO EMPINFO^PRSA8BNI(PRSENAME,PRSSN,WEEKHRS)
+36 DO TRHDR^PRSA8BNI
+37 FOR PRSD=1:1:7
Begin DoDot:4
+38 IF $Y>(IOSL-4)
SET OUT=$$RET^PRSA8BNI(TSTAMP)
if OUT
QUIT
DO EMPINFO^PRSA8BNI(PRSENAME,PRSSN,WEEKHRS)
DO TRHDR^PRSA8BNI
+39 if OUT
QUIT
+40 DO TOURDISP(PPI,PRSIEN,PRSD,.HRS)
End DoDot:4
if OUT
QUIT
End DoDot:3
+41 if OUT
QUIT
+42 IF $Y>(IOSL-5)
SET OUT=$$RET^PRSA8BNI(TSTAMP)
if OUT
QUIT
End DoDot:2
End DoDot:1
+43 QUIT
TOURDISP(PPI,PRSIEN,PRSD,HRS) ;
+1 NEW Y1,Y2,Y4,Y5,DTE,TD1C1,TD1C2,L2,L3,TD2C1,TD2C2
+2 SET TD1C1=$PIECE($GET(^PRST(458,PPI,"E",PRSIEN,"D",PRSD,0)),"^",2)
SET Y1=$GET(^(1))
SET Y4=$GET(^(4))
+3 SET TD2C1=$PIECE($GET(^PRST(458,PPI,"E",PRSIEN,"D",PRSD,0)),"^",13)
+4 IF Y1=""
SET Y1=$SELECT(TD1C1=1:"Day Off",TD1C1=2:"Day Tour",TD1C1=3!(TD1C1=4):"Intermittent",1:"")
+5 SET TD1C2=$PIECE($GET(^PRST(458,PPI,"E",PRSIEN,"D",PRSD+7,0)),"^",2)
SET Y2=$GET(^(1))
SET Y5=$GET(^(4))
+6 SET TD2C2=$PIECE($GET(^PRST(458,PPI,"E",PRSIEN,"D",PRSD+7,0)),"^",13)
+7 IF Y2=""
SET Y2=$SELECT(TD1C2=1:"Day Off",TD1C2=2:"Day Tour",TD1C2=3!(TD1C2=4):"Intermittent",1:"")
+8 SET DTE=$PIECE("Sun Mon Tue Wed Thu Fri Sat"," ",PRSD)
+9 WRITE !?7,DTE
SET (L2,L3)=0
+10 IF Y1=""
IF Y2=""
QUIT
+11 ;
S0 ; Set Schedule Array
+1 NEW A1,L1,B
+2 FOR L1=1:3:19
Begin DoDot:1
+3 SET A1=$PIECE(Y1,"^",L1)
if A1=""
QUIT
+4 SET L2=L2+1
SET Y1(L2)=A1
+5 if $PIECE(Y1,"^",L1+1)'=""
SET Y1(L2)=Y1(L2)_"-"_$PIECE(Y1,"^",L1+1)
+6 IF L1=1
Begin DoDot:2
+7 NEW DAYHRS
SET DAYHRS=$JUSTIFY($PIECE(HRS(PRSD),U,2),5,2)
+8 SET B=$EXTRACT(" ",1,20-$LENGTH(DAYHRS)-$LENGTH(Y1(L2)))
+9 SET Y1(L2)=$JUSTIFY(TD1C1,5,0)_" "_Y1(L2)_B_DAYHRS
End DoDot:2
+10 IF '$TEST
Begin DoDot:2
+11 SET Y1(L2)=" "_Y1(L2)
End DoDot:2
+12 IF $PIECE(Y1,"^",L1+2)'=""
Begin DoDot:2
+13 SET L2=L2+1
+14 SET Y1(L2)=" "_$PIECE($GET(^PRST(457.2,+$PIECE(Y1,"^",L1+2),0)),"^",1)
End DoDot:2
End DoDot:1
+15 if Y4=""
GOTO S1
+16 FOR L1=1:3:19
Begin DoDot:1
+17 SET A1=$PIECE(Y4,"^",L1)
if A1=""
QUIT
+18 SET L2=L2+1
+19 SET Y1(L2)=A1
+20 if $PIECE(Y4,"^",L1+1)'=""
SET Y1(L2)=Y1(L2)_"-"_$PIECE(Y4,"^",L1+1)
+21 IF L1=1
Begin DoDot:2
+22 SET Y1(L2)=$JUSTIFY(TD2C1,5,0)_" "_Y1(L2)
End DoDot:2
+23 IF '$TEST
Begin DoDot:2
+24 SET Y1(L2)=" "_Y1(L2)
End DoDot:2
+25 IF $PIECE(Y4,"^",L1+2)'=""
Begin DoDot:2
+26 SET L2=L2+1
+27 SET Y1(L2)=" "_$PIECE($GET(^PRST(457.2,+$PIECE(Y4,"^",L1+2),0)),"^",1)
End DoDot:2
End DoDot:1
+28 ;
S1 ; Set Schedule Array
+1 FOR L1=1:3:19
Begin DoDot:1
+2 SET A1=$PIECE(Y2,"^",L1)
if A1=""
QUIT
+3 SET L3=L3+1
+4 SET Y2(L3)=A1
+5 if $PIECE(Y2,"^",L1+1)'=""
SET Y2(L3)=Y2(L3)_"-"_$PIECE(Y2,"^",L1+1)
+6 IF L1=1
Begin DoDot:2
+7 NEW DAYHRS
SET DAYHRS=$JUSTIFY($PIECE(HRS(PRSD+7),U,2),5,2)
+8 SET B=$EXTRACT(" ",1,20-$LENGTH(DAYHRS)-$LENGTH(Y2(L3)))
+9 SET Y2(L3)=$JUSTIFY(TD1C2,5,0)_" "_Y2(L3)_B_DAYHRS
End DoDot:2
+10 IF '$TEST
Begin DoDot:2
+11 SET Y2(L3)=" "_Y2(L3)
End DoDot:2
+12 IF $PIECE(Y2,"^",L1+2)'=""
Begin DoDot:2
+13 SET L3=L3+1
+14 SET Y2(L3)=" "_$PIECE($GET(^PRST(457.2,+$PIECE(Y2,"^",L1+2),0)),"^",1)
End DoDot:2
End DoDot:1
+15 ;
+16 if Y5=""
GOTO S2
+17 ;
+18 FOR L1=1:3:19
Begin DoDot:1
+19 SET A1=$PIECE(Y5,"^",L1)
if A1=""
QUIT
+20 SET L3=L3+1
SET Y2(L3)=A1
+21 if $PIECE(Y5,"^",L1+1)'=""
SET Y2(L3)=Y2(L3)_"-"_$PIECE(Y5,"^",L1+1)
+22 IF L1=1
Begin DoDot:2
+23 SET Y2(L3)=$JUSTIFY(TD2C2,5,0)_" "_Y2(L3)
End DoDot:2
+24 IF '$TEST
Begin DoDot:2
+25 SET Y2(L3)=" "_Y2(L3)
End DoDot:2
+26 IF $PIECE(Y5,"^",L1+2)'=""
Begin DoDot:2
+27 SET L3=L3+1
+28 SET Y2(L3)=" "_$PIECE($GET(^PRST(457.2,+$PIECE(Y5,"^",L1+2),0)),"^",1)
End DoDot:2
End DoDot:1
+29 ;
S2 ;
+1 NEW K
+2 FOR K=1:1
if '$DATA(Y1(K))&'$DATA(Y2(K))
QUIT
Begin DoDot:1
+3 if K>1
WRITE !
if $DATA(Y1(K))
WRITE ?12,Y1(K)
if $DATA(Y2(K))
WRITE ?47,Y2(K)
End DoDot:1
+4 QUIT
