source: FOIAVistA/tag/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCHPNT1.m@ 642

PRCHPNT1 ;ID/RSD/RHD-CONT. OF PRINT ;2/12/98  2:49 PM
V ;;5.1;IFCAP;;Oct 20, 2000
 ;Per VHA Directive 10-93-142, this routine should not be modified.
 ;
PG1 S (PRCHJ,PRCH,PRCHPT,PRCHL,N)=0,PRCHP=P,P=1
 ;
PG 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
 G:P>1 Q I PRCHP>1 W !?12,"CONTINUED ON NEXT PAGE ",! S PRCHL=PRCHL+2
 F Y=1:1:19-PRCHL W !
 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)
 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
 W ! W:$D(^VA(200,P,.13)) ?10,$P(^(.13),U,2) W !!
 W ?2,$P(PRCH0,U,1),?25 S Y=$P(PRCH1,U,15) D DT F Y=1:1:4 W !
 ;
APP 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 !!
 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)
 I X]"" W "/ES/"_$$DECODE^PRCHES4(D0,1),?31 D:Y]"" DT
 I X="",$D(^VA(200,+P,0)) S X=$P(^(0),"^",1) W $P(X,",",2)," ",$P(X,",",1),?31 D:Y]"" DT
 W:$Y>0 @IOF D:$D(ZTSK) KILL^%ZTLOAD K ZTSK I PRCHP>1 D QUE^PRCHPNT
 ;
Q ;
 K DA,D0,DIWF,DIWR,DIWL,N,PRCH,PRCHI,PRCHJ,PRCHK,PRCHC,PRCHCNT,PRCHD,PRCH1,PRCH0,PRCH12,PRCHFTYP,PRCHHSP,PRCHINV,PRCHJD,PRCHLC,PRCHL1
 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")
 Q
 ;
PGQ F P=2:1:PRCHP S PRCHPT=0 D PGNX
 D:$D(ZTSK) KILL^%ZTLOAD K ZTSK
 Q
 ;
IT 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
 Q
WP0 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))
 D WP
 Q
 ;
WP1 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))
 ;
WP 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
 W ! S PRCHL=PRCHL+1
 Q
 ;
PGNX D TOP,PG,TOT
 Q
 ;
TOP 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 !
 Q
 ;
DIS 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
 Q
 ;
DIS1 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 !
 Q
 ;
EST 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),!
 Q
 ;
ADC 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")
 F K=0:0 S PRCHD=$O(^PRC(442.7,PRCH,1,PRCHD)) Q:'PRCHD  S X=^(PRCHD,0) D DIWP^PRCUTL($G(DA))
 G WP
 ;
REQ 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
 W ! S PRCHL=PRCHL+1
 Q
 ;
TOT F Y=1:1:47-PRCHL W !
 W ?66,$J(PRCHPT,8,2) W:$Y>0 @IOF
 Q
 ;
STQUE Q:'$D(ZTSK)  S X=0,U="^"
 D KILL^%ZTLOAD
 G PGQ
 ;
DT W:Y Y\100#100,"/",Y#100\1,"/",Y\10000+1700
 Q
 ;
DT1 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)
 Q