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

PRCHSF3.m

Go to the documentation of this file.
  1. PRCHSF3 ;WISC/DJM-UPDATING THE LINE ITEM DISCOUNTS ON THE 'AMENDED' 443.6 RECORD ;8/31/95 11:29 AM
  1. V ;;5.1;IFCAP;**118,138**;Oct 20, 2000;Build 18
  1. ;Per VHA Directive 2004-038, this routine should not be modified.
  1. ;GO THROUGH ALL LINE ITEMS AND CREATE 'PRCH("AM",PRCHCN)' ARRAY
  1. ;PRCHCN CAN BE A 'CONTRACT NUMBER' OR '.OM'.
  1. ;PRCH("AM",PRCHCN) HAS 3 "^" PARTS.
  1. ; PART 1 = NUMBER OF LINE ITEMS IN THIS ARRAY ELEMENT.
  1. ; PART 2 = TOTAL $AMOUNT OF ALL LINE ITEMS IN ARRAY ELEMENT.
  1. ; PART 3 = LISTING OF ALL LINE NUMBERS IN THIS ARRAY ELEMENT.
  1. ;THE LISTING IS SAVED IN THE FORMAT NEEDED TO USE WITHIN A MUMPS
  1. ;'FOR' COMMAND. FOR EXAMPLE: 1:1:2,4,6,8:11,
  1. ;
  1. N PRCH,PRCHDSC,PRCHEC,I,PRCHAMX,PRCHCN,PRCHLI,PRCHLCNT,K,TOT,K2,SHIP,OTOT,DIF,PRCHL0,PRCHL3,J,PRCHL1,PRCHL2,PRCHAC
  1. N PRCHACT,PRCHP,PRCHAMT,Y,PRCHN,PRCHD,PRCHDA,PRCHX,RDIS
  1. S PRCHPO=$S($D(PRCHPO):PRCHPO,1:D0),PRCHAM=$S($D(PRCHAM):PRCHAM,1:D1)
  1. D MVDIS^PRCHMA3
  1. ;REALIGN CONTRACT #/DISCOUNT ENTRIES - added via patch PRC*5.1*138
  1. A1 S PRCH=0 F S PRCH=$O(^PRC(443.6,PRCHPO,2,PRCH)),PRCHDSC=0 Q:+PRCH'>0 D
  1. . S PRCHCN=$P($G(^PRC(443.6,PRCHPO,2,PRCH,2)),U,2)
  1. . F S PRCHDSC=$O(^PRC(443.6,PRCHPO,3,PRCHDSC)) Q:+PRCHDSC'>0 D
  1. .. S RDIS=$G(^PRC(443.6,PRCHPO,3,PRCHDSC,0)) Q:RDIS=""
  1. .. I +RDIS=PRCH,PRCHCN'=$P(RDIS,U,5) S $P(^PRC(443.6,PRCHPO,3,PRCHDSC,0),U,5)=PRCHCN
  1. K PRCH,PRCHDSC,PRCHCN,RDIS
  1. B ;LOOP THROUGH ALL LINE ITEM ENTRIES AND ADD/UPDATE THE 'PRCH("AM",PRCHCN)' ARRAY.
  1. S (PRCH,PRCHEC)=0
  1. F I=1:1 S PRCH=$O(^PRC(443.6,PRCHPO,2,PRCH)) Q:PRCH=""!(PRCH'>0) D
  1. .S PRCHAMX=$G(^PRC(443.6,PRCHPO,2,PRCH,2)) I PRCHAMX]"" D
  1. ..S $P(PRCHAMX,U,6)="",^PRC(443.6,PRCHPO,2,PRCH,2)=PRCHAMX
  1. ..S PRCHCN=$P(PRCHAMX,U,2),PRCHAMX=+$P(PRCHAMX,U),PRCHLI=I
  1. ..D CN:PRCHCN]"",OM:PRCHCN=""
  1. ..Q
  1. .Q
  1. S PRCHLCNT=I-1 S:$D(^PRC(443.6,PRCHPO,2,0)) $P(^(0),U,3,4)="1^"_PRCHLCNT
  1. D UP
  1. TOT ;NOW LETS GET THE TOTAL FOR THIS DOCUMENT.
  1. S (K,TOT)=0 F S K=$O(^PRC(443.6,PRCHPO,2,K)) Q:K'>0 S K2=$G(^(K,2)) I K2]"" S TOT=TOT+$P(K2,U)-$P(K2,U,6)
  1. S SHIP=$P(^PRC(443.6,PRCHPO,0),U,13),TOT=TOT+SHIP,OTOT=$P(^PRC(442,PRCHPO,0),U,15),DIF=TOT-OTOT
  1. S $P(^PRC(443.6,PRCHPO,6,PRCHAM,0),U,3)=DIF
  1. S $P(^PRC(443.6,PRCHPO,0),U,15)=TOT
  1. Q
  1. ;
  1. LI ;CREAT THE ENTRY FOR THE 3rd "^" PIECE OF PRCH("AM",PRCHCN) HERE.
  1. S PRCHL0=$P(PRCH("AM",PRCHL3),U,3) Q:PRCHL0="" F J=1:1 S PRCHL1=$E(PRCHL0,$L(PRCHL0)-J) Q:PRCHL1'=+PRCHL1
  1. S PRCHL2=$E(PRCHL0,$L(PRCHL0)-J+1,$L(PRCHL0)-1),PRCHL2=PRCHL2+1 I PRCHL2'=PRCHLI S PRCHLI=PRCHL0_PRCHLI Q
  1. I PRCHL1=":" S PRCHLI=$E(PRCHL0,1,$L(PRCHL0)-J)_PRCHLI Q
  1. S PRCHLI=$E(PRCHL0,1,$L(PRCHL0)-1)_":1:"_PRCHLI
  1. Q
  1. ;
  1. CN ;CREATE THE 'PRCH("AM",PRCHCN)' ARRAY ELEMENT HERE, ALL THREE PARTS, FOR LINE ITEMS WITH A CONTRACT NUMBER.
  1. S:'$D(PRCH("AM",PRCHCN)) PRCH("AM",PRCHCN)="",PRCHEC=PRCHEC+1 S PRCHL3=PRCHCN
  1. D LI S PRCH("AM",PRCHCN)=($P(PRCH("AM",PRCHCN),U,1)+1)_U_($P(PRCH("AM",PRCHCN),U,2)+PRCHAMX)_U_PRCHLI_",",^PRC(443.6,PRCHPO,2,"AC",$E(PRCHCN,1,30),PRCH)=""
  1. Q
  1. ;
  1. OM ;CREATE THE 'PRCH("AM",PRCHCN)' ARRAY ELEMENT HERE, ALL THREE PARTS, FOR LINE ITEMS WITHOUT A CONTRACT NUMBER.
  1. S:'$D(PRCH("AM",".OM")) PRCH("AM",".OM")="",PRCHEC=PRCHEC+1 S PRCHL3=".OM" D LI S PRCH("AM",".OM")=($P(PRCH("AM",".OM"),U,1)+1)_U_($P(PRCH("AM",".OM"),U,2)+PRCHAMX)_U_PRCHLI_","
  1. Q
  1. ;
  1. UP ;NOW LETS DO THE ACTUAL UPDATING OF THE DISCOUNT FOR EACH LINE ITEM.
  1. ;
  1. S PRCH=0
  1. F I=1:1 S PRCH=$O(^PRC(443.6,PRCHPO,3,PRCH)) Q:PRCH=""!(PRCH'>0) S PRCHCN=$S($P(^(PRCH,0),U,5)]"":$P(^(0),U,5),1:".OM"),PRCHAC=$P(^(0),U,1),PRCHACT=$P(^(0),U,4),PRCHP=$P(^(0),U,2) D SET
  1. Q
  1. ;
  1. SET ;DECIDE THE LINE ITEM NUMBERS TO DO THE DISCOUNT ADJUSTMENT.
  1. G:PRCHAC="Q" PCTQ
  1. I PRCHAC[":" S PRCHAC=$P(PRCHAC,":",1)_":1:"_$P(PRCHAC,":",2)
  1. ;
  1. PCT ;FOR EACH 'LINE ITEM NUMBER' WITH A DISCOUNT DO IT HERE.
  1. S PRCHAMT=0,Y="F J="_PRCHAC_" S PRCHN=J D PCT1" X Y
  1. S PRCHAMT=PRCHAMT*100+.5\1/100,$P(PRCH("AM",PRCHCN),U,2)=$P(PRCH("AM",PRCHCN),U,2)-PRCHAMT
  1. Q
  1. ;
  1. PCT1 S PRCHN=$O(^PRC(443.6,PRCHPO,2,"B",PRCHN,0)),PRCHD=+$P($G(^PRC(443.6,PRCHPO,2,PRCHN,2)),U,1)
  1. I $E(PRCHP,1)="$" S PRCHDA=$P(PRCHP,"$",2)/PRCHACT
  1. E S PRCHDA=$J(PRCHD*(PRCHP/100),0,2)
  1. S PRCHAMT=PRCHAMT+PRCHDA,$P(^PRC(443.6,PRCHPO,2,PRCHN,2),U,6)=PRCHDA
  1. Q
  1. ;
  1. PCTQ ;COME HERE IF THE USER SELECTED A 'QUANTITY' DISCOUNT.
  1. ;
  1. S (PRCHAMT,PRCHCN,PRCHX)=0,PRCHACT=PRCHLCNT F K=0:0 S PRCHCN=$O(PRCH("AM",PRCHCN)) Q:PRCHCN="" S PRCHAC=$E($P(PRCH("AM",PRCHCN),U,3),1,$L($P(PRCH("AM",PRCHCN),U,3))-1) D PCT S PRCHX=PRCHX+PRCHAMT
  1. S $P(^PRC(443.6,PRCHPO,3,PRCH,0),U,3)=PRCHX
  1. Q