source: WorldVistAEHR/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCHPNT1.m@ 1141

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

initial load of WorldVistAEHR

File size: 3.8 KB
Line 
1PRCHPNT1 ;ID/RSD/RHD-CONT. OF PRINT ;2/12/98 2:49 PM
2V ;;5.1;IFCAP;;Oct 20, 2000
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4 ;
5PG1 S (PRCHJ,PRCH,PRCHPT,PRCHL,N)=0,PRCHP=P,P=1
6 ;
7PG S (PRCHL,PRCHI)=0 F I=0:0 S PRCHI=$O(^TMP($J,"P",P,PRCHI)) Q:PRCHI=""!(PRCHI<0) D IT:PRCHI=+PRCHI,DIS:PRCHI="D",EST:PRCHI="E",ADC:$E(PRCHI)="F",REQ:PRCHI="X" S PRCHJ=PRCHI I PRCHI="W" S PRCHL=PRCHL+1 D WP0
8 G:P>1 Q I PRCHP>1 W !?12,"CONTINUED ON NEXT PAGE ",! S PRCHL=PRCHL+2
9 F Y=1:1:19-PRCHL W !
10 S Y=$P($G(^PRC(442,D0,7)),U,3) W:Y="Y" ?48,"ESTIMATED" W ?66,$J($P(PRCH0,U,15),8,2),!?2 S Y=0 F I=1:1 S Y=$O(^PRC(442,D0,14,Y)) Q:'Y W:Y>1 "," W $P($G(^PRC(442.4,+^(Y,0),0)),U,2)
11 W !! S P=+$P(PRCH1,U,10),Y="" I $D(^PRC(442,D0,12)),$P(^(12),U,2)]"" S X=$P(^(12),U,2),Y=$P(^(12),U,3) W ?7,"/ES/"_$$DECODE^PRCHES5(D0)_" " D DT,DT1
12 W ! W:$D(^VA(200,P,.13)) ?10,$P(^(.13),U,2) W !!
13 W ?2,$P(PRCH0,U,1),?25 S Y=$P(PRCH1,U,15) D DT F Y=1:1:4 W !
14 ;
15APP W ?2,$P(PRCH0,U,4),"-",$P($P(PRCH0,U,3)," ",1),"-",$P(PRCH0,U,5),"-",$P(PRCH0,U,6),$S($P(PRCH0,U,8)>0:"-"_$P(PRCH0,U,8),1:"") W !!
16 W ?2 S (X,Y)="",P=0 I $D(^PRC(442,D0,10,1,0)) S Y=$P(^(0),U,6),P=+$P(^(0),U,2),X=$P(^(0),U,5)
17 I X]"" W "/ES/"_$$DECODE^PRCHES4(D0,1),?31 D:Y]"" DT
18 I X="",$D(^VA(200,+P,0)) S X=$P(^(0),"^",1) W $P(X,",",2)," ",$P(X,",",1),?31 D:Y]"" DT
19 W:$Y>0 @IOF D:$D(ZTSK) KILL^%ZTLOAD K ZTSK I PRCHP>1 D QUE^PRCHPNT
20 ;
21Q ;
22 K DA,D0,DIWF,DIWR,DIWL,N,PRCH,PRCHI,PRCHJ,PRCHK,PRCHC,PRCHCNT,PRCHD,PRCH1,PRCH0,PRCH12,PRCHFTYP,PRCHHSP,PRCHINV,PRCHJD,PRCHLC,PRCHL1
23 K PRCHLB,PRCHLE,PRCHS,PRCHSC,PRCHSHP,PRCHSIT,PRCHST,PRCHV,PRCHP,PRCHL,PRCHI0,PRCHI2,PRCHPT,PRCHQ,S,P,V,^TMP($J,"W"),^("PRCH"),^("P"),^UTILITY($J,"W")
24 Q
25 ;
26PGQ F P=2:1:PRCHP S PRCHPT=0 D PGNX
27 D:$D(ZTSK) KILL^%ZTLOAD K ZTSK
28 Q
29 ;
30IT G:PRCHJ=PRCHI WP1 S PRCH=PRCHI Q:'$D(^PRC(442,D0,2,PRCH)) S PRCHI0=^(PRCH,0),PRCHI2=^(2),N=N+1 D ITEM^PRCHPNT2
31 Q
32WP0 K ^UTILITY($J,"W") S DIWL=1,DIWR=54,DIWF="",PRCHK=0 F S PRCHK=$O(^PRC(442,D0,4,PRCHK)) Q:PRCHK=""!(PRCHK<0) S X=^(PRCHK,0) D DIWP^PRCUTL($G(DA))
33 D WP
34 Q
35 ;
36WP1 K ^UTILITY($J,"W") S DIWL=1,DIWR=33,DIWF="",PRCHK=0 F S PRCHK=$O(^PRC(442,D0,2,PRCHI,1,PRCHK)) Q:PRCHK=""!(PRCHK<0) S X=$G(^(PRCHK,0)) D DIWP^PRCUTL($G(DA))
37 ;
38WP F K=+^TMP($J,"P",P,PRCHI):1:$P(^TMP($J,"P",P,PRCHI),U,2) W !?9,$G(^UTILITY($J,"W",1,K,0)) S PRCHL=PRCHL+1
39 W ! S PRCHL=PRCHL+1
40 Q
41 ;
42PGNX D TOP,PG,TOT
43 Q
44 ;
45TOP W !!!!?63,P,?73,PRCHP,!!?55 S Y=$P(PRCH1,U,15) D DT W ?72,$P(PRCH0,U,1),!!?55,$P(PRCHV,U,1) F Y=1:1:5 W !
46 Q
47 ;
48DIS S PRCHD=^TMP($J,"P",P,"D") F PRCH=+PRCHD:1:$P(PRCHD,U,2) I $D(^PRC(442,D0,3,PRCH)) S PRCHI0=^(PRCH,0),N=N+1,PRCHPT=PRCHPT-$P(PRCHI0,U,3),PRCHL=PRCHL+2 W !?2,$J($P(PRCHI0,U,6),3),?8,"LESS ",$P(PRCHI0,U,2) D DIS1
49 Q
50 ;
51DIS1 W $S($E($P(PRCHI0,U,2),1)="$":"",1:" %")," FOR ",$S($P(PRCHI0,U,1)="Q":"QUANTITY DISCOUNT",1:"ITEMS: "_$P(PRCHI0,U,1)) W ?66,$J($P(PRCHI0,U,3),8,2) W !
52 Q
53 ;
54EST S PRCHD=^TMP($J,"P",P,"E"),N=N+1,PRCHPT=PRCHPT+$P(PRCH0,U,13),PRCHL=PRCHL+2 W !?2,$S($P(PRCH0,U,18)]"":$J($P(PRCH0,U,18),3),1:$J(N,3)),?8,"ESTIMATED SHIPPING AND/OR HANDLING",?66,$J($P(PRCH0,U,13),8,2),!
55 Q
56 ;
57ADC S PRCH=$P(PRCHI,U,2) Q:'$D(^PRC(442.7,PRCH,1,0)) S PRCHD=0,PRCHL=PRCHL+1,DIWL=1,DIWR=64,DIWF="" K ^UTILITY($J,"W")
58 F K=0:0 S PRCHD=$O(^PRC(442.7,PRCH,1,PRCHD)) Q:'PRCHD S X=^(PRCHD,0) D DIWP^PRCUTL($G(DA))
59 G WP
60 ;
61REQ S PRCHD=^TMP($J,"P",P,"X"),PRCHL=PRCHL+2 W !!?8,"V.A. TRANSACTION NUMBERS: " F PRCH=+PRCHD:0:$P(PRCHD,U,2) I $D(^PRC(442,D0,13,PRCH,0)),$D(^PRCS(410,+^(0),0)) W !?14,$P(^(0),U,1) S PRCH=$O(^PRC(442,D0,13,PRCH)),PRCHL=PRCHL+1 Q:'PRCH
62 W ! S PRCHL=PRCHL+1
63 Q
64 ;
65TOT F Y=1:1:47-PRCHL W !
66 W ?66,$J(PRCHPT,8,2) W:$Y>0 @IOF
67 Q
68 ;
69STQUE Q:'$D(ZTSK) S X=0,U="^"
70 D KILL^%ZTLOAD
71 G PGQ
72 ;
73DT W:Y Y\100#100,"/",Y#100\1,"/",Y\10000+1700
74 Q
75 ;
76DT1 Q:'Y S Y=$P(Y,".",2),Y=Y_$E("0000",1,(4-$L(Y))) Q:'Y W "@",$E(Y,1,2),":",$E(Y,3,4)
77 Q
Note: See TracBrowser for help on using the repository browser.