Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: PRCBP

PRCBP.m

Go to the documentation of this file.
  1. PRCBP ;WISC/CTB-PRINT OPTIONS FOR PRCB ;10/31/01 12:50pm
  1. V ;;5.1;IFCAP;**3,43,139**;Oct 20, 2000;Build 16
  1. ;Per VHA Directive 2004-038, this routine should not be modified.
  1. SE W !!,$C(7),"ENTRY TO THIS ROUTINE IS ONLY PERMITTED THROUGH THE APPROPRIATE",!,"MENU OR DRIVER" Q
  1. OUT K %,%Y,DIJ,DP,IOX,IOY,POP,PRCB,PRCF,PRC("CP"),X,Y,NOLCK Q
  1. EN1 ;PRINT RANGE OF TRANSACTIONS
  1. S PRCF("X")="ABFS" D ^PRCFSITE G:'% OUT
  1. 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
  1. 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
  1. 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
  1. D ZIS G:POP OUT S FLDS=$S(IOM<81:"[PRCB TRANS RANGE DISPLAY]",1:"[PRCB TRANS RANGE LIST]")
  1. S DIC="^PRCF(421,",BY="[PRCB BY TRANSACTION NUMBER]",L=0 D EN1^DIP D H G OUT
  1. Q1 W !!,$C(7),"ENTER A NUMBER BETWEEN ",D," AND ",PRCB("LAST"),". ('^' TO EXIT)" G @(C)
  1. ;
  1. EN2 ;PRINT SELECTED CONTROL POINTS
  1. ;Patch 3: This section no longer calls the PRCFQ. It calls %ZTLOAD.
  1. S NOTSK=0,NOLCK=0,EN2Q=0,EN2P=0,RECFLG=0
  1. K DIC("A") S PRCF("X")="ABFS" D ^PRCFSITE G:'% OUT
  1. S ^XTMP("PRCBP",$J)=""
  1. S DIC("A")="Select FUND CONTROL POINT: "
  1. F ZX=1:1 D Q:$G(Y)<0!($G(Y)="") Q:$G(OUT)=1
  1. .S DIC(0)="AEQZMN",DIC="^PRC(420,PRC(""SITE""),1,"
  1. .D ^DIC K DIC("A")
  1. .Q:Y<0
  1. .S CP=+Y
  1. .D EN23
  1. .I X=U K ^XTMP("PRCBP",$J) S OUT=1 Q
  1. .I RECFLG=0 D
  1. ..D EOP^PRC0A(.X,.Y,"No TXN for selected STATION, FISCAL, and Fund Control Point.","AO","")
  1. .S DIC("A")="ANOTHER FUND CONTROL POINT: "
  1. K ZX
  1. I $G(OUT)=1 K OUT G OUT
  1. I X=U K ^XTMP("PRCBP",$J) G CLNUP
  1. I '$O(^XTMP("PRCBP",$J,"AM",0)) G CLNUP
  1. K IO("Q"),IOP,ZTSK,%ZIS,IOC,ZTIO
  1. S %ZIS="NQ",%ZIS("B")="" D ^%ZIS I POP K ^XTMP("PRCBP",$J) G CLNUP
  1. I '$D(IO("Q")) S CP=9999 D EN23 S EN2P=1,EN2Q=0 G EN2P
  1. S EN2Q=1,EN2P=0
  1. S ZTDESC="PRINT SELECTED CONTROL POINTS",ZTRTN="EN2Q^PRCBP"
  1. S ZTSAVE("PRCF*")="",ZTSAVE("PRC*")=""
  1. D ^%ZTLOAD D ^%ZISC
  1. I '$D(ZTSK) S NOTSK=1 D ERRMSG G CLNUP
  1. W !," <Request Queued> Your Task number is: ",ZTSK,$C(7),!
  1. S TSKNUM=ZTSK,AQ=0,NOLCK=0
  1. S ^XTMP("PRCBP",TSKNUM)=""
  1. L +^XTMP("PRCBP",TSKNUM):5
  1. E S NOLCK=1 D ERRMSG G CLNUP
  1. F LOOP=1:1 S AQ=$O(^XTMP("PRCBP",$J,"AM",1,AQ)) Q:AQ="" D
  1. .S ^XTMP("PRCBP",TSKNUM,"AQ",1,AQ)=""
  1. S AQ=$O(^PRCF(421,"AC",PRCF("SIFY")_"-"_9999,AQ))
  1. S ^XTMP("PRCBP",TSKNUM,"AQ",1,AQ)=""
  1. K ^XTMP("PRCBP",$J)
  1. L -^XTMP("PRCBP",TSKNUM)
  1. G CLNUP
  1. ;
  1. EN2Q ;Queue the Print Task(s).
  1. ;
  1. D:$D(ZTQUEUED) KILL^%ZTLOAD
  1. I '$D(ZTSK) S NOTSK=1 D ERRMSG G CLNUP
  1. K TSKNUM S AQ=0,TSKNUM=ZTSK,NOTSK=0,NOLCK=0,EN2Q=1,EN2P=0
  1. G EN2P
  1. ;
  1. ERRMSG ;Write the error messages.
  1. ;
  1. N DTIME S DTIME=60
  1. I NOTSK=1 D
  1. .W !,"Could not get a Task Number. Enter RETURN or '^' to exit. "
  1. .R !,ANS:DTIME
  1. ;
  1. CLNUP ;Clean variables that no longer needed.
  1. ;
  1. D OUT
  1. K TSKNUM,PRC,IOP,%ZIS,IOC,ZTIO,IO("Q"),ION,IOP,RECFLG,NOTSK
  1. K AQ,LOOP,DIC,L,BY,FLDS,CP,ANS,I,N,EN2P,EN2Q,NOLCK,AM
  1. K ZTDESC,ZTQUEUED,ZTRTN,ZTSAVE("PRC*"),ZTSAVE("PRCF*")
  1. Q
  1. ;
  1. EN2P ;Print the Task(s).
  1. ;
  1. D:$D(ZTQUEUED) KILL^%ZTLOAD
  1. S AM=0,AQ=0
  1. S FLDS=$S(IOM<81:"[PRCB FCP DISPLAY]",1:"[PRCB FCP LIST]")
  1. S DIC="^PRCF(421,",BY="[PRCB BY SEARCH/FCP/TRANS]"
  1. S L=0,IOP=ION
  1. I EN2P D
  1. .F LOOP=1:1 S AM=$O(^XTMP("PRCBP",$J,"AM",1,AM)) Q:AM="" D
  1. ..S ^PRCF(421,"AM",1,AM)=""
  1. .K ^XTMP("PRCBP",$J)
  1. I EN2Q D
  1. .F LOOP=1:1 S AQ=$O(^XTMP("PRCBP",TSKNUM,"AQ",1,AQ)) Q:AQ="" D
  1. ..S ^PRCF(421,"AM",1,AQ)=""
  1. .K ^XTMP("PRCBP",TSKNUM)
  1. D EN1^DIP
  1. K ^PRCF(421,"AM")
  1. G CLNUP
  1. ;
  1. EN23 ;Setup the temp file with selected records (FCP).
  1. ;
  1. S N=0,RECFLG=0
  1. F I=1:1 S N=$O(^PRCF(421,"AC",PRCF("SIFY")_"-"_CP,N)) Q:N="" D
  1. .S RECFLG=1
  1. .S ^XTMP("PRCBP",$J,"AM",1,N)=""
  1. .S $P(^PRCF(421,N,2),"^",14)=1
  1. .W:CP'=9999 "."
  1. Q
  1. EN3 ;PRINT BY TDA NUMBER
  1. S PRCF("X")="ABFS" D ^PRCFSITE G:'% OUT
  1. S FR=$O(^PRCF(421,"B",PRCF("SIFY")_"-00000")) I FR="" W !,"NO TRANSACTIONS IN FY ",PRC("FY") R X:2 G OUT
  1. Q31 D DD^PRC0A(.X,.Y,"Beginning TDA Number","421,3O",1)
  1. G EN3:Y=""!(Y["^")
  1. S PRCA=Y
  1. Q32 D DD^PRC0A(.X,.Y,"Ending TDA Number","421,3O",9999)
  1. G EN3:Y["^",Q31:Y=""
  1. I PRCA]Y D EN^DDIOL("Beginning/Ending TDA numbers are not in order") G Q32
  1. S PRCB=Y
  1. S FR=PRCF("SIFY")_","_PRCA,TO=PRCF("SIFY")_","_PRCB
  1. S ZTDESC="PRINT TDA LISTING",ZTRTN="EN1Q^PRCBP",ZTSAVE("PRC*")="",ZTSAVE("PRCF*")="",ZTSAVE("FR")="",ZTSAVE("TO")="" D ^PRCFQ,H,OUT Q
  1. EN1Q S IOP=ION,FLDS=$S(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
  1. S DIC="^PRCF(421,",BY="]@.5,3",L=0 D EN1^DIP,H,OUT
  1. Q
  1. EN4 ;FTEE SUMMARY BY PROGRAM
  1. 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
  1. EN5 ;APPROPRIATION SUMMARY (DETAIL)
  1. S PRCF("X")="ABFS" D ^PRCFSITE G:'% OUT
  1. S ZTDESC="APPROPRIATION SUMMARY (DETAIL)",ZTRTN="EN5Q^PRCBP",ZTSAVE("PRC*")="",ZTSAVE("PRCF*")="" D ^PRCFQ,OUT Q
  1. EN5Q S FLDS=$S(IOM<81:"[PRCB DISPLAY APP SUM DETAIL]",1:"[PRCB APPROP SUM DETAIL]")
  1. S IOP=ION,L=0,DIC="^PRCF(421,",BY="[PRCB BY APP/FCP]",FR=PRCF("SIFY"),TO=PRCF("SIFY") D EN1^DIP,OUT Q
  1. EN6 ;APPROPTIATION SUMMARY (TOTALS)
  1. S PRCF("X")="ABFS" D ^PRCFSITE G:'% OUT
  1. S ZTDESC="APPROPRIATION SUMMARY (TOTALS)",ZTRTN="EN6Q^PRCBP",ZTSAVE("PRC*")="",ZTSAVE("PRCF*")="" D ^PRCFQ,OUT Q
  1. 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
  1. 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)
  1. Q
  1. ZIS K DQTIME,IOP S %ZIS="QN" D ^%ZIS Q:POP S IOP=ION I IO'=IO(0) S %ZIS="Q",IOP="Q;"_ION