PRCHPAM2 ;WISC/DJM-PRINT AMENDMENT ;6/29/00 12:20
V ;;5.1;IFCAP;**21,180**;Oct 20, 2000;Build 5
;Per VHA Directive 2004-038, this routine should not be modified.
;
;PRC*5.1*180 Add call to display amendment Delivery Date change
;
START(PRCHPO,PRCHAM) ;PRCHPO IS 443.6 INTERNAL ENTRY NUMBER FOR RECORD BEING AMENDED.
;PRCHAM IS IEN AMENDMENT MULTIPLE WITHIN PRCHPO BEING AMENDED.
;FIND OUT WHAT TYPES OF AMENDMENTS HAVE BEEN DONE TO BE ABLE TO
;DETERMINE WHAT TO PRINT OUT.
N AMEND,GOTO
S AMEND=0 F S AMEND=$O(^PRC(443.6,PRCHPO,6,PRCHAM,3,"AC",AMEND)) Q:AMEND'>0 S GOTO="E"_+AMEND_"^PRCHPAM2" D @GOTO
D LCNT^PRCHPAM5(.LCNT) S LCNTX=LCNT I LCNT>37 S LCNT=LCNT-52
F Q:LCNT'>41 S LCNT=LCNT-56,PRCHPGT=PRCHPGT+1
S:LCNTX>37 PRCHPGT=PRCHPGT+1
Q
;
E20 ;SHIP TO Edit PRINT
N FIELD,CHANGE,CHANGES,OLD,NEW,LCNT,DATA,SITE
D LCNT^PRCHPAM5(.LCNT)
S FIELD=$O(^PRC(443.6,PRCHPO,6,PRCHAM,3,"AC",AMEND,0)) Q:FIELD'>0
S CHANGE=$O(^PRC(443.6,PRCHPO,6,PRCHAM,3,"AC",AMEND,FIELD,0)) Q:CHANGE'>0
S CHANGES=^PRC(443.6,PRCHPO,6,PRCHAM,3,CHANGE,0),OLD=^PRC(443.6,PRCHPO,6,PRCHAM,3,CHANGE,1,1,0)
S SHIP=$P($P(CHANGES,U,3),";")
I SHIP=5.4 D
.S SITE=$P($G(^PRC(443.6,PRCHPO,23)),U,7),SITE=$S($G(SITE)]"":SITE,1:$P($P(^PRC(443.6,PRCHPO,0),U),"-"))
.S OLD=$P(^PRC(411,SITE,1,OLD,0),U)
.S NEW=$P(^PRC(443.6,PRCHPO,1),U,3),NEW=$P(^PRC(411,SITE,1,NEW,0),U)
.Q
I SHIP=5.3 D
.S NEW=$P(^PRC(443.6,PRCHPO,1),U,12),NEW=$P(^PRC(440.2,NEW,0),U),NEW=$P($P(^DPT(NEW,0),U),",",2)_" "_$P($P(^DPT(NEW,0),U),",")
.S OLD=$P(^PRC(440.2,OLD,0),U),OLD=$P($P(^DPT(OLD,0),U),",",2)_" "_$P($P(^DPT(OLD,0),U),",")
.Q
D LINE^PRCHPAM5(.LCNT,2) S DATA="Ship to location "_OLD_" has been changed to "_NEW_"."
D DATA^PRCHPAM5(.LCNT,DATA),LCNT1^PRCHPAM5(LCNT)
Q
E21 ;LINE ITEM Add PRINT
N FIELD,CHANGE,CHANGES,OLD,ITEM,ITEM0,ITEM1,LCNT,DATA,I,UOP
S FIELD=0 K ITEM D LCNT^PRCHPAM5(.LCNT)
F S FIELD=$O(^PRC(443.6,PRCHPO,6,PRCHAM,3,"AC",AMEND,FIELD)) Q:FIELD'>0 D
.S CHANGE=0 F S CHANGE=$O(^PRC(443.6,PRCHPO,6,PRCHAM,3,"AC",AMEND,FIELD,CHANGE)) Q:CHANGE'>0 D
..S CHANGES=^PRC(443.6,PRCHPO,6,PRCHAM,3,CHANGE,0),OLD=^PRC(443.6,PRCHPO,6,PRCHAM,3,CHANGE,1,1,0)
..S ITEM=$P(CHANGES,U,4) Q:$D(ITEM(ITEM)) S ITEM(ITEM)=1
..S ITEM0=$G(^PRC(443.6,PRCHPO,2,ITEM,0))
..I ITEM0="" Q
..I $P(ITEM0,U,2)=0,$P(ITEM0,U,9)=0 Q
..S ITEM1=$G(^PRC(443.6,PRCHPO,2,ITEM,1,1,0))
..D LINE^PRCHPAM5(.LCNT,2) S DATA=" *ADDED THROUGH AMENDMENT*" D DATA^PRCHPAM5(.LCNT,DATA)
..S DATA="Item No. "_$P(ITEM0,U)_" Item Master File No. "
..S DATA=DATA_$P(ITEM0,U,5)_" BOC: "_+$P(ITEM0,U,4)
..S DATA=DATA_" CONTRACT: "_$P($G(^PRC(443.6,PRCHPO,2,ITEM,2)),U,2)
..D DATA^PRCHPAM5(.LCNT,DATA)
..D NEW^PRCHPAM5
..S UOP=$S($P(ITEM0,U,3)>0:$P($G(^PRCD(420.5,$P(ITEM0,U,3),0)),U),1:"")
..S DATA=" Items per "_UOP_": "_$P(ITEM0,U,12)
..F I=1:1:26-$L(DATA) S DATA=DATA_" "
..S DATA=DATA_"NSN: "_$P(ITEM0,U,13) D DATA^PRCHPAM5(.LCNT,DATA)
..I $P(ITEM0,U,6)]"" S DATA=" STK#: "_$P(ITEM0,U,6) D DATA^PRCHPAM5(.LCNT,DATA)
..S UOP=$S($P(ITEM0,U,3)>0:$P($G(^PRCD(420.5,$P(ITEM0,U,3),0)),U),1:"")
..S DATA=" "_$P(ITEM0,U,2)_" "_UOP_" at $"_$J($P(ITEM0,U,9),12,4)_" = $"_$J($P(ITEM0,U,2)*$P(ITEM0,U,9),9,2)
..D DATA^PRCHPAM5(.LCNT,DATA),LCNT1^PRCHPAM5(LCNT)
Q
;
E22 ;LINE ITEM Delete PRINT
G E22^PRCHPAM3 ;NOT ENOUGH ROOM IN THIS ROUTINE.
;
E23 ;LINE ITEM Edit PRINT
G E23^PRCHPAM3
;
E24 ;SOURCE CODE Edit PRINT
G E24^PRCHPAM5
;
E25 ;Edit MAIL INVOICE TO PRINT
G E25^PRCHPAM4
;
E26 ;Edit METHOD OF PAYMENT PRINT
G E26^PRCHPAM4
;
E27 ;ADMINISTRATIVE CERTIFICATION Add PRINT
G E27^PRCHPAM4
;
E28 ;ADMINISTRATIVE CERTIFICATION Delete PRINT
G E28^PRCHPAM4
;
E29 ;EST. SHIPPING Edit PRINT
G E29^PRCHPAM4
;
E30 ;F.C.P. Edit PRINT
G E30^PRCHPAM5
;
E31 ;Change VENDOR PRINT
G E31^PRCHPAM5
;
E32 ;REPLACE P.O. NUMBER PRINT
G E32^PRCHPAM5
;
E33 ;PROMPT PAYMENT Edit PRINT
G E33^PRCHPAM6
;
E34 ;AUTHORITY Edit PRINT
G E34^PRCHPAM6
;
E35 ;F.O.B. Point PRINT
G E35^PRCHPAM6
;
E36 ;ITEM DISCOUNT Add PRINT
G E36^PRCHPAM7
;
E37 ;ITEM DISCOUNT Delete PRINT
G E37^PRCHPAM7
;
E98 ;DELIVERY DATE PRINT
G E98^PRCHPAM4 ;PRC*5.1*180 Call to display Delivery Date changes
Q
E99 ;NET AMOUNT PRINT
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCHPAM2 4302 printed Sep 23, 2025@19:45:19 Page 2
PRCHPAM2 ;WISC/DJM-PRINT AMENDMENT ;6/29/00 12:20
V ;;5.1;IFCAP;**21,180**;Oct 20, 2000;Build 5
+1 ;Per VHA Directive 2004-038, this routine should not be modified.
+2 ;
+3 ;PRC*5.1*180 Add call to display amendment Delivery Date change
+4 ;
START(PRCHPO,PRCHAM) ;PRCHPO IS 443.6 INTERNAL ENTRY NUMBER FOR RECORD BEING AMENDED.
+1 ;PRCHAM IS IEN AMENDMENT MULTIPLE WITHIN PRCHPO BEING AMENDED.
+2 ;FIND OUT WHAT TYPES OF AMENDMENTS HAVE BEEN DONE TO BE ABLE TO
+3 ;DETERMINE WHAT TO PRINT OUT.
+4 NEW AMEND,GOTO
+5 SET AMEND=0
FOR
SET AMEND=$ORDER(^PRC(443.6,PRCHPO,6,PRCHAM,3,"AC",AMEND))
if AMEND'>0
QUIT
SET GOTO="E"_+AMEND_"^PRCHPAM2"
DO @GOTO
+6 DO LCNT^PRCHPAM5(.LCNT)
SET LCNTX=LCNT
IF LCNT>37
SET LCNT=LCNT-52
+7 FOR
if LCNT'>41
QUIT
SET LCNT=LCNT-56
SET PRCHPGT=PRCHPGT+1
+8 if LCNTX>37
SET PRCHPGT=PRCHPGT+1
+9 QUIT
+10 ;
E20 ;SHIP TO Edit PRINT
+1 NEW FIELD,CHANGE,CHANGES,OLD,NEW,LCNT,DATA,SITE
+2 DO LCNT^PRCHPAM5(.LCNT)
+3 SET FIELD=$ORDER(^PRC(443.6,PRCHPO,6,PRCHAM,3,"AC",AMEND,0))
if FIELD'>0
QUIT
+4 SET CHANGE=$ORDER(^PRC(443.6,PRCHPO,6,PRCHAM,3,"AC",AMEND,FIELD,0))
if CHANGE'>0
QUIT
+5 SET CHANGES=^PRC(443.6,PRCHPO,6,PRCHAM,3,CHANGE,0)
SET OLD=^PRC(443.6,PRCHPO,6,PRCHAM,3,CHANGE,1,1,0)
+6 SET SHIP=$PIECE($PIECE(CHANGES,U,3),";")
+7 IF SHIP=5.4
Begin DoDot:1
+8 SET SITE=$PIECE($GET(^PRC(443.6,PRCHPO,23)),U,7)
SET SITE=$SELECT($GET(SITE)]"":SITE,1:$PIECE($PIECE(^PRC(443.6,PRCHPO,0),U),"-"))
+9 SET OLD=$PIECE(^PRC(411,SITE,1,OLD,0),U)
+10 SET NEW=$PIECE(^PRC(443.6,PRCHPO,1),U,3)
SET NEW=$PIECE(^PRC(411,SITE,1,NEW,0),U)
+11 QUIT
End DoDot:1
+12 IF SHIP=5.3
Begin DoDot:1
+13 SET NEW=$PIECE(^PRC(443.6,PRCHPO,1),U,12)
SET NEW=$PIECE(^PRC(440.2,NEW,0),U)
SET NEW=$PIECE($PIECE(^DPT(NEW,0),U),",",2)_" "_$PIECE($PIECE(^DPT(NEW,0),U),",")
+14 SET OLD=$PIECE(^PRC(440.2,OLD,0),U)
SET OLD=$PIECE($PIECE(^DPT(OLD,0),U),",",2)_" "_$PIECE($PIECE(^DPT(OLD,0),U),",")
+15 QUIT
End DoDot:1
+16 DO LINE^PRCHPAM5(.LCNT,2)
SET DATA="Ship to location "_OLD_" has been changed to "_NEW_"."
+17 DO DATA^PRCHPAM5(.LCNT,DATA)
DO LCNT1^PRCHPAM5(LCNT)
+18 QUIT
E21 ;LINE ITEM Add PRINT
+1 NEW FIELD,CHANGE,CHANGES,OLD,ITEM,ITEM0,ITEM1,LCNT,DATA,I,UOP
+2 SET FIELD=0
KILL ITEM
DO LCNT^PRCHPAM5(.LCNT)
+3 FOR
SET FIELD=$ORDER(^PRC(443.6,PRCHPO,6,PRCHAM,3,"AC",AMEND,FIELD))
if FIELD'>0
QUIT
Begin DoDot:1
+4 SET CHANGE=0
FOR
SET CHANGE=$ORDER(^PRC(443.6,PRCHPO,6,PRCHAM,3,"AC",AMEND,FIELD,CHANGE))
if CHANGE'>0
QUIT
Begin DoDot:2
+5 SET CHANGES=^PRC(443.6,PRCHPO,6,PRCHAM,3,CHANGE,0)
SET OLD=^PRC(443.6,PRCHPO,6,PRCHAM,3,CHANGE,1,1,0)
+6 SET ITEM=$PIECE(CHANGES,U,4)
if $DATA(ITEM(ITEM))
QUIT
SET ITEM(ITEM)=1
+7 SET ITEM0=$GET(^PRC(443.6,PRCHPO,2,ITEM,0))
+8 IF ITEM0=""
QUIT
+9 IF $PIECE(ITEM0,U,2)=0
IF $PIECE(ITEM0,U,9)=0
QUIT
+10 SET ITEM1=$GET(^PRC(443.6,PRCHPO,2,ITEM,1,1,0))
+11 DO LINE^PRCHPAM5(.LCNT,2)
SET DATA=" *ADDED THROUGH AMENDMENT*"
DO DATA^PRCHPAM5(.LCNT,DATA)
+12 SET DATA="Item No. "_$PIECE(ITEM0,U)_" Item Master File No. "
+13 SET DATA=DATA_$PIECE(ITEM0,U,5)_" BOC: "_+$PIECE(ITEM0,U,4)
+14 SET DATA=DATA_" CONTRACT: "_$PIECE($GET(^PRC(443.6,PRCHPO,2,ITEM,2)),U,2)
+15 DO DATA^PRCHPAM5(.LCNT,DATA)
+16 DO NEW^PRCHPAM5
+17 SET UOP=$SELECT($PIECE(ITEM0,U,3)>0:$PIECE($GET(^PRCD(420.5,$PIECE(ITEM0,U,3),0)),U),1:"")
+18 SET DATA=" Items per "_UOP_": "_$PIECE(ITEM0,U,12)
+19 FOR I=1:1:26-$LENGTH(DATA)
SET DATA=DATA_" "
+20 SET DATA=DATA_"NSN: "_$PIECE(ITEM0,U,13)
DO DATA^PRCHPAM5(.LCNT,DATA)
+21 IF $PIECE(ITEM0,U,6)]""
SET DATA=" STK#: "_$PIECE(ITEM0,U,6)
DO DATA^PRCHPAM5(.LCNT,DATA)
+22 SET UOP=$SELECT($PIECE(ITEM0,U,3)>0:$PIECE($GET(^PRCD(420.5,$PIECE(ITEM0,U,3),0)),U),1:"")
+23 SET DATA=" "_$PIECE(ITEM0,U,2)_" "_UOP_" at $"_$JUSTIFY($PIECE(ITEM0,U,9),12,4)_" = $"_$JUSTIFY($PIECE(ITEM0,U,2)*$PIECE(ITEM0,U,9),9,2)
+24 DO DATA^PRCHPAM5(.LCNT,DATA)
DO LCNT1^PRCHPAM5(LCNT)
End DoDot:2
End DoDot:1
+25 QUIT
+26 ;
E22 ;LINE ITEM Delete PRINT
+1 ;NOT ENOUGH ROOM IN THIS ROUTINE.
GOTO E22^PRCHPAM3
+2 ;
E23 ;LINE ITEM Edit PRINT
+1 GOTO E23^PRCHPAM3
+2 ;
E24 ;SOURCE CODE Edit PRINT
+1 GOTO E24^PRCHPAM5
+2 ;
E25 ;Edit MAIL INVOICE TO PRINT
+1 GOTO E25^PRCHPAM4
+2 ;
E26 ;Edit METHOD OF PAYMENT PRINT
+1 GOTO E26^PRCHPAM4
+2 ;
E27 ;ADMINISTRATIVE CERTIFICATION Add PRINT
+1 GOTO E27^PRCHPAM4
+2 ;
E28 ;ADMINISTRATIVE CERTIFICATION Delete PRINT
+1 GOTO E28^PRCHPAM4
+2 ;
E29 ;EST. SHIPPING Edit PRINT
+1 GOTO E29^PRCHPAM4
+2 ;
E30 ;F.C.P. Edit PRINT
+1 GOTO E30^PRCHPAM5
+2 ;
E31 ;Change VENDOR PRINT
+1 GOTO E31^PRCHPAM5
+2 ;
E32 ;REPLACE P.O. NUMBER PRINT
+1 GOTO E32^PRCHPAM5
+2 ;
E33 ;PROMPT PAYMENT Edit PRINT
+1 GOTO E33^PRCHPAM6
+2 ;
E34 ;AUTHORITY Edit PRINT
+1 GOTO E34^PRCHPAM6
+2 ;
E35 ;F.O.B. Point PRINT
+1 GOTO E35^PRCHPAM6
+2 ;
E36 ;ITEM DISCOUNT Add PRINT
+1 GOTO E36^PRCHPAM7
+2 ;
E37 ;ITEM DISCOUNT Delete PRINT
+1 GOTO E37^PRCHPAM7
+2 ;
E98 ;DELIVERY DATE PRINT
+1 ;PRC*5.1*180 Call to display Delivery Date changes
GOTO E98^PRCHPAM4
+2 QUIT
E99 ;NET AMOUNT PRINT
+1 QUIT
