source: FOIAVistA/tag/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCHDP2.m@ 1641

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

initial load of FOIAVistA 6/30/08 version
File size: 5.4 KB
Line 
1PRCHDP2 ;ID/RSD/RHD-DISPLAY P.O. ; [7/22/98 11:11am]
2V ;;5.1;IFCAP;**38**;Oct 20, 2000
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4 W !?8,"ENTER '^' TO HALT: " S PRCHDQ=0 R X:DTIME S:X["^" PRCHDQ=1 G ASK2:PRCHDQ D HDR
5 S (N,PRCHDI)=0 F I=0:0 S PRCHDI=$O(^PRC(442,D0,2,PRCHDI)) Q:PRCHDI'>0 S PRCHDI0=^(PRCHDI,0),PRCHDI2=$S($D(^(2)):^(2),1:""),N=+PRCHDI0 D ITEM G:PRCHDQ ASK2
6 S PRCHDI=0 F I=0:0 S PRCHDI=$O(^PRC(442,D0,3,PRCHDI)) Q:PRCHDI'>0 S PRCHDI0=^(PRCHDI,0),N=N+1 W !?2,$J(N,3),?7,"LESS ",$P(PRCHDI0,U,2),$S($E($P(PRCHDI0,U,2),1)="$":"",1:" %")," FOR " D DIS
7 I $P(PRCHD0,U,13)>0 W !?2,$J(N+1,3),?7,"EST. SHIPPING AND/OR HANDLING",?58,$J($P(PRCHD0,U,13),7,2)
8 G:'$D(^PRC(442,D0,15,0)) COM K ^(9999999),^UTILITY($J,"W")
9 F PRCHK=0:0 S PRCHK=$O(^PRC(442,D0,15,PRCHK)) Q:'PRCHK S PRCHI=^(PRCHK,0) I $D(^PRC(442.7,+PRCHI,0)),$O(^(1,0)) S DIWL=1,DIWR=60 F PRCHJ=0:0 S PRCHJ=$O(^PRC(442.7,+PRCHI,1,PRCHJ)) Q:'PRCHJ S X=^(PRCHJ,0) D DIWP^PRCUTL($G(DA))
10 ;
11 K ^TMP($J,"W") S %X="^UTILITY($J,""W"",",%Y="^TMP($J,""W""," D %XY^%RCR
12 W ! F J=0:0 S J=$O(^TMP($J,"W",1,J)) Q:'J W !?8,^(J,0) D ASK G:PRCHDQ ASK2
13COM G:'$D(^PRC(442,D0,4,0)) PT K ^UTILITY($J,"W") S DIWL=1,DIWR=60,PRCHJ=0 F S PRCHJ=$O(^PRC(442,D0,4,PRCHJ)) Q:PRCHJ="" S X=^(PRCHJ,0) D DIWP^PRCUTL($G(DA))
14 K ^TMP($J,"W") S %X="^UTILITY($J,""W"",",%Y="^TMP($J,""W""," D %XY^%RCR
15 W ! S J=0 F S J=$O(^TMP($J,"W",1,J)) Q:J="" W !?8,^(J,0) D ASK G:PRCHDQ ASK2
16PT I $O(^PRC(442,D0,13,0)) W !!?8,"V.A. TRANSACTION NUMBERS: " F PRCHI=0:0 S PRCHI=$O(^PRC(442,D0,13,PRCHI)) Q:'PRCHI I $D(^PRCS(410,PRCHI,0)) W !?14,$P(^(0),U,1)
17 I $D(^PRC(442,D0,6,0)) F PRCHI=0:0 S PRCHI=$O(^PRC(442,D0,6,PRCHI)) Q:'PRCHI I $D(^(PRCHI,0)) W !!?3,"AMENDMENT NUMBER: ",PRCHI,?40,"EFFECTIVE DATE: " S Y=$P(^(0),U,2) D DT D AMD Q:PRCHDQ
18ASK2 D:'PRCHDQ EN^PRCHDP4 G:'$O(^PRC(442,D0,11,0)) ASK1 W ! S %A=" Review a Receiving Report ",%B="",%=2 D ^PRCFYN G:%'=1 Q
19PT1 K DIC S (PRCHPO,DA(1))=D0,DIC="^PRC(442,DA(1),11,",DIC(0)="NEAZ"
20 ;--added for PRC*5.1*38
21 S DIC("W")="D ADJCHK^PRCHDP2"
22 D ^DIC G:Y<0 Q S PRCHDPT=+Y,PRCHDRD=$P(Y(0),U,1),PRCHDTP=1 D ^PRCHDP3 G PT1
23ASK I $Y+5>IOSL W !?8,"ENTER '^' TO HALT: " R X:DTIME S:X["^" PRCHDQ=1 D:'PRCHDQ HDR Q
24 Q
25ASK1 W !,$C(7) G:PRCHDQ Q W "END OF DISPLAY--PRESS RETURN OR ENTER '^' TO HALT: " R X:DTIME G Q
26HDR W:$Y>0 @IOF,!!?55,"UNIT",?70,"TOTAL",!,"ITEM",?15,"DESCRIPTION",?42,"QTY",?46,"UNIT",?55,"COST",?70,"COST",! F I=1:1:80 W "-"
27 Q
28ITEM S DIWL=1,DIWR=33,DIWF="",PRCHDIW=0 K ^UTILITY($J,"W")
29 N PURCTYPE S:$P($G(^PRC(442,D0,23)),"^",11)="S" PURCTYPE=1
30 F PRCHJ=1:1 S PRCHDIW=$O(^PRC(442,D0,2,PRCHDI,1,PRCHDIW)) Q:PRCHDIW'>0 S X=$S($D(^(PRCHDIW,0)):^(0),1:"") D DIWP^PRCUTL($G(DA))
31 K ^TMP($J,"W") S %X="^UTILITY($J,""W"",",%Y="^TMP($J,""W""," D %XY^%RCR
32 S PRCHDCNT=$S($D(^TMP($J,"W",1)):^(1),1:"") W ! I $G(PURCTYPE)="" W ?2,$J(+$P(PRCHDI0,U,1),3)
33 W ?7,$S($D(^(1,1,0)):^(0),1:"")
34 I $G(PURCTYPE)="" W ?40,$J($P(PRCHDI0,U,2),5),?47,$S($D(^PRCD(420.5,+$P(PRCHDI0,U,3),0)):$P(^(0),U,1),1:"")
35 S X=$P($P(PRCHDI0,U,9),".",2) I $G(PURCTYPE)="" W ?52,$S($L(X)>3:$J($P(PRCHDI0,U,9),5,4),$L(X)>2:$J($P(PRCHDI0,U,9),6,3),$P(PRCHDI0,U,9)="N/C":" N/C",1:$J($P(PRCHDI0,U,9),7,2))
36 W ?67,$J($P(PRCHDI2,U,1),7,2)
37 I PRCHDCNT>1 S K=1 F S K=$O(^TMP($J,"W",1,K)) Q:K=""!(K'>0) D:$Y+5>IOSL ASK Q:PRCHDQ W !?8,^(K,0)
38 Q:PRCHDQ
39 W:$P(PRCHDI0,U,6)]"" !?8,"STK#: ",$P(PRCHDI0,U,6) W:$P(PRCHDI0,U,13)]"" !,?8,"NSN: ",$P(PRCHDI0,U,13) W:$P($G(^PRC(442,D0,2,PRCHDI,4)),U,12)]"" !,?8,"FOOD GROUP: ",$P(^(4),U,12)
40 W:$P(PRCHDI2,U,8)]"" !,?8,"QTY PREV RCVD: ",$J($P(PRCHDI2,U,8),5) I $D(^PRC(442,D0,2,PRCHDI,3,"AC")) W !,?8,"PARTIAL NO.: " S X=0 F K=1:1 S X=$O(^PRC(442,D0,2,PRCHDI,3,"AC",X)) Q:X="" W:K>1 "," W X
41 N ZZ S ZZ=0 D EDISTAT^PRCHUTL(D0,PRCHDI,.ZZ) ;***** NEW CODE EDI STATUS DISPLAY *****
42 I $G(PURCTYPE)="",$P(PRCHDI0,U,12) W:'ZZ ! W ?8,"Items per ",$S($D(^PRCD(420.5,+$P(PRCHDI0,U,3),0)):$P(^(0),U,1),1:""),": ",$P(PRCHDI0,U,12),!
43 D ASK ;***** NEW CODE TO CORRECT PAGING PROBLEM *****
44 W:$X>1 !
45 W ?8,"BOC: ",$P($P(PRCHDI0,U,4)," ",1) S FMSLN=$O(^PRC(442,D0,22,"B",+$P(PRCHDI0,U,4),0))
46 I FMSLN>0,'$P($G(^PRC(442,D0,23)),U,8) S FMSLN="00"_$P($G(^PRC(442,D0,22,FMSLN,0)),U,3),FMSLN=$E(FMSLN,$L(FMSLN)-2,99) W ?22,"FMS LINE: ",FMSLN
47 W:$P(PRCHDI2,U,2)]"" ?40,"CONTRACT: ",$P(PRCHDI2,U,2)
48 W !
49 Q
50DIS W $S($P(PRCHDI0,U,1)="Q":"QUANTITY DISCOUNT",1:"ITEMS: "_$P(PRCHDI0,U,1)),?57,$J($P(PRCHDI0,U,3),8,2),! Q
51 Q
52AMD D:$D(^PRC(442,D0,6,PRCHI,3)) Q:PRCHDQ
53 .K ^TMP($J,"W") D START^PRCHDP5(D0,PRCHI)
54 .W ! F J=0:0 S J=$O(^TMP($J,"W",1,J)) Q:'J W !?8,^(J,0) D ASK Q:PRCHDQ
55 .Q
56 D:$D(^PRC(442,D0,6,PRCHI,2))
57 .K ^UTILITY($J,"W") S DIWL=1,DIWR=60 F PRCHJ=0:0 S PRCHJ=$O(^PRC(442,D0,6,PRCHI,2,PRCHJ)) Q:'PRCHJ S X=^(PRCHJ,0) D DIWP^PRCUTL($G(DA))
58 .K ^TMP($J,"W") S %X="^UTILITY($J,""W"",",%Y="^TMP($J,""W""," D %XY^%RCR
59 .W ! F J=0:0 S J=$O(^TMP($J,"W",1,J)) Q:'J W !?8,^(J,0) D ASK Q:PRCHDQ
60 .Q
61 Q
62DT I Y W Y\100#100,"/",Y#100\1,"/",Y\10000+1700
63 Q
64ADJCHK ;Check for any Adjustment on PO. If any show the adjuster. PRC*5.1*38
65 Q:'$D(^PRC(442,PRCHPO,6,0))
66 N CHKADJ,ISADJ,ADJDT,ADJDATA,ADJNUM
67 S CHKADJ="",ISADJ=0,ADJDT=""
68 S CHKADJ=$P($G(^PRC(442,PRCHPO,11,Y,0)),U,21)
69 I CHKADJ="" Q
70 S ADJDATA=$G(^PRC(442,PRCHPO,6,CHKADJ,0))
71 N Y
72 S Y=$P($G(ADJDATA),"^",2)
73 Q:'Y
74 D DD^%DT
75 W ?30,"(Adjustment date: ",Y,")"
76 Q
77Q ;W @IOF ;REMOVE IF PROBLEM WITH KERNEL V6.5
78 K I,J,K,N,DIC,DIWF,DIWL,DIWR,IOP,PRCHDI,PRCHD0,PRCHD1,PRCHFTYP,PRCHDSIT,PRCHDHSP,PRCHDSHP,PRCHDST,PRCHDS,PRCHDV,PRCHDQ,PRCHDI0,PRCHDI2,PRCHDIW,PRCHDCNT,PRCHI,PRCHJ,PRCHK,S,V,^TMP($J,"W"),^UTILITY($J,"W"),KK,JJ Q
Note: See TracBrowser for help on using the repository browser.