- PRCHDAM3 ;WISC/DJM-PRINT AMENDMENT, ROUTINE #3 ;6/29/00 12:16
- 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^PRCHDAM4(.LCNT)
- F S CHANGE=$O(^PRC(443.6,PRCHPO,6,PRCHAM,3,"AC",AMEND,.04,CHANGE)) Q:CHANGE'>0 D
- .S SITE=$P($G(^PRC(443.6,PRCHPO,23)),U,7) S SITE=$S($G(SITE)]"":SITE,1:$P($P(^PRC(443.6,PRCHPO,0),U),"-"))
- .S OLD=^PRC(443.6,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(443.6,PRCHPO,12),U,6),MIT=$P($S($D(^PRC(411,SITE,4,MIT,0)):^(0),1:""),U)
- .D LINE^PRCHDAM4(.LCNT,2) S DATA="MAIL INVOICE to "_OLD_" has been **AMENDED** to become MAIL INVOICE to "_MIT
- .D DATA^PRCHDAM4(.LCNT,DATA),LCNT1^PRCHDAM4(LCNT)
- Q
- E26 ;Edit METHOD OF PAYMENT PRINT
- N CHANGE,MOP,OLD,LCNT,DATA
- S CHANGE=0 D LCNT^PRCHDAM4(.LCNT)
- F S CHANGE=$O(^PRC(443.6,PRCHPO,6,PRCHAM,3,"AC",AMEND,.02,CHANGE)) Q:CHANGE'>0 D
- .S OLD=^PRC(443.6,PRCHPO,6,PRCHAM,3,CHANGE,1,1,0),OLD=$P(^PRCD(442.5,OLD,0),U)
- .S MOP=$P(^PRC(443.6,PRCHPO,0),U,2),MOP=$P(^PRCD(442.5,MOP,0),U)
- .D LINE^PRCHDAM4(.LCNT,2) S DATA="METHOD of PAYMENT of "_OLD D DATA^PRCHDAM4(.LCNT,DATA)
- .S DATA="has been changed to "_MOP D DATA^PRCHDAM4(.LCNT,DATA),LCNT1^PRCHDAM4(LCNT)
- Q
- E27 ;ADMINISTRATIVE CERTIFICATION Add PRINT
- N CHANGE,CHANGES,AC,VAL,LCNT,DATA
- S CHANGE=0 D LCNT^PRCHDAM4(.LCNT)
- F S CHANGE=$O(^PRC(443.6,PRCHPO,6,PRCHAM,3,"AC",AMEND,.01,CHANGE)) Q:CHANGE'>0 D
- .S CHANGES=^PRC(443.6,PRCHPO,6,PRCHAM,3,CHANGE,0)
- .S AC=$P(CHANGES,U,4),VAL=$G(^PRC(443.6,PRCHPO,15,AC,0)) Q:VAL=""
- .S AC=$P(VAL,U),VAL=$P($G(^PRC(442.7,+VAL,0)),U,2)
- .D LINE^PRCHDAM4(.LCNT,2) S DATA="ADMINISTRATIVE CERTIFICATION "_AC_", "_VAL_", has been ADDED"
- .D DATA^PRCHDAM4(.LCNT,DATA),LCNT1^PRCHDAM4(LCNT)
- Q
- E28 ;ADMINISTRATIVE CERTIFICATION Delete PRINT
- N CHANGE,CHANGES,AC,OLD,LCNT,DATA
- S CHANGE=0 D LCNT^PRCHDAM4(.LCNT)
- F S CHANGE=$O(^PRC(443.6,PRCHPO,6,PRCHAM,3,"AC",AMEND,.01,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 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^PRCHDAM4(.LCNT,2) S DATA="ADMINISTRATIVE CERTIFICATION "_AC_OLD D DATA^PRCHDAM4(.LCNT,DATA)
- .S DATA="has been DELETED"
- .D DATA^PRCHDAM4(.LCNT,DATA),LCNT1^PRCHDAM4(LCNT)
- Q
- E29 ;EST. SHIPPING Edit PRINT
- N CHANGE,OLD,EST,LCNT,DATA,OBOC,OBOC1,FLAG
- S CHANGE=0 D LCNT^PRCHDAM4(.LCNT)
- F S CHANGE=$O(^PRC(443.6,PRCHPO,6,PRCHAM,3,"AC",AMEND,13,CHANGE)) Q:CHANGE'>0 D
- .S OLD=^PRC(443.6,PRCHPO,6,PRCHAM,3,CHANGE,1,1,0),OLD=$FN(OLD,"-",2)
- .S EST=$P(^PRC(443.6,PRCHPO,0),U,13),EST=$FN(EST,"-",2)
- .S (OBOC1,FLAG)=0 K OBOC
- .F S OBOC1=$O(^PRC(443.6,PRCHPO,6,PRCHAM,3,"AC",AMEND,13.05,OBOC1)) Q:OBOC1'>0 D Q:FLAG=1
- ..S OBOC=+(^PRC(443.6,PRCHPO,6,PRCHAM,3,OBOC1,1,1,0)),FLAG=1
- .I '$D(OBOC) S OBOC=+$P($G(^PRC(443.6,PRCHPO,23)),U)
- .D LINE^PRCHDAM4(.LCNT,2)
- .I OLD'>0 D
- ..S DATA="**ADDED THROUGH AMENDMENT**" D DATA^PRCHDAM4(.LCNT,DATA)
- ..S DATA="Estimated Shipping and/or Handling of $"_EST_" has been added" D DATA^PRCHDAM4(.LCNT,DATA)
- ..S DATA="BOC: "_+$P($G(^PRC(443.6,PRCHPO,23)),U) D DATA^PRCHDAM4(.LCNT,DATA)
- ..Q
- .I OLD>0 D
- ..S DATA="Estimated Shipping and/or Handling of $"_OLD_" has been changed" D DATA^PRCHDAM4(.LCNT,DATA) S DATA="to $"_EST D DATA^PRCHDAM4(.LCNT,DATA)
- ..S DATA="BOC: "_OBOC_" has been changed to: "_+$P($G(^PRC(443.6,PRCHPO,23)),U) D DATA^PRCHDAM4(.LCNT,DATA)
- ..Q
- .D LCNT1^PRCHDAM4(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^PRCHDAM4(.LCNT)
- F S CHANGE=$O(^PRC(443.6,PRCHPO,6,PRCHAM,3,"AC",AMEND,7,CHANGE)) Q:CHANGE'>0 D
- .S OLD=^PRC(443.6,PRCHPO,6,PRCHAM,3,CHANGE,1,1,0)
- .S DDATE=$P(^PRC(443.6,PRCHPO,0),U,10)
- .D LINE^PRCHDAM4(.LCNT,2) S DATA="DELIVERY DATE "_$$FMTE^XLFDT(OLD)_" has been changed to "_$$FMTE^XLFDT(DDATE) D DATA^PRCHDAM4(.LCNT,DATA),LCNT1^PRCHDAM4(LCNT)
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCHDAM3 4216 printed Feb 18, 2025@23:32:53 Page 2
- PRCHDAM3 ;WISC/DJM-PRINT AMENDMENT, ROUTINE #3 ;6/29/00 12:16
- 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^PRCHDAM4(.LCNT)
- +3 FOR
- SET CHANGE=$ORDER(^PRC(443.6,PRCHPO,6,PRCHAM,3,"AC",AMEND,.04,CHANGE))
- if CHANGE'>0
- QUIT
- Begin DoDot:1
- +4 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),"-"))
- +5 SET OLD=^PRC(443.6,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(443.6,PRCHPO,12),U,6)
- SET MIT=$PIECE($SELECT($DATA(^PRC(411,SITE,4,MIT,0)):^(0),1:""),U)
- +7 DO LINE^PRCHDAM4(.LCNT,2)
- SET DATA="MAIL INVOICE to "_OLD_" has been **AMENDED** to become MAIL INVOICE to "_MIT
- +8 DO DATA^PRCHDAM4(.LCNT,DATA)
- DO LCNT1^PRCHDAM4(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^PRCHDAM4(.LCNT)
- +3 FOR
- SET CHANGE=$ORDER(^PRC(443.6,PRCHPO,6,PRCHAM,3,"AC",AMEND,.02,CHANGE))
- if CHANGE'>0
- QUIT
- Begin DoDot:1
- +4 SET OLD=^PRC(443.6,PRCHPO,6,PRCHAM,3,CHANGE,1,1,0)
- SET OLD=$PIECE(^PRCD(442.5,OLD,0),U)
- +5 SET MOP=$PIECE(^PRC(443.6,PRCHPO,0),U,2)
- SET MOP=$PIECE(^PRCD(442.5,MOP,0),U)
- +6 DO LINE^PRCHDAM4(.LCNT,2)
- SET DATA="METHOD of PAYMENT of "_OLD
- DO DATA^PRCHDAM4(.LCNT,DATA)
- +7 SET DATA="has been changed to "_MOP
- DO DATA^PRCHDAM4(.LCNT,DATA)
- DO LCNT1^PRCHDAM4(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^PRCHDAM4(.LCNT)
- +3 FOR
- SET CHANGE=$ORDER(^PRC(443.6,PRCHPO,6,PRCHAM,3,"AC",AMEND,.01,CHANGE))
- if CHANGE'>0
- QUIT
- Begin DoDot:1
- +4 SET CHANGES=^PRC(443.6,PRCHPO,6,PRCHAM,3,CHANGE,0)
- +5 SET AC=$PIECE(CHANGES,U,4)
- SET VAL=$GET(^PRC(443.6,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^PRCHDAM4(.LCNT,2)
- SET DATA="ADMINISTRATIVE CERTIFICATION "_AC_", "_VAL_", has been ADDED"
- +8 DO DATA^PRCHDAM4(.LCNT,DATA)
- DO LCNT1^PRCHDAM4(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^PRCHDAM4(.LCNT)
- +3 FOR
- SET CHANGE=$ORDER(^PRC(443.6,PRCHPO,6,PRCHAM,3,"AC",AMEND,.01,CHANGE))
- if CHANGE'>0
- QUIT
- Begin DoDot:1
- +4 SET CHANGES=^PRC(443.6,PRCHPO,6,PRCHAM,3,CHANGE,0)
- SET OLD=^PRC(443.6,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^PRCHDAM4(.LCNT,2)
- SET DATA="ADMINISTRATIVE CERTIFICATION "_AC_OLD
- DO DATA^PRCHDAM4(.LCNT,DATA)
- +7 SET DATA="has been DELETED"
- +8 DO DATA^PRCHDAM4(.LCNT,DATA)
- DO LCNT1^PRCHDAM4(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^PRCHDAM4(.LCNT)
- +3 FOR
- SET CHANGE=$ORDER(^PRC(443.6,PRCHPO,6,PRCHAM,3,"AC",AMEND,13,CHANGE))
- if CHANGE'>0
- QUIT
- Begin DoDot:1
- +4 SET OLD=^PRC(443.6,PRCHPO,6,PRCHAM,3,CHANGE,1,1,0)
- SET OLD=$FNUMBER(OLD,"-",2)
- +5 SET EST=$PIECE(^PRC(443.6,PRCHPO,0),U,13)
- SET EST=$FNUMBER(EST,"-",2)
- +6 SET (OBOC1,FLAG)=0
- KILL OBOC
- +7 FOR
- SET OBOC1=$ORDER(^PRC(443.6,PRCHPO,6,PRCHAM,3,"AC",AMEND,13.05,OBOC1))
- if OBOC1'>0
- QUIT
- Begin DoDot:2
- +8 SET OBOC=+(^PRC(443.6,PRCHPO,6,PRCHAM,3,OBOC1,1,1,0))
- SET FLAG=1
- End DoDot:2
- if FLAG=1
- QUIT
- +9 IF '$DATA(OBOC)
- SET OBOC=+$PIECE($GET(^PRC(443.6,PRCHPO,23)),U)
- +10 DO LINE^PRCHDAM4(.LCNT,2)
- +11 IF OLD'>0
- Begin DoDot:2
- +12 SET DATA="**ADDED THROUGH AMENDMENT**"
- DO DATA^PRCHDAM4(.LCNT,DATA)
- +13 SET DATA="Estimated Shipping and/or Handling of $"_EST_" has been added"
- DO DATA^PRCHDAM4(.LCNT,DATA)
- +14 SET DATA="BOC: "_+$PIECE($GET(^PRC(443.6,PRCHPO,23)),U)
- DO DATA^PRCHDAM4(.LCNT,DATA)
- +15 QUIT
- End DoDot:2
- +16 IF OLD>0
- Begin DoDot:2
- +17 SET DATA="Estimated Shipping and/or Handling of $"_OLD_" has been changed"
- DO DATA^PRCHDAM4(.LCNT,DATA)
- SET DATA="to $"_EST
- DO DATA^PRCHDAM4(.LCNT,DATA)
- +18 SET DATA="BOC: "_OBOC_" has been changed to: "_+$PIECE($GET(^PRC(443.6,PRCHPO,23)),U)
- DO DATA^PRCHDAM4(.LCNT,DATA)
- +19 QUIT
- End DoDot:2
- +20 DO LCNT1^PRCHDAM4(LCNT)
- +21 QUIT
- End DoDot:1
- +22 QUIT
- 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^PRCHDAM4(.LCNT)
- +4 FOR
- SET CHANGE=$ORDER(^PRC(443.6,PRCHPO,6,PRCHAM,3,"AC",AMEND,7,CHANGE))
- if CHANGE'>0
- QUIT
- Begin DoDot:1
- +5 SET OLD=^PRC(443.6,PRCHPO,6,PRCHAM,3,CHANGE,1,1,0)
- +6 SET DDATE=$PIECE(^PRC(443.6,PRCHPO,0),U,10)
- +7 DO LINE^PRCHDAM4(.LCNT,2)
- SET DATA="DELIVERY DATE "_$$FMTE^XLFDT(OLD)_" has been changed to "_$$FMTE^XLFDT(DDATE)
- DO DATA^PRCHDAM4(.LCNT,DATA)
- DO LCNT1^PRCHDAM4(LCNT)
- End DoDot:1
- +8 QUIT