source: FOIAVistA/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCHRP5.m@ 1607

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

initial load of FOIAVistA 6/30/08 version

File size: 5.8 KB
Line 
1PRCHRP5 ;WISC/KMB/CR-RECONCILED PURCHASE CARD ORDERS ;6/29/98 15:27
2 ;;5.1;IFCAP;**8**;Oct 20, 2000
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4START ;
5 ; set check for reconciled reports
6 N FLAG S FLAG=1 G EN
7START1 ;
8 ; entry point for unreconciled reports
9 N FLAG S FLAG=0
10EN K ^TMP($J)
11 N CCTOT,XXZ,LIN,CCREF,CCRF,CCAMT,CP,PCARD,PO,P,PA,PRC,PRCRI,LABEL,XX,F1,F2,F3,F4,STATUS,YY,Y,PDATE,VEND,RDATE,RPTDATE,PC,USER,AMT,XXZ,EX,COUNT,FDATE,EDATE,TYPE
12 N RMPR,RMPR1,OSTAT,OREC,OREC6,MERC,CNTCC,CNTSTR,P,LN,Z0,Z1,Z2,Z3,Z4
13 S:$G(FLAG)="" FLAG=0 S:$G(FLG)="" FLG=""
14 S:$G(FLAG)=1 LABEL="START" S:$G(FLAG)=0 LABEL="START1"
15 S PRCF("X")="S" D ^PRCFSITE I '$D(PRC("SITE")) K FLAG QUIT
16 Q:$G(X)="^"
17 ;
18RANGE ;
19 S DIR("A")="Enter beginning date",DIR("?")="Enter the first date for which you wish to see records"
20 S DIR(0)="D^^" D ^DIR K DIR Q:+Y<1 S FDATE=+Y W " ",Y(0)
21 S DIR("A")="Enter ending date",DIR("?")="Enter the last date for which you wish to see records"
22 S DIR(0)="D^^" D ^DIR K DIR Q:+Y<1 S EDATE=+Y W " ",Y(0)
23 I EDATE<FDATE W !,"Date range is incorrect." G RANGE
24 I $G(X)="^" K FLG,FLAG Q
25 S %ZIS("B")="",%ZIS="MQ" D ^%ZIS Q:POP
26 I $D(IO("Q")) S ZTRTN="DETAIL^PRCHRP5",ZTSAVE("*")="" D ^%ZTLOAD,^%ZISC K FLG,FLAG,^TMP($J) Q
27 D DETAIL,^%ZISC K FLG,FLAG,^TMP($J)
28 Q
29DETAIL ;
30 ;variable F4 is used to store the first line from the COMMENTS
31 ;field. If there is a Prosthetics entry for the order, the
32 ;first line of file 664's REMARKS field is stored in F4.
33 S COUNT=1,XX="" F S XX=$O(^PRC(442,"F",25,XX)) Q:XX="" D
34 .S (CCREF,CCRF,CCAMT)=""
35 .S F1=$G(^PRC(442,XX,0)) S CP=$P(F1,"^",3)
36 .S F2=$G(^PRC(442,XX,1)),F3=$G(^PRC(442,XX,2,1,1,1,0))
37 .S F4=$G(^PRC(442,XX,4,1,0))
38 .S STATUS=+$P($G(^PRC(442,XX,7)),"^",2)
39 .Q:(STATUS=1)!(STATUS=45)
40 .I $G(FLAG)=1 Q:"^40^41^50^51^"'[("^"_STATUS_"^")
41 .I $G(FLAG)=0 Q:"^4^5^6^40^41^50^51^"[("^"_STATUS_"^")
42 .I $D(PRC("SITE")) Q:$P(F1,"-",1)'=PRC("SITE")
43 .I $G(FLAG)=1 S Y=$P($G(^PRC(442,XX,23)),"^",19) Q:Y<FDATE Q:Y>EDATE
44 .I $G(FLAG)'=1 S Y=$P(F2,"^",15) Q:Y<FDATE Q:Y>EDATE
45 .I $P($G(^PRC(442,XX,24)),"^",3)="RMPR" S RMPR=$P(F1,"^") I $D(^RMPR(664,"AC",RMPR)) S RMPR1=$O(^RMPR(664,"AC",RMPR,0)),F4=$P($G(^RMPR(664,+RMPR1,1,1,0)),"^",8)
46 .S PC=$P($G(^PRC(442,XX,23)),"^",8),PC=$P($G(^PRC(440.5,+PC,0)),"^") S:PC="" PC=0
47 .S STATUS=$P($G(^PRC(442,XX,7)),"^")
48 .I $G(FLAG)=1 Q:$P($G(^PRC(442,XX,23)),"^",19)=""
49 .S PCARD=$P($G(^PRC(442,XX,23)),"^",8) Q:PCARD=""
50 .I $G(FLG)=2 I $P($G(^PRC(440.5,PCARD,0)),"^",10)'=DUZ,$P($G(^PRC(440.5,PCARD,0)),"^",9)'=DUZ Q
51 .I $G(FLG)=1 Q:$P($G(^PRC(440.5,PCARD,0)),"^",8)'=DUZ
52 .S STATUS=$P($G(^PRCD(442.3,STATUS,0)),"^")
53 .S USER=$P($G(^PRC(440.5,PCARD,0)),"^",8) Q:USER=""
54 .S USER=$P($G(^VA(200,+USER,0)),"^"),VEND=$P(F2,"^"),VEND=$P($G(^PRC(440,+VEND,0)),"^"),AMT=$P(F1,"^",15)
55 .I VEND="SIMPLIFIED",$P($G(^PRC(442,XX,24)),"^",2)'="" S VEND=$P($G(^PRC(442,XX,24)),"^",2)
56 .S VEND=$E(VEND,1,30)
57 .Q:USER=""
58 .S PO=$P(F1,"^")
59 .S (YY,Y)=$P(F2,"^",15) D DD^%DT S PDATE=Y
60 .S Y=$P($G(^PRC(442,XX,23)),"^",19),TYPE=$P($G(^PRC(442,XX,23)),"^",11) D DD^%DT S RDATE=Y
61 .S:TYPE["D" TYPE="DELIV." S:TYPE="P" TYPE="DETAILED" S:TYPE="S" TYPE="SIMPLIFIED"
62 .S CCTOT=0 I $G(FLAG)=1,$O(^PRCH(440.6,"PO",XX,0))'="" S CCREF=0 D
63 ..F S CCREF=$O(^PRCH(440.6,"PO",XX,CCREF)) Q:CCREF="" D
64 ...S OREC=$G(^PRCH(440.6,CCREF,0)),OREC6=$G(^PRCH(440.6,CCREF,6))
65 ...S OSTAT="NO" I $P($G(^PRCH(440.6,CCREF,1)),"^",4)="Y" S OSTAT="YES"
66 ...S CCRF=$P(OREC,"^"),CCAMT=$P(OREC,"^",14),MERC=$P(OREC6,"^") S ^TMP($J,USER,PC,YY,COUNT,3,CCREF)=CCRF_"^"_CCAMT_"^"_MERC_"^"_OSTAT
67 ...S CCTOT=CCTOT+CCAMT
68 .S ^TMP($J,USER,PC,YY,COUNT,4)=$J(CCTOT,0,2)
69 .S:$G(FLAG)=0&($P($G(^PRC(442,XX,23)),"^",19)'="") RDATE=""
70 .S ^TMP($J,USER,PC,YY,COUNT)=PDATE_"^"_RDATE_"^"_PO_"^"_AMT_"^"_VEND_"^"_STATUS_"^"_TYPE_"^"_USER
71 .S ^TMP($J,USER,PC,YY,COUNT,1)=$E(F3,1,35) S ^TMP($J,USER,PC,YY,COUNT,2)=$E(F4,1,55)
72 .S:$G(^TMP($J,USER,2))="" ^TMP($J,USER,2)=0 S ^TMP($J,USER,2)=^TMP($J,USER,2)+AMT
73 .S COUNT=COUNT+1
74 ;
75WRITE ;
76 S X=DT D NOW^%DTC,YX^%DTC S RPTDATE=Y
77 U IO S U="^",P=1,EX=""
78 I '$D(^TMP($J)) S Z0="" S FLAG=$S($G(FLAG)=1:1,$G(FLAG)=0:0,1:1) D HEADER W !!!!,?10,"*** NO RECORDS TO PRINT ***" Q
79 ;
80 S Z0=0 F S Z0=$O(^TMP($J,Z0)) Q:Z0="" Q:EX[U D
81 .D HEADER
82 .S Z1="" F S Z1=$O(^TMP($J,Z0,Z1)) Q:Z1="" Q:EX[U D
83 ..S Z2="" F S Z2=$O(^TMP($J,Z0,Z1,Z2)) Q:Z2="" Q:EX[U D
84 ...S Z3="" F S Z3=$O(^TMP($J,Z0,Z1,Z2,Z3)) Q:Z3="" Q:EX[U D
85 ....W ! S LN=^TMP($J,Z0,Z1,Z2,Z3) W !,$P(LN,"^"),?20,$P(LN,"^",2),?40,$P(LN,"^",3),?55,$J($P(LN,"^",4),0,2),?67,$P(LN,"^",7)
86 ....S LIN=^TMP($J,Z0,Z1,Z2,Z3,1) W !,$P(LN,"^",5),?40,$P(LIN,"^")
87 ....W !,$P(LN,"^",6)
88 ....I $G(FLAG)=1,$G(FLG)=1 W !,^TMP($J,Z0,Z1,Z2,Z3,2)
89 ....I $G(FLAG)=1 S CNTCC="" F S CNTCC=$O(^TMP($J,Z0,Z1,Z2,Z3,3,CNTCC)) Q:CNTCC="" S CNTSTR=^TMP($J,Z0,Z1,Z2,Z3,3,CNTCC) W !,$P(CNTSTR,"^"),?20,$P(CNTSTR,"^",2),?40,$P(CNTSTR,"^",3),?67,$P(CNTSTR,"^",4)
90 ....I (IOSL-$Y)<6 D HOLD Q:EX[U
91 ....I $G(FLAG)=1 W !," RECONCILED SUBTOTAL - $",^TMP($J,Z0,Z1,Z2,Z3,4)
92 ....I $G(FLAG)=0 W !,^TMP($J,Z0,Z1,Z2,Z3,2)
93 .W !," BUYER SUBTOTAL - $",$J(^TMP($J,Z0,2),0,2)
94 .I $E(IOST,1,2)="C-",EX'[U W !,"Press return to continue, '^' to exit: " R XXZ:DTIME S:XXZ[U EX=U S:'$T EX=U
95 K Z0,Z1,Z2,Z3
96 Q
97 ;
98HOLD G HEADER:$E(IOST,1,2)'="C-"!(IO'=IO(0)) W !,"Press return to continue, '^' to exit: " R XXZ:DTIME S:XXZ[U EX=U S:'$T EX=U I EX'=U,$G(Z1)'="",$G(Z3)'="" D HEADER
99 QUIT
100 ;
101HEADER ;
102 W @IOF W !
103 I $G(FLAG)=0 W "UNRECONCILED"
104 I $G(FLAG)=1 W "RECONCILED"
105 W " PURCHASE CARD ORDERS",?45,RPTDATE,?70,"PAGE ",P
106 W !,"P.O. DATE"
107 I $G(FLAG)=1 W ?20,"DATE RECONCILED"
108 W ?40,"ORDER #",?55,"$AMT",?67,"TYPE(S/D)",!,"VENDOR",?40,"DESCRIPTION"
109 W !,"STATUS" I $G(FLAG)=0 W !,"COMMENTS"
110 I $G(FLAG)=1,$G(FLG)=1 W !,"COMMENTS"
111 I $G(FLAG)=1 W !,"DOC-REF #",?20,"RECONCILED $AMT",?40,"RECONCILE VENDOR",?67,"FINAL CHARGE"
112 W ! F I=1:1:8 W "----------"
113 W !,"BUYER: ",Z0
114 S P=P+1
115 QUIT
Note: See TracBrowser for help on using the repository browser.