- 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 Jan 18, 2025@03:24:21 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