PRCBP.m

PRCBP ;WISC/CTB-PRINT OPTIONS FOR PRCB ;10/31/01 12:50pm

V ;;5.1;IFCAP;**3,43,139**;Oct 20, 2000;Build 16

 ;Per VHA Directive 2004-038, this routine should not be modified.

SE W !!,$C(7),"ENTRY TO THIS ROUTINE IS ONLY PERMITTED THROUGH THE APPROPRIATE",!,"MENU OR DRIVER" Q

OUT K %,%Y,DIJ,DP,IOX,IOY,POP,PRCB,PRCF,PRC("CP"),X,Y,NOLCK Q

EN1 ;PRINT RANGE OF TRANSACTIONS

 S PRCF("X")="ABFS" D ^PRCFSITE G:'% OUT

R1 S C="R1",D=1 W !,"START WITH TRANSACTION NUMBER: 1// " R X:$S($D(DTIME):DTIME,1:300) S:X="" X=1 G:X["^" OUT G:X["?"!(X'?1.5N)!(+X'=X)!(X<1)!(X>PRCB("LAST")) Q1 S FR=X K X

R2 S C="R2",D=FR R !!,"GO TO TRANSACTION NUMBER: LAST// ",X:$S($D(DTIME):DTIME,1:300) S:X="" X=PRCB("LAST") G:X["^" OUT G:X["?"!(X'?1.4N)!(+X'=X)!(X<FR)!(X>PRCB("LAST")) Q1 S TO=X

 S X="0000"_FR,X=$E(X,$L(X)-4,$L(X)),FR=PRCF("SIFY")_"-"_X S X="0000"_TO,X=$E(X,$L(X)-4,$L(X)),TO=PRCF("SIFY")_"-"_X

 D ZIS G:POP OUT S FLDS=$S(IOM<81:"[PRCB TRANS RANGE DISPLAY]",1:"[PRCB TRANS RANGE LIST]")

 S DIC="^PRCF(421,",BY="[PRCB BY TRANSACTION NUMBER]",L=0 D EN1^DIP D H G OUT

Q1 W !!,$C(7),"ENTER A NUMBER BETWEEN ",D," AND ",PRCB("LAST"),".  ('^' TO EXIT)" G @(C)

 ;

EN2 ;PRINT SELECTED CONTROL POINTS

 ;Patch 3: This section no longer calls the PRCFQ. It calls %ZTLOAD.

 S NOTSK=0,NOLCK=0,EN2Q=0,EN2P=0,RECFLG=0

 K DIC("A") S PRCF("X")="ABFS" D ^PRCFSITE G:'% OUT

 S ^XTMP("PRCBP",$J)=""

 S DIC("A")="Select FUND CONTROL POINT: "

 F ZX=1:1 D  Q:$G(Y)<0!($G(Y)="")  Q:$G(OUT)=1

 .S DIC(0)="AEQZMN",DIC="^PRC(420,PRC(""SITE""),1,"

 .D ^DIC K DIC("A")

 .Q:Y<0

 .S CP=+Y

 .D EN23

 .I X=U K ^XTMP("PRCBP",$J) S OUT=1 Q

 .I RECFLG=0 D

 ..D EOP^PRC0A(.X,.Y,"No TXN for selected STATION, FISCAL, and Fund Control Point.","AO","")

 .S DIC("A")="ANOTHER FUND CONTROL POINT: "

 K ZX

 I $G(OUT)=1 K OUT G OUT

 I X=U K ^XTMP("PRCBP",$J) G CLNUP

 I '$O(^XTMP("PRCBP",$J,"AM",0)) G CLNUP

 K IO("Q"),IOP,ZTSK,%ZIS,IOC,ZTIO

 S %ZIS="NQ",%ZIS("B")="" D ^%ZIS I POP K ^XTMP("PRCBP",$J) G CLNUP

 I '$D(IO("Q")) S CP=9999 D EN23 S EN2P=1,EN2Q=0 G EN2P

 S EN2Q=1,EN2P=0

 S ZTDESC="PRINT SELECTED CONTROL POINTS",ZTRTN="EN2Q^PRCBP"

 S ZTSAVE("PRCF*")="",ZTSAVE("PRC*")=""

 D ^%ZTLOAD D ^%ZISC

 I '$D(ZTSK) S NOTSK=1 D ERRMSG G CLNUP

 W !,"  <Request Queued> Your Task number is: ",ZTSK,$C(7),!

 S TSKNUM=ZTSK,AQ=0,NOLCK=0

 S ^XTMP("PRCBP",TSKNUM)=""

 L +^XTMP("PRCBP",TSKNUM):5

 E  S NOLCK=1 D ERRMSG G CLNUP

 F LOOP=1:1 S AQ=$O(^XTMP("PRCBP",$J,"AM",1,AQ)) Q:AQ=""  D

 .S ^XTMP("PRCBP",TSKNUM,"AQ",1,AQ)=""

 S AQ=$O(^PRCF(421,"AC",PRCF("SIFY")_"-"_9999,AQ))

 S ^XTMP("PRCBP",TSKNUM,"AQ",1,AQ)=""

 K ^XTMP("PRCBP",$J)

 L -^XTMP("PRCBP",TSKNUM)

 G CLNUP

 ;

EN2Q ;Queue the Print Task(s).

 ;

 D:$D(ZTQUEUED) KILL^%ZTLOAD

 I '$D(ZTSK) S NOTSK=1 D ERRMSG G CLNUP

 K TSKNUM S AQ=0,TSKNUM=ZTSK,NOTSK=0,NOLCK=0,EN2Q=1,EN2P=0

 G EN2P

 ;

ERRMSG ;Write the error messages.

 ;

 N DTIME S DTIME=60

 I NOTSK=1 D

 .W !,"Could not get a Task Number. Enter RETURN or '^' to exit. "

 .R !,ANS:DTIME

 ;

CLNUP ;Clean variables that no longer needed.

 ;

 D OUT

 K TSKNUM,PRC,IOP,%ZIS,IOC,ZTIO,IO("Q"),ION,IOP,RECFLG,NOTSK

 K AQ,LOOP,DIC,L,BY,FLDS,CP,ANS,I,N,EN2P,EN2Q,NOLCK,AM

 K ZTDESC,ZTQUEUED,ZTRTN,ZTSAVE("PRC*"),ZTSAVE("PRCF*")

 Q

 ;

EN2P ;Print the Task(s).

 ;

 D:$D(ZTQUEUED) KILL^%ZTLOAD

 S AM=0,AQ=0

 S FLDS=$S(IOM<81:"[PRCB FCP DISPLAY]",1:"[PRCB FCP LIST]")

 S DIC="^PRCF(421,",BY="[PRCB BY SEARCH/FCP/TRANS]"

 S L=0,IOP=ION

 I EN2P  D

 .F LOOP=1:1 S AM=$O(^XTMP("PRCBP",$J,"AM",1,AM)) Q:AM=""  D

 ..S ^PRCF(421,"AM",1,AM)=""

 .K ^XTMP("PRCBP",$J)

 I EN2Q  D

 .F LOOP=1:1 S AQ=$O(^XTMP("PRCBP",TSKNUM,"AQ",1,AQ)) Q:AQ=""  D

 ..S ^PRCF(421,"AM",1,AQ)=""

 .K ^XTMP("PRCBP",TSKNUM)

 D EN1^DIP

 K ^PRCF(421,"AM")

 G CLNUP

 ;

EN23 ;Setup the temp file with selected records (FCP).

 ;

 S N=0,RECFLG=0

 F I=1:1 S N=$O(^PRCF(421,"AC",PRCF("SIFY")_"-"_CP,N)) Q:N=""  D

 .S RECFLG=1

 .S ^XTMP("PRCBP",$J,"AM",1,N)=""

 .S $P(^PRCF(421,N,2),"^",14)=1

 .W:CP'=9999 "."

 Q

EN3 ;PRINT BY TDA NUMBER

 S PRCF("X")="ABFS" D ^PRCFSITE G:'% OUT

 S FR=$O(^PRCF(421,"B",PRCF("SIFY")_"-00000")) I FR="" W !,"NO TRANSACTIONS IN FY ",PRC("FY") R X:2 G OUT

Q31 D DD^PRC0A(.X,.Y,"Beginning TDA Number","421,3O",1)

 G EN3:Y=""!(Y["^")

 S PRCA=Y

Q32 D DD^PRC0A(.X,.Y,"Ending TDA Number","421,3O",9999)

 G EN3:Y["^",Q31:Y=""

 I PRCA]Y D EN^DDIOL("Beginning/Ending TDA numbers are not in order") G Q32

 S PRCB=Y

 S FR=PRCF("SIFY")_","_PRCA,TO=PRCF("SIFY")_","_PRCB

 S ZTDESC="PRINT TDA LISTING",ZTRTN="EN1Q^PRCBP",ZTSAVE("PRC*")="",ZTSAVE("PRCF*")="",ZTSAVE("FR")="",ZTSAVE("TO")="" D ^PRCFQ,H,OUT Q

EN1Q S IOP=ION,FLDS=$S(IOM<81:"[PRCB TDA DISPLAY]",1:"[PRCB TDA LIST]")

 ;S DIC="^PRCF(421,",BY="[PRCB BY TRANS/TDA]",L=0 D EN1^DIP,H,OUT

 S DIC="^PRCF(421,",BY="]@.5,3",L=0 D EN1^DIP,H,OUT

 Q

EN4 ;FTEE SUMMARY BY PROGRAM

 S PRCF("X")="ABFS" D ^PRCFSITE G:'% OUT S L=0,DIC="^PRCF(421,",BY="[PRCB BY APPROP/TDA]",FR=PRCF("SIFY"),TO=PRCF("SIFY")_"Z",FLDS="[PRCB FTEE SUMMARY]" D EN1^DIP,OUT Q

EN5 ;APPROPRIATION SUMMARY (DETAIL)

 S PRCF("X")="ABFS" D ^PRCFSITE G:'% OUT

 S ZTDESC="APPROPRIATION SUMMARY (DETAIL)",ZTRTN="EN5Q^PRCBP",ZTSAVE("PRC*")="",ZTSAVE("PRCF*")="" D ^PRCFQ,OUT Q

EN5Q S FLDS=$S(IOM<81:"[PRCB DISPLAY APP SUM DETAIL]",1:"[PRCB APPROP SUM  DETAIL]")

 S IOP=ION,L=0,DIC="^PRCF(421,",BY="[PRCB BY APP/FCP]",FR=PRCF("SIFY"),TO=PRCF("SIFY") D EN1^DIP,OUT Q

EN6 ;APPROPTIATION SUMMARY (TOTALS)

 S PRCF("X")="ABFS" D ^PRCFSITE G:'% OUT

 S ZTDESC="APPROPRIATION SUMMARY (TOTALS)",ZTRTN="EN6Q^PRCBP",ZTSAVE("PRC*")="",ZTSAVE("PRCF*")="" D ^PRCFQ,OUT Q

EN6Q S IOP=PRIOP,L=0,DIC="^PRCF(421,",BY="[PRCB BY APP/FCP]",FR=PRCF("SIFY"),TO=PRCF("SIFY"),FLDS="[PRCB APPROP SUM  TOTAL]" D EN1^DIP,OUT Q

H I $D(IO(0)),IO=IO(0),$D(IOST),IOST["C-" W !,"PRESS RETURN TO CONTINUE",$C(7) R X:$S($D(DTIME):DTIME,1:300)

 Q

ZIS K DQTIME,IOP S %ZIS="QN" D ^%ZIS Q:POP  S IOP=ION I IO'=IO(0) S %ZIS="Q",IOP="Q;"_ION

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---PRCBP   5953     printed  Feb 18, 2025@23:27:08                                                                                                                                                                                                       Page 2

PRCBP     ;WISC/CTB-PRINT OPTIONS FOR PRCB ;10/31/01 12:50pm

V         ;;5.1;IFCAP;**3,43,139**;Oct 20, 2000;Build 16

 +1       ;Per VHA Directive 2004-038, this routine should not be modified.

SE         WRITE !!,$CHAR(7),"ENTRY TO THIS ROUTINE IS ONLY PERMITTED THROUGH THE APPROPRIATE",!,"MENU OR DRIVER"

           QUIT 

OUT        KILL %,%Y,DIJ,DP,IOX,IOY,POP,PRCB,PRCF,PRC("CP"),X,Y,NOLCK

           QUIT 

EN1       ;PRINT RANGE OF TRANSACTIONS

 +1        SET PRCF("X")="ABFS"

           DO ^PRCFSITE

           if '%

               GOTO OUT

R1         SET C="R1"

           SET D=1

           WRITE !,"START WITH TRANSACTION NUMBER: 1// "

           READ X:$SELECT($DATA(DTIME):DTIME,1:300)

           if X=""

               SET X=1

           if X["^"

               GOTO OUT

           if X["?"!(X'?1.5N)!(+X'=X)!(X<1)!(X>PRCB("LAST"))

               GOTO Q1

           SET FR=X

           KILL X

R2         SET C="R2"

           SET D=FR

           READ !!,"GO TO TRANSACTION NUMBER: LAST// ",X:$SELECT($DATA(DTIME):DTIME,1:300)

           if X=""

               SET X=PRCB("LAST")

           if X["^"

               GOTO OUT

           if X["?"!(X'?1.4N)!(+X'=X)!(X<FR)!(X>PRCB("LAST"))

               GOTO Q1

           SET TO=X

 +1        SET X="0000"_FR

           SET X=$EXTRACT(X,$LENGTH(X)-4,$LENGTH(X))

           SET FR=PRCF("SIFY")_"-"_X

           SET X="0000"_TO

           SET X=$EXTRACT(X,$LENGTH(X)-4,$LENGTH(X))

           SET TO=PRCF("SIFY")_"-"_X

 +2        DO ZIS

           if POP

               GOTO OUT

           SET FLDS=$SELECT(IOM<81:"[PRCB TRANS RANGE DISPLAY]",1:"[PRCB TRANS RANGE LIST]")

 +3        SET DIC="^PRCF(421,"

           SET BY="[PRCB BY TRANSACTION NUMBER]"

           SET L=0

           DO EN1^DIP

           DO H

           GOTO OUT

Q1         WRITE !!,$CHAR(7),"ENTER A NUMBER BETWEEN ",D," AND ",PRCB("LAST"),".  ('^' TO EXIT)"

           GOTO @(C)

 +1       ;

EN2       ;PRINT SELECTED CONTROL POINTS

 +1       ;Patch 3: This section no longer calls the PRCFQ. It calls %ZTLOAD.

 +2        SET NOTSK=0

           SET NOLCK=0

           SET EN2Q=0

           SET EN2P=0

           SET RECFLG=0

 +3        KILL DIC("A")

           SET PRCF("X")="ABFS"

           DO ^PRCFSITE

           if '%

               GOTO OUT

 +4        SET ^XTMP("PRCBP",$JOB)=""

 +5        SET DIC("A")="Select FUND CONTROL POINT: "

 +6        FOR ZX=1:1

               Begin DoDot:1

 +7                SET DIC(0)="AEQZMN"

                   SET DIC="^PRC(420,PRC(""SITE""),1,"

 +8                DO ^DIC

                   KILL DIC("A")

 +9                if Y<0

                       QUIT 

 +10               SET CP=+Y

 +11               DO EN23

 +12               IF X=U

                       KILL ^XTMP("PRCBP",$JOB)

                       SET OUT=1

                       QUIT 

 +13               IF RECFLG=0

                       Begin DoDot:2

 +14                       DO EOP^PRC0A(.X,.Y,"No TXN for selected STATION, FISCAL, and Fund Control Point.","AO","")

                       End DoDot:2

 +15               SET DIC("A")="ANOTHER FUND CONTROL POINT: "

               End DoDot:1

               if $GET(Y)<0!($GET(Y)="")

                   QUIT 

               if $GET(OUT)=1

                   QUIT 

 +16       KILL ZX

 +17       IF $GET(OUT)=1

               KILL OUT

               GOTO OUT

 +18       IF X=U

               KILL ^XTMP("PRCBP",$JOB)

               GOTO CLNUP

 +19       IF '$ORDER(^XTMP("PRCBP",$JOB,"AM",0))

               GOTO CLNUP

 +20       KILL IO("Q"),IOP,ZTSK,%ZIS,IOC,ZTIO

 +21       SET %ZIS="NQ"

           SET %ZIS("B")=""

           DO ^%ZIS

           IF POP

               KILL ^XTMP("PRCBP",$JOB)

               GOTO CLNUP

 +22       IF '$DATA(IO("Q"))

               SET CP=9999

               DO EN23

               SET EN2P=1

               SET EN2Q=0

               GOTO EN2P

 +23       SET EN2Q=1

           SET EN2P=0

 +24       SET ZTDESC="PRINT SELECTED CONTROL POINTS"

           SET ZTRTN="EN2Q^PRCBP"

 +25       SET ZTSAVE("PRCF*")=""

           SET ZTSAVE("PRC*")=""

 +26       DO ^%ZTLOAD

           DO ^%ZISC

 +27       IF '$DATA(ZTSK)

               SET NOTSK=1

               DO ERRMSG

               GOTO CLNUP

 +28       WRITE !,"  <Request Queued> Your Task number is: ",ZTSK,$CHAR(7),!

 +29       SET TSKNUM=ZTSK

           SET AQ=0

           SET NOLCK=0

 +30       SET ^XTMP("PRCBP",TSKNUM)=""

 +31       LOCK +^XTMP("PRCBP",TSKNUM):5

 +32      IF '$TEST

               SET NOLCK=1

               DO ERRMSG

               GOTO CLNUP

 +33       FOR LOOP=1:1

               SET AQ=$ORDER(^XTMP("PRCBP",$JOB,"AM",1,AQ))

               if AQ=""

                   QUIT 

               Begin DoDot:1

 +34               SET ^XTMP("PRCBP",TSKNUM,"AQ",1,AQ)=""

               End DoDot:1

 +35       SET AQ=$ORDER(^PRCF(421,"AC",PRCF("SIFY")_"-"_9999,AQ))

 +36       SET ^XTMP("PRCBP",TSKNUM,"AQ",1,AQ)=""

 +37       KILL ^XTMP("PRCBP",$JOB)

 +38       LOCK -^XTMP("PRCBP",TSKNUM)

 +39       GOTO CLNUP

 +40      ;

EN2Q      ;Queue the Print Task(s).

 +1       ;

 +2        if $DATA(ZTQUEUED)

               DO KILL^%ZTLOAD

 +3        IF '$DATA(ZTSK)

               SET NOTSK=1

               DO ERRMSG

               GOTO CLNUP

 +4        KILL TSKNUM

           SET AQ=0

           SET TSKNUM=ZTSK

           SET NOTSK=0

           SET NOLCK=0

           SET EN2Q=1

           SET EN2P=0

 +5        GOTO EN2P

 +6       ;

ERRMSG    ;Write the error messages.

 +1       ;

 +2        NEW DTIME

           SET DTIME=60

 +3        IF NOTSK=1

               Begin DoDot:1

 +4                WRITE !,"Could not get a Task Number. Enter RETURN or '^' to exit. "

 +5                READ !,ANS:DTIME

               End DoDot:1

 +6       ;

CLNUP     ;Clean variables that no longer needed.

 +1       ;

 +2        DO OUT

 +3        KILL TSKNUM,PRC,IOP,%ZIS,IOC,ZTIO,IO("Q"),ION,IOP,RECFLG,NOTSK

 +4        KILL AQ,LOOP,DIC,L,BY,FLDS,CP,ANS,I,N,EN2P,EN2Q,NOLCK,AM

 +5        KILL ZTDESC,ZTQUEUED,ZTRTN,ZTSAVE("PRC*"),ZTSAVE("PRCF*")

 +6        QUIT 

 +7       ;

EN2P      ;Print the Task(s).

 +1       ;

 +2        if $DATA(ZTQUEUED)

               DO KILL^%ZTLOAD

 +3        SET AM=0

           SET AQ=0

 +4        SET FLDS=$SELECT(IOM<81:"[PRCB FCP DISPLAY]",1:"[PRCB FCP LIST]")

 +5        SET DIC="^PRCF(421,"

           SET BY="[PRCB BY SEARCH/FCP/TRANS]"

 +6        SET L=0

           SET IOP=ION

 +7        IF EN2P

               Begin DoDot:1

 +8                FOR LOOP=1:1

                       SET AM=$ORDER(^XTMP("PRCBP",$JOB,"AM",1,AM))

                       if AM=""

                           QUIT 

                       Begin DoDot:2

 +9                        SET ^PRCF(421,"AM",1,AM)=""

                       End DoDot:2

 +10               KILL ^XTMP("PRCBP",$JOB)

               End DoDot:1

 +11       IF EN2Q

               Begin DoDot:1

 +12               FOR LOOP=1:1

                       SET AQ=$ORDER(^XTMP("PRCBP",TSKNUM,"AQ",1,AQ))

                       if AQ=""

                           QUIT 

                       Begin DoDot:2

 +13                       SET ^PRCF(421,"AM",1,AQ)=""

                       End DoDot:2

 +14               KILL ^XTMP("PRCBP",TSKNUM)

               End DoDot:1

 +15       DO EN1^DIP

 +16       KILL ^PRCF(421,"AM")

 +17       GOTO CLNUP

 +18      ;

EN23      ;Setup the temp file with selected records (FCP).

 +1       ;

 +2        SET N=0

           SET RECFLG=0

 +3        FOR I=1:1

               SET N=$ORDER(^PRCF(421,"AC",PRCF("SIFY")_"-"_CP,N))

               if N=""

                   QUIT 

               Begin DoDot:1

 +4                SET RECFLG=1

 +5                SET ^XTMP("PRCBP",$JOB,"AM",1,N)=""

 +6                SET $PIECE(^PRCF(421,N,2),"^",14)=1

 +7                if CP'=9999

                       WRITE "."

               End DoDot:1

 +8        QUIT 

EN3       ;PRINT BY TDA NUMBER

 +1        SET PRCF("X")="ABFS"

           DO ^PRCFSITE

           if '%

               GOTO OUT

 +2        SET FR=$ORDER(^PRCF(421,"B",PRCF("SIFY")_"-00000"))

           IF FR=""

               WRITE !,"NO TRANSACTIONS IN FY ",PRC("FY")

               READ X:2

               GOTO OUT

Q31        DO DD^PRC0A(.X,.Y,"Beginning TDA Number","421,3O",1)

 +1        if Y=""!(Y["^")

               GOTO EN3

 +2        SET PRCA=Y

Q32        DO DD^PRC0A(.X,.Y,"Ending TDA Number","421,3O",9999)

 +1        if Y["^"

               GOTO EN3

           if Y=""

               GOTO Q31

 +2        IF PRCA]Y

               DO EN^DDIOL("Beginning/Ending TDA numbers are not in order")

               GOTO Q32

 +3        SET PRCB=Y

 +4        SET FR=PRCF("SIFY")_","_PRCA

           SET TO=PRCF("SIFY")_","_PRCB

 +5        SET ZTDESC="PRINT TDA LISTING"

           SET ZTRTN="EN1Q^PRCBP"

           SET ZTSAVE("PRC*")=""

           SET ZTSAVE("PRCF*")=""

           SET ZTSAVE("FR")=""

           SET ZTSAVE("TO")=""

           DO ^PRCFQ

           DO H

           DO OUT

           QUIT 

EN1Q       SET IOP=ION

           SET FLDS=$SELECT(IOM<81:"[PRCB TDA DISPLAY]",1:"[PRCB TDA LIST]")

 +1       ;S DIC="^PRCF(421,",BY="[PRCB BY TRANS/TDA]",L=0 D EN1^DIP,H,OUT

 +2        SET DIC="^PRCF(421,"

           SET BY="]@.5,3"

           SET L=0

           DO EN1^DIP

           DO H

           DO OUT

 +3        QUIT 

EN4       ;FTEE SUMMARY BY PROGRAM

 +1        SET PRCF("X")="ABFS"

           DO ^PRCFSITE

           if '%

               GOTO OUT

           SET L=0

           SET DIC="^PRCF(421,"

           SET BY="[PRCB BY APPROP/TDA]"

           SET FR=PRCF("SIFY")

           SET TO=PRCF("SIFY")_"Z"

           SET FLDS="[PRCB FTEE SUMMARY]"

           DO EN1^DIP

           DO OUT

           QUIT 

EN5       ;APPROPRIATION SUMMARY (DETAIL)

 +1        SET PRCF("X")="ABFS"

           DO ^PRCFSITE

           if '%

               GOTO OUT

 +2        SET ZTDESC="APPROPRIATION SUMMARY (DETAIL)"

           SET ZTRTN="EN5Q^PRCBP"

           SET ZTSAVE("PRC*")=""

           SET ZTSAVE("PRCF*")=""

           DO ^PRCFQ

           DO OUT

           QUIT 

EN5Q       SET FLDS=$SELECT(IOM<81:"[PRCB DISPLAY APP SUM DETAIL]",1:"[PRCB APPROP SUM  DETAIL]")

 +1        SET IOP=ION

           SET L=0

           SET DIC="^PRCF(421,"

           SET BY="[PRCB BY APP/FCP]"

           SET FR=PRCF("SIFY")

           SET TO=PRCF("SIFY")

           DO EN1^DIP

           DO OUT

           QUIT 

EN6       ;APPROPTIATION SUMMARY (TOTALS)

 +1        SET PRCF("X")="ABFS"

           DO ^PRCFSITE

           if '%

               GOTO OUT

 +2        SET ZTDESC="APPROPRIATION SUMMARY (TOTALS)"

           SET ZTRTN="EN6Q^PRCBP"

           SET ZTSAVE("PRC*")=""

           SET ZTSAVE("PRCF*")=""

           DO ^PRCFQ

           DO OUT

           QUIT 

EN6Q       SET IOP=PRIOP

           SET L=0

           SET DIC="^PRCF(421,"

           SET BY="[PRCB BY APP/FCP]"

           SET FR=PRCF("SIFY")

           SET TO=PRCF("SIFY")

           SET FLDS="[PRCB APPROP SUM  TOTAL]"

           DO EN1^DIP

           DO OUT

           QUIT 

H          IF $DATA(IO(0))

               IF IO=IO(0)

                   IF $DATA(IOST)

                       IF IOST["C-"

                           WRITE !,"PRESS RETURN TO CONTINUE",$CHAR(7)

                           READ X:$SELECT($DATA(DTIME):DTIME,1:300)

 +1        QUIT 

ZIS        KILL DQTIME,IOP

           SET %ZIS="QN"

           DO ^%ZIS

           if POP

               QUIT 

           SET IOP=ION

           IF IO'=IO(0)

               SET %ZIS="Q"

               SET IOP="Q;"_ION