- PRCHDSP7 ;WISC/DJM-PRINT AMENDMENT,ROUTINE #4 ;6/23/94 8:46 AM ;5/13/94 10:37 AM
- V ;;5.1;IFCAP;;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^PRCHPAM5(.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^PRCHPAM5(.LCNT,2) S DATA="Source Code was changed from "_OLD_" to "_NEW D DATA^PRCHPAM5(.LCNT,DATA),LCNT1^PRCHPAM5(LCNT)
- Q
- ;
- E30 ;F.C.P. Edit PRINT
- N CHANGE,OLD,FCP,LCNT,DATA
- S CHANGE=0 D LCNT^PRCHPAM5(.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^PRCHPAM5(.LCNT,2) S DATA="The FUND CONTROL POINT of "_OLD D DATA^PRCHPAM5(.LCNT,DATA)
- .S DATA="has been changed to "_FCP
- .D DATA^PRCHPAM5(.LCNT,DATA),LCNT1^PRCHPAM5(LCNT)
- Q
- ;
- E31 ;Change VENDOR PRINT
- N CHANGE,OLD,VEN,LCNT,DATA
- S CHANGE=0 D LCNT^PRCHPAM5(.LCNT)
- F S CHANGE=$O(^PRC(442,PRCHPO,6,PRCHAM,3,"AC",AMEND,5,CHANGE)) Q:CHANGE'>0 D
- .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^PRCHPAM5(.LCNT,2) S DATA="Vendor "_OLD_" has been changed to "_VEN
- .D DATA^PRCHPAM5(.LCNT,DATA),LCNT1^PRCHPAM5(LCNT)
- Q
- ;
- E32 ;REPLACE P.O. NUMBER PRINT
- N CHANGE,NPO,OPO,LCNT,DATA
- S CHANGE=0 D LCNT^PRCHPAM5(.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^PRCHPAM5(.LCNT,2) S DATA="Purchase Order number "_OPO_" has been changed to "_NPO
- .D DATA^PRCHPAM5(.LCNT,DATA),LCNT1^PRCHPAM5(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^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: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^PRCHPAM5(.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^PRCHPAM5(.LCNT,DATA) Q
- ..I DAYS2=0,PCT2=0 S DATA=" *ADDED THROUGH AMENDMENT*" D DATA^PRCHPAM5(.LCNT,DATA) D
- ...S DATA="Prompt Payment "_NPCT_$S(NPCT=+NPCT:"%",1:"")_"/"_NDAYS1_$S(NDAYS1=+NDAYS1:" days",1:"")_" has been added"
- ...D DATA^PRCHPAM5(.LCNT,DATA) Q
- ..Q
- .Q
- D LCNT1^PRCHPAM5(LCNT)
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCHDSP7 3590 printed Jan 18, 2025@03:08:11 Page 2
- PRCHDSP7 ;WISC/DJM-PRINT AMENDMENT,ROUTINE #4 ;6/23/94 8:46 AM ;5/13/94 10:37 AM
- V ;;5.1;IFCAP;;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^PRCHPAM5(.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^PRCHPAM5(.LCNT,2)
- SET DATA="Source Code was changed from "_OLD_" to "_NEW
- DO DATA^PRCHPAM5(.LCNT,DATA)
- DO LCNT1^PRCHPAM5(LCNT)
- +7 QUIT
- +8 ;
- E30 ;F.C.P. Edit PRINT
- +1 NEW CHANGE,OLD,FCP,LCNT,DATA
- +2 SET CHANGE=0
- DO LCNT^PRCHPAM5(.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^PRCHPAM5(.LCNT,2)
- SET DATA="The FUND CONTROL POINT of "_OLD
- DO DATA^PRCHPAM5(.LCNT,DATA)
- +7 SET DATA="has been changed to "_FCP
- +8 DO DATA^PRCHPAM5(.LCNT,DATA)
- DO LCNT1^PRCHPAM5(LCNT)
- End DoDot:1
- +9 QUIT
- +10 ;
- E31 ;Change VENDOR PRINT
- +1 NEW CHANGE,OLD,VEN,LCNT,DATA
- +2 SET CHANGE=0
- DO LCNT^PRCHPAM5(.LCNT)
- +3 FOR
- SET CHANGE=$ORDER(^PRC(442,PRCHPO,6,PRCHAM,3,"AC",AMEND,5,CHANGE))
- if CHANGE'>0
- QUIT
- Begin DoDot:1
- +4 SET OLD=^PRC(442,PRCHPO,6,PRCHAM,3,CHANGE,1,1,0)
- SET OLD=$PIECE(^PRC(440,OLD,0),U)
- +5 SET VEN=$PIECE(^PRC(442,PRCHPO,1),U)
- SET VEN=$PIECE(^PRC(440,VEN,0),U)
- +6 DO LINE^PRCHPAM5(.LCNT,2)
- SET DATA="Vendor "_OLD_" has been changed to "_VEN
- +7 DO DATA^PRCHPAM5(.LCNT,DATA)
- DO LCNT1^PRCHPAM5(LCNT)
- End DoDot:1
- +8 QUIT
- +9 ;
- E32 ;REPLACE P.O. NUMBER PRINT
- +1 NEW CHANGE,NPO,OPO,LCNT,DATA
- +2 SET CHANGE=0
- DO LCNT^PRCHPAM5(.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^PRCHPAM5(.LCNT,2)
- SET DATA="Purchase Order number "_OPO_" has been changed to "_NPO
- +7 DO DATA^PRCHPAM5(.LCNT,DATA)
- DO LCNT1^PRCHPAM5(LCNT)
- End DoDot:1
- +8 QUIT
- +9 ;
- E33 ;PROMPT PAYMENT Edit PRINT
- +1 ;
- +2 ;N CHANGE,CHANGES,FIELD,OLD,PAY,LCNT,DATA,PCT,PCT1,PCT2,DAYS,DAYS1,DAYS2,TERMS,NPCT,NDAYS1
- +3 SET FIELD=0
- KILL PAY
- DO LCNT^PRCHPAM5(.LCNT)
- +4 FOR
- SET FIELD=$ORDER(^PRC(442,PRCHPO,6,PRCHAM,3,"AC",AMEND,FIELD))
- if FIELD'>0
- QUIT
- Begin DoDot:1
- +5 SET CHANGE=0
- FOR
- SET CHANGE=$ORDER(^PRC(442,PRCHPO,6,PRCHAM,3,"AC",AMEND,FIELD,CHANGE))
- if CHANGE'>0
- QUIT
- Begin DoDot:2
- +6 SET CHANGES=^PRC(442,PRCHPO,6,PRCHAM,3,CHANGE,0)
- SET OLD=^PRC(442,PRCHPO,6,PRCHAM,3,CHANGE,1,1,0)
- +7 if FIELD=.01
- SET PCT2=OLD
- if FIELD=1
- SET DAYS2=OLD
- +8 SET PAY=$PIECE(CHANGES,U,4)
- if $DATA(PAY(PAY))
- QUIT
- SET PAY(PAY)=1
- +9 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
- +10 SET DAYS2=^PRC(442,PRCHPO,6,PRCHAM,3,DAYS,1,1,0)
- QUIT
- End DoDot:3
- QUIT
- +11 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
- +12 SET PCT2=^PRC(442,PRCHPO,6,PRCHAM,3,PCT,1,1,0)
- QUIT
- End DoDot:3
- QUIT
- +13 SET TERMS=^PRC(442,PRCHPO,5,PAY,0)
- SET NPCT=$PIECE(TERMS,U)
- SET NDAYS1=$PIECE(TERMS,U,2)
- +14 DO LINE^PRCHPAM5(.LCNT,2)
- +15 SET DAYS2=$GET(DAYS2)
- SET PCT2=$GET(PCT2)
- +16 IF DAYS2'=0
- IF PCT2'=0
- SET DATA="Prompt Payment "_PCT2_$SELECT(PCT2=+PCT2:"%",1:"")_"/"_DAYS2_$SELECT(DAYS2=+DAYS2:" days",1:"")
- Begin DoDot:3
- +17 SET DATA=DATA_" has been changed to "_NPCT_$SELECT(NPCT=+NPCT:"%",1:"")_"/"_NDAYS1_$SELECT(NDAYS1=+NDAYS1:" days",1:"")
- +18 DO DATA^PRCHPAM5(.LCNT,DATA)
- QUIT
- End DoDot:3
- +19 IF DAYS2=0
- IF PCT2=0
- SET DATA=" *ADDED THROUGH AMENDMENT*"
- DO DATA^PRCHPAM5(.LCNT,DATA)
- Begin DoDot:3
- +20 SET DATA="Prompt Payment "_NPCT_$SELECT(NPCT=+NPCT:"%",1:"")_"/"_NDAYS1_$SELECT(NDAYS1=+NDAYS1:" days",1:"")_" has been added"
- +21 DO DATA^PRCHPAM5(.LCNT,DATA)
- QUIT
- End DoDot:3
- +22 QUIT
- End DoDot:2
- +23 QUIT
- End DoDot:1
- +24 DO LCNT1^PRCHPAM5(LCNT)
- +25 QUIT