- PRSD1150 ;HISC/GWB-RECORD OF LEAVE DATA ;2/5/1998
- ;;4.0;PAID;**35,100**;Sep 21, 1995;Build 3
- ;;Per VHA Directive 2004-038, this routine should not be modified.
- EMP K DIC S DIC="^PRSPC(",DIC(0)="AEMQZ"
- S DIC("A")="Select SEPARATED EMPLOYEE: " D ^DIC K DIC
- I Y'>0 G EX
- S DA=+Y
- I $P($G(^PRSPC(DA,1)),U,33)'="Y" D G EMP
- .W !!,*7,"This is not a separated employee. "
- .W "The SEPARATION IND does not equal Y.",!
- START ;
- K DASHES S $P(DASHES,"-",80)="-"
- S ZERO=^PRSPC(DA,0)
- S NAME=$P(ZERO,U,1),STATION=$P(ZERO,U,7),TLU=$P(ZERO,U,8)
- S SSN=$P(ZERO,U,9),SSN=$E(SSN,1,3)_"-"_$E(SSN,4,5)_"-"_$E(SSN,6,9)
- S SAL=$P(ZERO,U,29),HR=$S(SAL>99:SAL/2087,1:SAL),HR=$J(HR,0,2)
- S Y=$P(ZERO,U,49) X ^DD(450,458,2.1) S CCORG=Y
- S DS=$P($G(^PRSPC(DA,1)),U,42),LPP=$P($G(^PRSPC(DA,"MISC4")),U,16)
- S SCD=$P(ZERO,U,31)
- S SCDYR=$E(SCD,1,3),SCDMO=+$E(SCD,4,5),SCDDY=+$E(SCD,6,7)
- S DOS=$P($G(^PRSPC(DA,1)),U,2)
- S DOS1=$$FMADD^XLFDT(DOS,1) ; add 1 day so empl. credited for DOS
- S DOS1YR=$E(DOS1,1,3),DOS1MO=+$E(DOS1,4,5),DOS1DY=+$E(DOS1,6,7)
- ;
- ; calculate difference between DOS1 and SCD
- S TOTDY=DOS1DY-SCDDY
- S TOTMO=DOS1MO-SCDMO
- S TOTYR=DOS1YR-SCDYR
- ; if negative days then recalc. Subtract 1 from month and get days by
- ; adding the days from first and last month together.
- I TOTDY<0 D
- . S SCDDIM=$P("31^28^31^30^31^30^31^31^30^31^30^31",U,SCDMO)
- . I SCDDIM=28 S SCDDIM=SCDDIM+$$LEAPYR^PRSLIB00(SCDYR+1700)
- . S TOTDY=SCDDIM-SCDDY+DOS1DY
- . S TOTMO=TOTMO-1
- I TOTMO<0 S TOTMO=TOTMO+12,TOTYR=TOTYR-1
- ;
- ROLD S CATEGORY="RECORD OF LEAVE DATA",PAGE=0
- K ^UTILITY("DIQ1",$J) S DIC="^PRSPC("
- S DR="30;49;50",DIQ(0)="IE" D EN^DIQ1 W @IOF D HDR S PRTC=1
- F F=30,49,50 D WR G:'PRTC EX
- W !,"TOTAL SERVICE FOR LEAVE.........",TOTYR," YEARS"
- W !," ",TOTMO," MONTHS"
- W !," ",TOTDY," DAYS"
- K ^UTILITY("DIQ1",$J) S DIC="^PRSPC("
- S DR="462;510",DIQ(0)="IE" D EN^DIQ1
- F F=462,510 D WR G:'PRTC EX
- W !,"HOURLY RATE.....................",HR
- S END="" D PRTC
- EX K ^UTILITY("DIQ1",$J)
- N PRSTLV D KILL^XUSCLEAN W @IOF
- Q
- WR S NODEDD=^DD(450,F,0),NODEUTIL=$G(^UTILITY("DIQ1",$J,450,DA,F,"E"))
- I (NODEUTIL="")!(NODEUTIL="NA") K NODEDD,NODEUTIL Q
- S FLDNAM=$P(NODEDD,U,1)
- S INT=^UTILITY("DIQ1",$J,450,DA,F,"I")
- EXT S EXT=^UTILITY("DIQ1",$J,450,DA,F,"E")
- S IL=$L(INT)
- I $P(NODEDD,U,2)["NJ",+INT=0 K NODEDD,NODEUTIL Q
- I $P(NODEDD,U,5)["""$""" S VAL=$FN(INT,",",2) G IOSL
- I $P(NODEDD,U,2)["D" S VAL=EXT G IOSL
- I $P(NODEDD,U,2)["NJ" S VAL=$J(INT,IL,2) G IOSL
- S VAL=EXT
- IOSL K DOTS S NOD=32-$L(FLDNAM),$P(DOTS,".",NOD)="."
- I $Y>(IOSL-4) D PRTC Q:'PRTC
- W !,FLDNAM,DOTS
- D VAL Q
- VAL I $L(VAL)<48 W ?32,VAL Q
- S COLUMN=32,LGTH=0
- F LOOP=1:1 Q:LGTH=$L(VAL)!(LGTH>($L(VAL))) W:$L($P(VAL," ",LOOP))>(80-COLUMN) ! S:$L($P(VAL," ",LOOP))>(80-COLUMN) COLUMN=32 W ?COLUMN,$P(VAL," ",LOOP) S COLUMN=COLUMN+$L($P(VAL," ",LOOP))+1,LGTH=LGTH+$L($P(VAL," ",LOOP))+1
- Q
- HDR W:$Y>0 @IOF S PAGE=PAGE+1
- S CLNGTH=$L(CCORG),TAB=(80-CLNGTH)\2,TAB=TAB-1
- W !,NAME,?TAB,CCORG,?61,"DUTY STATION: ",STATION_DS
- W !,SSN,?71,"T&L: ",TLU,!,DASHES
- S CLNGTH=$L(CATEGORY),TAB=(80-CLNGTH)\2,TAB=TAB-1
- W !,"LAST PP: ",LPP,?TAB,CATEGORY,?73,"PAGE ",PAGE
- W !,DASHES
- K CLNGTH,TAB Q
- PRTC W:$Y<22 ! K DIR,DIRUT,DIROUT,DTOUT,DUOUT
- S DIR(0)="E",DIR("A")="Press RETURN to continue" D ^DIR
- I $D(DIRUT) S PRTC=0 Q
- D:'$D(END) HDR Q
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRSD1150 3434 printed Mar 13, 2025@21:30:03 Page 2
- PRSD1150 ;HISC/GWB-RECORD OF LEAVE DATA ;2/5/1998
- +1 ;;4.0;PAID;**35,100**;Sep 21, 1995;Build 3
- +2 ;;Per VHA Directive 2004-038, this routine should not be modified.
- EMP KILL DIC
- SET DIC="^PRSPC("
- SET DIC(0)="AEMQZ"
- +1 SET DIC("A")="Select SEPARATED EMPLOYEE: "
- DO ^DIC
- KILL DIC
- +2 IF Y'>0
- GOTO EX
- +3 SET DA=+Y
- +4 IF $PIECE($GET(^PRSPC(DA,1)),U,33)'="Y"
- Begin DoDot:1
- +5 WRITE !!,*7,"This is not a separated employee. "
- +6 WRITE "The SEPARATION IND does not equal Y.",!
- End DoDot:1
- GOTO EMP
- START ;
- +1 KILL DASHES
- SET $PIECE(DASHES,"-",80)="-"
- +2 SET ZERO=^PRSPC(DA,0)
- +3 SET NAME=$PIECE(ZERO,U,1)
- SET STATION=$PIECE(ZERO,U,7)
- SET TLU=$PIECE(ZERO,U,8)
- +4 SET SSN=$PIECE(ZERO,U,9)
- SET SSN=$EXTRACT(SSN,1,3)_"-"_$EXTRACT(SSN,4,5)_"-"_$EXTRACT(SSN,6,9)
- +5 SET SAL=$PIECE(ZERO,U,29)
- SET HR=$SELECT(SAL>99:SAL/2087,1:SAL)
- SET HR=$JUSTIFY(HR,0,2)
- +6 SET Y=$PIECE(ZERO,U,49)
- XECUTE ^DD(450,458,2.1)
- SET CCORG=Y
- +7 SET DS=$PIECE($GET(^PRSPC(DA,1)),U,42)
- SET LPP=$PIECE($GET(^PRSPC(DA,"MISC4")),U,16)
- +8 SET SCD=$PIECE(ZERO,U,31)
- +9 SET SCDYR=$EXTRACT(SCD,1,3)
- SET SCDMO=+$EXTRACT(SCD,4,5)
- SET SCDDY=+$EXTRACT(SCD,6,7)
- +10 SET DOS=$PIECE($GET(^PRSPC(DA,1)),U,2)
- +11 ; add 1 day so empl. credited for DOS
- SET DOS1=$$FMADD^XLFDT(DOS,1)
- +12 SET DOS1YR=$EXTRACT(DOS1,1,3)
- SET DOS1MO=+$EXTRACT(DOS1,4,5)
- SET DOS1DY=+$EXTRACT(DOS1,6,7)
- +13 ;
- +14 ; calculate difference between DOS1 and SCD
- +15 SET TOTDY=DOS1DY-SCDDY
- +16 SET TOTMO=DOS1MO-SCDMO
- +17 SET TOTYR=DOS1YR-SCDYR
- +18 ; if negative days then recalc. Subtract 1 from month and get days by
- +19 ; adding the days from first and last month together.
- +20 IF TOTDY<0
- Begin DoDot:1
- +21 SET SCDDIM=$PIECE("31^28^31^30^31^30^31^31^30^31^30^31",U,SCDMO)
- +22 IF SCDDIM=28
- SET SCDDIM=SCDDIM+$$LEAPYR^PRSLIB00(SCDYR+1700)
- +23 SET TOTDY=SCDDIM-SCDDY+DOS1DY
- +24 SET TOTMO=TOTMO-1
- End DoDot:1
- +25 IF TOTMO<0
- SET TOTMO=TOTMO+12
- SET TOTYR=TOTYR-1
- +26 ;
- ROLD SET CATEGORY="RECORD OF LEAVE DATA"
- SET PAGE=0
- +1 KILL ^UTILITY("DIQ1",$JOB)
- SET DIC="^PRSPC("
- +2 SET DR="30;49;50"
- SET DIQ(0)="IE"
- DO EN^DIQ1
- WRITE @IOF
- DO HDR
- SET PRTC=1
- +3 FOR F=30,49,50
- DO WR
- if 'PRTC
- GOTO EX
- +4 WRITE !,"TOTAL SERVICE FOR LEAVE.........",TOTYR," YEARS"
- +5 WRITE !," ",TOTMO," MONTHS"
- +6 WRITE !," ",TOTDY," DAYS"
- +7 KILL ^UTILITY("DIQ1",$JOB)
- SET DIC="^PRSPC("
- +8 SET DR="462;510"
- SET DIQ(0)="IE"
- DO EN^DIQ1
- +9 FOR F=462,510
- DO WR
- if 'PRTC
- GOTO EX
- +10 WRITE !,"HOURLY RATE.....................",HR
- +11 SET END=""
- DO PRTC
- EX KILL ^UTILITY("DIQ1",$JOB)
- +1 NEW PRSTLV
- DO KILL^XUSCLEAN
- WRITE @IOF
- +2 QUIT
- WR SET NODEDD=^DD(450,F,0)
- SET NODEUTIL=$GET(^UTILITY("DIQ1",$JOB,450,DA,F,"E"))
- +1 IF (NODEUTIL="")!(NODEUTIL="NA")
- KILL NODEDD,NODEUTIL
- QUIT
- +2 SET FLDNAM=$PIECE(NODEDD,U,1)
- +3 SET INT=^UTILITY("DIQ1",$JOB,450,DA,F,"I")
- EXT SET EXT=^UTILITY("DIQ1",$JOB,450,DA,F,"E")
- +1 SET IL=$LENGTH(INT)
- +2 IF $PIECE(NODEDD,U,2)["NJ"
- IF +INT=0
- KILL NODEDD,NODEUTIL
- QUIT
- +3 IF $PIECE(NODEDD,U,5)["""$"""
- SET VAL=$FNUMBER(INT,",",2)
- GOTO IOSL
- +4 IF $PIECE(NODEDD,U,2)["D"
- SET VAL=EXT
- GOTO IOSL
- +5 IF $PIECE(NODEDD,U,2)["NJ"
- SET VAL=$JUSTIFY(INT,IL,2)
- GOTO IOSL
- +6 SET VAL=EXT
- IOSL KILL DOTS
- SET NOD=32-$LENGTH(FLDNAM)
- SET $PIECE(DOTS,".",NOD)="."
- +1 IF $Y>(IOSL-4)
- DO PRTC
- if 'PRTC
- QUIT
- +2 WRITE !,FLDNAM,DOTS
- +3 DO VAL
- QUIT
- VAL IF $LENGTH(VAL)<48
- WRITE ?32,VAL
- QUIT
- +1 SET COLUMN=32
- SET LGTH=0
- +2 FOR LOOP=1:1
- if LGTH=$LENGTH(VAL)!(LGTH>($LENGTH(VAL)))
- QUIT
- if $LENGTH($PIECE(VAL," ",LOOP))>(80-COLUMN)
- WRITE !
- if $LENGTH($PIECE(VAL," ",LOOP))>(80-COLUMN)
- SET COLUMN=32
- WRITE ?COLUMN,$PIECE(VAL," ",LOOP)
- SET COLUMN=COLUMN+$LENGTH($PIECE(VAL," ",LOOP))+1
- SET LGTH=LGTH+$LENGTH($PIECE(VAL," ",LOOP))+1
- +3 QUIT
- HDR if $Y>0
- WRITE @IOF
- SET PAGE=PAGE+1
- +1 SET CLNGTH=$LENGTH(CCORG)
- SET TAB=(80-CLNGTH)\2
- SET TAB=TAB-1
- +2 WRITE !,NAME,?TAB,CCORG,?61,"DUTY STATION: ",STATION_DS
- +3 WRITE !,SSN,?71,"T&L: ",TLU,!,DASHES
- +4 SET CLNGTH=$LENGTH(CATEGORY)
- SET TAB=(80-CLNGTH)\2
- SET TAB=TAB-1
- +5 WRITE !,"LAST PP: ",LPP,?TAB,CATEGORY,?73,"PAGE ",PAGE
- +6 WRITE !,DASHES
- +7 KILL CLNGTH,TAB
- QUIT
- PRTC if $Y<22
- WRITE !
- KILL DIR,DIRUT,DIROUT,DTOUT,DUOUT
- +1 SET DIR(0)="E"
- SET DIR("A")="Press RETURN to continue"
- DO ^DIR
- +2 IF $DATA(DIRUT)
- SET PRTC=0
- QUIT
- +3 if '$DATA(END)
- DO HDR
- QUIT
- +4 QUIT
