Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: PRCHDP9

PRCHDP9.m

Go to the documentation of this file.
  1. PRCHDP9 ;WISC/DJM-PRINT AMENDMENT,ROUTINE #5 ;12/12/95 9:22 AM
  1. V ;;5.1;IFCAP;;Oct 20, 2000
  1. ;Per VHA Directive 10-93-142, this routine should not be modified.
  1. ;
  1. E34 ;AUTHORITY Edit PRINT
  1. ;N CHANGE,CHANGES,OLD,NEW,LCNT,DATA,DT2,I
  1. S CHANGE=0 D LCNT^PRCHDP9(.LCNT)
  1. F S CHANGE=$O(^PRC(442,PRCHPO,6,PRCHAM,3,"AC",AMEND,3,CHANGE)) Q:CHANGE'>0 D
  1. .S CHANGES=$G(^PRC(442,PRCHPO,6,PRCHAM,3,CHANGE,0)),OLD=$G(^PRC(442,PRCHPO,6,PRCHAM,3,CHANGE,1,1,0))
  1. .S NEW=$P($G(^PRC(442,PRCHPO,6,PRCHAM,0)),U,4)
  1. .D LINE^PRCHDP9(.LCNT,2)
  1. .I OLD=0 S DATA=" *ADDED THROUGH AMENDMENT*" D DATA^PRCHDP9(.LCNT,DATA) D
  1. ..S DATA="Authority Edit is",DT2=$P(^PRCD(442.2,NEW,0),U,2) D D DATA^PRCHDP9(.LCNT,DATA)
  1. ...I $L(DATA)+$L(DT2)>239 S DATA=DATA_":" D DATA^PRCHDP9(.LCNT,DATA) S DATA=DT2 Q
  1. ...S DATA=DATA_" "_DT2
  1. .I OLD>0 S DATA="Authority Edit " D D DATA(.LCNT,DATA)
  1. ..F I=1:1:3 S DT2=$S(I=1:$P(^PRCD(442.2,OLD,0),U,2),I=2:" has been changed to ",I=3:$P(^PRCD(442.2,NEW,0),U,2)) D CHK(.DATA,DT2)
  1. .D LCNT1^PRCHDP9(LCNT)
  1. .Q
  1. Q
  1. ;
  1. CHK(DATA,DT2) ;
  1. I $L(DATA)+$L(DT2)<241 S DATA=DATA_DT2 Q
  1. D DATA(.LCNT,DATA) S DATA=DT2
  1. Q
  1. E35 ;F.O.B. Point PRINT
  1. Q
  1. ;N CHANGE,OLD,NEW
  1. S CHANGE=0 D LCNT^PRCHDP9(.LCNT)
  1. F S CHANGE=$O(^PRC(442,PRCHPO,6,PRCHAM,3,"AC",AMEND,6.4,CHANGE)) Q:CHANGE'>0 D
  1. .S OLD=$G(^PRC(442,PRCHPO,6,PRCHAM,3,CHANGE,1,1,0)),NEW=$P($G(^PRC(442,PRCHPO,1)),U,6)
  1. .D LINE^PRCHPAM5(.LCNT,2)
  1. .S DATA="F.O.B. Point "_OLD_" has been changed to "_NEW D DATA^PRCHDP9(.LCNT,DATA)
  1. .D LCNT1^PRCHDP9(LCNT)
  1. .Q
  1. Q
  1. ;
  1. E36 ;ITEM DISCOUNT Add/Edit PRINT
  1. N CHANGE,CHANGES,FIELD,OLD,NEW,ITEMD,ITEMD0,NEWI,NEWP,LCNT,DATA,DIS,DIS1,DIS2,PCT,PCT1,PCT2,FLAGDISC
  1. S FIELD=0 K ITEMD D LCNT^PRCHDP9(.LCNT)
  1. F S FIELD=$O(^PRC(442,PRCHPO,6,PRCHAM,3,"AC",AMEND,FIELD)) Q:FIELD'>0 D
  1. .S CHANGE=0 F S CHANGE=$O(^PRC(442,PRCHPO,6,PRCHAM,3,"AC",AMEND,FIELD,CHANGE)) Q:CHANGE'>0 D
  1. ..S CHANGES=$G(^PRC(442,PRCHPO,6,PRCHAM,3,CHANGE,0))
  1. ..S OLD=$G(^PRC(442,PRCHPO,6,PRCHAM,3,CHANGE,1,1,0))
  1. ..K DIS2,PCT2 ;Remove old values before they get reset in the loop.
  1. ..S:FIELD=.01 DIS2=OLD
  1. ..S:FIELD=1 PCT2=OLD
  1. ..S FLAGDISC=$S(OLD=0:0,1:1) ;FLAGDISC=0 means a new entry,FLAGDISC=1 means an existing entry.
  1. ..S ITEMD=$P(CHANGES,U,4) Q:$D(ITEMD(ITEMD)) S ITEMD(ITEMD)=1
  1. ..S ITEMD0=$G(^PRC(442,PRCHPO,3,ITEMD,0)) I ITEMD0="" Q
  1. ..;If an entry is found in 'AC' x-ref for PERCENT/DOLLAR AMOUNT field #1, then lookup for the ITEM field #.01 and for the same item define var DIS2.
  1. ..;I FIELD=1 S DIS=0 F S DIS=$O(^PRC(442,PRCHPO,6,PRCHAM,3,"AC",36,.01,DIS)) Q:DIS'>0 S DIS1=$P($G(^PRC(442,PRCHPO,6,PRCHAM,3,DIS,0)),U,4) I DIS1=ITEMD D Q
  1. ..;.S DIS2=$G(^PRC(442,PRCHPO,6,PRCHAM,3,DIS,1,1,0)) Q
  1. ..;If an entry is found in 'AC' x-ref for the ITEM field #.01, then lookup for PERCENT/DOLLAR AMOUNT field #1 and for the same item define var PCT2.
  1. ..I FIELD=.01 S PCT=0 F S PCT=$O(^PRC(442,PRCHPO,6,PRCHAM,3,"AC",36,1,PCT)) Q:PCT'>0 S PCT1=$P($G(^PRC(442,PRCHPO,6,PRCHAM,3,PCT,0)),U,4) I PCT1=ITEMD D Q
  1. ...S PCT2=$G(^PRC(442,PRCHPO,6,PRCHAM,3,PCT,1,1,0)) Q
  1. ..S NEW=$G(^PRC(442,PRCHPO,3,ITEMD,0)),NEWP=$P(NEW,U,2),NEWI=$P(NEW,U)
  1. ..D LINE^PRCHDP9(.LCNT,2)
  1. ..S DIS2=$G(DIS2),PCT2=$G(PCT2)
  1. ..;I DIS2=0 S DATA=" *ADDED THROUGH AMENDMENT*" D DATA^PRCHDP9(.LCNT,DATA) D
  1. ..I FLAGDISC=0 S DATA=" *ADDED THROUGH AMENDMENT*" D DATA^PRCHDP9(.LCNT,DATA) D Q
  1. ...S DATA=$S(NEWP["$":NEWP,1:NEWP_"%")_" Discount For Item(s): "_NEWI D DATA^PRCHDP9(.LCNT,DATA) Q
  1. ..;The new entry is completed with FLAGDISC=0, the existing entries will be dealt with the following conditional code
  1. ..I DIS2]"",PCT2]"" S DATA=$S(PCT2["$":PCT2,1:PCT2_"%")_" Discount For Item(s): "_DIS2 D DATA^PRCHDP9(.LCNT,DATA) D Q
  1. ...S DATA=" Will now be AMENDED to read "_$S(NEWP["$":NEWP,1:NEWP_"%")_" discount for an item(s): "_NEWI D DATA^PRCHDP9(.LCNT,DATA) Q
  1. ..;If only field PERCENT/DOLLAR AMOUNT #1 is changed.
  1. ..I PCT2]"" S DATA=" The discount on item(s) "_NEWI_" will now be AMENDED to read "_$S(NEWP["$":NEWP,1:NEWP_"%") D DATA^PRCHDP9(.LCNT,DATA) Q
  1. ..;If only field ITEM #.01 is changed.
  1. ..I DIS2]"" S DATA=" The item(s) "_DIS2_" will now be AMENDED to read "_NEWI D DATA^PRCHDP9(.LCNT,DATA) Q
  1. .Q
  1. D LCNT1^PRCHDP9(LCNT)
  1. Q
  1. ;
  1. E37 ;ITEM DISCOUNT Delete PRINT
  1. ;N CHANGE,CHANGES,OLD,LCNT,DATA,DIS,ITEMD,ITEMD0
  1. S FIELD=0 K ITEMD D LCNT^PRCHDP9(.LCNT)
  1. F S FIELD=$O(^PRC(442,PRCHPO,6,PRCHAM,3,"AC",AMEND,FIELD)) Q:FIELD'>0 D
  1. .S CHANGE=0 F S CHANGE=$O(^PRC(442,PRCHPO,6,PRCHAM,3,"AC",AMEND,FIELD,CHANGE)) Q:CHANGE'>0 D
  1. ..S CHANGES=$G(^PRC(442,PRCHPO,6,PRCHAM,3,CHANGE,0)),OLD=$G(^PRC(442,PRCHPO,6,PRCHAM,3,CHANGE,1,1,0))
  1. ..S ITEMD=$P(CHANGES,U,4)
  1. ..S ITEMD0=$G(^PRC(442,PRCHPO,3,ITEMD,0)) I ITEMD="" Q
  1. ..S DIS=$P($G(^PRC(442,PRCHPO,3,ITEMD,0)),U)
  1. ..D LINE^PRCHDP9(.LCNT,2)
  1. ..S DATA=" *DELETED THROUGH AMENDMENT*" D DATA^PRCHDP9(.LCNT,DATA)
  1. ..S DATA=$S(OLD["$":OLD,1:OLD_"%")_" Discount For Items: "_DIS_" is DELETED" D DATA^PRCHDP9(.LCNT,DATA),LCNT1^PRCHDP9(LCNT)
  1. ..Q
  1. .Q
  1. Q
  1. LCNT(LCNT) ;FETCH THE CURRENT LINE COUNT FROM "W" ARRAY
  1. S LCNT=+$G(^TMP($J,"W",1))
  1. Q
  1. ;
  1. LINE(LCNT,LINES) ;ADDS A NUMBER OF BLANK "LINES" INTO "W" ARRAY
  1. N I
  1. F I=1:1:LINES S LCNT=LCNT+1,^TMP($J,"W",1,LCNT,0)=" "
  1. Q
  1. ;
  1. DATA(LCNT,DATA) ;PLACES THE AMENDMENT LINE OF TEXT INTO THE "W" ARRAY
  1. S LCNT=LCNT+1,^TMP($J,"W",1,LCNT,0)=DATA
  1. Q
  1. ;
  1. LCNT1(LCNT) ;PUT BACK LCNT INTO "W" ARRAY
  1. S ^TMP($J,"W",1)=LCNT
  1. Q