source: WorldVistAEHR/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCHRP9.m@ 623

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

initial load of WorldVistAEHR

File size: 3.2 KB
Line 
1PRCHRP9 ;WISC/KMB-DISPUTED PURCHASE CARD ORDERS ;8/21/96 12:09
2 ;;5.1;IFCAP;;Oct 20, 2000
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4STRT S FLAG=1 ;Buyer report.
5 G EN
6START ;
7 S FLAG=2 ;Official report.
8EN K ^TMP($J)
9 S LABEL="START" S:$G(FLAG)=1 LABEL="STRT"
10 W @IOF S PRCF("X")="S" D ^PRCFSITE Q:'$D(PRC("SITE"))
11 Q:$G(X)="^"
12 S %ZIS("B")="",%ZIS="MQ" D ^%ZIS Q:POP
13 I $D(IO("Q")) S ZTRTN="DETAIL^PRCHRP9",ZTSAVE("FLAG")="",ZTSAVE("PRC*")="" D ^%ZTLOAD,^%ZISC Q
14 D DETAIL,^%ZISC
15 D CLEAN
16 Q
17 ;
18CLEAN ;
19 K ^TMP($J),I,ID,FLAG,LN,Z0,Z1,Z2,Z3,PO,LABEL,X,XX,F0,F1,F2,F3,F4,F23,RECDT,YY,Y,PDATE,VEND,RDATE,PC,PC0,PC1,USER,AMT,XXZ,EX,PCNAME,AA,P,TIMDATE,PRCRI,ZIP
20 Q
21 ;
22DETAIL ;
23 S (EX,XX)="" F S XX=$O(^PRC(440.5,XX)) Q:XX="" D
24 .S ZIP=$G(^PRC(440.5,XX,0)),ID=$P(ZIP,"^") S:$P(ZIP,"^",9)=DUZ AA(ID)="" S:$P(ZIP,"^",10)=DUZ AA(ID)=""
25 S (EX,XX)="" F S XX=$O(^PRC(442,"F",25,XX)) Q:XX="" D
26 .S F0=$G(^PRC(442,XX,0))
27 .S F1=$G(^PRC(442,XX,1))
28 .S F23=$G(^PRC(442,XX,23))
29 .I $P(F23,"^",9)="" Q
30 .I $P(F23,"^",9)="N" Q
31 .I $G(FLAG)=1,$P(F1,"^",10)'=DUZ Q
32 .Q:("^40^41^45^"[("^"_$P($G(^PRC(442,XX,7)),U,2)_"^"))
33 .S PC1=+$P(F23,"^",8),PC0=$G(^PRC(440.5,PC1,0))
34 .S PC=$P(PC0,"^") Q:+PC=0
35 .Q:$P(F0,"-",1)'=PRC("SITE") ;Don't mix stations
36 .S USER=$P(PC0,"^",8),USER=$P($G(^VA(200,+USER,0)),"^")
37 .Q:USER=""
38 .;
39 .; See if the Approving Official or Alternate have anything to approve.
40 .I $G(FLAG)=2 Q:'$D(AA(PC))
41 .I $G(FLAG)=2 Q:$P(PC0,"^",9)'=DUZ&($P(PC0,"^",10)'=DUZ)
42 .S F3=$G(^PRC(442,XX,2,1,1,1,0))
43 .S F4=$G(^PRC(442,XX,4,1,0))
44 .S PCNAME=$P(PC0,"^",11),PCNAME=$E(PCNAME,1,15)
45 .S VEND=$P(F1,"^"),VEND=$P($G(^PRC(440,+VEND,0)),"^"),AMT=$J($P(F0,"^",15),0,2)
46 .I VEND="SIMPLIFIED",$P($G(^PRC(442,XX,24)),"^",2)'="" S VEND=$P($G(^PRC(442,XX,24)),"^",2)
47 .S VEND=$E(VEND,1,25)
48 .S PO=$P(F0,"^")
49 .S (YY,Y)=$P(F1,"^",15) D DD^%DT S PDATE=Y
50 .Q:YY=""
51 .S Y=$P(F23,"^",19) D DD^%DT S RECDT=$P(Y,".")
52 .S ^TMP($J,USER,PC,YY,PO,0)=PCNAME_"^"_PDATE_"^"_AMT_"^"_PO_"^"_VEND_"^"_RECDT
53 .S ^TMP($J,USER,PC,YY,PO,1)=$E(F3,1,45),^TMP($J,USER,PC,YY,PO,2)=$E(F4,1,99)
54 ;
55WRITE ; Let's go to the printer.
56 U IO S U="^"
57 S X=DT D NOW^%DTC,YX^%DTC S TIMDATE=Y
58 S P=1,Z0="" I $O(^TMP($J,0))="" D HEADER W !!!!,?10," **** NO RECORDS TO PRINT ****" QUIT
59 S Z0="" F S Z0=$O(^TMP($J,Z0)) Q:EX[U Q:Z0="" D
60 .D HEADER
61 .S Z1="" F S Z1=$O(^TMP($J,Z0,Z1)) Q:Z1="" Q:EX[U D
62 ..S Z2="" F S Z2=$O(^TMP($J,Z0,Z1,Z2)) Q:Z2="" Q:EX[U D
63 ...S Z3="" F S Z3=$O(^TMP($J,Z0,Z1,Z2,Z3)) Q:Z3="" Q:EX[U D
64 ....W ! S LN=^TMP($J,Z0,Z1,Z2,Z3,0) W !,$P(LN,"^"),?15,$P(LN,"^",2),?30,$P(LN,"^",3),?41,$P(LN,"^",4),?54,$P(LN,"^",5)
65 ....W !,$P(LN,"^",6),?20,^TMP($J,Z0,Z1,Z2,Z3,1)
66 ....W !,^TMP($J,Z0,Z1,Z2,Z3,2)
67 ....I (IOSL-$Y)<6 D HOLD
68 .I $E(IOST,1,2)'="P-",EX'[U W !!,"Press return to continue, '^' to exit: " R XXZ:DTIME S:XXZ[U EX=U S:'$T EX=U
69 Q
70 ;
71HOLD G HEADER:$E(IOST,1,2)="P-"!(IO'=IO(0)) W !!,"Press return to continue, '^' to exit: " R XXZ:DTIME S:XXZ[U EX=U S:'$T EX=U D:EX'=U HEADER
72 Q
73 ;
74HEADER ;
75 W @IOF
76 W "DISPUTED PURCHASE CARD ORDERS",?40,TIMDATE,?70,"PAGE ",P
77 W !,"PC NAME",?15,"P.O. DATE",?30,"$AMT",?41,"PC ORDER #",?54,"VENDOR",!,"DATE RECONCILED",?20,"DESCRIPTION",!,"COMMENTS"
78 W ! F I=1:1:8 W "----------"
79 W !,"BUYER: ",Z0
80 S P=P+1
81 QUIT
Note: See TracBrowser for help on using the repository browser.