- PRCHAMY3 ;WISC/DJM-PRINT AMENDMENT, ROUTINE #3 ;8/31/95 11:24 AM
- V ;;5.1;IFCAP;;Oct 20, 2000
- ;Per VHA Directive 10-93-142, this routine should not be modified.
- ;
- E29 ;EST. SHIPPING Edit
- 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=$G(^PRC(442,PRCHPO,6,PRCHAM,3,CHANGE,1,1,0)),OLD=$FN(OLD,"-",2)
- .S EST=$P($G(^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.5,OBOC1)) Q:OBOC1'>0 D Q:FLAG=1
- ..S OBOC=+(^PRC(442,PRCHPO,6,PRCHAM,3,OBOC1,1,1,0)),FLAG=1
- .I '$D(OBOC) S OBOC=+$P($G(^PRC(442,PRCHPO,23)),U)
- .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)
- ..S DATA="BOC: "_+$P($G(^PRC(442,PRCHPO,23)),U) 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)
- ..S DATA="BOC: "_OBOC_" has been changed to: "+$P($G(^PRC(442,PRCHPO,23)),U) D DATA^PRCHPAM5(.LCNT,DATA)
- ..Q
- .D LCNT1^PRCHPAM5(LCNT)
- .Q
- Q
- ;
- OLD ;GET ALL THE OLD DESCRIPTION FROM 'CHANGES' MULTIPLE AND SET INTO
- ;THE DISPLAY '^TMP($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 NEW DESCRIPTION FROM THE LINE ITEM MULTIPLE AND SET
- ;INTO THE DISPLAY '^TMP($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[HPRCHAMY3 2131 printed Mar 13, 2025@21:10:44 Page 2
- PRCHAMY3 ;WISC/DJM-PRINT AMENDMENT, ROUTINE #3 ;8/31/95 11:24 AM
- V ;;5.1;IFCAP;;Oct 20, 2000
- +1 ;Per VHA Directive 10-93-142, this routine should not be modified.
- +2 ;
- E29 ;EST. SHIPPING Edit
- +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=$GET(^PRC(442,PRCHPO,6,PRCHAM,3,CHANGE,1,1,0))
- SET OLD=$FNUMBER(OLD,"-",2)
- +5 SET EST=$PIECE($GET(^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.5,OBOC1))
- if OBOC1'>0
- QUIT
- Begin DoDot:2
- +8 SET OBOC=+(^PRC(442,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(442,PRCHPO,23)),U)
- +10 DO LINE^PRCHPAM5(.LCNT,2)
- +11 IF OLD'>0
- Begin DoDot:2
- +12 SET DATA="**ADDED THROUGH AMENDMENT**"
- DO DATA^PRCHPAM5(.LCNT,DATA)
- +13 SET DATA="Estimated Shipping and/or Handling of $"_EST_" has been added"
- DO DATA^PRCHPAM5(.LCNT,DATA)
- +14 SET DATA="BOC: "_+$PIECE($GET(^PRC(442,PRCHPO,23)),U)
- DO DATA^PRCHPAM5(.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^PRCHPAM5(.LCNT,DATA)
- +18 SET DATA="to $"_EST
- DO DATA^PRCHPAM5(.LCNT,DATA)
- +19 SET DATA="BOC: "_OBOC_" has been changed to: "+$PIECE($GET(^PRC(442,PRCHPO,23)),U)
- DO DATA^PRCHPAM5(.LCNT,DATA)
- +20 QUIT
- End DoDot:2
- +21 DO LCNT1^PRCHPAM5(LCNT)
- +22 QUIT
- End DoDot:1
- +23 QUIT
- +24 ;
- OLD ;GET ALL THE OLD DESCRIPTION FROM 'CHANGES' MULTIPLE AND SET INTO
- +1 ;THE DISPLAY '^TMP($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 NEW DESCRIPTION FROM THE LINE ITEM MULTIPLE AND SET
- +1 ;INTO THE DISPLAY '^TMP($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
