source: WorldVistAEHR/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCHAMY5.m@ 1464

PRCHAMY5 ;WISC/DJM-PRINT AMENDMENT,ROUTINE #5 ;7/20/94  9:45 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.

 ;

E36 ;ITEM DISCOUNT Add/Edit

 N CHANGE,CHANGES,FIELD,OLD,NEW,ITEMD,ITEMD0,NEWI,NEWP,LCNT,DATA,DIS,DIS1,DIS2,PCT,PCT1,PCT2,FLAGDISC

 S FIELD=0 K ITEMD 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=$G(^PRC(442,PRCHPO,6,PRCHAM,3,CHANGE,0))

 ..S OLD=$G(^PRC(442,PRCHPO,6,PRCHAM,3,CHANGE,1,1,0))

 ..K DIS2,PCT2 ;removing old values of DIS2,PCT2 before they are reset with new values in the loop.

 ..S:FIELD=.01 DIS2=OLD

 ..S:FIELD=1 PCT2=OLD

 ..S FLAGDISC=$S(OLD=0:0,1:1) ;FLAGDISC=0 means a new entry, FLAGDISC=1 means an existing entry.

 ..S ITEMD=$P(CHANGES,U,4) Q:$D(ITEMD(ITEMD))  S ITEMD(ITEMD)=1

 ..S ITEMD0=$G(^PRC(442,PRCHPO,3,ITEMD,0)) I ITEMD0="" Q

 ..;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

 ..;.S DIS2=$G(^PRC(442,PRCHPO,6,PRCHAM,3,DIS,1,1,0)) Q

 ..;if an entry is found in 'AC' x-ref for the ITEM field #.01, then look-up for PERCENT/DOLLAR AMOUNT field #1 and then for same item define var PCT2.

 ..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

 ...S PCT2=$G(^PRC(442,PRCHPO,6,PRCHAM,3,PCT,1,1,0)) Q

 ..S NEW=$G(^PRC(442,PRCHPO,3,ITEMD,0)),NEWP=$P(NEW,U,2),NEWI=$P(NEW,U)

 ..D LINE^PRCHPAM5(.LCNT,2)

 ..S DIS2=$G(DIS2),PCT2=$G(PCT2)

 ..;I DIS2=0 S DATA=" *ADDED THROUGH AMENDMENT*" D DATA^PRCHPAM5(.LCNT,DATA) D

 ..I FLAGDISC=0 S DATA=" *ADDED THROUGH AMENDMENT*" D DATA^PRCHPAM5(.LCNT,DATA) D  Q

 ...S DATA=$S(NEWP["$":NEWP,1:NEWP_"%")_" Discount For Items: "_NEWI D DATA^PRCHPAM5(.LCNT,DATA) Q

 ..;The new entry is completed with FLAGDISC=0, the existing entries are dealt with following conditions code

 ..;If both fields ITEM #.01 and PERCENT/DOLLAR AMOUNT #1 are changed.

 ..I DIS2]"",PCT2]"" S DATA=$S(PCT2["$":PCT2,1:PCT2_"%")_" Discount For Item(s): "_DIS2 D DATA^PRCHPAM5(.LCNT,DATA) D  Q

 ...S DATA=" Will now be AMENDED to read "_$S(NEWP["$":NEWP,1:NEWP_"%")_" discount for an item: "_NEWI D DATA^PRCHPAM5(.LCNT,DATA) Q

 ..;If only field ITEM #.01 is changed.

 ..I DIS2]"" S DATA=" The item(s) "_DIS2_" will now be AMENDED to read "_NEWI D DATA^PRCHPAM5(.LCNT,DATA) Q

 ..;If only field PERCENT/DOLLAR AMOUNT #1 is changed.

 ..I PCT2]"" S DATA=" The discount on item "_NEWI_" will now be AMENDED to read "_$S(NEWP["$":NEWP,1:NEWP_"%") D DATA^PRCHPAM5(.LCNT,DATA) Q

 .Q

 D LCNT1^PRCHPAM5(LCNT)

 Q

 ;

E37 ;ITEM DISCOUNT Delete

 N CHANGE,CHANGES,OLD,LCNT,DATA,DIS,ITEMD,ITEMD0

 S FIELD=0 K ITEMD 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=$G(^PRC(442,PRCHPO,6,PRCHAM,3,CHANGE,0)),OLD=$G(^PRC(442,PRCHPO,6,PRCHAM,3,CHANGE,1,1,0))

 ..S ITEMD=$P(CHANGES,U,4)

 ..S ITEMD0=$G(^PRC(442,PRCHPO,3,ITEMD,0)) I ITEMD="" Q

 ..S DIS=$P($G(^PRC(442,PRCHPO,3,ITEMD,0)),U)

 ..D LINE^PRCHPAM5(.LCNT,2)

 ..S DATA=" *DELETED THROUGH AMENDMENT*" D DATA^PRCHPAM5(.LCNT,DATA)

 ..S DATA=$S(OLD["$":OLD,1:OLD_"%")_" Discount For Items: "_DIS_" is DELETED" D DATA^PRCHPAM5(.LCNT,DATA),LCNT1^PRCHPAM5(LCNT)

 ..Q

 .Q

 Q