- PRCHAMYC ;WISC/DJM-UPDATING THE LINE ITEM DISCOUNTS ON THE AMENDED 442 RECORD ;2/17/95 11:00 AM
- V ;;5.1;IFCAP;**91**;Oct 20, 2000
- ;Per VHA Directive 10-93-142, 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,
- ;
- ;kill existing PRCH("AM") array data
- K PRCH("AM")
- ;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(442,PRCHPO,2,PRCH)) Q:PRCH=""!(PRCH'>0) D
- .S PRCHAMX=$G(^PRC(442,PRCHPO,2,PRCH,2))
- .S $P(PRCHAMX,U,6)="",^PRC(442,PRCHPO,2,PRCH,2)=PRCHAMX
- .S PRCHCN=$P(PRCHAMX,U,2),PRCHAMX=$P(PRCHAMX,U),PRCHLI=I
- .D CN:PRCHCN]"",OM:PRCHCN=""
- .Q
- S PRCHLCNT=I-1 S:$D(^PRC(442,PRCHPO,2,0)) $P(^(0),U,3,4)="1^"_PRCHLCNT
- G UP
- ;
- 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(442,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(442,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 G:$D(PRCHER) Q" X Y
- S PRCHAMT=PRCHAMT*100+.5\1/100,$P(PRCH("AM",PRCHCN),U,2)=$P(PRCH("AM",PRCHCN),U,2)-PRCHAMT
- S $P(^PRC(442,PRCHPO,3,PRCH,0),U,3)=PRCHAMT,$P(^(0),U,6)=I+PRCHLCNT
- Q
- ;
- PCT1 S PRCHN=$O(^PRC(442,PRCHPO,2,"B",PRCHN,0)),PRCHD=+$P($G(^PRC(442,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(442,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(442,PRCHPO,3,PRCH,0),U,3)=PRCHX
- Q
- ;
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCHAMYC 3552 printed Feb 18, 2025@23:32:24 Page 2
- PRCHAMYC ;WISC/DJM-UPDATING THE LINE ITEM DISCOUNTS ON THE AMENDED 442 RECORD ;2/17/95 11:00 AM
- V ;;5.1;IFCAP;**91**;Oct 20, 2000
- +1 ;Per VHA Directive 10-93-142, 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 ;kill existing PRCH("AM") array data
- +12 KILL PRCH("AM")
- +13 ;LOOP THROUGH ALL LINE ITEM ENTRIES AND ADD/UPDATE THE 'PRCH("AM",PRCHCN)' ARRAY.
- +14 SET (PRCH,PRCHEC)=0
- FOR I=1:1
- SET PRCH=$ORDER(^PRC(442,PRCHPO,2,PRCH))
- if PRCH=""!(PRCH'>0)
- QUIT
- Begin DoDot:1
- +15 SET PRCHAMX=$GET(^PRC(442,PRCHPO,2,PRCH,2))
- +16 SET $PIECE(PRCHAMX,U,6)=""
- SET ^PRC(442,PRCHPO,2,PRCH,2)=PRCHAMX
- +17 SET PRCHCN=$PIECE(PRCHAMX,U,2)
- SET PRCHAMX=$PIECE(PRCHAMX,U)
- SET PRCHLI=I
- +18 if PRCHCN]""
- DO CN
- if PRCHCN=""
- DO OM
- +19 QUIT
- End DoDot:1
- +20 SET PRCHLCNT=I-1
- if $DATA(^PRC(442,PRCHPO,2,0))
- SET $PIECE(^(0),U,3,4)="1^"_PRCHLCNT
- +21 GOTO UP
- +22 ;
- 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(442,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(442,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 G:$D(PRCHER) Q"
- 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 SET $PIECE(^PRC(442,PRCHPO,3,PRCH,0),U,3)=PRCHAMT
- SET $PIECE(^(0),U,6)=I+PRCHLCNT
- +4 QUIT
- +5 ;
- PCT1 SET PRCHN=$ORDER(^PRC(442,PRCHPO,2,"B",PRCHN,0))
- SET PRCHD=+$PIECE($GET(^PRC(442,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(442,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(442,PRCHPO,3,PRCH,0),U,3)=PRCHX
- +4 QUIT
- +5 ;