PRCHDSP6 ;WISC/DJM-PRINT AMENDMENT, ROUTINE #3 ;6/29/00 12:20
V ;;5.1;IFCAP;**180**;Oct 20, 2000;Build 5
;Per VHA Directive 2004-038, this routine should not be modified.
;
;PRC*5.1*180 Add Amend to Delivery date display (98-7)
;
E25 ;Edit MAIL INVOICE TO PRINT
N CHANGE,OLD,MIT,LCNT,DATA,SITE
S CHANGE=0 D LCNT^PRCHPAM5(.LCNT)
F S CHANGE=$O(^PRC(442,PRCHPO,6,PRCHAM,3,"AC",AMEND,.04,CHANGE)) Q:CHANGE'>0 D
.S SITE=$P($G(^PRC(442,PRCHPO,23)),U,7) S SITE=$S($G(SITE)]"":SITE,1:$P($P(^PRC(442,PRCHPO,0),U),"-"))
.S OLD=^PRC(442,PRCHPO,6,PRCHAM,3,CHANGE,1,1,0),OLD=$P($S($D(^PRC(411,SITE,4,OLD,0)):^(0),1:""),U)
.S MIT=$P(^PRC(442,PRCHPO,12),U,6),MIT=$P($S($D(^PRC(411,SITE,4,MIT,0)):^(0),1:""),U)
.D LINE^PRCHPAM5(.LCNT,2) S DATA="MAIL INVOICE to "_OLD_" has been **AMENDED** to become MAIL INVOICE to "_MIT
.D DATA^PRCHPAM5(.LCNT,DATA),LCNT1^PRCHPAM5(LCNT)
Q
E26 ;Edit METHOD OF PAYMENT PRINT
N CHANGE,MOP,OLD,LCNT,DATA
S CHANGE=0 D LCNT^PRCHPAM5(.LCNT)
F S CHANGE=$O(^PRC(442,PRCHPO,6,PRCHAM,3,"AC",AMEND,.02,CHANGE)) Q:CHANGE'>0 D
.S OLD=^PRC(442,PRCHPO,6,PRCHAM,3,CHANGE,1,1,0),OLD=$P(^PRCD(442.5,OLD,0),U)
.S MOP=$P(^PRC(442,PRCHPO,0),U,2),MOP=$P(^PRCD(442.5,MOP,0),U)
.D LINE^PRCHPAM5(.LCNT,2) S DATA="METHOD of PAYMENT of "_OLD D DATA^PRCHPAM5(.LCNT,DATA)
.S DATA="has been changed to "_MOP D DATA^PRCHPAM5(.LCNT,DATA),LCNT1^PRCHPAM5(LCNT)
Q
E27 ;ADMINISTRATIVE CERTIFICATION Add PRINT
N CHANGE,CHANGES,AC,VAL,LCNT,DATA
S CHANGE=0 D LCNT^PRCHPAM5(.LCNT)
F S CHANGE=$O(^PRC(442,PRCHPO,6,PRCHAM,3,"AC",AMEND,.01,CHANGE)) Q:CHANGE'>0 D
.S CHANGES=^PRC(442,PRCHPO,6,PRCHAM,3,CHANGE,0)
.S AC=$P(CHANGES,U,4),VAL=$G(^PRC(442,PRCHPO,15,AC,0)) Q:VAL=""
.S AC=$P(VAL,U),VAL=$P($G(^PRC(442.7,+VAL,0)),U,2)
.D LINE^PRCHPAM5(.LCNT,2) S DATA="ADMINISTRATIVE CERTIFICATION "_AC_", "_VAL_", has been ADDED"
.D DATA^PRCHPAM5(.LCNT,DATA),LCNT1^PRCHPAM5(LCNT)
Q
E28 ;ADMINISTRATIVE CERTIFICATION Delete PRINT
N CHANGE,CHANGES,AC,OLD,LCNT,DATA
S CHANGE=0 D LCNT^PRCHPAM5(.LCNT)
F S CHANGE=$O(^PRC(442,PRCHPO,6,PRCHAM,3,"AC",AMEND,.01,CHANGE)) Q:CHANGE'>0 D
.S CHANGES=^PRC(442,PRCHPO,6,PRCHAM,3,CHANGE,0),OLD=^PRC(442,PRCHPO,6,PRCHAM,3,CHANGE,1,1,0)
.S AC=$P(CHANGES,U,4),OLD=$S(OLD>0:$P($G(^PRC(442.7,+OLD,0)),U,2),1:""),OLD=$S(OLD]"":", "_OLD_",",1:"")
.D LINE^PRCHPAM5(.LCNT,2) S DATA="ADMINISTRATIVE CERTIFICATION "_AC_OLD D DATA^PRCHPAM5(.LCNT,DATA)
.S DATA="has been DELETED"
.D DATA^PRCHPAM5(.LCNT,DATA),LCNT1^PRCHPAM5(LCNT)
Q
E29 ;EST. SHIPPING Edit PRINT
N CHANGE,OLD,EST,LCNT,DATA,OBOC,OBOC1,FLAG
S CHANGE=0 D LCNT^PRCHPAM5(.LCNT)
F S CHANGE=$O(^PRC(442,PRCHPO,6,PRCHAM,3,"AC",AMEND,13,CHANGE)) Q:CHANGE'>0 D
.S OLD=^PRC(442,PRCHPO,6,PRCHAM,3,CHANGE,1,1,0),OLD=$FN(OLD,"-",2)
.S EST=$P(^PRC(442,PRCHPO,0),U,13),EST=$FN(EST,"-",2)
.S (OBOC1,FLAG)=0 K OBOC
.F S OBOC1=$O(^PRC(442,PRCHPO,6,PRCHAM,3,"AC",AMEND,13.05,OBOC1)) Q:OBOC1'>0 D Q:FLAG=1
.D LINE^PRCHPAM5(.LCNT,2)
.I OLD'>0 D
..S DATA="**ADDED THROUGH AMENDMENT**" D DATA^PRCHPAM5(.LCNT,DATA)
..S DATA="Estimated Shipping and/or Handling of $"_EST_" has been added" D DATA^PRCHPAM5(.LCNT,DATA)
..Q
.I OLD>0 D
..S DATA="Estimated Shipping and/or Handling of $"_OLD_" has been changed" D DATA^PRCHPAM5(.LCNT,DATA) S DATA="to $"_EST D DATA^PRCHPAM5(.LCNT,DATA)
..Q
.D LCNT1^PRCHPAM5(LCNT)
.Q
Q
;
E98 ;
;Edit DELIVERY DATE ;PRC*5.1*180 Display of Delivery Date amend
N CHANGE,DDATE,OLD,LCNT,DATA
S CHANGE=0 D LCNT^PRCHPAM5(.LCNT)
F S CHANGE=$O(^PRC(442,PRCHPO,6,PRCHAM,3,"AC",AMEND,7,CHANGE)) Q:CHANGE'>0 D
.S OLD=^PRC(442,PRCHPO,6,PRCHAM,3,CHANGE,1,1,0)
.S DDATE=$P(^PRC(442,PRCHPO,0),U,10)
.D LINE^PRCHPAM5(.LCNT,2) S DATA="DELIVERY DATE "_$$FMTE^XLFDT(OLD)_" has been changed to "_$$FMTE^XLFDT(DDATE) D DATA^PRCHPAM5(.LCNT,DATA),LCNT1^PRCHPAM5(LCNT)
Q
OLD ;GET ALL THE OLD DESCRIPTION FROM 'CHANGES' MULTIPLE AND SET INTO
;THE DISPLAY '^UTILITY($J,"AMD"' ARRAY.
N LINE,DATA
S LINE=1
F D:DES]"" Q:DES=""
.S DATA=$E(DES,1,75) D DATA^PRCHPAM5(.LCNT,DATA)
.S DES=$E(DES,76,255) Q:$L(DES)'<75 Q:LINE'>0
.S LINE=$O(^PRC(442,PRCHPO,6,PRCHAM,3,PRCHLN,1,LINE)) Q:LINE'>0
.S DES=DES_$G(^PRC(442,PRCHPO,6,PRCHAM,3,PRCHLN,1,LINE,0))
.Q
Q
;
NEW ;GET ALL THE DESCRIPTION FROM THE LINE ITEM MULTIPLE AND SET
;INTO THE DISPLAY '^UTILITY($J,"AMD"' ARRAY.
N LINE,DATA
S LINE=1
F D:ITEM1]"" Q:ITEM1=""
.S DATA=$E(ITEM1,1,75) D DATA^PRCHPAM5(.LCNT,DATA)
.S ITEM1=$E(ITEM1,76,255) Q:$L(ITEM1)'<75 Q:LINE'>0
.S LINE=$O(^PRC(442,PRCHPO,2,ITEM,1,LINE)) Q:LINE'>0
.S ITEM1=ITEM1_$G(^PRC(442,PRCHPO,2,ITEM,1,LINE,0))
.Q
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCHDSP6 4664 printed Sep 23, 2025@19:43:02 Page 2
PRCHDSP6 ;WISC/DJM-PRINT AMENDMENT, ROUTINE #3 ;6/29/00 12:20
V ;;5.1;IFCAP;**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 Amend to Delivery date display (98-7)
+4 ;
E25 ;Edit MAIL INVOICE TO PRINT
+1 NEW CHANGE,OLD,MIT,LCNT,DATA,SITE
+2 SET CHANGE=0
DO LCNT^PRCHPAM5(.LCNT)
+3 FOR
SET CHANGE=$ORDER(^PRC(442,PRCHPO,6,PRCHAM,3,"AC",AMEND,.04,CHANGE))
if CHANGE'>0
QUIT
Begin DoDot:1
+4 SET SITE=$PIECE($GET(^PRC(442,PRCHPO,23)),U,7)
SET SITE=$SELECT($GET(SITE)]"":SITE,1:$PIECE($PIECE(^PRC(442,PRCHPO,0),U),"-"))
+5 SET OLD=^PRC(442,PRCHPO,6,PRCHAM,3,CHANGE,1,1,0)
SET OLD=$PIECE($SELECT($DATA(^PRC(411,SITE,4,OLD,0)):^(0),1:""),U)
+6 SET MIT=$PIECE(^PRC(442,PRCHPO,12),U,6)
SET MIT=$PIECE($SELECT($DATA(^PRC(411,SITE,4,MIT,0)):^(0),1:""),U)
+7 DO LINE^PRCHPAM5(.LCNT,2)
SET DATA="MAIL INVOICE to "_OLD_" has been **AMENDED** to become MAIL INVOICE to "_MIT
+8 DO DATA^PRCHPAM5(.LCNT,DATA)
DO LCNT1^PRCHPAM5(LCNT)
End DoDot:1
+9 QUIT
E26 ;Edit METHOD OF PAYMENT PRINT
+1 NEW CHANGE,MOP,OLD,LCNT,DATA
+2 SET CHANGE=0
DO LCNT^PRCHPAM5(.LCNT)
+3 FOR
SET CHANGE=$ORDER(^PRC(442,PRCHPO,6,PRCHAM,3,"AC",AMEND,.02,CHANGE))
if CHANGE'>0
QUIT
Begin DoDot:1
+4 SET OLD=^PRC(442,PRCHPO,6,PRCHAM,3,CHANGE,1,1,0)
SET OLD=$PIECE(^PRCD(442.5,OLD,0),U)
+5 SET MOP=$PIECE(^PRC(442,PRCHPO,0),U,2)
SET MOP=$PIECE(^PRCD(442.5,MOP,0),U)
+6 DO LINE^PRCHPAM5(.LCNT,2)
SET DATA="METHOD of PAYMENT of "_OLD
DO DATA^PRCHPAM5(.LCNT,DATA)
+7 SET DATA="has been changed to "_MOP
DO DATA^PRCHPAM5(.LCNT,DATA)
DO LCNT1^PRCHPAM5(LCNT)
End DoDot:1
+8 QUIT
E27 ;ADMINISTRATIVE CERTIFICATION Add PRINT
+1 NEW CHANGE,CHANGES,AC,VAL,LCNT,DATA
+2 SET CHANGE=0
DO LCNT^PRCHPAM5(.LCNT)
+3 FOR
SET CHANGE=$ORDER(^PRC(442,PRCHPO,6,PRCHAM,3,"AC",AMEND,.01,CHANGE))
if CHANGE'>0
QUIT
Begin DoDot:1
+4 SET CHANGES=^PRC(442,PRCHPO,6,PRCHAM,3,CHANGE,0)
+5 SET AC=$PIECE(CHANGES,U,4)
SET VAL=$GET(^PRC(442,PRCHPO,15,AC,0))
if VAL=""
QUIT
+6 SET AC=$PIECE(VAL,U)
SET VAL=$PIECE($GET(^PRC(442.7,+VAL,0)),U,2)
+7 DO LINE^PRCHPAM5(.LCNT,2)
SET DATA="ADMINISTRATIVE CERTIFICATION "_AC_", "_VAL_", has been ADDED"
+8 DO DATA^PRCHPAM5(.LCNT,DATA)
DO LCNT1^PRCHPAM5(LCNT)
End DoDot:1
+9 QUIT
E28 ;ADMINISTRATIVE CERTIFICATION Delete PRINT
+1 NEW CHANGE,CHANGES,AC,OLD,LCNT,DATA
+2 SET CHANGE=0
DO LCNT^PRCHPAM5(.LCNT)
+3 FOR
SET CHANGE=$ORDER(^PRC(442,PRCHPO,6,PRCHAM,3,"AC",AMEND,.01,CHANGE))
if CHANGE'>0
QUIT
Begin DoDot:1
+4 SET CHANGES=^PRC(442,PRCHPO,6,PRCHAM,3,CHANGE,0)
SET OLD=^PRC(442,PRCHPO,6,PRCHAM,3,CHANGE,1,1,0)
+5 SET AC=$PIECE(CHANGES,U,4)
SET OLD=$SELECT(OLD>0:$PIECE($GET(^PRC(442.7,+OLD,0)),U,2),1:"")
SET OLD=$SELECT(OLD]"":", "_OLD_",",1:"")
+6 DO LINE^PRCHPAM5(.LCNT,2)
SET DATA="ADMINISTRATIVE CERTIFICATION "_AC_OLD
DO DATA^PRCHPAM5(.LCNT,DATA)
+7 SET DATA="has been DELETED"
+8 DO DATA^PRCHPAM5(.LCNT,DATA)
DO LCNT1^PRCHPAM5(LCNT)
End DoDot:1
+9 QUIT
E29 ;EST. SHIPPING Edit PRINT
+1 NEW CHANGE,OLD,EST,LCNT,DATA,OBOC,OBOC1,FLAG
+2 SET CHANGE=0
DO LCNT^PRCHPAM5(.LCNT)
+3 FOR
SET CHANGE=$ORDER(^PRC(442,PRCHPO,6,PRCHAM,3,"AC",AMEND,13,CHANGE))
if CHANGE'>0
QUIT
Begin DoDot:1
+4 SET OLD=^PRC(442,PRCHPO,6,PRCHAM,3,CHANGE,1,1,0)
SET OLD=$FNUMBER(OLD,"-",2)
+5 SET EST=$PIECE(^PRC(442,PRCHPO,0),U,13)
SET EST=$FNUMBER(EST,"-",2)
+6 SET (OBOC1,FLAG)=0
KILL OBOC
+7 FOR
SET OBOC1=$ORDER(^PRC(442,PRCHPO,6,PRCHAM,3,"AC",AMEND,13.05,OBOC1))
if OBOC1'>0
QUIT
Begin DoDot:2
End DoDot:2
if FLAG=1
QUIT
+8 DO LINE^PRCHPAM5(.LCNT,2)
+9 IF OLD'>0
Begin DoDot:2
+10 SET DATA="**ADDED THROUGH AMENDMENT**"
DO DATA^PRCHPAM5(.LCNT,DATA)
+11 SET DATA="Estimated Shipping and/or Handling of $"_EST_" has been added"
DO DATA^PRCHPAM5(.LCNT,DATA)
+12 QUIT
End DoDot:2
+13 IF OLD>0
Begin DoDot:2
+14 SET DATA="Estimated Shipping and/or Handling of $"_OLD_" has been changed"
DO DATA^PRCHPAM5(.LCNT,DATA)
SET DATA="to $"_EST
DO DATA^PRCHPAM5(.LCNT,DATA)
+15 QUIT
End DoDot:2
+16 DO LCNT1^PRCHPAM5(LCNT)
+17 QUIT
End DoDot:1
+18 QUIT
+19 ;
E98 ;
+1 ;Edit DELIVERY DATE ;PRC*5.1*180 Display of Delivery Date amend
+2 NEW CHANGE,DDATE,OLD,LCNT,DATA
+3 SET CHANGE=0
DO LCNT^PRCHPAM5(.LCNT)
+4 FOR
SET CHANGE=$ORDER(^PRC(442,PRCHPO,6,PRCHAM,3,"AC",AMEND,7,CHANGE))
if CHANGE'>0
QUIT
Begin DoDot:1
+5 SET OLD=^PRC(442,PRCHPO,6,PRCHAM,3,CHANGE,1,1,0)
+6 SET DDATE=$PIECE(^PRC(442,PRCHPO,0),U,10)
+7 DO LINE^PRCHPAM5(.LCNT,2)
SET DATA="DELIVERY DATE "_$$FMTE^XLFDT(OLD)_" has been changed to "_$$FMTE^XLFDT(DDATE)
DO DATA^PRCHPAM5(.LCNT,DATA)
DO LCNT1^PRCHPAM5(LCNT)
End DoDot:1
+8 QUIT
OLD ;GET ALL THE OLD DESCRIPTION FROM 'CHANGES' MULTIPLE AND SET INTO
+1 ;THE DISPLAY '^UTILITY($J,"AMD"' ARRAY.
+2 NEW LINE,DATA
+3 SET LINE=1
+4 FOR
if DES]""
Begin DoDot:1
+5 SET DATA=$EXTRACT(DES,1,75)
DO DATA^PRCHPAM5(.LCNT,DATA)
+6 SET DES=$EXTRACT(DES,76,255)
if $LENGTH(DES)'<75
QUIT
if LINE'>0
QUIT
+7 SET LINE=$ORDER(^PRC(442,PRCHPO,6,PRCHAM,3,PRCHLN,1,LINE))
if LINE'>0
QUIT
+8 SET DES=DES_$GET(^PRC(442,PRCHPO,6,PRCHAM,3,PRCHLN,1,LINE,0))
+9 QUIT
End DoDot:1
if DES=""
QUIT
+10 QUIT
+11 ;
NEW ;GET ALL THE DESCRIPTION FROM THE LINE ITEM MULTIPLE AND SET
+1 ;INTO THE DISPLAY '^UTILITY($J,"AMD"' ARRAY.
+2 NEW LINE,DATA
+3 SET LINE=1
+4 FOR
if ITEM1]""
Begin DoDot:1
+5 SET DATA=$EXTRACT(ITEM1,1,75)
DO DATA^PRCHPAM5(.LCNT,DATA)
+6 SET ITEM1=$EXTRACT(ITEM1,76,255)
if $LENGTH(ITEM1)'<75
QUIT
if LINE'>0
QUIT
+7 SET LINE=$ORDER(^PRC(442,PRCHPO,2,ITEM,1,LINE))
if LINE'>0
QUIT
+8 SET ITEM1=ITEM1_$GET(^PRC(442,PRCHPO,2,ITEM,1,LINE,0))
+9 QUIT
End DoDot:1
if ITEM1=""
QUIT
+10 QUIT
