PRCHDP2 ;ID/RSD/RHD-DISPLAY P.O. ;  [7/22/98 11:11am]
V ;;5.1;IFCAP;**38**;Oct 20, 2000
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 W !?8,"ENTER '^' TO HALT: " S PRCHDQ=0 R X:DTIME S:X["^" PRCHDQ=1 G ASK2:PRCHDQ D HDR
 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
 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
 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)
 G:'$D(^PRC(442,D0,15,0)) COM K ^(9999999),^UTILITY($J,"W")
 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))
 ;
 K ^TMP($J,"W") S %X="^UTILITY($J,""W"",",%Y="^TMP($J,""W""," D %XY^%RCR
 W ! F J=0:0 S J=$O(^TMP($J,"W",1,J)) Q:'J  W !?8,^(J,0) D ASK G:PRCHDQ ASK2
COM 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))
 K ^TMP($J,"W") S %X="^UTILITY($J,""W"",",%Y="^TMP($J,""W""," D %XY^%RCR
 W ! S J=0 F  S J=$O(^TMP($J,"W",1,J)) Q:J=""  W !?8,^(J,0) D ASK G:PRCHDQ ASK2
PT 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)
 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
ASK2 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
PT1 K DIC S (PRCHPO,DA(1))=D0,DIC="^PRC(442,DA(1),11,",DIC(0)="NEAZ"
 ;--added for PRC*5.1*38
 S DIC("W")="D ADJCHK^PRCHDP2"
 D ^DIC G:Y<0 Q S PRCHDPT=+Y,PRCHDRD=$P(Y(0),U,1),PRCHDTP=1 D ^PRCHDP3 G PT1
ASK I $Y+5>IOSL W !?8,"ENTER '^' TO HALT: " R X:DTIME S:X["^" PRCHDQ=1 D:'PRCHDQ HDR Q
 Q
ASK1 W !,$C(7) G:PRCHDQ Q W "END OF DISPLAY--PRESS RETURN OR ENTER '^' TO HALT: " R X:DTIME G Q
HDR 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 "-"
 Q
ITEM S DIWL=1,DIWR=33,DIWF="",PRCHDIW=0 K ^UTILITY($J,"W")
 N PURCTYPE S:$P($G(^PRC(442,D0,23)),"^",11)="S" PURCTYPE=1
 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))
 K ^TMP($J,"W") S %X="^UTILITY($J,""W"",",%Y="^TMP($J,""W""," D %XY^%RCR
 S PRCHDCNT=$S($D(^TMP($J,"W",1)):^(1),1:"") W ! I $G(PURCTYPE)="" W ?2,$J(+$P(PRCHDI0,U,1),3)
 W ?7,$S($D(^(1,1,0)):^(0),1:"")
 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:"")
 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))
 W ?67,$J($P(PRCHDI2,U,1),7,2)
 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)
 Q:PRCHDQ
 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)
 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
 N ZZ S ZZ=0 D EDISTAT^PRCHUTL(D0,PRCHDI,.ZZ) ;***** NEW CODE EDI STATUS DISPLAY *****
 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),!
 D ASK ;***** NEW CODE TO CORRECT PAGING PROBLEM *****
 W:$X>1 !
 W ?8,"BOC: ",$P($P(PRCHDI0,U,4)," ",1) S FMSLN=$O(^PRC(442,D0,22,"B",+$P(PRCHDI0,U,4),0))
 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
 W:$P(PRCHDI2,U,2)]"" ?40,"CONTRACT: ",$P(PRCHDI2,U,2)
 W !
 Q
DIS W $S($P(PRCHDI0,U,1)="Q":"QUANTITY DISCOUNT",1:"ITEMS: "_$P(PRCHDI0,U,1)),?57,$J($P(PRCHDI0,U,3),8,2),! Q
 Q
AMD D:$D(^PRC(442,D0,6,PRCHI,3))  Q:PRCHDQ
 .K ^TMP($J,"W") D START^PRCHDP5(D0,PRCHI)
 .W ! F J=0:0 S J=$O(^TMP($J,"W",1,J)) Q:'J  W !?8,^(J,0) D ASK Q:PRCHDQ
 .Q
 D:$D(^PRC(442,D0,6,PRCHI,2))
 .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))
 .K ^TMP($J,"W") S %X="^UTILITY($J,""W"",",%Y="^TMP($J,""W""," D %XY^%RCR
 .W ! F J=0:0 S J=$O(^TMP($J,"W",1,J)) Q:'J  W !?8,^(J,0) D ASK Q:PRCHDQ
 .Q
 Q
DT I Y W Y\100#100,"/",Y#100\1,"/",Y\10000+1700
 Q
ADJCHK ;Check for any Adjustment on PO. If any show the adjuster. PRC*5.1*38
 Q:'$D(^PRC(442,PRCHPO,6,0))
 N CHKADJ,ISADJ,ADJDT,ADJDATA,ADJNUM
 S CHKADJ="",ISADJ=0,ADJDT=""
 S CHKADJ=$P($G(^PRC(442,PRCHPO,11,Y,0)),U,21)
 I CHKADJ="" Q
 S ADJDATA=$G(^PRC(442,PRCHPO,6,CHKADJ,0))
 N Y
 S Y=$P($G(ADJDATA),"^",2)
 Q:'Y
 D DD^%DT
 W ?30,"(Adjustment date: ",Y,")"
 Q
Q ;W @IOF  ;REMOVE IF PROBLEM WITH KERNEL V6.5
 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