source: WorldVistAEHR/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCSP1A.m@ 1800

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

initial load of WorldVistAEHR

File size: 8.6 KB
RevLine 
[613]1PRCSP1A ;WISC/SAW/BGJ-CONTROL POINT ACTIVITY PRINT OPTIONS CON'T ;5/1/92 9:20 AM [2/18/99 9:02am]
2 ;;5.1;IFCAP;**90**;Oct 20, 2000;Build 4
3 ;Modified from FOIA VISTA,
4 ;Copyright 2008 WorldVistA. Licensed under the terms of the GNU
5 ;General Public License See attached copy of the License.
6 ;
7 ;This program is free software; you can redistribute it and/or modify
8 ;it under the terms of the GNU General Public License as published by
9 ;the Free Software Foundation; either version 2 of the License, or
10 ;(at your option) any later version.
11 ;
12 ;This program is distributed in the hope that it will be useful,
13 ;but WITHOUT ANY WARRANTY; without even the implied warranty of
14 ;MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 ;GNU General Public License for more details.
16 ;
17 ;You should have received a copy of the GNU General Public License along
18 ;with this program; if not, write to the Free Software Foundation, Inc.,
19 ;51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
20 ;Per VHA Directive 10-93-142, this routine should not be modified.
21CPB ;CP BAL
22 N PRCSST
23 S PRCSST=1 D EN1^PRCSUT G W2:'$D(PRC("SITE")),EXIT:Y<0 S PRCSZ=Z
24CPB1 K C1 W !,"Summary Balances Report Only" S %=2 D YN^DICN G EXIT:%<0,CPB1:%=0 S:%=1 C1=1
25 D DEV1 G EXIT:POP I $D(IO("Q")) S ZTRTN="QUE^PRCSP1A",ZTDESC="RUNNING BALANCE REPORT",ZTSAVE("PRC*")="" S:$D(C1) ZTSAVE("C1")="" D ^%ZTLOAD D ^%ZISC D W1 G EXIT:%'=1 W !! G CPB
26 D QUE D ^%ZISC D W1 G EXIT:%'=1 K C1 W !! G CPB
27QUE ;
28 N PRCC,PRCD,PRCE
29 N A,B
30 S PRC("CP")=$P($G(^PRC(420,PRC("SITE"),1,+PRC("CP"),0)),"^",1)
31 U IO S Z1="",P=0 D NOW^%DTC S Y=% D DD^%DT S TDATE=Y,PRCS("A")=1 I $D(^PRC(420,PRC("SITE"),1,+PRC("CP"),0)),$P(^(0),"^",11)="Y" S PRCS("A")=1
32 S PRCC=$P($$QTRDATE^PRC0D(PRC("FY"),PRC("QTR")),"^",7)
33 S PRCC=PRCC_"-"_PRC("SITE")_"-"_$P(PRC("CP")," ")_"-",PRCD=PRCC_"~"
34 S (N,Z,Z(0))=PRCSZ,Z(0)=Z(0)_"-",(PRCS("O"),PRCS("C"))=0,N(1)="" D:'$D(C1) HDR D:$D(C1) HDR2
35 I $G(C1)=1 W !,"STATION: ",PRC("SITE")," FUND CONTROL POINT: ",PRC("CP"),!,?5,"FISCAL YEAR: ",PRC("FY")," QTR: ",PRC("QTR")
36 F S PRCC=$O(^PRCS(410,"RB",PRCC)) QUIT:PRCC]PRCD!'PRCC S N(1)=$O(^(PRCC,"")),J=" " QUIT:'N(1) S:'PRCS("A") J=$S($D(^PRCS(410,N(1),7)):$P(^(7),"^",6),1:"") I J'=""!($P(^PRCS(410,N(1),0),"^",2)'="O"),$P(^(0),"^",2)]"" D TOT
37 Q:Z1=U D CRT:$E(IOST,1,2)="C-" QUIT:Z1=U D ^PRCSFMS Q:Z1=U
38 D:IOSL-$Y<8 HOLD Q:Z1=U
39 W !!!,"Balance Summary",?20,$J("1st Quarter",15),$J("2nd Quarter",15),$J("3rd Quarter",15),$J("4th Quarter",15)
40 S PRCC=$$FCPBAL^PRC0D(PRC("SITE"),PRC("CP"),PRC("FY"),2)
41 S PRCD=$$FCPBAL^PRC0D(PRC("SITE"),PRC("CP"),PRC("FY"),1)
42 W !!,"Actual CP Bal:",?20 F A=1:1:4 W $J($P(PRCC,"^",A),15,2)
43 W !,"Actual Fiscal Bal:",?20 F A=1:1:4 W $J($P(PRCD,"^",A),15,2)
44 W !,"Tot Commit, not Obl:",?20 F A=1:1:4 W $J($J($P(PRCD,"^",A),0,2)-$J($P(PRCC,"^",A),0,2),15,2)
45 I $J(PRCS("C"),0,2)-$J($P(PRCC,"^",PRC("QTR")),0,2)!($J(PRCS("O"),0,2)-$J($P(PRCD,"^",PRC("QTR")),0,2)) W ! D EN^DDIOL("Report balances do not agree with actual balances. Please recalculate"),EN^DDIOL("your control point.")
46 W !!,"SECTION 1 CODES # - cancelled order * - order not obligated or signed",!,?17,"@ - purchase card order for reconciliation",!,?17,"& - reconciled order with final charge - ready for approval",!,?17,"R - total reconciled charges"
47 W !,"SECTION 2 CODES",!,?17,"@ - purchase card CC transaction is not reconciled",!
48 W !,"The symbols '*','@', and '&' indicate incomplete items.",!,"Please take the necessary steps to clear these items."
49 D EXIT D:$D(ZTSK) KILL^%ZTLOAD Q
50TOT N PRCA,PRCB,PRCG,PRCF,PRCH,PRCJ,PRCK
51 S T="" S:$D(^PRCS(410,N(1),4)) T=^(4) S X=^(0),Z=$P(X,"^",2),T(0)=$P(T,"^",5),T(1)=$J($P(T,"^",8),0,2),T(3)=$P(T,"^",14),T=$J($P(T,"^",3),0,2),PRCA=$G(^(4)),PRCB=$G(^(7)),PRCH="*^*"
52 I $P($G(^PRCS(410,N(1),1)),"^",2)=9999999 S PRCH=""
53 S PRCF=$G(^PRCS(410,N(1),0)),PRCG=$P(PRCF,"^",2),PRCK=$P(PRCF,"^"),PRCF=$P(PRCF,"^",4),PRCK=$P(PRCK,"-",2)_$P(PRCK,"-",3)_$P(PRCK,"-",5)
54 I PRCG="A",PRCF=1 S:$P(PRCB,"^",6)]"" PRCS("C")=PRCS("C")-T(1),$P(PRCH,"^")="" S:$P(PRCA,"^",10)]"" PRCS("O")=PRCS("O")-T,$P(PRCH,"^",2)="" Q:$D(C1) G WRT
55 I PRCG="O" S:$P(PRCB,"^",6)]"" PRCS("C")=PRCS("C")-T(1),$P(PRCH,"^")="" S:$P(PRCA,"^",10)]"" PRCS("O")=PRCS("O")-T,$P(PRCH,"^",2)=""
56 I PRCG="C" S PRCH="",PRCS("C")=PRCS("C")+T(1),PRCS("O")=PRCS("O")+T
57 I PRCG="A" S PRCH="",PRCS("C")=PRCS("C")-T(1) S:T(3)'="Y" PRCS("O")=PRCS("O")-T
58 I PRCG="CA" S PRCH="#^#"
59 S PRCJ=$P($G(^PRCS(410,N(1),4)),"^",5)
60 I PRCH'["#",PRCJ'="" S PRCJ=$P(^PRCS(410,N(1),0),"-")_"-"_PRCJ,PRCJ=$O(^PRC(442,"B",PRCJ,0)) I +PRCJ'=0,$P($G(^PRC(442,PRCJ,0)),"^",2)=25 S X=$G(^(7)) D
61 . S:PRCG'="A" PRCH="@" S:$P($G(X),"^",2)=40!($P($G(X),"^",2)=41) PRCH="^" S:$P($G(X),"^",2)=50!($P($G(X),"^",2)=51) PRCH="&"
62 . S T=$P($$FP^PRCH0A(+PRCJ),U,2),$P(PRCH,"^",2)="R"
63 . QUIT
64 QUIT:$D(C1)
65WRT Q:Z1=U D:IOSL-$Y<8 HOLD Q:Z1=U S X1=$S(Z="O":"OBLIGATION",Z="A":"ADJUSTMENT",Z="CA":"CANCELLED",1:"CEILING")
66 I $P($G(^PRCS(410,N(1),0)),"^",4)=5 S X1="ISSUE BOOK"
67 S PZIP=$P($P(X,"^"),"-",5),PZIP=$E(PZIP,1,4)
68 W !,PRCK,?8,$E(X1,1,3),?12,T(0)
69 S Y=$P($G(^PRCS(410,N(1),4)),"^",4) S:Y="" Y=$P($G(^PRCS(410,N(1),7)),"^",5) I Y'="" W ?26,$E(Y,4,5),"/",$E(Y,6,7),"/",$E(Y,2,3)
70 W ?36,$J(T(1),10,2),$P(PRCH,"^")
71 W ?47,$J(PRCS("C"),10,2) I T'="",T(3)'="Y" W ?58,$J(T,10,2),$P(PRCH,"^",2)
72 W ?69,$J(PRCS("O"),10,2) Q
73HDR S P=P+1 W @IOF,"CONTROL POINT BALANCE - ",Z(0)_" "_$P(PRC("CP")," ",2),?50,TDATE,?73,"PAGE ",P
74 W !!,?69,"FISCAL"
75 W !,"FYQSeq# TXN OBL #",?26,"AP/OB DT",?37,"COMM $AMT",?50,"CP $BAL",?60,"OBL $AMT",?69,"UNOBL $BAL"
76 S L="",$P(L,"-",IOM)="-" W !,L S L="" Q
77HDR2 S P=P+1 W @IOF,"CONTROL POINT BALANCE - ",Z(0)_" "_$P(PRC("CP")," ",2),?50,TDATE,?73,"PAGE ",P,! Q
78HOLD G HDR:$E(IOST,1,2)'="C-"
79CRT W !,"Press return to continue, uparrow (^) to exit: " R Z1:DTIME S:'$T Z1=U I ((Z1'=U)&('$D(C1))) D HDR
80 Q
81CTR ;CEILING TRANS
82 D EN^PRCSUT G W2:'$D(PRC("SITE")),EXIT:Y<0 S PRCSAZ=PRC("SITE")_"-"_PRC("FY")_"-"_PRC("QTR")_"-"_$P(PRC("CP")," ")
83 S FLDS="[PRCSCTR]",DHD="CEILING REPORT - CP: "_PRC("CP"),BY="@.01,@1",FR=PRCSAZ_"-0001,C",TO=PRCSAZ_"-9999,C" D S
84 N REPORT2 S REPORT2=1 D T2^PRCSAPP1 K PRC("CP"),PRCSAZ G CTR
85ITEMH ;EP;Entry Point for Control Point ITEM HISTORY ; AAC/JDM 10-12-97 - ADDED LINES 66-67 & 69-80 FOR E3R #3344
86 ;EN3^PRCSUT Gets the SITE & Prompts for CONTROL POINT
87 ;DODIP Runs EN1^DIP to list history to selected device
88 D EN3^PRCSUT G W2:'$D(PRC("SITE")),EXIT:Y<0 S D0=+Y
89 S CTL=$P(Y,U,2),(FR1,TO1)=CTL
90 ;
91 ; CHOOSE OLD WAY ( LAST 5 ) OR NEW WAY ( DATE RANGE )
92 K DIR
93 S DIR(0)="S^L:Last 5 Purchase Orders;D:Date Range"
94 S DIR("A")="Select ITEM HISTORY Viewing Method"
95 S DIR("B")="L"
96 D ^DIR
97 G:$D(DIRUT) EXIT
98 W !
99 G:Y="L" ITEMH1
100 ;
101 ; FALL THROUGH TO DATE RANGE DISPLAY
102 ;
103ITEMH0 ; VIEW HISTORY BY DATE RANGE
104 ;
105 S DIC="^PRC(441,",DIC(0)="AEMNQZ" D ^DIC G EXIT:Y<0
106 S (FR2,TO2)=$P(Y,U,1)
107 K DIR S DIR(0)="D",DIR("A")="DATE ORDERED (BEGIN RANGE) ",DIR("B")="T-30" D ^DIR G:$D(DIRUT) EXIT
108 D ^%DT S FR3=Y
109 K DIR S DIR(0)="D",DIR("A")="DATE ORDERED (END RANGE) ",DIR("B")="T" D ^DIR G:$D(DIRUT) EXIT
110 D ^%DT S TO3=Y
111 D DODIP
112 G ITEMH
113 ;
114ITEMH1 S DIC="^PRC(441,",DIC(0)="AEMNQZ" D ^DIC G EXIT:Y<0 S D0=+Y
115 D DEV G EXIT:POP
116 ;
117ITEMH2 W @IOF S X=D0 D ITEM0^PRCSES1 I $D(ZTSK) D KILL^%ZTLOAD G EXIT
118W3 D:$E(IOST,1,2)="C-" W W !!,"Would you like to look at another Item History" S %=2 D YN^DICN G W3:%=0,EXIT:%=2!(%<0) G ITEMH
119S S L=0,DIC="^PRCS(410,"
120 D EN1^DIP Q
121 ;
122DEV K IO("Q") S IOP="HOME" D ^%ZIS Q
123 ;
124DEV1 K IO("Q") S %ZIS("B")="HOME",%ZIS="MQ" D ^%ZIS Q
125 ;
126W1 K YY S YY(1)="Would you like to run another running balances report",YY(1,"F")="!!" D EN^DDIOL(.YY)
127 S %=2 D YN^DICN G W1:%=0 Q
128W2 K YY S YY(1)="You are not an authorized control point user.",YY(1,"F")="!!",YY(2)="Contact your control point official.",YY(2,"F")="!" D EN^DDIOL(.YY)
129 K DIR S DIR(0)="E" D ^DIR G EXIT
130W4 K YY S YY(1)="Enter information for another report or '^' to return to the menu.",YY(1,"F")="!!" D EN^DDIOL(.YY) Q
131W I $E(IOST,1,2)="C-" K DIR S DIR(0)="E" D ^DIR
132 I $E(IOST,1,2)'="C-" D ^%ZISC U IO
133 ;
134EXIT K PUR,TDATE,REPORT2,%,%IS,%DT,BY,C0,C2,C3,D,D0,DA,DHD,DIC,DIE,P
135 K PRCSZ,PRCS,FLDS,FR,I,L,N,T,TO,X,X1,Y,Z,Z1,PZIP,ZTRTN,ZTSAVE Q
136 K C,CTL,DIR,DTOUT,DUOUT,DIROUT,DIRUT,FR1,FR2,FR3,PRC,PRCSIP,TO1,TO2,TO3,AA,YY
137 Q
138WRITMD ;EP0; WRITES ITEM SHORT DESCRIPTION ON HISTORY HEADER
139 W $P(^PRC(441,FR2,0),U,2)
140 Q
141WRITMN ;EP; WRITES ITEM NUMBER
142 W $P(^PRC(441,FR2,0),U,1)
143 Q
144DODIP ; EP ;FOR RTNS CALLING FOR CP ITEM HIST
145 ; AAC/JDM 11/12/97 - THIS SECTION ADDED FOR E3R #3344
146 ; PRCSPGQ is page variable
147 ; PRCSDT is Date/Time in DEC 11, 1998@8:35 format
148 ;
149 S PRCSPGQ=0
150 D NOW^%DTC
151 S Y=$J(%,7,4)
152 D DD^%DT
153 S PRCSDT=Y
154 S FLDS="[PRCS CP ITEMHIST]",BY="[PRCS CP ITEMHIST]",L=0,DIC="^PRCS(410,"
155 S FR=FR1_","_FR2_","_FR3
156 S TO=TO1_","_TO2_","_TO3
157 D EN1^DIP
158 Q
Note: See TracBrowser for help on using the repository browser.