- PRCHDP8 ;WISC/DJM-PRINT AMENDMENT,ROUTINE #4 ;6/23/94 8:44 AM ;5/13/94 10:37 AM
- V ;;5.1;IFCAP;**74**;Oct 20, 2000
- ;Per VHA Directive 10-93-142, this routine should not be modified.
- ;
- E24 ;SOURCE CODE Edit PRINT
- N CHANGE,OLD,NEW,LCNT,DATA
- D LCNT^PRCHDP9(.LCNT)
- S CHANGE=$O(^PRC(442,PRCHPO,6,PRCHAM,3,"AC",24,8,0)) Q:CHANGE'>0
- S OLD=^PRC(442,PRCHPO,6,PRCHAM,3,CHANGE,1,1,0),OLD=$P(^PRCD(420.8,OLD,0),U)
- S NEW=$P(^PRC(442,PRCHPO,1),U,7),NEW=$P(^PRCD(420.8,NEW,0),U)
- D LINE^PRCHDP9(.LCNT,2) S DATA="Source Code was changed from "_OLD_" to "_NEW D DATA^PRCHDP9(.LCNT,DATA),LCNT1^PRCHDP9(LCNT)
- Q
- ;
- E30 ;F.C.P. Edit PRINT
- N CHANGE,OLD,FCP,LCNT,DATA
- S CHANGE=0 D LCNT^PRCHDP9(.LCNT)
- F S CHANGE=$O(^PRC(442,PRCHPO,6,PRCHAM,3,"AC",AMEND,1,CHANGE)) Q:CHANGE'>0 D
- .S OLD=^PRC(442,PRCHPO,6,PRCHAM,3,CHANGE,1,1,0)
- .S FCP=$P(^PRC(442,PRCHPO,0),U,3)
- .D LINE^PRCHDP9(.LCNT,2) S DATA="The FUND CONTROL POINT of "_OLD D DATA^PRCHDP9(.LCNT,DATA)
- .S DATA="has been changed to "_FCP
- .D DATA^PRCHDP9(.LCNT,DATA),LCNT1^PRCHDP9(LCNT)
- Q
- ;
- E31 ;Change VENDOR PRINT
- N CHANGE,OLD,VEN,LCNT,DATA,CNT,CNT1,CNT2,AA
- S CHANGE=0,CNT=0,CNT2=0 D LCNT^PRCHDP9(.LCNT)
- ;
- ;Check for multiple vendor changes
- F S CNT=$O(^PRC(442,PRCHPO,6,CNT)) Q:'CNT D
- . S CNT1=0
- . F S CNT1=$O(^PRC(442,PRCHPO,6,CNT,3,CNT1)) Q:'CNT1 D
- . . S TYPE=$G(^PRC(442,PRCHPO,6,CNT,3,CNT1,0))
- . . S TYPE=$P(TYPE,U,2) I TYPE'=31 Q
- . . S VEN=$G(^PRC(442,PRCHPO,6,CNT,3,CNT1,1,1,0))
- . . Q:VEN=""
- . . S CNT2=CNT2+1,AA(CNT)=VEN ;Count/track vendor changes
- ;
- F S CHANGE=$O(^PRC(442,PRCHPO,6,PRCHAM,3,"AC",AMEND,5,CHANGE)) Q:CHANGE'>0 D
- .;Print vendor amendments.
- .I CNT2>1 D E31A Q
- .S OLD=^PRC(442,PRCHPO,6,PRCHAM,3,CHANGE,1,1,0),OLD=$P(^PRC(440,OLD,0),U)
- .S VEN=$P(^PRC(442,PRCHPO,1),U),VEN=$P(^PRC(440,VEN,0),U)
- .D LINE^PRCHDP9(.LCNT,2) S DATA="Vendor "_OLD_" has been changed to "_VEN
- .D DATA^PRCHDP9(.LCNT,DATA),LCNT1^PRCHDP9(LCNT)
- Q
- ;
- E31A ;Print multiple vendor changes.
- S OLD=$P(^PRC(440,AA(PRCHAM),0),U)
- S VEN=$O(AA(PRCHAM))
- I VEN="" S VEN=$P(^PRC(442,PRCHPO,1),U)
- E S VEN=AA(VEN)
- S VEN=$P(^PRC(440,VEN,0),U)
- ;
- D LINE^PRCHDP9(.LCNT,2)
- S DATA="Vendor "_OLD_" has been changed to "_VEN
- D DATA^PRCHDP9(.LCNT,DATA),LCNT1^PRCHDP9(LCNT)
- Q
- ;
- E32 ;REPLACE P.O. NUMBER PRINT
- N CHANGE,NPO,OPO,LCNT,DATA
- S CHANGE=0 D LCNT^PRCHDP9(.LCNT)
- F S CHANGE=$O(^PRC(442,PRCHPO,6,PRCHAM,3,"AC",AMEND,28,CHANGE)) Q:CHANGE'>0 D
- .S NPO=$P(^PRC(442,PRCHPO,23),U,4),NPO=$P(^PRC(442,NPO,0),U)
- .S OPO=$P(^PRC(442,PRCHPO,0),U)
- .D LINE^PRCHDP9(.LCNT,2) S DATA="Purchase Order number "_OPO_" has been changed to "_NPO
- .D DATA^PRCHDP9(.LCNT,DATA),LCNT1^PRCHDP9(LCNT)
- Q
- ;
- E33 ;PROMPT PAYMENT Edit PRINT
- ;N CHANGE,CHANGES,FIELD,OLD,PAY,LCNT,DATA,PCT,PCT1,PCT2,DAYS,DAYS1,DAYS2,TERMS,NPCT,NDAYS1
- S FIELD=0 K PAY D LCNT^PRCHDP9(.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:FIELD=.01 PCT2=OLD S:FIELD=1 DAYS2=OLD
- ..S PAY=$P(CHANGES,U,4) Q:$D(PAY(PAY)) S PAY(PAY)=1
- ..I FIELD'=1 S DAYS=0 F S DAYS=$O(^PRC(442,PRCHPO,6,PRCHAM,3,"AC",33,1,DAYS)) Q:DAYS'>0 S DAYS1=$P(^PRC(442,PRCHPO,6,PRCHAM,3,DAYS,0),U,4) I DAYS1=PAY D Q
- ...S DAYS2=^PRC(442,PRCHPO,6,PRCHAM,3,DAYS,1,1,0) Q
- ..I FIELD'=.01 S PCT=0 F S PCT=$O(^PRC(442,PRCHPO,6,PRCHAM,3,"AC",33,.01,PCT)) Q:PCT'>0 S PCT1=$P(^PRC(442,PRCHPO,6,PRCHAM,3,PCT,0),U,4) I PCT1=PAY D Q
- ...S PCT2=^PRC(442,PRCHPO,6,PRCHAM,3,PCT,1,1,0) Q
- ..S TERMS=^PRC(442,PRCHPO,5,PAY,0),NPCT=$P(TERMS,U),NDAYS1=$P(TERMS,U,2)
- ..D LINE^PRCHDP9(.LCNT,2)
- ..S DAYS2=$G(DAYS2),PCT2=$G(PCT2)
- ..I DAYS2'=0,PCT2'=0 S DATA="Prompt Payment "_PCT2_$S(PCT2=+PCT2:"%",1:"")_"/"_DAYS2_$S(DAYS2=+DAYS2:" days",1:"") D
- ...S DATA=DATA_" has been changed to "_NPCT_$S(NPCT=+NPCT:"%",1:"")_"/"_NDAYS1_$S(NDAYS1=+NDAYS1:" days",1:"")
- ...D DATA^PRCHDP9(.LCNT,DATA) Q
- ..I DAYS2=0,PCT2=0 S DATA=" *ADDED THROUGH AMENDMENT*" D DATA^PRCHDP9(.LCNT,DATA) D
- ...S DATA="Prompt Payment "_NPCT_$S(NPCT=+NPCT:"%",1:"")_"/"_NDAYS1_$S(NDAYS1=+NDAYS1:" days",1:"")_" has been added"
- ...D DATA^PRCHDP9(.LCNT,DATA) Q
- ..Q
- .Q
- D LCNT1^PRCHDP9(LCNT)
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCHDP8 4355 printed Apr 23, 2025@18:21:17 Page 2
- PRCHDP8 ;WISC/DJM-PRINT AMENDMENT,ROUTINE #4 ;6/23/94 8:44 AM ;5/13/94 10:37 AM
- V ;;5.1;IFCAP;**74**;Oct 20, 2000
- +1 ;Per VHA Directive 10-93-142, this routine should not be modified.
- +2 ;
- E24 ;SOURCE CODE Edit PRINT
- +1 NEW CHANGE,OLD,NEW,LCNT,DATA
- +2 DO LCNT^PRCHDP9(.LCNT)
- +3 SET CHANGE=$ORDER(^PRC(442,PRCHPO,6,PRCHAM,3,"AC",24,8,0))
- if CHANGE'>0
- QUIT
- +4 SET OLD=^PRC(442,PRCHPO,6,PRCHAM,3,CHANGE,1,1,0)
- SET OLD=$PIECE(^PRCD(420.8,OLD,0),U)
- +5 SET NEW=$PIECE(^PRC(442,PRCHPO,1),U,7)
- SET NEW=$PIECE(^PRCD(420.8,NEW,0),U)
- +6 DO LINE^PRCHDP9(.LCNT,2)
- SET DATA="Source Code was changed from "_OLD_" to "_NEW
- DO DATA^PRCHDP9(.LCNT,DATA)
- DO LCNT1^PRCHDP9(LCNT)
- +7 QUIT
- +8 ;
- E30 ;F.C.P. Edit PRINT
- +1 NEW CHANGE,OLD,FCP,LCNT,DATA
- +2 SET CHANGE=0
- DO LCNT^PRCHDP9(.LCNT)
- +3 FOR
- SET CHANGE=$ORDER(^PRC(442,PRCHPO,6,PRCHAM,3,"AC",AMEND,1,CHANGE))
- if CHANGE'>0
- QUIT
- Begin DoDot:1
- +4 SET OLD=^PRC(442,PRCHPO,6,PRCHAM,3,CHANGE,1,1,0)
- +5 SET FCP=$PIECE(^PRC(442,PRCHPO,0),U,3)
- +6 DO LINE^PRCHDP9(.LCNT,2)
- SET DATA="The FUND CONTROL POINT of "_OLD
- DO DATA^PRCHDP9(.LCNT,DATA)
- +7 SET DATA="has been changed to "_FCP
- +8 DO DATA^PRCHDP9(.LCNT,DATA)
- DO LCNT1^PRCHDP9(LCNT)
- End DoDot:1
- +9 QUIT
- +10 ;
- E31 ;Change VENDOR PRINT
- +1 NEW CHANGE,OLD,VEN,LCNT,DATA,CNT,CNT1,CNT2,AA
- +2 SET CHANGE=0
- SET CNT=0
- SET CNT2=0
- DO LCNT^PRCHDP9(.LCNT)
- +3 ;
- +4 ;Check for multiple vendor changes
- +5 FOR
- SET CNT=$ORDER(^PRC(442,PRCHPO,6,CNT))
- if 'CNT
- QUIT
- Begin DoDot:1
- +6 SET CNT1=0
- +7 FOR
- SET CNT1=$ORDER(^PRC(442,PRCHPO,6,CNT,3,CNT1))
- if 'CNT1
- QUIT
- Begin DoDot:2
- +8 SET TYPE=$GET(^PRC(442,PRCHPO,6,CNT,3,CNT1,0))
- +9 SET TYPE=$PIECE(TYPE,U,2)
- IF TYPE'=31
- QUIT
- +10 SET VEN=$GET(^PRC(442,PRCHPO,6,CNT,3,CNT1,1,1,0))
- +11 if VEN=""
- QUIT
- +12 ;Count/track vendor changes
- SET CNT2=CNT2+1
- SET AA(CNT)=VEN
- End DoDot:2
- End DoDot:1
- +13 ;
- +14 FOR
- SET CHANGE=$ORDER(^PRC(442,PRCHPO,6,PRCHAM,3,"AC",AMEND,5,CHANGE))
- if CHANGE'>0
- QUIT
- Begin DoDot:1
- +15 ;Print vendor amendments.
- +16 IF CNT2>1
- DO E31A
- QUIT
- +17 SET OLD=^PRC(442,PRCHPO,6,PRCHAM,3,CHANGE,1,1,0)
- SET OLD=$PIECE(^PRC(440,OLD,0),U)
- +18 SET VEN=$PIECE(^PRC(442,PRCHPO,1),U)
- SET VEN=$PIECE(^PRC(440,VEN,0),U)
- +19 DO LINE^PRCHDP9(.LCNT,2)
- SET DATA="Vendor "_OLD_" has been changed to "_VEN
- +20 DO DATA^PRCHDP9(.LCNT,DATA)
- DO LCNT1^PRCHDP9(LCNT)
- End DoDot:1
- +21 QUIT
- +22 ;
- E31A ;Print multiple vendor changes.
- +1 SET OLD=$PIECE(^PRC(440,AA(PRCHAM),0),U)
- +2 SET VEN=$ORDER(AA(PRCHAM))
- +3 IF VEN=""
- SET VEN=$PIECE(^PRC(442,PRCHPO,1),U)
- +4 IF '$TEST
- SET VEN=AA(VEN)
- +5 SET VEN=$PIECE(^PRC(440,VEN,0),U)
- +6 ;
- +7 DO LINE^PRCHDP9(.LCNT,2)
- +8 SET DATA="Vendor "_OLD_" has been changed to "_VEN
- +9 DO DATA^PRCHDP9(.LCNT,DATA)
- DO LCNT1^PRCHDP9(LCNT)
- +10 QUIT
- +11 ;
- E32 ;REPLACE P.O. NUMBER PRINT
- +1 NEW CHANGE,NPO,OPO,LCNT,DATA
- +2 SET CHANGE=0
- DO LCNT^PRCHDP9(.LCNT)
- +3 FOR
- SET CHANGE=$ORDER(^PRC(442,PRCHPO,6,PRCHAM,3,"AC",AMEND,28,CHANGE))
- if CHANGE'>0
- QUIT
- Begin DoDot:1
- +4 SET NPO=$PIECE(^PRC(442,PRCHPO,23),U,4)
- SET NPO=$PIECE(^PRC(442,NPO,0),U)
- +5 SET OPO=$PIECE(^PRC(442,PRCHPO,0),U)
- +6 DO LINE^PRCHDP9(.LCNT,2)
- SET DATA="Purchase Order number "_OPO_" has been changed to "_NPO
- +7 DO DATA^PRCHDP9(.LCNT,DATA)
- DO LCNT1^PRCHDP9(LCNT)
- End DoDot:1
- +8 QUIT
- +9 ;
- E33 ;PROMPT PAYMENT Edit PRINT
- +1 ;N CHANGE,CHANGES,FIELD,OLD,PAY,LCNT,DATA,PCT,PCT1,PCT2,DAYS,DAYS1,DAYS2,TERMS,NPCT,NDAYS1
- +2 SET FIELD=0
- KILL PAY
- DO LCNT^PRCHDP9(.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 if FIELD=.01
- SET PCT2=OLD
- if FIELD=1
- SET DAYS2=OLD
- +7 SET PAY=$PIECE(CHANGES,U,4)
- if $DATA(PAY(PAY))
- QUIT
- SET PAY(PAY)=1
- +8 IF FIELD'=1
- SET DAYS=0
- FOR
- SET DAYS=$ORDER(^PRC(442,PRCHPO,6,PRCHAM,3,"AC",33,1,DAYS))
- if DAYS'>0
- QUIT
- SET DAYS1=$PIECE(^PRC(442,PRCHPO,6,PRCHAM,3,DAYS,0),U,4)
- IF DAYS1=PAY
- Begin DoDot:3
- +9 SET DAYS2=^PRC(442,PRCHPO,6,PRCHAM,3,DAYS,1,1,0)
- QUIT
- End DoDot:3
- QUIT
- +10 IF FIELD'=.01
- SET PCT=0
- FOR
- SET PCT=$ORDER(^PRC(442,PRCHPO,6,PRCHAM,3,"AC",33,.01,PCT))
- if PCT'>0
- QUIT
- SET PCT1=$PIECE(^PRC(442,PRCHPO,6,PRCHAM,3,PCT,0),U,4)
- IF PCT1=PAY
- Begin DoDot:3
- +11 SET PCT2=^PRC(442,PRCHPO,6,PRCHAM,3,PCT,1,1,0)
- QUIT
- End DoDot:3
- QUIT
- +12 SET TERMS=^PRC(442,PRCHPO,5,PAY,0)
- SET NPCT=$PIECE(TERMS,U)
- SET NDAYS1=$PIECE(TERMS,U,2)
- +13 DO LINE^PRCHDP9(.LCNT,2)
- +14 SET DAYS2=$GET(DAYS2)
- SET PCT2=$GET(PCT2)
- +15 IF DAYS2'=0
- IF PCT2'=0
- SET DATA="Prompt Payment "_PCT2_$SELECT(PCT2=+PCT2:"%",1:"")_"/"_DAYS2_$SELECT(DAYS2=+DAYS2:" days",1:"")
- Begin DoDot:3
- +16 SET DATA=DATA_" has been changed to "_NPCT_$SELECT(NPCT=+NPCT:"%",1:"")_"/"_NDAYS1_$SELECT(NDAYS1=+NDAYS1:" days",1:"")
- +17 DO DATA^PRCHDP9(.LCNT,DATA)
- QUIT
- End DoDot:3
- +18 IF DAYS2=0
- IF PCT2=0
- SET DATA=" *ADDED THROUGH AMENDMENT*"
- DO DATA^PRCHDP9(.LCNT,DATA)
- Begin DoDot:3
- +19 SET DATA="Prompt Payment "_NPCT_$SELECT(NPCT=+NPCT:"%",1:"")_"/"_NDAYS1_$SELECT(NDAYS1=+NDAYS1:" days",1:"")_" has been added"
- +20 DO DATA^PRCHDP9(.LCNT,DATA)
- QUIT
- End DoDot:3
- +21 QUIT
- End DoDot:2
- +22 QUIT
- End DoDot:1
- +23 DO LCNT1^PRCHDP9(LCNT)
- +24 QUIT
