- 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 Mar 13, 2025@21:14:12 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
