source: WorldVistAEHR/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCBP.m@ 1078

Last change on this file since 1078 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR

File size: 5.7 KB
Line 
1PRCBP ;WISC/CTB-PRINT OPTIONS FOR PRCB ;10/31/01 12:50pm
2V ;;5.1;IFCAP;**3,43**;Oct 20, 2000
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4SE W !!,$C(7),"ENTRY TO THIS ROUTINE IS ONLY PERMITTED THROUGH THE APPROPRIATE",!,"MENU OR DRIVER" Q
5OUT K %,%Y,DIJ,DP,IOX,IOY,POP,PRCB,PRCF,PRC("CP"),X,Y,NOLCK Q
6EN1 ;PRINT RANGE OF TRANSACTIONS
7 S PRCF("X")="ABFS" D ^PRCFSITE G:'% OUT
8R1 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.4N)!(+X'=X)!(X<1)!(X>PRCB("LAST")) Q1 S FR=X K X
9R2 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
10 S X="000"_FR,X=$E(X,$L(X)-3,$L(X)),FR=PRCF("SIFY")_"-"_X S X="000"_TO,X=$E(X,$L(X)-3,$L(X)),TO=PRCF("SIFY")_"-"_X
11 D ZIS G:POP OUT S FLDS=$S(IOM<81:"[PRCB TRANS RANGE DISPLAY]",1:"[PRCB TRANS RANGE LIST]")
12 S DIC="^PRCF(421,",BY="[PRCB BY TRANSACTION NUMBER]",L=0 D EN1^DIP D H G OUT
13Q1 W !!,$C(7),"ENTER A NUMBER BETWEEN ",D," AND ",PRCB("LAST"),". ('^' TO EXIT)" G @(C)
14 ;
15EN2 ;PRINT SELECTED CONTROL POINTS
16 ;Patch 3: This section no longer calls the PRCFQ. It calls %ZTLOAD.
17 S NOTSK=0,NOLCK=0,EN2Q=0,EN2P=0,RECFLG=0
18 K DIC("A") S PRCF("X")="ABFS" D ^PRCFSITE G:'% OUT
19 S ^XTMP("PRCBP",$J)=""
20 S DIC("A")="Select FUND CONTROL POINT: "
21 F ZX=1:1 D Q:$G(Y)<0!($G(Y)="") Q:$G(OUT)=1
22 .S DIC(0)="AEQZMN",DIC="^PRC(420,PRC(""SITE""),1,"
23 .D ^DIC K DIC("A")
24 .Q:Y<0
25 .S CP=+Y
26 .D EN23
27 .I X=U K ^XTMP("PRCBP",$J) S OUT=1 Q
28 .I RECFLG=0 D
29 ..D EOP^PRC0A(.X,.Y,"No TXN for selected STATION, FISCAL, and Fund Control Point.","AO","")
30 .S DIC("A")="ANOTHER FUND CONTROL POINT: "
31 K ZX
32 I $G(OUT)=1 K OUT G OUT
33 I X=U K ^XTMP("PRCBP",$J) G CLNUP
34 I '$O(^XTMP("PRCBP",$J,"AM",0)) G CLNUP
35 K IO("Q"),IOP,ZTSK,%ZIS,IOC,ZTIO
36 S %ZIS="NQ",%ZIS("B")="" D ^%ZIS I POP K ^XTMP("PRCBP",$J) G CLNUP
37 I '$D(IO("Q")) S CP=9999 D EN23 S EN2P=1,EN2Q=0 G EN2P
38 S EN2Q=1,EN2P=0
39 S ZTDESC="PRINT SELECTED CONTROL POINTS",ZTRTN="EN2Q^PRCBP"
40 S ZTSAVE("PRCF*")="",ZTSAVE("PRC*")=""
41 D ^%ZTLOAD D ^%ZISC
42 I '$D(ZTSK) S NOTSK=1 D ERRMSG G CLNUP
43 W !," <Request Queued> Your Task number is: ",ZTSK,$C(7),!
44 S TSKNUM=ZTSK,AQ=0,NOLCK=0
45 S ^XTMP("PRCBP",TSKNUM)=""
46 L +^XTMP("PRCBP",TSKNUM):5
47 E S NOLCK=1 D ERRMSG G CLNUP
48 F LOOP=1:1 S AQ=$O(^XTMP("PRCBP",$J,"AM",1,AQ)) Q:AQ="" D
49 .S ^XTMP("PRCBP",TSKNUM,"AQ",1,AQ)=""
50 S AQ=$O(^PRCF(421,"AC",PRCF("SIFY")_"-"_9999,AQ))
51 S ^XTMP("PRCBP",TSKNUM,"AQ",1,AQ)=""
52 K ^XTMP("PRCBP",$J)
53 L -^XTMP("PRCBP",TSKNUM)
54 G CLNUP
55 ;
56EN2Q ;Queue the Print Task(s).
57 ;
58 D:$D(ZTQUEUED) KILL^%ZTLOAD
59 I '$D(ZTSK) S NOTSK=1 D ERRMSG G CLNUP
60 K TSKNUM S AQ=0,TSKNUM=ZTSK,NOTSK=0,NOLCK=0,EN2Q=1,EN2P=0
61 G EN2P
62 ;
63ERRMSG ;Write the error messages.
64 ;
65 N DTIME S DTIME=60
66 I NOTSK=1 D
67 .W !,"Could not get a Task Number. Enter RETURN or '^' to exit. "
68 .R !,ANS:DTIME
69 ;
70CLNUP ;Clean variables that no longer needed.
71 ;
72 D OUT
73 K TSKNUM,PRC,IOP,%ZIS,IOC,ZTIO,IO("Q"),ION,IOP,RECFLG,NOTSK
74 K AQ,LOOP,DIC,L,BY,FLDS,CP,ANS,I,N,EN2P,EN2Q,NOLCK,AM
75 K ZTDESC,ZTQUEUED,ZTRTN,ZTSAVE("PRC*"),ZTSAVE("PRCF*")
76 Q
77 ;
78EN2P ;Print the Task(s).
79 ;
80 D:$D(ZTQUEUED) KILL^%ZTLOAD
81 S AM=0,AQ=0
82 S FLDS=$S(IOM<81:"[PRCB FCP DISPLAY]",1:"[PRCB FCP LIST]")
83 S DIC="^PRCF(421,",BY="[PRCB BY SEARCH/FCP/TRANS]"
84 S L=0,IOP=ION
85 I EN2P D
86 .F LOOP=1:1 S AM=$O(^XTMP("PRCBP",$J,"AM",1,AM)) Q:AM="" D
87 ..S ^PRCF(421,"AM",1,AM)=""
88 .K ^XTMP("PRCBP",$J)
89 I EN2Q D
90 .F LOOP=1:1 S AQ=$O(^XTMP("PRCBP",TSKNUM,"AQ",1,AQ)) Q:AQ="" D
91 ..S ^PRCF(421,"AM",1,AQ)=""
92 .K ^XTMP("PRCBP",TSKNUM)
93 D EN1^DIP
94 K ^PRCF(421,"AM")
95 G CLNUP
96 ;
97EN23 ;Setup the temp file with selected records (FCP).
98 ;
99 S N=0,RECFLG=0
100 F I=1:1 S N=$O(^PRCF(421,"AC",PRCF("SIFY")_"-"_CP,N)) Q:N="" D
101 .S RECFLG=1
102 .S ^XTMP("PRCBP",$J,"AM",1,N)=""
103 .S $P(^PRCF(421,N,2),"^",14)=1
104 .W:CP'=9999 "."
105 Q
106EN3 ;PRINT BY TDA NUMBER
107 S PRCF("X")="ABFS" D ^PRCFSITE G:'% OUT
108 S FR=$O(^PRCF(421,"B",PRCF("SIFY")_"-0000")) I FR="" W !,"NO TRANSACTIONS IN FY ",PRC("FY") R X:2 G OUT
109Q31 D DD^PRC0A(.X,.Y,"Beginning TDA Number","421,3O",1)
110 G EN3:Y=""!(Y["^")
111 S PRCA=Y
112Q32 D DD^PRC0A(.X,.Y,"Ending TDA Number","421,3O",9999)
113 G EN3:Y["^",Q31:Y=""
114 I PRCA]Y D EN^DDIOL("Beginning/Ending TDA numbers are not in order") G Q32
115 S PRCB=Y
116 S FR=PRCF("SIFY")_","_PRCA,TO=PRCF("SIFY")_","_PRCB
117 S ZTDESC="PRINT TDA LISTING",ZTRTN="EN1Q^PRCBP",ZTSAVE("PRC*")="",ZTSAVE("PRCF*")="",ZTSAVE("FR")="",ZTSAVE("TO")="" D ^PRCFQ,H,OUT Q
118EN1Q S IOP=ION,FLDS=$S(IOM<81:"[PRCB TDA DISPLAY]",1:"[PRCB TDA LIST]")
119 ;S DIC="^PRCF(421,",BY="[PRCB BY TRANS/TDA]",L=0 D EN1^DIP,H,OUT
120 S DIC="^PRCF(421,",BY="]@.5,3",L=0 D EN1^DIP,H,OUT
121 Q
122EN4 ;FTEE SUMMARY BY PROGRAM
123 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
124EN5 ;APPROPRIATION SUMMARY (DETAIL)
125 S PRCF("X")="ABFS" D ^PRCFSITE G:'% OUT
126 S ZTDESC="APPROPRIATION SUMMARY (DETAIL)",ZTRTN="EN5Q^PRCBP",ZTSAVE("PRC*")="",ZTSAVE("PRCF*")="" D ^PRCFQ,OUT Q
127EN5Q S FLDS=$S(IOM<81:"[PRCB DISPLAY APP SUM DETAIL]",1:"[PRCB APPROP SUM DETAIL]")
128 S IOP=ION,L=0,DIC="^PRCF(421,",BY="[PRCB BY APP/FCP]",FR=PRCF("SIFY"),TO=PRCF("SIFY") D EN1^DIP,OUT Q
129EN6 ;APPROPTIATION SUMMARY (TOTALS)
130 S PRCF("X")="ABFS" D ^PRCFSITE G:'% OUT
131 S ZTDESC="APPROPRIATION SUMMARY (TOTALS)",ZTRTN="EN6Q^PRCBP",ZTSAVE("PRC*")="",ZTSAVE("PRCF*")="" D ^PRCFQ,OUT Q
132EN6Q 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
133H 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)
134 Q
135ZIS K DQTIME,IOP S %ZIS="QN" D ^%ZIS Q:POP S IOP=ION I IO'=IO(0) S %ZIS="Q",IOP="Q;"_ION
Note: See TracBrowser for help on using the repository browser.