- PRSDSRS ;HISC/GWB-SERVICE RECORD SCREEN ;2/8/95 14:14
- ;;4.0;PAID;**114,100,132**;Sep 21, 1995;Build 13
- ;;Per VHA Directive 2004-038, this routine should not be modified.
- ;
- EMP S DA="",SSN=$P($G(^VA(200,DUZ,1)),"^",9)
- I SSN'="" S DA=$O(^PRSPC("SSN",SSN,0))
- I 'DA W !!,*7,"Your SSN was not found in both the New Person & Employee File!" G EX
- START D WAIT^DICD
- 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 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)
- D ^PRSDYTD
- SRS S CATEGORY="SERVICE RECORD SCREEN",PAGE=0
- K ^UTILITY("DIQ1",$J) S DIC="^PRSPC("
- S DR="2:5;9:11;13;15;15.5;16;19:23;26;28;30:32;37:39;42;43;47;52;53;64;82;83;89:116.2;139;120;132;142;143;144;226;231;395:427;458;538;600;634"
- S DIQ(0)="IE" D EN^DIQ1
- W @IOF D HDR S PRTC=1
- F F=16,20,15.5,13,38,28,82,83,142:1:144,23,3,37,9,15,19,21,11,458,42,39,53,52,32,31,4,43,10,5,47,139,120,132,226,231,26,64,538,22,30,2,600,634 D WR G:'PRTC EX
- S END="" D PRTC G:'PRTC EX
- FU S FUFLD=89 K FUYES
- F S FUFLD=$O(^UTILITY("DIQ1",$J,450,DA,FUFLD)) Q:(FUFLD>116.2)!(FUFLD="") I ^UTILITY("DIQ1",$J,450,DA,FUFLD,"I")'="" S FUYES=""
- G:'$D(FUYES) TSP K END S CATEGORY="FOLLOWUPS"
- W @IOF D HDR S PRTC=1
- F F=115.17,89:1:97,97.1,98,98.1,98.2,98.3,98.4,99,99.1,100:1:114,114.1,114.2,115.01:.01:115.14,115.18,115.19,115.2,115.21,115.15,115.16,115.17,116.01:.01:116.2 D WR G:'PRTC EX
- S END="" D PRTC G:'PRTC EX
- TSP K END S CATEGORY="THRIFT SAVINGS PLAN"
- W @IOF D HDR S PRTC=1
- F F=409,410,406,399,396,404,412,403,395,397,398,414,413,415,417,419,418,420,422,424,423,425,427,400,401,402,405,407,408 D WR G:'PRTC EX
- W:TSPYTD'=0 !!,"TSP EMP DED YTD.................",$FN(TSPYTD,",",2)
- S END="" D PRTC G:'PRTC EX
- 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 F=26 W:HBDYTD'=0 !,"HEALTH BENEFITS DEDUCTION YTD...",$FN(HBDYTD,",",2)
- I (NODEUTIL="")!(NODEUTIL="NA") K NODEDD,NODEUTIL Q
- S FLDNAM=$P(NODEDD,U,1)
- I F=15.5 S INT=^UTILITY("DIQ1",$J,450,DA,F,"E") G EXT
- 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
- S:F=15 FLDNAM="NORMAL HOURS" S:F=458 INT=$E(INT,1,4)_":"_$E(INT,5,8)
- S:F=414 FLDNAM="TSP CSF DIST PCT" S:F=419 FLDNAM="TSP FIF DIST PCT"
- S:F=424 FLDNAM="TSP GSF DIST PCT"
- I $P(NODEDD,U,5)["""$""" S VAL=$FN(INT,",",2) G IOSL
- I F>88,F<116.3 S VAL=EXT I $D(^PRSP(454,1,"PUC","C",FLDNAM)) S FUIEN=$O(^PRSP(454,1,"PUC","C",FLDNAM,0)) I $P(^PRSP(454,1,"PUC",FUIEN,0),U,3)'="" S VAL=VAL_" "_$P(^PRSP(454,1,"PUC",FUIEN,0),U,3) G IOSL
- I (F=404)!(F=414)!(F=419)!(F=424) S VAL=EXT 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
- S:F=458 VAL=INT
- IOSL K DOTS S NOD=32-$L(FLDNAM),$P(DOTS,".",NOD)="."
- I $Y>(IOSL-4) D PRTC Q:'PRTC
- I (F=400)!(F=407)!(F=414)!(F=419)!(F=424) W !
- 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
- I '$G(PRSTLV) W !,"XXX-XX-",$E(SSN,8,11),?71,"T&L: ",TLU,!,DASHES
- I $G(PRSTLV)=7 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
- SVC S Y=$P(^PRSPC(DA,0),U,49),C=$P(^DD(450,458,0),U,2) D Y^DIQ S USRSVC=Y
- S DIC="^PRSPC(",DIC(0)="AEQ",DIC("A")="Select EMPLOYEE: "
- S DIC("S")="S YSAV=Y,Y=$P(^PRSPC(YSAV,0),U,49),C=$P(^DD(450,458,0),U,2) D Y^DIQ S EMPSVC=Y,Y=YSAV I USRSVC=EMPSVC"
- D ^DIC I Y=-1 G EX
- S DA=+Y D START G SVC
- ;S %ZIS="QM" D ^%ZIS G EX:POP
- ;I $D(IO("Q")) D G EX
- ;.S ZTRTN="START^PRSDSRS",ZTDESC="PRS SERVICE RECORD SCREEN"
- ;.S ZTSAVE("DA")=""
- ;.D ^%ZTLOAD W:$D(ZTSK) !,"Request Queued!" D HOME^%ZIS K IO("Q") Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRSDSRS 4501 printed Feb 18, 2025@23:52:40 Page 2
- PRSDSRS ;HISC/GWB-SERVICE RECORD SCREEN ;2/8/95 14:14
- +1 ;;4.0;PAID;**114,100,132**;Sep 21, 1995;Build 13
- +2 ;;Per VHA Directive 2004-038, this routine should not be modified.
- +3 ;
- EMP SET DA=""
- SET SSN=$PIECE($GET(^VA(200,DUZ,1)),"^",9)
- +1 IF SSN'=""
- SET DA=$ORDER(^PRSPC("SSN",SSN,0))
- +2 IF 'DA
- WRITE !!,*7,"Your SSN was not found in both the New Person & Employee File!"
- GOTO EX
- START DO WAIT^DICD
- +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 Y=$PIECE(ZERO,U,49)
- XECUTE ^DD(450,458,2.1)
- SET CCORG=Y
- +6 SET DS=$PIECE($GET(^PRSPC(DA,1)),U,42)
- SET LPP=$PIECE($GET(^PRSPC(DA,"MISC4")),U,16)
- +7 DO ^PRSDYTD
- SRS SET CATEGORY="SERVICE RECORD SCREEN"
- SET PAGE=0
- +1 KILL ^UTILITY("DIQ1",$JOB)
- SET DIC="^PRSPC("
- +2 SET DR="2:5;9:11;13;15;15.5;16;19:23;26;28;30:32;37:39;42;43;47;52;53;64;82;83;89:116.2;139;120;132;142;143;144;226;231;395:427;458;538;600;634"
- +3 SET DIQ(0)="IE"
- DO EN^DIQ1
- +4 WRITE @IOF
- DO HDR
- SET PRTC=1
- +5 FOR F=16,20,15.5,13,38,28,82,83,142:1:144,23,3,37,9,15,19,21,11,458,42,39,53,52,32,31,4,43,10,5,47,139,120,132,226,231,26,64,538,22,30,2,600,634
- DO WR
- if 'PRTC
- GOTO EX
- +6 SET END=""
- DO PRTC
- if 'PRTC
- GOTO EX
- FU SET FUFLD=89
- KILL FUYES
- +1 FOR
- SET FUFLD=$ORDER(^UTILITY("DIQ1",$JOB,450,DA,FUFLD))
- if (FUFLD>116.2)!(FUFLD="")
- QUIT
- IF ^UTILITY("DIQ1",$JOB,450,DA,FUFLD,"I")'=""
- SET FUYES=""
- +2 if '$DATA(FUYES)
- GOTO TSP
- KILL END
- SET CATEGORY="FOLLOWUPS"
- +3 WRITE @IOF
- DO HDR
- SET PRTC=1
- +4 FOR F=115.17,89:1:97,97.1,98,98.1,98.2,98.3,98.4,99,99.1,100:1:114,114.1,114.2,115.01:.01:115.14,115.18,115.19,115.2,115.21,115.15,115.16,115.17,116.01:.01:116.2
- DO WR
- if 'PRTC
- GOTO EX
- +5 SET END=""
- DO PRTC
- if 'PRTC
- GOTO EX
- TSP KILL END
- SET CATEGORY="THRIFT SAVINGS PLAN"
- +1 WRITE @IOF
- DO HDR
- SET PRTC=1
- +2 FOR F=409,410,406,399,396,404,412,403,395,397,398,414,413,415,417,419,418,420,422,424,423,425,427,400,401,402,405,407,408
- DO WR
- if 'PRTC
- GOTO EX
- +3 if TSPYTD'=0
- WRITE !!,"TSP EMP DED YTD.................",$FNUMBER(TSPYTD,",",2)
- +4 SET END=""
- DO PRTC
- if 'PRTC
- GOTO EX
- 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 F=26
- if HBDYTD'=0
- WRITE !,"HEALTH BENEFITS DEDUCTION YTD...",$FNUMBER(HBDYTD,",",2)
- +2 IF (NODEUTIL="")!(NODEUTIL="NA")
- KILL NODEDD,NODEUTIL
- QUIT
- +3 SET FLDNAM=$PIECE(NODEDD,U,1)
- +4 IF F=15.5
- SET INT=^UTILITY("DIQ1",$JOB,450,DA,F,"E")
- GOTO EXT
- +5 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 F=15
- SET FLDNAM="NORMAL HOURS"
- if F=458
- SET INT=$EXTRACT(INT,1,4)_":"_$EXTRACT(INT,5,8)
- +4 if F=414
- SET FLDNAM="TSP CSF DIST PCT"
- if F=419
- SET FLDNAM="TSP FIF DIST PCT"
- +5 if F=424
- SET FLDNAM="TSP GSF DIST PCT"
- +6 IF $PIECE(NODEDD,U,5)["""$"""
- SET VAL=$FNUMBER(INT,",",2)
- GOTO IOSL
- +7 IF F>88
- IF F<116.3
- SET VAL=EXT
- IF $DATA(^PRSP(454,1,"PUC","C",FLDNAM))
- SET FUIEN=$ORDER(^PRSP(454,1,"PUC","C",FLDNAM,0))
- IF $PIECE(^PRSP(454,1,"PUC",FUIEN,0),U,3)'=""
- SET VAL=VAL_" "_$PIECE(^PRSP(454,1,"PUC",FUIEN,0),U,3)
- GOTO IOSL
- +8 IF (F=404)!(F=414)!(F=419)!(F=424)
- SET VAL=EXT
- GOTO IOSL
- +9 IF $PIECE(NODEDD,U,2)["D"
- SET VAL=EXT
- GOTO IOSL
- +10 IF $PIECE(NODEDD,U,2)["NJ"
- SET VAL=$JUSTIFY(INT,IL,2)
- GOTO IOSL
- +11 SET VAL=EXT
- +12 if F=458
- SET VAL=INT
- IOSL KILL DOTS
- SET NOD=32-$LENGTH(FLDNAM)
- SET $PIECE(DOTS,".",NOD)="."
- +1 IF $Y>(IOSL-4)
- DO PRTC
- if 'PRTC
- QUIT
- +2 IF (F=400)!(F=407)!(F=414)!(F=419)!(F=424)
- WRITE !
- +3 WRITE !,FLDNAM,DOTS
- +4 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 IF '$GET(PRSTLV)
- WRITE !,"XXX-XX-",$EXTRACT(SSN,8,11),?71,"T&L: ",TLU,!,DASHES
- +4 IF $GET(PRSTLV)=7
- WRITE !,SSN,?71,"T&L: ",TLU,!,DASHES
- +5 SET CLNGTH=$LENGTH(CATEGORY)
- SET TAB=(80-CLNGTH)\2
- SET TAB=TAB-1
- +6 WRITE !,"LAST PP: ",LPP,?TAB,CATEGORY,?73,"PAGE ",PAGE
- +7 WRITE !,DASHES
- +8 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
- SVC SET Y=$PIECE(^PRSPC(DA,0),U,49)
- SET C=$PIECE(^DD(450,458,0),U,2)
- DO Y^DIQ
- SET USRSVC=Y
- +1 SET DIC="^PRSPC("
- SET DIC(0)="AEQ"
- SET DIC("A")="Select EMPLOYEE: "
- +2 SET DIC("S")="S YSAV=Y,Y=$P(^PRSPC(YSAV,0),U,49),C=$P(^DD(450,458,0),U,2) D Y^DIQ S EMPSVC=Y,Y=YSAV I USRSVC=EMPSVC"
- +3 DO ^DIC
- IF Y=-1
- GOTO EX
- +4 SET DA=+Y
- DO START
- GOTO SVC
- +5 ;S %ZIS="QM" D ^%ZIS G EX:POP
- +6 ;I $D(IO("Q")) D G EX
- +7 ;.S ZTRTN="START^PRSDSRS",ZTDESC="PRS SERVICE RECORD SCREEN"
- +8 ;.S ZTSAVE("DA")=""
- +9 ;.D ^%ZTLOAD W:$D(ZTSK) !,"Request Queued!" D HOME^%ZIS K IO("Q") Q