Routine: PRCHFPT2

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

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

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

PGNX I P'>(PRCHP-BOCPG) D TOP,PG,TOT

 I BOCCT>2&(P>(PRCHP-BOCPG)) D BOCTOP,MORBOC^PRCHFPT4

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 !!

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,!!

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

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 !

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",!

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

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 !

DT W:Y Y\100#100,"/",Y#100\1,"/",Y\10000+1700

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCHFPT2   4601     printed  Apr 23, 2025@18:22:09                                                                                                                                                                                                    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

PRCHFPT2.m