source: FOIAVistA/tag/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCHRP7.m@ 636

Last change on this file since 636 was 628, checked in by George Lilly, 14 years ago

initial load of FOIAVistA 6/30/08 version
File size: 5.0 KB
Line 
1PRCHRP7 ;WISC/KMB/CR-DELINQUENT PC LISTING ;6/05/98 13:17
2 ;;5.1;IFCAP;**8**;Oct 20, 2000
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4STRT ;
5 N FLAG S FLAG=2
6STRT1 ;
7 S:$G(FLAG)="" FLAG=1
8START ;
9 K ^TMP($J)
10 N AMT1,END,PNUM,Y,P,USER,VEN,VEND,PC,PC1,STATUS,VPHONE,ADATE,TDATE,Z1,Z2,Z3,QTY,QTYOUT,CP,X,XXZ,EX,QTYORD,QTYPRCD,QTYOUT,ITEM,PART,PARTDATE,STR,YDATE,TAMT,TIMEDATE
11 N DETAIL1,DETAIL2,DETAIL3,I,PCNAME,ZP,CC,LDESC,CCP,ORDTOT,QTYAMT,QSTATUS
12 N AMTDSCT,PDATE,PRC,PRCRI,STR1,STR2,STR3,Q,Q1,Q2,Q3
13 S:$G(FLAG)="" FLAG=0
14 S PRCF("X")="S" D ^PRCFSITE Q:'$D(PRC("SITE")) Q:$G(X)="^"
15 W !,"Please enter a device for printing this report",!
16 S %ZIS("B")="",%ZIS="MQ" D ^%ZIS Q:POP
17 I $D(IO("Q")) S ZTSAVE("*")="",ZTRTN="DEL^PRCHRP7" D ^%ZTLOAD,^%ZISC K FLAG QUIT
18 D DEL,^%ZISC K FLAG
19 Q
20 ;
21DEL ;
22 D NOW^%DTC S TDATE=$P(%,"."),(P,EX)=1
23 S ZP="" F S ZP=$O(^PRC(442,"F",25,ZP)) Q:ZP="" D
24 .S Z1=$G(^PRC(442,ZP,0)),Z2=$G(^PRC(442,ZP,1)),Z3=$G(^PRC(442,ZP,23)) S ADATE=$P($G(^PRC(442,ZP,1)),"^",15)
25 .;Do not mix orders from different stations.
26 .I $D(PRC("SITE")) Q:$P(Z1,"-")'=PRC("SITE")
27 .Q:$P(Z1,"^",10)>TDATE
28 .S QSTATUS=+$P($G(^PRC(442,ZP,7)),"^",2)
29 .Q:"^22^23^24^25^26^29^32^34^39^44^46^47^"'[("^"_QSTATUS_"^")
30 .S Y=$P(ADATE,".") D DD^%DT S PDATE=Y
31 .Q:$G(^PRC(442,ZP,2,0))=""
32 .S VEN=$P(Z2,"^"),VPHONE=$P($G(^PRC(440,+VEN,0)),"^",10),VEND=$P($G(^PRC(440,+VEN,0)),"^")
33 .I VEND="SIMPLIFIED",$P($G(^PRC(442,ZP,24)),"^",2)'="" S VEND=$P($G(^PRC(442,ZP,24)),"^",2)
34 .S STATUS=$P($G(^PRC(442,ZP,7)),"^")
35 .S STATUS=$P($G(^PRCD(442.3,+STATUS,0)),"^") S:STATUS="" STATUS=0
36 .S STATUS=$E(STATUS,1,34)
37 .S PC1=$P(Z3,"^",8) Q:+PC1=0 S PC=$P($G(^PRC(440.5,+PC1,0)),"^") Q:PC=""
38 .I $G(FLAG)=1 I $P($G(^PRC(440.5,+PC1,0)),"^",9)'=DUZ QUIT
39 .I $G(FLAG)=2 I $P($G(^PRC(440.5,+PC1,0)),"^",8)'=DUZ QUIT
40 .S PCNAME=$P($G(^PRC(440.5,PC1,0)),"^",11),PCNAME=$E(PCNAME,1,15)
41 .S CP=$P(Z1,"^",3),CP=$P(CP," ")
42 .S USER=$P($G(^PRC(440.5,PC1,0)),"^",8),USER=$P($G(^VA(200,+USER,0)),"^") Q:USER=""
43 .S PNUM=$P(Z1,"^",1)
44 .S ITEM=0 F S ITEM=$O(^PRC(442,ZP,2,ITEM)) Q:ITEM="" D
45 ..Q:'$D(^PRC(442,ZP,2,"C",ITEM))
46 ..;
47 ..;Get the orders with partials received.
48 ..I $D(^PRC(442,ZP,2,ITEM))&($D(^PRC(442,ZP,2,ITEM,3))) D
49 ...S DETAIL1=^PRC(442,ZP,2,ITEM,0),QTYORD=$P(DETAIL1,"^",2),QTYAMT=$P(DETAIL1,"^",9)
50 ...S (PART,ORDTOT)=0 F S PART=$O(^PRC(442,ZP,2,ITEM,3,PART)) Q:PART="" D
51 ....S STR=$G(^PRC(442,ZP,2,ITEM,3,PART,0)) Q:STR=""
52 ....S YDATE=$P(STR,"^")
53 ....S Y=$P(YDATE,".") D DD^%DT S PARTDATE=Y
54 ....D DETAIL2
55 ..;
56 ..;Get orders without any partials received.
57 ..I $D(^PRC(442,ZP,2,ITEM))&('$D(^PRC(442,ZP,2,ITEM,3))) D
58 ...S DETAIL1=^PRC(442,ZP,2,ITEM,0),QTYORD=$P(DETAIL1,"^",2),QTYAMT=$P(DETAIL1,"^",9)
59 ...S YDATE=$P(^PRC(442,ZP,0),"^",10)
60 ...S Y=$P(YDATE,".") D DD^%DT S PARTDATE=Y
61 ...D DETAIL2
62 ;
63 D PRINT
64 K ^TMP($J)
65 Q
66 ;
67DETAIL2 ; Get common calculations in one place, account for discounts too.
68 S DETAIL3=$G(^PRC(442,ZP,2,ITEM,2)),QTYPRCD=$P(DETAIL3,"^",8)
69 S AMTDSCT=$P(DETAIL3,"^",6)
70 S QTYOUT=QTYORD-QTYPRCD
71 S ORDTOT=QTYOUT*QTYAMT I AMTDSCT>0 S ORDTOT=ORDTOT-AMTDSCT
72 S ORDTOT=$J(ORDTOT,0,2)
73 S LDESC=$G(^PRC(442,ZP,2,ITEM,1,1,0)),LDESC=$E(LDESC,1,40)
74 S ^TMP($J,USER,PNUM,STATUS,PC,1)=PCNAME_"^"_PNUM_"^"_STATUS_"^"_PDATE
75 S ^TMP($J,USER,PNUM,STATUS,PC,2,ITEM)=PARTDATE_"^"_ITEM_"^"_QTYORD_"^"_QTYOUT_"^"_ORDTOT_"^"_LDESC
76 S ^TMP($J,USER,PNUM,STATUS,PC,3)=VEND_"^"_VPHONE
77 Q
78 ;
79PRINT ; Variable AMT1 equals the total amount outstanding by purchase card
80 ; and user.
81 D NOW^%DTC S Y=% D DD^%DT S TIMEDATE=Y
82 U IO
83 I '$D(^TMP($J)) S P=1,Q="" D HEADER W !!!!,?10,"*** NO RECORDS TO PRINT ***" Q
84 S Q=0 F S Q=$O(^TMP($J,Q)) Q:Q="" Q:EX="^" D
85 .D HEADER
86 .S AMT1=0
87 .S Q1="" F S Q1=$O(^TMP($J,Q,Q1)) Q:Q1="" Q:EX="^" D
88 ..S Q2="" F S Q2=$O(^TMP($J,Q,Q1,Q2)) Q:Q2="" Q:EX="^" D
89 ...S Q3="" F S Q3=$O(^TMP($J,Q,Q1,Q2,Q3)) Q:Q3="" Q:EX="^" D
90 ....S STR1=^TMP($J,Q,Q1,Q2,Q3,1),STR2=^TMP($J,Q,Q1,Q2,Q3,3)
91 ....W !,$P(STR1,"^"),?20,$P(STR1,"^",2),?32,$P(STR1,"^",3),?68,$P(STR1,"^",4),!,$P(STR2,"^"),?45,$P(STR2,"^",2)
92 ....S ITEM="" F S ITEM=$O(^TMP($J,Q,Q1,Q2,Q3,2,ITEM)) Q:ITEM="" Q:EX="^" D
93 .....S STR3=^TMP($J,Q,Q1,Q2,Q3,2,ITEM) W !,$P(STR3,"^"),?15,$P(STR3,"^",2),?40,$P(STR3,"^",3),?54,$P(STR3,"^",4),!,$P(STR3,"^",5),?30,$P(STR3,"^",6)
94 .....S AMT1=$P(STR3,"^",5)+$G(AMT1)
95 .....I (IOSL-$Y)<7 D HOLD Q:EX[U
96 ....W !,"PURCHASE CARD SUBTOTAL: ",$J(AMT1,0,2),!
97 .I $E(IOST,1,2)="C-",EX'["^" W !,"Press return to continue, '^' to exit: " R XXZ:DTIME S:XXZ["^" EX="^" S:'$T EX=U
98 QUIT
99 ;
100HOLD 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=U I EX'="^",$G(Q3)'="" D HEADER
101 QUIT
102 ;
103HEADER ;
104 W @IOF
105 W "DELINQUENT PURCHASE CARD LISTING",?45,TIMEDATE,?70,"PAGE ",P
106 W !!,"PURCHASE CARD NAME",?20,"PO NUMBER",?32,"STATUS",?67,"PO DATE",!,"VENDOR",?45,"VENDOR PHONE"
107 W !,"DELIVERY DATE",?15,"LINE ITEM OUTSTANDING",?40,"QTY ORDERED",?54,"QTY OUTSTANDING",!,"AMOUNT OUTSTANDING",?30,"ITEM DESCRIPTION"
108 W ! F I=1:1:8 W "----------"
109 W !,?20,"BUYER: ",Q,!
110 S P=P+1 QUIT
Note: See TracBrowser for help on using the repository browser.