- 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 ---[H[J[2J[HPRCBP 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