PRCHFPT2 ;WISC/RSD/RHD-CONT. OF PRINT ;5/12/99 12:22
;;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="" D IT:PRCHI=+PRCHI,DIS:PRCHI="D",EST:PRCHI="E",ADC:$E(PRCHI)="F",REQ:PRCHI="X" S PRCHJ=PRCHI I PRCHI="W" S PRCHW="PRCH",PRCHL=PRCHL+1 D WP
Q:P>1 I (PRCHP-BOCPG)>1 W !?10,"ITEMS CONTINUED ON NEXT PAGE ",! S PRCHL=PRCHL+2
F Y=1:1:18-PRCHL W !
W:$X>0 !
W PRCHULN D AUTH^PRCHFPT3 G:PRCHDES'="R" PGS W "WAREHOUSE CERT. SIGN: "
I $D(^PRC(442,D0,11,PRCHFPT,0)),$P(^(0),U,8)]"" S X=$P(^(0),U,8),P=$P(^(0),U,7) W "/ES/"_$$DECODE^PRCHES1(D0,PRCHFPT) W ?59,"DATE REC'D: " S Y=$P(^PRC(442,D0,11,PRCHFPT,0),U,1) D DT
I W " PARTIAL: ",PRCHFPT,$S($P(^PRC(442,D0,11,PRCHFPT,0),U,9)="F":" FINAL",1:"")
E W $E(PRCHULN,1,35),?59,"DATE REC'D: ",$E(PRCHULN,1,25)
W !!,"SERVICE CERT. SIGN: ",$E(PRCHULN,1,35),?59,"DATE REC'D: ",$E(PRCHULN,1,25)
;
PGS W !,"90-2138-7-ADP, JAN 1984" W:PRCHDES="R" ?72,"RECEIVING REPORT COPY" W ! I PRCHP>1 F P=2:1:PRCHP S PRCHPT=0 D PGNX
;PRINT MULTIPLE DELIVERY SCHEDULE (IF ANY)
I PRCHDES'="F" S PRCHQUIT=0,PRCHONL=0 D EN2^PRCHDP4
;
Q K DEST,PRCH0,PRCH1,PRCH12,PRCH,PRCHDES,PRCHFTYP,PRCHS,PRCHHSP,PRCHLC,PRCHST,PRCHW,PRCHSIT,PRCHSHP,PRCHINV,PRCHI,PRCHI0,PRCHI2,PRCHDA,PRCHDTA,^PRC(442,D0,15,9999999),D0,DA,DIWF,DIWL,DIWR
K BOCPG,BOCCT,PZZBOC,FMSLN,LITEM,CHGSHP,N,COUNT,BCT,BOC22,BOC,BOLN
K PRCHJ,PRCHJD,PRCHK,PRCHC,PRCHV,PRCHL,PRCHLC,PRCHLB,PRCHL1,PRCHLE,PRCHPT,PRCHP,PRCHD,PRCHREPR,PRCHULN,PRCHCNT,PRCHFPT,N,S,P,I,J,K,V,X,Y,Z,^TMP($J,"W"),^("PRCH"),^("P"),^UTILITY($J,"W") D:$D(ZTSK) KILL^%ZTLOAD K ZTSK
Q
;
IT S:PRCHJ=PRCHI PRCHW="W" G:PRCHJ=PRCHI WP S PRCH=PRCHI Q:'$D(^PRC(442,D0,2,PRCH)) S PRCHI0=^(PRCH,0),PRCHI2=$G(^(2)),N=N+1 D ITEM^PRCHFPT3
Q
;
WP F K=+^TMP($J,"P",P,PRCHI):1:$P(^TMP($J,"P",P,PRCHI),U,2) W !?8,$G(^TMP($J,PRCHW,1,K,0)) S PRCHL=PRCHL+1
S PRCHL=PRCHL+1
Q
;
PGNX I P'>(PRCHP-BOCPG) D TOP,PG,TOT
I BOCCT>2&(P>(PRCHP-BOCPG)) D BOCTOP,MORBOC^PRCHFPT4
Q
;
TOP W @IOF,!?15,$S(PRCHDES="US":" USING SERVICE COPY",1:"ORDER FOR SUPPLIES OR SERVICES"),?52,"PAGE NO.",?63,P," OF ",PRCHP," PAGES",!?23,"(CONTINUATION)",?52,"DATE: " S Y=$P(PRCH1,U,15) D DT
W ?70,"PO # ",$P($P(PRCH0,U,1),"-",2),!?5,"ISSUING OFFICE: DEPT. OF VETERANS AFFAIRS",?50,"VENDOR: ",$P(PRCHV,U,1),!,PRCHULN
W !?59,"UNIT",?69,"TOTAL" W:PRCHDES="R" ?80,"QTY",?90,"AMT" W !,"ITEM",?15,"DESCRIPTION",?46,"QTY",?51,"UNIT",?59,"COST",?69,"COST" W:PRCHDES="R" ?80,"REC",?90,"REC" W !,PRCHULN
W !!
Q
;
BOCTOP W @IOF,!?15,$S(PRCHDES="US":" USING SERVICE COPY",1:"ORDER FOR SUPPLIES OR SERVICES"),?52,"PAGE NO.",?63,P," OF ",PRCHP," PAGES",!?23,"(CONTINUATION)",?52,"DATE: " S Y=$P(PRCH1,U,15) D DT
W ?70,"PO # ",$P($P(PRCH0,U,1),"-",2),!?5,"ISSUING OFFICE: DEPT. OF VETERANS AFFAIRS",?50,"VENDOR: ",$P(PRCHV,U,1),!,PRCHULN,!!
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),?7,"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)),?7,"ESTIMATED SHIPPING AND/OR HANDLING",?66,$J($P(PRCH0,U,13),8,2),!
W ?8,"BOC: ",+$P($G(^PRC(442,D0,23)),U),?22,"FMS LINE: 991",!
Q
ADC S PRCH=$P(PRCHI,U,2) Q:'$D(^PRC(442.7,+PRCH,1,0)) S PRCHD=0,DIWR=64,DIWL=1,DIWF="",PRCHW="W" G:PRCHJ=PRCHI WP K ^UTILITY($J,"W")
F PRCHJJ=0:0 S PRCHD=$O(^PRC(442.7,PRCH,1,PRCHD)) Q:'PRCHD S X=^(PRCHD,0) D DIWP^PRCUTL($G(DA))
K ^TMP($J,"W") S %X="^UTILITY($J,""W"",",%Y="^TMP($J,""W""," D %XY^%RCR
K PRCHJJ
G WP
;
REQ ; Q:$G(PRCHTYPE)'="" ; PRC*5*156 (Show txn# for all PO's)
S PRCHD=^TMP($J,"P",P,"X")
W !!,"V.A. TRANSACTION NUMBERS: " S PRCHL=PRCHL+2
F PRCH=+PRCHD:0 D Q:'PRCH
. I $D(^PRC(442,D0,13,PRCH,0))&$D(^PRCS(410,+^(0),0)) D
. . W !?14,$P(^PRCS(410,+^PRC(442,D0,13,PRCH,0),0),U,1) S PRCHL=PRCHL+1
. S PRCH=$O(^PRC(442,D0,13,PRCH))
W ! S PRCHL=PRCHL+1
Q
;
TOT F Y=1:1:47-PRCHL W !
W !?25,"TOTALS CARRIED FORWARD TO FIRST SHEET: ",?66,$J(PRCHPT,8,2),!!
W "90-2139-ADP, MAY 1985" W:PRCHDES="R" ?72,"RECEIVING REPORT COPY"
W !
Q
;
DT W:Y Y\100#100,"/",Y#100\1,"/",Y\10000+1700
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCHFPT2 4601 printed Apr 09, 2024@21:17:37 Page 2
PRCHFPT2 ;WISC/RSD/RHD-CONT. OF PRINT ;5/12/99 12:22
+1 ;;5.1;IFCAP;;Oct 20, 2000
+2 ;Per VHA Directive 10-93-142, this routine should not be modified.
+3 ;
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=""
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 PRCHW="PRCH"
SET PRCHL=PRCHL+1
DO WP
+1 if P>1
QUIT
IF (PRCHP-BOCPG)>1
WRITE !?10,"ITEMS CONTINUED ON NEXT PAGE ",!
SET PRCHL=PRCHL+2
+2 FOR Y=1:1:18-PRCHL
WRITE !
+3 if $X>0
WRITE !
+4 WRITE PRCHULN
DO AUTH^PRCHFPT3
if PRCHDES'="R"
GOTO PGS
WRITE "WAREHOUSE CERT. SIGN: "
+5 IF $DATA(^PRC(442,D0,11,PRCHFPT,0))
IF $PIECE(^(0),U,8)]""
SET X=$PIECE(^(0),U,8)
SET P=$PIECE(^(0),U,7)
WRITE "/ES/"_$$DECODE^PRCHES1(D0,PRCHFPT)
WRITE ?59,"DATE REC'D: "
SET Y=$PIECE(^PRC(442,D0,11,PRCHFPT,0),U,1)
DO DT
+6 IF $TEST
WRITE " PARTIAL: ",PRCHFPT,$SELECT($PIECE(^PRC(442,D0,11,PRCHFPT,0),U,9)="F":" FINAL",1:"")
+7 IF '$TEST
WRITE $EXTRACT(PRCHULN,1,35),?59,"DATE REC'D: ",$EXTRACT(PRCHULN,1,25)
+8 WRITE !!,"SERVICE CERT. SIGN: ",$EXTRACT(PRCHULN,1,35),?59,"DATE REC'D: ",$EXTRACT(PRCHULN,1,25)
+9 ;
PGS WRITE !,"90-2138-7-ADP, JAN 1984"
if PRCHDES="R"
WRITE ?72,"RECEIVING REPORT COPY"
WRITE !
IF PRCHP>1
FOR P=2:1:PRCHP
SET PRCHPT=0
DO PGNX
+1 ;PRINT MULTIPLE DELIVERY SCHEDULE (IF ANY)
+2 IF PRCHDES'="F"
SET PRCHQUIT=0
SET PRCHONL=0
DO EN2^PRCHDP4
+3 ;
Q KILL DEST,PRCH0,PRCH1,PRCH12,PRCH,PRCHDES,PRCHFTYP,PRCHS,PRCHHSP,PRCHLC,PRCHST,PRCHW,PRCHSIT,PRCHSHP,PRCHINV,PRCHI,PRCHI0,PRCHI2,PRCHDA,PRCHDTA,^PRC(442,D0,15,9999999),D0,DA,DIWF,DIWL,DIWR
+1 KILL BOCPG,BOCCT,PZZBOC,FMSLN,LITEM,CHGSHP,N,COUNT,BCT,BOC22,BOC,BOLN
+2 KILL PRCHJ,PRCHJD,PRCHK,PRCHC,PRCHV,PRCHL,PRCHLC,PRCHLB,PRCHL1,PRCHLE,PRCHPT,PRCHP,PRCHD,PRCHREPR,PRCHULN,PRCHCNT,PRCHFPT,N,S,P,I,J,K,V,X,Y,Z,^TMP($JOB,"W"),^("PRCH"),^("P"),^UTILITY($JOB,"W")
if $DATA(ZTSK)
DO KILL^%ZTLOAD
KILL ZTSK
+3 QUIT
+4 ;
IT if PRCHJ=PRCHI
SET PRCHW="W"
if PRCHJ=PRCHI
GOTO WP
SET PRCH=PRCHI
if '$DATA(^PRC(442,D0,2,PRCH))
QUIT
SET PRCHI0=^(PRCH,0)
SET PRCHI2=$GET(^(2))
SET N=N+1
DO ITEM^PRCHFPT3
+1 QUIT
+2 ;
WP FOR K=+^TMP($JOB,"P",P,PRCHI):1:$PIECE(^TMP($JOB,"P",P,PRCHI),U,2)
WRITE !?8,$GET(^TMP($JOB,PRCHW,1,K,0))
SET PRCHL=PRCHL+1
+1 SET PRCHL=PRCHL+1
+2 QUIT
+3 ;
PGNX IF P'>(PRCHP-BOCPG)
DO TOP
DO PG
DO TOT
+1 IF BOCCT>2&(P>(PRCHP-BOCPG))
DO BOCTOP
DO MORBOC^PRCHFPT4
+2 QUIT
+3 ;
TOP WRITE @IOF,!?15,$SELECT(PRCHDES="US":" USING SERVICE COPY",1:"ORDER FOR SUPPLIES OR SERVICES"),?52,"PAGE NO.",?63,P," OF ",PRCHP," PAGES",!?23,"(CONTINUATION)",?52,"DATE: "
SET Y=$PIECE(PRCH1,U,15)
DO DT
+1 WRITE ?70,"PO # ",$PIECE($PIECE(PRCH0,U,1),"-",2),!?5,"ISSUING OFFICE: DEPT. OF VETERANS AFFAIRS",?50,"VENDOR: ",$PIECE(PRCHV,U,1),!,PRCHULN
+2 WRITE !?59,"UNIT",?69,"TOTAL"
if PRCHDES="R"
WRITE ?80,"QTY",?90,"AMT"
WRITE !,"ITEM",?15,"DESCRIPTION",?46,"QTY",?51,"UNIT",?59,"COST",?69,"COST"
if PRCHDES="R"
WRITE ?80,"REC",?90,"REC"
WRITE !,PRCHULN
+3 WRITE !!
+4 QUIT
+5 ;
BOCTOP WRITE @IOF,!?15,$SELECT(PRCHDES="US":" USING SERVICE COPY",1:"ORDER FOR SUPPLIES OR SERVICES"),?52,"PAGE NO.",?63,P," OF ",PRCHP," PAGES",!?23,"(CONTINUATION)",?52,"DATE: "
SET Y=$PIECE(PRCH1,U,15)
DO DT
+1 WRITE ?70,"PO # ",$PIECE($PIECE(PRCH0,U,1),"-",2),!?5,"ISSUING OFFICE: DEPT. OF VETERANS AFFAIRS",?50,"VENDOR: ",$PIECE(PRCHV,U,1),!,PRCHULN,!!
+2 QUIT
+3 ;
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),?7,"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)),?7,"ESTIMATED SHIPPING AND/OR HANDLING",?66,$JUSTIFY($PIECE(PRCH0,U,13),8,2),!
+1 WRITE ?8,"BOC: ",+$PIECE($GET(^PRC(442,D0,23)),U),?22,"FMS LINE: 991",!
+2 QUIT
ADC SET PRCH=$PIECE(PRCHI,U,2)
if '$DATA(^PRC(442.7,+PRCH,1,0))
QUIT
SET PRCHD=0
SET DIWR=64
SET DIWL=1
SET DIWF=""
SET PRCHW="W"
if PRCHJ=PRCHI
GOTO WP
KILL ^UTILITY($JOB,"W")
+1 FOR PRCHJJ=0:0
SET PRCHD=$ORDER(^PRC(442.7,PRCH,1,PRCHD))
if 'PRCHD
QUIT
SET X=^(PRCHD,0)
DO DIWP^PRCUTL($GET(DA))
+2 KILL ^TMP($JOB,"W")
SET %X="^UTILITY($J,""W"","
SET %Y="^TMP($J,""W"","
DO %XY^%RCR
+3 KILL PRCHJJ
+4 GOTO WP
+5 ;
REQ ; Q:$G(PRCHTYPE)'="" ; PRC*5*156 (Show txn# for all PO's)
+1 SET PRCHD=^TMP($JOB,"P",P,"X")
+2 WRITE !!,"V.A. TRANSACTION NUMBERS: "
SET PRCHL=PRCHL+2
+3 FOR PRCH=+PRCHD:0
Begin DoDot:1
+4 IF $DATA(^PRC(442,D0,13,PRCH,0))&$DATA(^PRCS(410,+^(0),0))
Begin DoDot:2
+5 WRITE !?14,$PIECE(^PRCS(410,+^PRC(442,D0,13,PRCH,0),0),U,1)
SET PRCHL=PRCHL+1
End DoDot:2
+6 SET PRCH=$ORDER(^PRC(442,D0,13,PRCH))
End DoDot:1
if 'PRCH
QUIT
+7 WRITE !
SET PRCHL=PRCHL+1
+8 QUIT
+9 ;
TOT FOR Y=1:1:47-PRCHL
WRITE !
+1 WRITE !?25,"TOTALS CARRIED FORWARD TO FIRST SHEET: ",?66,$JUSTIFY(PRCHPT,8,2),!!
+2 WRITE "90-2139-ADP, MAY 1985"
if PRCHDES="R"
WRITE ?72,"RECEIVING REPORT COPY"
+3 WRITE !
+4 QUIT
+5 ;
DT if Y
WRITE Y\100#100,"/",Y#100\1,"/",Y\10000+1700
+1 QUIT
