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