- PRCHDSP4 ;WISC/DJM-PRINT AMENDMENT ;6/29/00 12:19
- 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 442 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(442,PRCHPO,6,PRCHAM,3,"AC",AMEND)) Q:AMEND'>0 S GOTO="E"_+AMEND_"^PRCHDSP4" 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(442,PRCHPO,6,PRCHAM,3,"AC",AMEND,0)) Q:FIELD'>0
- S CHANGE=$O(^PRC(442,PRCHPO,6,PRCHAM,3,"AC",AMEND,FIELD,0)) Q:CHANGE'>0
- S CHANGES=^PRC(442,PRCHPO,6,PRCHAM,3,CHANGE,0),OLD=^PRC(442,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(442,PRCHPO,23)),U,7),SITE=$S($G(SITE)]"":SITE,1:$P($P(^PRC(442,PRCHPO,0),U),"-"))
- .S OLD=$P(^PRC(411,SITE,1,OLD,0),U)
- .S NEW=$P(^PRC(442,PRCHPO,1),U,3),NEW=$P(^PRC(411,SITE,1,NEW,0),U)
- .Q
- I SHIP=5.3 D
- .S NEW=$P(^PRC(442,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(442,PRCHPO,6,PRCHAM,3,"AC",AMEND,FIELD)) Q:FIELD'>0 D
- .S CHANGE=0 F S CHANGE=$O(^PRC(442,PRCHPO,6,PRCHAM,3,"AC",AMEND,FIELD,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 ITEM=$P(CHANGES,U,4) Q:$D(ITEM(ITEM)) S ITEM(ITEM)=1
- ..S ITEM0=$G(^PRC(442,PRCHPO,2,ITEM,0))
- ..I ITEM0="" Q
- ..I $P(ITEM0,U,2)=0,$P(ITEM0,U,9)=0 Q
- ..S ITEM1=$G(^PRC(442,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(442,PRCHPO,2,ITEM,2)),U,2)
- ..D DATA^PRCHPAM5(.LCNT,DATA)
- ..D NEW^PRCHDSP6
- ..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^PRCHDSP5 ;NOT ENOUGH ROOM IN THIS ROUTINE.
- ;
- E23 ;LINE ITEM Edit PRINT
- G E23^PRCHDSP5
- ;
- E24 ;SOURCE CODE Edit PRINT
- G E24^PRCHDSP7
- ;
- E25 ;Edit MAIL INVOICE TO PRINT
- G E25^PRCHDSP6
- ;
- E26 ;Edit METHOD OF PAYMENT PRINT
- G E26^PRCHDSP6
- ;
- E27 ;ADMINISTRATIVE CERTIFICATION Add PRINT
- G E27^PRCHDSP6
- ;
- E28 ;ADMINISTRATIVE CERTIFICATION Delete PRINT
- G E28^PRCHDSP6
- ;
- E29 ;EST. SHIPPING Edit PRINT
- G E29^PRCHDSP6
- ;
- E30 ;F.C.P. Edit PRINT
- G E30^PRCHDSP7
- ;
- E31 ;Change VENDOR PRINT
- G E31^PRCHDSP7
- ;
- E32 ;REPLACE P.O. NUMBER PRINT
- G E32^PRCHDSP7
- ;
- E33 ;PROMPT PAYMENT Edit PRINT
- G E33^PRCHDSP7
- ;
- E34 ;AUTHORITY Edit PRINT
- G E34^PRCHDSP8
- ;
- E35 ;F.O.B. Point PRINT
- G E35^PRCHDSP8
- ;
- E36 ;ITEM DISCOUNT Add/Edit PRINT
- G E36^PRCHDSP8
- ;
- E37 ;ITEM DISCOUNT Delete PRINT
- G E37^PRCHDSP8
- ;
- E98 ;DELIVERY DATE PRINT
- G E98^PRCHDSP6 ;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[HPRCHDSP4 4273 printed Feb 18, 2025@23:33:19 Page 2
- PRCHDSP4 ;WISC/DJM-PRINT AMENDMENT ;6/29/00 12:19
- 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 442 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(442,PRCHPO,6,PRCHAM,3,"AC",AMEND))
- if AMEND'>0
- QUIT
- SET GOTO="E"_+AMEND_"^PRCHDSP4"
- 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(442,PRCHPO,6,PRCHAM,3,"AC",AMEND,0))
- if FIELD'>0
- QUIT
- +4 SET CHANGE=$ORDER(^PRC(442,PRCHPO,6,PRCHAM,3,"AC",AMEND,FIELD,0))
- if CHANGE'>0
- QUIT
- +5 SET CHANGES=^PRC(442,PRCHPO,6,PRCHAM,3,CHANGE,0)
- SET OLD=^PRC(442,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(442,PRCHPO,23)),U,7)
- SET SITE=$SELECT($GET(SITE)]"":SITE,1:$PIECE($PIECE(^PRC(442,PRCHPO,0),U),"-"))
- +9 SET OLD=$PIECE(^PRC(411,SITE,1,OLD,0),U)
- +10 SET NEW=$PIECE(^PRC(442,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(442,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(442,PRCHPO,6,PRCHAM,3,"AC",AMEND,FIELD))
- if FIELD'>0
- QUIT
- Begin DoDot:1
- +4 SET CHANGE=0
- FOR
- SET CHANGE=$ORDER(^PRC(442,PRCHPO,6,PRCHAM,3,"AC",AMEND,FIELD,CHANGE))
- if CHANGE'>0
- QUIT
- Begin DoDot:2
- +5 SET CHANGES=^PRC(442,PRCHPO,6,PRCHAM,3,CHANGE,0)
- SET OLD=^PRC(442,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(442,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(442,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(442,PRCHPO,2,ITEM,2)),U,2)
- +15 DO DATA^PRCHPAM5(.LCNT,DATA)
- +16 DO NEW^PRCHDSP6
- +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^PRCHDSP5
- +2 ;
- E23 ;LINE ITEM Edit PRINT
- +1 GOTO E23^PRCHDSP5
- +2 ;
- E24 ;SOURCE CODE Edit PRINT
- +1 GOTO E24^PRCHDSP7
- +2 ;
- E25 ;Edit MAIL INVOICE TO PRINT
- +1 GOTO E25^PRCHDSP6
- +2 ;
- E26 ;Edit METHOD OF PAYMENT PRINT
- +1 GOTO E26^PRCHDSP6
- +2 ;
- E27 ;ADMINISTRATIVE CERTIFICATION Add PRINT
- +1 GOTO E27^PRCHDSP6
- +2 ;
- E28 ;ADMINISTRATIVE CERTIFICATION Delete PRINT
- +1 GOTO E28^PRCHDSP6
- +2 ;
- E29 ;EST. SHIPPING Edit PRINT
- +1 GOTO E29^PRCHDSP6
- +2 ;
- E30 ;F.C.P. Edit PRINT
- +1 GOTO E30^PRCHDSP7
- +2 ;
- E31 ;Change VENDOR PRINT
- +1 GOTO E31^PRCHDSP7
- +2 ;
- E32 ;REPLACE P.O. NUMBER PRINT
- +1 GOTO E32^PRCHDSP7
- +2 ;
- E33 ;PROMPT PAYMENT Edit PRINT
- +1 GOTO E33^PRCHDSP7
- +2 ;
- E34 ;AUTHORITY Edit PRINT
- +1 GOTO E34^PRCHDSP8
- +2 ;
- E35 ;F.O.B. Point PRINT
- +1 GOTO E35^PRCHDSP8
- +2 ;
- E36 ;ITEM DISCOUNT Add/Edit PRINT
- +1 GOTO E36^PRCHDSP8
- +2 ;
- E37 ;ITEM DISCOUNT Delete PRINT
- +1 GOTO E37^PRCHDSP8
- +2 ;
- E98 ;DELIVERY DATE PRINT
- +1 ;PRC*5.1*180 Call to display Delivery Date changes
- GOTO E98^PRCHDSP6
- +2 QUIT
- E99 ;NET AMOUNT PRINT
- +1 QUIT