source: WorldVistAEHR/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCHDPO.m@ 1259

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

initial load of WorldVistAEHR

File size: 4.0 KB
Line 
1PRCHDPO ;WOIFO/CR - DELINQUENT DELIVERY LISTING PA OPTION ; 2/20/01 12:55 PM
2 ;;5.1;IFCAP;**8**;Oct 20, 2000
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4A1 ;
5 D CLEAN
6DATE S DIR("A")="START WITH DELIVERY DATE",DIR(0)="D^^" D ^DIR K DIR Q:Y["^"!(Y<1)
7 S FDATE=+Y W " ",Y(0)
8 ;
9 S DIR("A")="GO TO DELIVERY DATE",DIR(0)="D^^" D ^DIR K DIR Q:Y["^"!(Y<1)
10 S EDATE=+Y W " ",Y(0)
11 I EDATE<FDATE W !,$C(7),"Less than 'FROM' value.",! K EDATE,FDATE G DATE
12 ;
13 S %ZIS("B")="",%ZIS="MQ" D ^%ZIS Q:POP
14 I $D(IO("Q")) S ZTRTN="STAT^PRCHDPO",ZTSAVE("*")="" D ^%ZTLOAD,^%ZISC Q
15 D STAT
16 D ^%ZISC
17 Q
18 ;
19FRMDT ; Make the current date for the header easier to read.
20 D NOW^%DTC S Y=% D DD^%DT
21 S X1=$P(Y,"@",1),X2=$P(X1,",",1)_","_$P(X1,", ",2)
22 S X3=$P($P(Y,"@",2),":",1,2)
23 S DATE=X2_" "_X3
24 Q
25 ;
26FRMDT1 ; Compress the delivery date display.
27 S X1=$P(Y,",",1)_","_$P(Y,", ",2)
28 Q
29 ;
30STAT ; Gather all the statistics
31 S (GTOT,AMT1)=0,(VENTOT,SUBUSER)="",P=1
32 S I="" F S I=$O(^PRC(442,"B",I)) Q:I="" D
33 .S ZP="" F S ZP=$O(^PRC(442,"B",I,ZP)) Q:ZP="" D
34 ..S ZP0=$G(^PRC(442,ZP,0)),DELDT=$P(ZP0,"^",10)
35 ..S PONUM=$P(ZP0,"^",1),MOP=$P(ZP0,"^",2)
36 ..; Check all possible methods of processing
37 ..Q:"^1^2^3^4^7^8^9^21^22^23^25^26^"'[("^"_MOP_"^")
38 ..S ZP1=$G(^PRC(442,ZP,1))
39 ..Q:ZP1=""
40 ..Q:DELDT<FDATE
41 ..Q:DELDT>EDATE
42 ..S Y=DELDT D DD^%DT,FRMDT1 S DELDT=X1 ; Show a human-readable date
43 ..S VENPTR=$P(ZP1,"^",1)
44 ..Q:VENPTR=""!(VENPTR=0)!(VENPTR'>0)
45 ..S VENDOR=$P(^PRC(440,VENPTR,0),"^",1)
46 ..S PHONE=$P($G(^PRC(440,VENPTR,0)),"^",10)
47 ..S PRCHPA=+$P(ZP1,"^",10) Q:PRCHPA=""!(PRCHPA=0)
48 ..I $D(^VA(200,PRCHPA,0)) S USER=$P(^VA(200,PRCHPA,0),"^")
49 ..S:$D(^PRC(442,ZP,7)) ZP7=^PRC(442,ZP,7)
50 ..S SUPT=+$P(ZP7,"^",1)
51 ..S PRCSTAT=$P($G(^PRCD(442.3,SUPT,0)),"^")
52 ..S SUPORD=$P(ZP7,"^",2)
53 ..Q:"^20^21^22^23^24^25^26^27^28^29^32^34^39^44^46^47^"'[("^"_SUPORD_"^")
54 ..S TOTAMT=$P(ZP0,"^",15),LIQAMT=$P(ZP0,"^",17)
55 ..I LIQAMT<0,(TOTAMT-LIQAMT)>TOTAMT S COSOUT=0
56 ..E S COSOUT=TOTAMT-LIQAMT I COSOUT<0 S COSOUT=0
57 ..S ^TMP($J,USER,VENDOR,PONUM)=PONUM_"^"_PRCSTAT_"^"_COSOUT_"^"_VENDOR_"^"_PHONE_"^"_DELDT
58 ;
59PRINT ; Let's print the outstanding orders and dollar amounts.
60 ;
61 U IO
62 D FRMDT
63 S (P,EX)=1,(TOT,AMT1)=0
64 I '$D(^TMP($J)) S P=1,(Q,Q1)="" D HEADER W !!!!,?10,"*** NO RECORDS TO PRINT ***" Q
65 S Q="" F S Q=$O(^TMP($J,Q)) Q:Q="" Q:EX="^" D
66 .D HEADER S (VENTOT,SUBUSER)=""
67 .S Q1="" F S Q1=$O(^TMP($J,Q,Q1)) Q:Q1="" Q:EX="^" D
68 ..W:Q1]"" !,?18,"VENDOR: ",Q1
69 ..S Q2="" F S Q2=$O(^TMP($J,Q,Q1,Q2)) Q:Q2="" Q:EX="^" D
70 ...S AMT1=0
71 ...S STR3=^TMP($J,Q,Q1,Q2)
72 ...W !,$P(STR3,"^",1),?15,$P(STR3,"^",2),?60,$J($P(STR3,"^",3),10,2)
73 ...W !,?3,$P(STR3,"^",6),?17,$P(STR3,"^",5)
74 ...I (IOSL-$Y)<8 D HOLD Q:EX="^"
75 ...S AMT1=$P(STR3,"^",3),TOT=AMT1+$G(TOT),VENTOT(USER,VENPTR)=TOT
76 ..W !,?60,"----------"
77 ..W !,"SUBTOTAL",?60,$J(VENTOT(USER,VENPTR),10,2),!
78 ..S GTOT=$G(GTOT)+VENTOT(USER,VENPTR),SUBUSER(USER)=VENTOT(USER,VENPTR)+$G(SUBUSER(USER))
79 ..S TOT=0
80 .I $E(IOST,1,2)="C-",EX'["^" W !,"Press return to continue, '^' to exit: " R XXZ:DTIME S:XXZ="^" EX="^" S:'$T EX="^"
81 .I $G(Q2)="" D
82 ..W ?60,"----------"
83 ..W !,"SUBTOTAL",?60,$J(SUBUSER(USER),10,2) S SUBUSER(USER)=""
84 ..; This is the subtotal for the user including all the vendors used.
85 W !,?60,"----------"
86 W !,"TOTAL",?55,$J(GTOT,15,2)
87 D CLEAN
88 Q
89 ;
90HOLD G HEADER:$E(IOST,1,2)'="C-"!(IO'=IO(0)) W !,"Press return to continue, '^' to exit: " R XXZ:DTIME S:XXZ["^" EX="^" S:'$T EX="^" I EX'="^",$G(Q2)'="" D HEADER
91 Q
92 ;
93HEADER ;
94 W @IOF
95 W !,"DELINQUENT PURCHASE ORDERS",?42,DATE,?68,"PAGE ",P,!
96 W !,"PO NUMBER",?15,"SUPPLY STATUS",?63,"COST",!
97 W ?3,"DELIVERY",?17,"PHONE",?60,"OUTSTANDING",!
98 W ?3,"DATE",?17,"NUMBER",?45,"(QTY*UNIT COST FOR ITEMS NOT REC'D)",!
99 F I=1:1:10 W "--------"
100 W !!,?15,"PA/PPM/AUTHORIZED BUYER: ",Q,!
101 S P=P+1
102 Q
103 ;
104CLEAN K AMT1,COSOUT,DATE,DELDT,EDATE,FDATE,PRCHPA,PRCSTAT,Q,Q1,Q2,^TMP($J)
105 K SUPT,TOT,TOTAMT,VENDOR,VENPTR,VENTOT,X,X1,X2,X3,XXZ,Y,ZP,ZP0,ZP1,ZP7
106 K EX,ENTOT,GTOT,I,LIQAMT,MOP,P,PHONE,PONUM,STR3,SUBUSER,SUPORD,USER
107 Q
Note: See TracBrowser for help on using the repository browser.