source: WorldVistAEHR/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCHRP1.m@ 1006

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

initial load of WorldVistAEHR

File size: 3.6 KB
Line 
1PRCHRP1 ;WISC/KMB-PURCHASE CARD TRANS. STATUS ;9/25/96
2 ;;5.1;IFCAP;;Oct 20, 2000
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4OBL ;
5 W @IOF W !!,"NOTE - You cannot use the PURCHASE CARD HOLDER field for lookups.",!! S PRCF("X")="S" D ^PRCFSITE G EXIT:'$D(PRC("SITE"))
6 S DIC("A")="P.O./REQ. NO.: ",DIC(0)="AEMQZ",D="C",DIC("S")="I $P(^(0),""^"",2)=25",DIC="^PRC(442,"
7 W !! D IX^DIC K DIC G EXIT:+Y<0 S (DA,ZIP)=+Y
8 ;
9 D DETAIL1
10 W !,"Do you wish to print this report" S %=1 D YN^DICN I %'=1 G OBL
11 S %ZIS("B")="",%ZIS="MQ" D ^%ZIS Q:POP
12 I $D(IO("Q")) S ZTRTN="DETAIL^PRCHRP1",ZTSAVE("ZIP")="" D ^%ZTLOAD,^%ZISC G OBL
13 D DETAIL,^%ZISC H 3 G OBL
14DETAIL ;
15 U IO
16DETAIL1 ;
17 S R=$G(^PRC(442,ZIP,0)),S=$G(^PRC(442,ZIP,1)),T=$G(^PRC(442,ZIP,23))
18 W !,"Transaction Number: ",$P(R,"^"),?40,"FCP: ",$E($P(R,"^",3),1,30)
19 S PP=$P($G(^PRC(442,ZIP,7)),"^") W !,"Transaction Status: ",$P($G(^PRCD(442.3,+PP,0)),"^")
20 S Y=$P(S,"^",15),YY=$P(R,"^",10)
21 D DD^%DT W !,"Date of Request: ",Y S Y=$P(R,"^",10) D DD^%DT W ?40,"Date Required: ",Y
22 S VRR=$P($G(^PRC(440,+$P(S,"^"),0)),"^") I VRR="SIMPLIFIED",$P($G(^PRC(442,ZIP,24)),"^",2)'="" S VRR=$P($G(^PRC(442,ZIP,24)),"^",2)
23 W !,"Vendor: ",VRR
24 W !,"Committed (Estimated) Cost: ",$J($P(R,"^",15),0,2) S Y=YY D DD^%DT W ?40,"Date Committed: ",Y
25 W !,"Purchase Card Amount: ",$J($P(R,"^",15),0,2) S YY=$P($G(^PRC(442,ZIP,12)),"^",3) S Y=YY D DD^%DT W ?40,"Date Signed: ",Y
26 W !,"Transaction Amount: ",$J($P(R,"^",15),0,2),?40,"Accounting Data: ",$P(R,"^",4)
27 ;
28 W !!,"Originator of Request: ",$P($G(^VA(200,+$P(S,"^",10),0)),"^")
29 W !,"Requesting Service: ",$P($G(^DIC(49,+$P(S,"^",2),0)),"^")
30 K ^UTILITY($J,"W") S DIWL=1,DIWR=62,DIWF="",PRCSDY=8,PRCSI=0
31 F PRCSJ=1:1 S PRCSI=$O(^PRC(442,ZIP,4,PRCSI)) Q:'PRCSI S X=^(PRCSI,0) D DIWP^PRCUTL($G(DA))
32 S I=$S($D(^UTILITY($J,"W",DIWL)):+^(DIWL),1:0)
33 I I F J=1:1:I W ! W:J=1 "Comments:" W ?15,^UTILITY($J,"W",DIWL,J,0) S PRCSDY=PRCSDY+1
34 W !,"Delivery Location: ",$P(S,"^",11)
35 S SORT=$P(T,"^",13) I SORT'="" S PZ1=$P(SORT,";"),PZ2=$P(SORT,";",2),PZ3="^"_PZ2_PZ1_",0)" S SORT=$G(@PZ3) S SORT=$P(SORT,"^")
36 W !,"Sort Group: ",SORT
37 D CCDATA
38 W ! QUIT
39ITEM ;
40 S COUNT=$P(R,"^",14) Q:COUNT=""
41 D HEADER
42 F FF=1:1:COUNT D
43 .S QQ=$G(^PRC(442,ZIP,2,FF,0)) Q:QQ=""
44 .W !,$P(QQ,"^",6),?12,"|",?50,"|",$P(QQ,"^",2),?60,"|",$P($G(^PRC(420.5,+$P(QQ,"^",3),0)),"^"),?70,"|",$P(QQ,"^",9)
45 .S C1=0 I $G(^PRC(442,ZIP,2,FF,1,0))'="" F J=1:1 K ^UTILITY($J,"W") S C1=$O(^PRC(442,ZIP,2,FF,1,C1)) Q:+C1=0 D
46 ..N L1,L2,L3 S DIWL=14,DIWR=48,DIWF=""
47 ..S X=^PRC(442,ZIP,2,FF,1,C1,0) S:J=1 X=$P(^PRC(442,ZIP,2,FF,1,0),"^")_" "_X D DIWP^PRCUTL($G(ZIP))
48 ..S Z=^UTILITY($J,"W",DIWL) W !
49 ..I Z>1 F J=1:1:(Z-1) W !,?12,"|",^UTILITY($J,"W",DIWL,J,0),?50,"|",?60,"|",?70,"|" D:$Y>61 HEADER W !,?12,"|",?50,"|",?60,"|",?70,"|"
50 ..I Z>1 W !,?12,"|",^UTILITY($J,"W",DIWL,Z,0),?50,"|",?60,"|",?70,"|" D:$Y>61 HEADER W !,?12,"|",?50,"|",?60,"|",?70,"|"
51 ..I Z<2 W ?12,"|",^UTILITY($J,"W",DIWL,1,0),?50,"|",?60,"|",?70,"|" D:$Y>61 HEADER W !,?12,"|",?50,"|",?60,"|",?70,"|"
52 QUIT
53CCDATA ;
54 S CCREC="" F S CCREC=$O(^PRCH(440.6,"PO",ZIP,CCREC)) Q:CCREC="" D
55 .S CCSTR=$G(^PRCH(440.6,CCREC,0)) S Y=$P(CCSTR,"^",7) D DD^%DT W !,"Transaction date: ",Y,?35,"Credit card ref.#: ",$P(CCSTR,"^")
56 .W !,"Amount: ",$P(CCSTR,"^",14)
57 QUIT
58EXIT K DA,PRCRI,CCREC,CCSTR,SORT,VRR,COUNT,FF,I,J,R,S,T,QQ,Y,YY,PP,PZ1,PZ2,PZ3,SORT,PRCSJ,PRCSI,PRCSDY,ZIP
59 QUIT
60HEADER ;
61 I IO=IO(0) H 5
62 W @IOF
63 W !,?30,"ITEM INFORMATION"
64 W !,"Transaction Number: ",$P(R,"^"),?40,"FCP: ",$E($P(R,"^",3),1,30),!
65 F I=1:1:8 W "----------"
66 W !,"STOCK NUMBER",?14,"ITEM DESCRIPTION",?51,"QUANTITY",?64,"U/I",?71,"UNIT COST",!
67 F I=1:1:8 W "----------"
68 Q
Note: See TracBrowser for help on using the repository browser.