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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCHPNT1 3918 printed Sep 23, 2025@19:45:29 Page 2
PRCHPNT1 ;ID/RSD/RHD-CONT. OF PRINT ;2/12/98 2:49 PM
V ;;5.1;IFCAP;;Oct 20, 2000
+1 ;Per VHA Directive 10-93-142, this routine should not be modified.
+2 ;
PG1 SET (PRCHJ,PRCH,PRCHPT,PRCHL,N)=0
SET PRCHP=P
SET P=1
+1 ;
PG SET (PRCHL,PRCHI)=0
FOR I=0:0
SET PRCHI=$ORDER(^TMP($JOB,"P",P,PRCHI))
if PRCHI=""!(PRCHI<0)
QUIT
if PRCHI=+PRCHI
DO IT
if PRCHI="D"
DO DIS
if PRCHI="E"
DO EST
if $EXTRACT(PRCHI)="F"
DO ADC
if PRCHI="X"
DO REQ
SET PRCHJ=PRCHI
IF PRCHI="W"
SET PRCHL=PRCHL+1
DO WP0
+1 if P>1
GOTO Q
IF PRCHP>1
WRITE !?12,"CONTINUED ON NEXT PAGE ",!
SET PRCHL=PRCHL+2
+2 FOR Y=1:1:19-PRCHL
WRITE !
+3 SET Y=$PIECE($GET(^PRC(442,D0,7)),U,3)
if Y="Y"
WRITE ?48,"ESTIMATED"
WRITE ?66,$JUSTIFY($PIECE(PRCH0,U,15),8,2),!?2
SET Y=0
FOR I=1:1
SET Y=$ORDER(^PRC(442,D0,14,Y))
if 'Y
QUIT
if Y>1
WRITE ","
WRITE $PIECE($GET(^PRC(442.4,+^(Y,0),0)),U,2)
+4 WRITE !!
SET P=+$PIECE(PRCH1,U,10)
SET Y=""
IF $DATA(^PRC(442,D0,12))
IF $PIECE(^(12),U,2)]""
SET X=$PIECE(^(12),U,2)
SET Y=$PIECE(^(12),U,3)
WRITE ?7,"/ES/"_$$DECODE^PRCHES5(D0)_" "
DO DT
DO DT1
+5 WRITE !
if $DATA(^VA(200,P,.13))
WRITE ?10,$PIECE(^(.13),U,2)
WRITE !!
+6 WRITE ?2,$PIECE(PRCH0,U,1),?25
SET Y=$PIECE(PRCH1,U,15)
DO DT
FOR Y=1:1:4
WRITE !
+7 ;
APP WRITE ?2,$PIECE(PRCH0,U,4),"-",$PIECE($PIECE(PRCH0,U,3)," ",1),"-",$PIECE(PRCH0,U,5),"-",$PIECE(PRCH0,U,6),$SELECT($PIECE(PRCH0,U,8)>0:"-"_$PIECE(PRCH0,U,8),1:"")
WRITE !!
+1 WRITE ?2
SET (X,Y)=""
SET P=0
IF $DATA(^PRC(442,D0,10,1,0))
SET Y=$PIECE(^(0),U,6)
SET P=+$PIECE(^(0),U,2)
SET X=$PIECE(^(0),U,5)
+2 IF X]""
WRITE "/ES/"_$$DECODE^PRCHES4(D0,1),?31
if Y]""
DO DT
+3 IF X=""
IF $DATA(^VA(200,+P,0))
SET X=$PIECE(^(0),"^",1)
WRITE $PIECE(X,",",2)," ",$PIECE(X,",",1),?31
if Y]""
DO DT
+4 if $Y>0
WRITE @IOF
if $DATA(ZTSK)
DO KILL^%ZTLOAD
KILL ZTSK
IF PRCHP>1
DO QUE^PRCHPNT
+5 ;
Q ;
+1 KILL DA,D0,DIWF,DIWR,DIWL,N,PRCH,PRCHI,PRCHJ,PRCHK,PRCHC,PRCHCNT,PRCHD,PRCH1,PRCH0,PRCH12,PRCHFTYP,PRCHHSP,PRCHINV,PRCHJD,PRCHLC,PRCHL1
+2 KILL PRCHLB,PRCHLE,PRCHS,PRCHSC,PRCHSHP,PRCHSIT,PRCHST,PRCHV,PRCHP,PRCHL,PRCHI0,PRCHI2,PRCHPT,PRCHQ,S,P,V,^TMP($JOB,"W"),^("PRCH"),^("P"),^UTILITY($JOB,"W")
+3 QUIT
+4 ;
PGQ FOR P=2:1:PRCHP
SET PRCHPT=0
DO PGNX
+1 if $DATA(ZTSK)
DO KILL^%ZTLOAD
KILL ZTSK
+2 QUIT
+3 ;
IT if PRCHJ=PRCHI
GOTO WP1
SET PRCH=PRCHI
if '$DATA(^PRC(442,D0,2,PRCH))
QUIT
SET PRCHI0=^(PRCH,0)
SET PRCHI2=^(2)
SET N=N+1
DO ITEM^PRCHPNT2
+1 QUIT
WP0 KILL ^UTILITY($JOB,"W")
SET DIWL=1
SET DIWR=54
SET DIWF=""
SET PRCHK=0
FOR
SET PRCHK=$ORDER(^PRC(442,D0,4,PRCHK))
if PRCHK=""!(PRCHK<0)
QUIT
SET X=^(PRCHK,0)
DO DIWP^PRCUTL($GET(DA))
+1 DO WP
+2 QUIT
+3 ;
WP1 KILL ^UTILITY($JOB,"W")
SET DIWL=1
SET DIWR=33
SET DIWF=""
SET PRCHK=0
FOR
SET PRCHK=$ORDER(^PRC(442,D0,2,PRCHI,1,PRCHK))
if PRCHK=""!(PRCHK<0)
QUIT
SET X=$GET(^(PRCHK,0))
DO DIWP^PRCUTL($GET(DA))
+1 ;
WP FOR K=+^TMP($JOB,"P",P,PRCHI):1:$PIECE(^TMP($JOB,"P",P,PRCHI),U,2)
WRITE !?9,$GET(^UTILITY($JOB,"W",1,K,0))
SET PRCHL=PRCHL+1
+1 WRITE !
SET PRCHL=PRCHL+1
+2 QUIT
+3 ;
PGNX DO TOP
DO PG
DO TOT
+1 QUIT
+2 ;
TOP WRITE !!!!?63,P,?73,PRCHP,!!?55
SET Y=$PIECE(PRCH1,U,15)
DO DT
WRITE ?72,$PIECE(PRCH0,U,1),!!?55,$PIECE(PRCHV,U,1)
FOR Y=1:1:5
WRITE !
+1 QUIT
+2 ;
DIS SET PRCHD=^TMP($JOB,"P",P,"D")
FOR PRCH=+PRCHD:1:$PIECE(PRCHD,U,2)
IF $DATA(^PRC(442,D0,3,PRCH))
SET PRCHI0=^(PRCH,0)
SET N=N+1
SET PRCHPT=PRCHPT-$PIECE(PRCHI0,U,3)
SET PRCHL=PRCHL+2
WRITE !?2,$JUSTIFY($PIECE(PRCHI0,U,6),3),?8,"LESS ",$PIECE(PRCHI0,U,2)
DO DIS1
+1 QUIT
+2 ;
DIS1 WRITE $SELECT($EXTRACT($PIECE(PRCHI0,U,2),1)="$":"",1:" %")," FOR ",$SELECT($PIECE(PRCHI0,U,1)="Q":"QUANTITY DISCOUNT",1:"ITEMS: "_$PIECE(PRCHI0,U,1))
WRITE ?66,$JUSTIFY($PIECE(PRCHI0,U,3),8,2)
WRITE !
+1 QUIT
+2 ;
EST SET PRCHD=^TMP($JOB,"P",P,"E")
SET N=N+1
SET PRCHPT=PRCHPT+$PIECE(PRCH0,U,13)
SET PRCHL=PRCHL+2
WRITE !?2,$SELECT($PIECE(PRCH0,U,18)]"":$JUSTIFY($PIECE(PRCH0,U,18),3),1:$JUSTIFY(N,3)),?8,"ESTIMATED SHIPPING AND/OR HANDLING",?66,$JUSTIFY($PIECE(PRCH0,U,13),8,2),!
+1 QUIT
+2 ;
ADC SET PRCH=$PIECE(PRCHI,U,2)
if '$DATA(^PRC(442.7,PRCH,1,0))
QUIT
SET PRCHD=0
SET PRCHL=PRCHL+1
SET DIWL=1
SET DIWR=64
SET DIWF=""
KILL ^UTILITY($JOB,"W")
+1 FOR K=0:0
SET PRCHD=$ORDER(^PRC(442.7,PRCH,1,PRCHD))
if 'PRCHD
QUIT
SET X=^(PRCHD,0)
DO DIWP^PRCUTL($GET(DA))
+2 GOTO WP
+3 ;
REQ SET PRCHD=^TMP($JOB,"P",P,"X")
SET PRCHL=PRCHL+2
WRITE !!?8,"V.A. TRANSACTION NUMBERS: "
FOR PRCH=+PRCHD:0:$PIECE(PRCHD,U,2)
IF $DATA(^PRC(442,D0,13,PRCH,0))
IF $DATA(^PRCS(410,+^(0),0))
WRITE !?14,$PIECE(^(0),U,1)
SET PRCH=$ORDER(^PRC(442,D0,13,PRCH))
SET PRCHL=PRCHL+1
if 'PRCH
QUIT
+1 WRITE !
SET PRCHL=PRCHL+1
+2 QUIT
+3 ;
TOT FOR Y=1:1:47-PRCHL
WRITE !
+1 WRITE ?66,$JUSTIFY(PRCHPT,8,2)
if $Y>0
WRITE @IOF
+2 QUIT
+3 ;
STQUE if '$DATA(ZTSK)
QUIT
SET X=0
SET U="^"
+1 DO KILL^%ZTLOAD
+2 GOTO PGQ
+3 ;
DT if Y
WRITE Y\100#100,"/",Y#100\1,"/",Y\10000+1700
+1 QUIT
+2 ;
DT1 if 'Y
QUIT
SET Y=$PIECE(Y,".",2)
SET Y=Y_$EXTRACT("0000",1,(4-$LENGTH(Y)))
if 'Y
QUIT
WRITE "@",$EXTRACT(Y,1,2),":",$EXTRACT(Y,3,4)
+1 QUIT
