- PRSPCORE ;WOIFO/JAH - pt phys report on Core Hour Tours ;01/22/05
- ;;4.0;PAID;**93**;Sep 21, 1995;Build 7
- ;;Per VHA Directive 2004-038, this routine should not be modified.
- ;
- ; Report all tours of duty that currently have a Core Hours
- ; designation in the TOUR OF DUTY(#457.1)
- ;
- ; The Payroll Supervisor will need to remove the
- ; designation from the indicated tour.
- ;
- Q
- COREHRS ; main driver for the core hours report
- ; Get Station Number
- N Y,%,TSTAMP,%ZIS,POP,INCLUDE,PPI,PPE
- D NOW^%DTC S Y=% D DD^%DT S TSTAMP=Y
- ;
- ; look for core designation in the tours
- ;
- D INTRO
- Q:$$ASK^PRSLIB00(1)
- S INCLUDE=$$INCLEMP^PRSPCORE()
- Q:INCLUDE<0
- S PPI=0
- I INCLUDE S PPI=$$WHICHPP() Q:PPI<0
- I PPI>0 S PPE=$P(^PRST(458,PPI,0),U)
- ; if the pay period is not open then don't try to print employee list
- I PPI=0 S INCLUDE=0
- ;
- S %ZIS="MQ"
- D ^%ZIS
- Q:POP
- I $D(IO("Q")) D
- . K IO("Q")
- . N ZTDESC,ZTRTN,ZTSAVE
- . S ZTDESC="PAID TOURS WITH CORE TIME REPORT",ZTRTN="TOURCHK^PRSPCORE"
- . S ZTSAVE("TSTAMP")="",ZTSAVE("INCLUDE")="",ZTSAVE("PPI")="",ZTSAVE("PPE")=""
- . D ^%ZTLOAD
- .;
- E D
- . D TOURCHK
- Q
- ;
- INTRO ;always show the option description to the user since this is
- ; standalone secondary option.
- N X,Y,DIC,PRSHLP,PRSER,OPTIEN,LN
- W @IOF,!
- S X="PRSP PS CORE HRS RPT"
- S DIC="^DIC(19,"
- S DIC(0)="MZ"
- D ^DIC
- Q:$G(Y)'>0
- S OPTIEN=+$G(Y)
- S X=$$GET1^DIQ(19,OPTIEN,3.5,,"PRSHLP","PRSER")
- S LN=0
- F S LN=$O(PRSHLP(LN)) Q:LN'>0 D
- . W !,PRSHLP(LN)
- S LN=0
- F S LN=$O(PRSER(LN)) Q:LN'>0 D
- . W !,PRSER(LN)
- Q
- HDR(TSTAMP) ;
- N I,L1
- W @IOF,!
- I $G(INCLUDE) W ?2,"Employee search in PP ",PPE," included."
- W ?(IOM-$L(TSTAMP)-1),TSTAMP
- S L1="PAID - TOURS OF DUTY WITH PHYS/DENT CORE HOURS SEGMENTS REPORT"
- W !,?(IOM-$L(L1))/2,L1
- W !," TOUR #",?10,"TOUR NAME",?50,"SEGMENT"
- W !
- F I=1:1:IOM-1 W "-"
- Q
- ;
- RET(TSTAMP) ;
- I ($E(IOST,1,2)'="C-")!($D(ZTQUEUED)) D HDR(TSTAMP) Q 0
- ;
- N OUT
- S OUT=$$ASK^PRSLIB00(1)
- I 'OUT D HDR(TSTAMP)
- Q OUT
- ;
- TOURCHK ; check tour of duty file for tours with special time Phy/Dent core
- ;
- ; STIEN-SPECIAL TOUR INDICATOR IEN (457.2)
- ; STPTR-POINTER FROM TOUR OF DUTY FILE TO THE SPECIAL TOUR IND FILE
- ;
- U IO
- N I,ZNODE,NODE1,OUT,STPTR,STIEN,STCNT,SEGCNT,HASCORE,NODEX,TOUR
- ; Loop through tours
- ;
- S STIEN=$O(^PRST(457.2,"B","Phy/Den Core Hours",0))
- I STIEN'>0 D Q
- . D HDR(TSTAMP)
- . W !!,"REPORT ABORTED!"
- . W !,"No Phy/Den Core Hours entry found in file 457.2"
- S (STCNT,TOUR,OUT)=0,NODEX=1
- D HDR(TSTAMP)
- F S TOUR=$O(^PRST(457.1,TOUR)) Q:TOUR'>0!(OUT) D
- . S HASCORE=0
- . S ZNODE=$G(^PRST(457.1,TOUR,0))
- . S NODE1=$G(^PRST(457.1,TOUR,1))
- . ;
- . ; Loop through 7 Special Codes looking for code
- . ; #3 Phy/Den Core Hours
- . ;
- . S SEGCNT=0
- . F I=3:3:21 D
- .. S STPTR=$P(NODE1,U,I)
- .. I STPTR=STIEN S SEGCNT=SEGCNT+1 D
- ... S HASCORE=1
- ... I SEGCNT=1 D
- .... S STCNT=STCNT+1
- .... W !!,$J(TOUR,7),?10,$P(ZNODE,U)
- ... E D
- .... W !
- ... W ?50,I/3,": ",$P(NODE1,U,I-2)," - ",$P(NODE1,U,I-1)
- .;
- . I $Y>(IOSL-3) S OUT=$$RET(TSTAMP) Q:OUT
- . I HASCORE S OUT=$$TLLIST^PRSPCORE(TOUR,TSTAMP) Q:OUT
- . I INCLUDE,HASCORE S OUT=$$EMPLIST(TSTAMP,TOUR,PPI,TOUR) S HASCORE=0 Q:OUT
- ;
- ;
- I STCNT=0 W !!,?5,"No Tours were found with Special Tour Indicator of Phy/Den Core Hrs"
- D ^%ZISC
- I $D(ZTSK) S ZTREQ="@"
- Q
- WHICHPP() ;
- N PPI,SRT,DFN
- S PPI=$P($G(^PRST(458,"AD",DT)),U)
- I PPI'>0 S PPI=$O(^PRST(458,99999),-1)
- Q:PPI'>0
- S DFN=0 D NOL^PRSATE2
- S PPI=$S(SRT="L":PPI-1,SRT="N":PPI+1,SRT="C":PPI,1:-1)
- Q:PPI<0 PPI
- I '$G(^PRST(458,PPI,0)) S PPI=0 W !,"No employee tour data available for the unopened pay period."
- Q PPI
- INCLEMP() ;ASK USER IF THEY WANT TO INCLUDE EMPLOYEES WITH THE TOUR
- N DIR,DIRUT,Y,INCLUDE
- S DIR(0)="YA0"
- S DIR("B")="N"
- S DIR("A")="List employees with Phys/Den Core Hours Tours?"
- D ^DIR
- S INCLUDE=+Y
- I $D(DIRUT) S INCLUDE=-1
- Q INCLUDE
- EMPLIST(TS,TR,PPI,STIEN) ;LOOP THRU PP TO DISPLAY EMPS W/ PHY/DEN CORE TOURS
- ;
- N PRSIEN,PRSD,TRNODE,TR1,TR2,CORECNT,FOUND,OUT
- S OUT=0
- W !
- S (CORECNT,PRSIEN,OUT)=0
- ; ^PRST(458,236,"E",12717,"D",12,0) = 12^295^0^9^13198^3050114.11 ...
- ;
- F S PRSIEN=$O(^PRST(458,PPI,"E",PRSIEN)) Q:PRSIEN'>0!(OUT) D
- . S (PRSD,FOUND)=0
- . F PRSD=1:1:14 D
- .. S TRNODE=$G(^PRST(458,PPI,"E",PRSIEN,"D",PRSD,0))
- .. S TR1=$P(TRNODE,U,2)
- .. S TR2=$P(TRNODE,U,13)
- .. I (TR1=STIEN)!(TR2=STIEN) S FOUND=1,CORECNT=CORECNT+1 Q
- . S ZNODE=$G(^PRSPC(PRSIEN,0))
- . I FOUND W !,?12,$P(ZNODE,U),?45,"T&L: ",$P(ZNODE,U,8),?67,"nnn-nn-",$E($P(ZNODE,U,9),6,9)
- . I $Y>(IOSL-3) S OUT=$$RET(TSTAMP) Q:OUT
- I CORECNT=0 W !,?12,"No employees with this core hours tour in pp ",PPE
- Q OUT
- ;
- TLLIST(TIE,TSTAMP) ;LOOP THRU TOUR TO DISPLAY ASSOCIATED T&Ls
- ; INPUT : Tour Internal Entry number
- ; local vars:
- ; ATL - Associated T & L unit
- ; ATLCT - count the assoc tls
- N ATL,ATLCT,OUT
- W !,?12,"Associated T&Ls: "
- I $$GET1^DIQ(457.1,TIE,4,,,)="YES" D Q 0
- . W "This tour is available to all T&L units."
- ;
- S (OUT,ATLCT,ATL)=0
- F S ATL=$O(^PRST(457.1,TIE,"T","B",ATL)) Q:ATL'>0!(OUT) D
- . I $X>(IOM-10) D
- .. W ", ",!,?29
- . E D
- .. I ATLCT>0 W ", "
- . I $Y>(IOSL-3) S OUT=$$RET(TSTAMP) Q:OUT W !!,?12,"Associated T&Ls: "
- . S ATLCT=ATLCT+1
- . W $$GET1^DIQ(455.5,ATL,.01,,,)
- I ATLCT=0 W "No T&L units are associated with this tour."
- Q OUT
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRSPCORE 5479 printed Feb 18, 2025@23:54:19 Page 2
- PRSPCORE ;WOIFO/JAH - pt phys report on Core Hour Tours ;01/22/05
- +1 ;;4.0;PAID;**93**;Sep 21, 1995;Build 7
- +2 ;;Per VHA Directive 2004-038, this routine should not be modified.
- +3 ;
- +4 ; Report all tours of duty that currently have a Core Hours
- +5 ; designation in the TOUR OF DUTY(#457.1)
- +6 ;
- +7 ; The Payroll Supervisor will need to remove the
- +8 ; designation from the indicated tour.
- +9 ;
- +10 QUIT
- COREHRS ; main driver for the core hours report
- +1 ; Get Station Number
- +2 NEW Y,%,TSTAMP,%ZIS,POP,INCLUDE,PPI,PPE
- +3 DO NOW^%DTC
- SET Y=%
- DO DD^%DT
- SET TSTAMP=Y
- +4 ;
- +5 ; look for core designation in the tours
- +6 ;
- +7 DO INTRO
- +8 if $$ASK^PRSLIB00(1)
- QUIT
- +9 SET INCLUDE=$$INCLEMP^PRSPCORE()
- +10 if INCLUDE<0
- QUIT
- +11 SET PPI=0
- +12 IF INCLUDE
- SET PPI=$$WHICHPP()
- if PPI<0
- QUIT
- +13 IF PPI>0
- SET PPE=$PIECE(^PRST(458,PPI,0),U)
- +14 ; if the pay period is not open then don't try to print employee list
- +15 IF PPI=0
- SET INCLUDE=0
- +16 ;
- +17 SET %ZIS="MQ"
- +18 DO ^%ZIS
- +19 if POP
- QUIT
- +20 IF $DATA(IO("Q"))
- Begin DoDot:1
- +21 KILL IO("Q")
- +22 NEW ZTDESC,ZTRTN,ZTSAVE
- +23 SET ZTDESC="PAID TOURS WITH CORE TIME REPORT"
- SET ZTRTN="TOURCHK^PRSPCORE"
- +24 SET ZTSAVE("TSTAMP")=""
- SET ZTSAVE("INCLUDE")=""
- SET ZTSAVE("PPI")=""
- SET ZTSAVE("PPE")=""
- +25 DO ^%ZTLOAD
- +26 ;
- End DoDot:1
- +27 IF '$TEST
- Begin DoDot:1
- +28 DO TOURCHK
- End DoDot:1
- +29 QUIT
- +30 ;
- INTRO ;always show the option description to the user since this is
- +1 ; standalone secondary option.
- +2 NEW X,Y,DIC,PRSHLP,PRSER,OPTIEN,LN
- +3 WRITE @IOF,!
- +4 SET X="PRSP PS CORE HRS RPT"
- +5 SET DIC="^DIC(19,"
- +6 SET DIC(0)="MZ"
- +7 DO ^DIC
- +8 if $GET(Y)'>0
- QUIT
- +9 SET OPTIEN=+$GET(Y)
- +10 SET X=$$GET1^DIQ(19,OPTIEN,3.5,,"PRSHLP","PRSER")
- +11 SET LN=0
- +12 FOR
- SET LN=$ORDER(PRSHLP(LN))
- if LN'>0
- QUIT
- Begin DoDot:1
- +13 WRITE !,PRSHLP(LN)
- End DoDot:1
- +14 SET LN=0
- +15 FOR
- SET LN=$ORDER(PRSER(LN))
- if LN'>0
- QUIT
- Begin DoDot:1
- +16 WRITE !,PRSER(LN)
- End DoDot:1
- +17 QUIT
- HDR(TSTAMP) ;
- +1 NEW I,L1
- +2 WRITE @IOF,!
- +3 IF $GET(INCLUDE)
- WRITE ?2,"Employee search in PP ",PPE," included."
- +4 WRITE ?(IOM-$LENGTH(TSTAMP)-1),TSTAMP
- +5 SET L1="PAID - TOURS OF DUTY WITH PHYS/DENT CORE HOURS SEGMENTS REPORT"
- +6 WRITE !,?(IOM-$LENGTH(L1))/2,L1
- +7 WRITE !," TOUR #",?10,"TOUR NAME",?50,"SEGMENT"
- +8 WRITE !
- +9 FOR I=1:1:IOM-1
- WRITE "-"
- +10 QUIT
- +11 ;
- RET(TSTAMP) ;
- +1 IF ($EXTRACT(IOST,1,2)'="C-")!($DATA(ZTQUEUED))
- DO HDR(TSTAMP)
- QUIT 0
- +2 ;
- +3 NEW OUT
- +4 SET OUT=$$ASK^PRSLIB00(1)
- +5 IF 'OUT
- DO HDR(TSTAMP)
- +6 QUIT OUT
- +7 ;
- TOURCHK ; check tour of duty file for tours with special time Phy/Dent core
- +1 ;
- +2 ; STIEN-SPECIAL TOUR INDICATOR IEN (457.2)
- +3 ; STPTR-POINTER FROM TOUR OF DUTY FILE TO THE SPECIAL TOUR IND FILE
- +4 ;
- +5 USE IO
- +6 NEW I,ZNODE,NODE1,OUT,STPTR,STIEN,STCNT,SEGCNT,HASCORE,NODEX,TOUR
- +7 ; Loop through tours
- +8 ;
- +9 SET STIEN=$ORDER(^PRST(457.2,"B","Phy/Den Core Hours",0))
- +10 IF STIEN'>0
- Begin DoDot:1
- +11 DO HDR(TSTAMP)
- +12 WRITE !!,"REPORT ABORTED!"
- +13 WRITE !,"No Phy/Den Core Hours entry found in file 457.2"
- End DoDot:1
- QUIT
- +14 SET (STCNT,TOUR,OUT)=0
- SET NODEX=1
- +15 DO HDR(TSTAMP)
- +16 FOR
- SET TOUR=$ORDER(^PRST(457.1,TOUR))
- if TOUR'>0!(OUT)
- QUIT
- Begin DoDot:1
- +17 SET HASCORE=0
- +18 SET ZNODE=$GET(^PRST(457.1,TOUR,0))
- +19 SET NODE1=$GET(^PRST(457.1,TOUR,1))
- +20 ;
- +21 ; Loop through 7 Special Codes looking for code
- +22 ; #3 Phy/Den Core Hours
- +23 ;
- +24 SET SEGCNT=0
- +25 FOR I=3:3:21
- Begin DoDot:2
- +26 SET STPTR=$PIECE(NODE1,U,I)
- +27 IF STPTR=STIEN
- SET SEGCNT=SEGCNT+1
- Begin DoDot:3
- +28 SET HASCORE=1
- +29 IF SEGCNT=1
- Begin DoDot:4
- +30 SET STCNT=STCNT+1
- +31 WRITE !!,$JUSTIFY(TOUR,7),?10,$PIECE(ZNODE,U)
- End DoDot:4
- +32 IF '$TEST
- Begin DoDot:4
- +33 WRITE !
- End DoDot:4
- +34 WRITE ?50,I/3,": ",$PIECE(NODE1,U,I-2)," - ",$PIECE(NODE1,U,I-1)
- End DoDot:3
- End DoDot:2
- +35 ;
- +36 IF $Y>(IOSL-3)
- SET OUT=$$RET(TSTAMP)
- if OUT
- QUIT
- +37 IF HASCORE
- SET OUT=$$TLLIST^PRSPCORE(TOUR,TSTAMP)
- if OUT
- QUIT
- +38 IF INCLUDE
- IF HASCORE
- SET OUT=$$EMPLIST(TSTAMP,TOUR,PPI,TOUR)
- SET HASCORE=0
- if OUT
- QUIT
- End DoDot:1
- +39 ;
- +40 ;
- +41 IF STCNT=0
- WRITE !!,?5,"No Tours were found with Special Tour Indicator of Phy/Den Core Hrs"
- +42 DO ^%ZISC
- +43 IF $DATA(ZTSK)
- SET ZTREQ="@"
- +44 QUIT
- WHICHPP() ;
- +1 NEW PPI,SRT,DFN
- +2 SET PPI=$PIECE($GET(^PRST(458,"AD",DT)),U)
- +3 IF PPI'>0
- SET PPI=$ORDER(^PRST(458,99999),-1)
- +4 if PPI'>0
- QUIT
- +5 SET DFN=0
- DO NOL^PRSATE2
- +6 SET PPI=$SELECT(SRT="L":PPI-1,SRT="N":PPI+1,SRT="C":PPI,1:-1)
- +7 if PPI<0
- QUIT PPI
- +8 IF '$GET(^PRST(458,PPI,0))
- SET PPI=0
- WRITE !,"No employee tour data available for the unopened pay period."
- +9 QUIT PPI
- INCLEMP() ;ASK USER IF THEY WANT TO INCLUDE EMPLOYEES WITH THE TOUR
- +1 NEW DIR,DIRUT,Y,INCLUDE
- +2 SET DIR(0)="YA0"
- +3 SET DIR("B")="N"
- +4 SET DIR("A")="List employees with Phys/Den Core Hours Tours?"
- +5 DO ^DIR
- +6 SET INCLUDE=+Y
- +7 IF $DATA(DIRUT)
- SET INCLUDE=-1
- +8 QUIT INCLUDE
- EMPLIST(TS,TR,PPI,STIEN) ;LOOP THRU PP TO DISPLAY EMPS W/ PHY/DEN CORE TOURS
- +1 ;
- +2 NEW PRSIEN,PRSD,TRNODE,TR1,TR2,CORECNT,FOUND,OUT
- +3 SET OUT=0
- +4 WRITE !
- +5 SET (CORECNT,PRSIEN,OUT)=0
- +6 ; ^PRST(458,236,"E",12717,"D",12,0) = 12^295^0^9^13198^3050114.11 ...
- +7 ;
- +8 FOR
- SET PRSIEN=$ORDER(^PRST(458,PPI,"E",PRSIEN))
- if PRSIEN'>0!(OUT)
- QUIT
- Begin DoDot:1
- +9 SET (PRSD,FOUND)=0
- +10 FOR PRSD=1:1:14
- Begin DoDot:2
- +11 SET TRNODE=$GET(^PRST(458,PPI,"E",PRSIEN,"D",PRSD,0))
- +12 SET TR1=$PIECE(TRNODE,U,2)
- +13 SET TR2=$PIECE(TRNODE,U,13)
- +14 IF (TR1=STIEN)!(TR2=STIEN)
- SET FOUND=1
- SET CORECNT=CORECNT+1
- QUIT
- End DoDot:2
- +15 SET ZNODE=$GET(^PRSPC(PRSIEN,0))
- +16 IF FOUND
- WRITE !,?12,$PIECE(ZNODE,U),?45,"T&L: ",$PIECE(ZNODE,U,8),?67,"nnn-nn-",$EXTRACT($PIECE(ZNODE,U,9),6,9)
- +17 IF $Y>(IOSL-3)
- SET OUT=$$RET(TSTAMP)
- if OUT
- QUIT
- End DoDot:1
- +18 IF CORECNT=0
- WRITE !,?12,"No employees with this core hours tour in pp ",PPE
- +19 QUIT OUT
- +20 ;
- TLLIST(TIE,TSTAMP) ;LOOP THRU TOUR TO DISPLAY ASSOCIATED T&Ls
- +1 ; INPUT : Tour Internal Entry number
- +2 ; local vars:
- +3 ; ATL - Associated T & L unit
- +4 ; ATLCT - count the assoc tls
- +5 NEW ATL,ATLCT,OUT
- +6 WRITE !,?12,"Associated T&Ls: "
- +7 IF $$GET1^DIQ(457.1,TIE,4,,,)="YES"
- Begin DoDot:1
- +8 WRITE "This tour is available to all T&L units."
- End DoDot:1
- QUIT 0
- +9 ;
- +10 SET (OUT,ATLCT,ATL)=0
- +11 FOR
- SET ATL=$ORDER(^PRST(457.1,TIE,"T","B",ATL))
- if ATL'>0!(OUT)
- QUIT
- Begin DoDot:1
- +12 IF $X>(IOM-10)
- Begin DoDot:2
- +13 WRITE ", ",!,?29
- End DoDot:2
- +14 IF '$TEST
- Begin DoDot:2
- +15 IF ATLCT>0
- WRITE ", "
- End DoDot:2
- +16 IF $Y>(IOSL-3)
- SET OUT=$$RET(TSTAMP)
- if OUT
- QUIT
- WRITE !!,?12,"Associated T&Ls: "
- +17 SET ATLCT=ATLCT+1
- +18 WRITE $$GET1^DIQ(455.5,ATL,.01,,,)
- End DoDot:1
- +19 IF ATLCT=0
- WRITE "No T&L units are associated with this tour."
- +20 QUIT OUT