- 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 Jan 18, 2025@03:11:54 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