PRCHDP9 ;WISC/DJM-PRINT AMENDMENT,ROUTINE #5 ;12/12/95 9:22 AM
V ;;5.1;IFCAP;;Oct 20, 2000
;Per VHA Directive 10-93-142, this routine should not be modified.
;
E34 ;AUTHORITY Edit PRINT
;N CHANGE,CHANGES,OLD,NEW,LCNT,DATA,DT2,I
S CHANGE=0 D LCNT^PRCHDP9(.LCNT)
F S CHANGE=$O(^PRC(442,PRCHPO,6,PRCHAM,3,"AC",AMEND,3,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 NEW=$P($G(^PRC(442,PRCHPO,6,PRCHAM,0)),U,4)
.D LINE^PRCHDP9(.LCNT,2)
.I OLD=0 S DATA=" *ADDED THROUGH AMENDMENT*" D DATA^PRCHDP9(.LCNT,DATA) D
..S DATA="Authority Edit is",DT2=$P(^PRCD(442.2,NEW,0),U,2) D D DATA^PRCHDP9(.LCNT,DATA)
...I $L(DATA)+$L(DT2)>239 S DATA=DATA_":" D DATA^PRCHDP9(.LCNT,DATA) S DATA=DT2 Q
...S DATA=DATA_" "_DT2
.I OLD>0 S DATA="Authority Edit " D D DATA(.LCNT,DATA)
..F I=1:1:3 S DT2=$S(I=1:$P(^PRCD(442.2,OLD,0),U,2),I=2:" has been changed to ",I=3:$P(^PRCD(442.2,NEW,0),U,2)) D CHK(.DATA,DT2)
.D LCNT1^PRCHDP9(LCNT)
.Q
Q
;
CHK(DATA,DT2) ;
I $L(DATA)+$L(DT2)<241 S DATA=DATA_DT2 Q
D DATA(.LCNT,DATA) S DATA=DT2
Q
E35 ;F.O.B. Point PRINT
Q
;N CHANGE,OLD,NEW
S CHANGE=0 D LCNT^PRCHDP9(.LCNT)
F S CHANGE=$O(^PRC(442,PRCHPO,6,PRCHAM,3,"AC",AMEND,6.4,CHANGE)) Q:CHANGE'>0 D
.S OLD=$G(^PRC(442,PRCHPO,6,PRCHAM,3,CHANGE,1,1,0)),NEW=$P($G(^PRC(442,PRCHPO,1)),U,6)
.D LINE^PRCHPAM5(.LCNT,2)
.S DATA="F.O.B. Point "_OLD_" has been changed to "_NEW D DATA^PRCHDP9(.LCNT,DATA)
.D LCNT1^PRCHDP9(LCNT)
.Q
Q
;
E36 ;ITEM DISCOUNT Add/Edit PRINT
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^PRCHDP9(.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 ;Remove old values before they get reset 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
..;If an entry is found in 'AC' x-ref for PERCENT/DOLLAR AMOUNT field #1, then lookup for the ITEM field #.01 and for the same item define var DIS2.
..;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 lookup for PERCENT/DOLLAR AMOUNT field #1 and for the 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^PRCHDP9(.LCNT,2)
..S DIS2=$G(DIS2),PCT2=$G(PCT2)
..;I DIS2=0 S DATA=" *ADDED THROUGH AMENDMENT*" D DATA^PRCHDP9(.LCNT,DATA) D
..I FLAGDISC=0 S DATA=" *ADDED THROUGH AMENDMENT*" D DATA^PRCHDP9(.LCNT,DATA) D Q
...S DATA=$S(NEWP["$":NEWP,1:NEWP_"%")_" Discount For Item(s): "_NEWI D DATA^PRCHDP9(.LCNT,DATA) Q
..;The new entry is completed with FLAGDISC=0, the existing entries will be dealt with the following conditional code
..I DIS2]"",PCT2]"" S DATA=$S(PCT2["$":PCT2,1:PCT2_"%")_" Discount For Item(s): "_DIS2 D DATA^PRCHDP9(.LCNT,DATA) D Q
...S DATA=" Will now be AMENDED to read "_$S(NEWP["$":NEWP,1:NEWP_"%")_" discount for an item(s): "_NEWI D DATA^PRCHDP9(.LCNT,DATA) Q
..;If only field PERCENT/DOLLAR AMOUNT #1 is changed.
..I PCT2]"" S DATA=" The discount on item(s) "_NEWI_" will now be AMENDED to read "_$S(NEWP["$":NEWP,1:NEWP_"%") D DATA^PRCHDP9(.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^PRCHDP9(.LCNT,DATA) Q
.Q
D LCNT1^PRCHDP9(LCNT)
Q
;
E37 ;ITEM DISCOUNT Delete PRINT
;N CHANGE,CHANGES,OLD,LCNT,DATA,DIS,ITEMD,ITEMD0
S FIELD=0 K ITEMD D LCNT^PRCHDP9(.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^PRCHDP9(.LCNT,2)
..S DATA=" *DELETED THROUGH AMENDMENT*" D DATA^PRCHDP9(.LCNT,DATA)
..S DATA=$S(OLD["$":OLD,1:OLD_"%")_" Discount For Items: "_DIS_" is DELETED" D DATA^PRCHDP9(.LCNT,DATA),LCNT1^PRCHDP9(LCNT)
..Q
.Q
Q
LCNT(LCNT) ;FETCH THE CURRENT LINE COUNT FROM "W" ARRAY
S LCNT=+$G(^TMP($J,"W",1))
Q
;
LINE(LCNT,LINES) ;ADDS A NUMBER OF BLANK "LINES" INTO "W" ARRAY
N I
F I=1:1:LINES S LCNT=LCNT+1,^TMP($J,"W",1,LCNT,0)=" "
Q
;
DATA(LCNT,DATA) ;PLACES THE AMENDMENT LINE OF TEXT INTO THE "W" ARRAY
S LCNT=LCNT+1,^TMP($J,"W",1,LCNT,0)=DATA
Q
;
LCNT1(LCNT) ;PUT BACK LCNT INTO "W" ARRAY
S ^TMP($J,"W",1)=LCNT
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCHDP9 5439 printed Sep 23, 2025@19:42:53 Page 2
PRCHDP9 ;WISC/DJM-PRINT AMENDMENT,ROUTINE #5 ;12/12/95 9:22 AM
V ;;5.1;IFCAP;;Oct 20, 2000
+1 ;Per VHA Directive 10-93-142, this routine should not be modified.
+2 ;
E34 ;AUTHORITY Edit PRINT
+1 ;N CHANGE,CHANGES,OLD,NEW,LCNT,DATA,DT2,I
+2 SET CHANGE=0
DO LCNT^PRCHDP9(.LCNT)
+3 FOR
SET CHANGE=$ORDER(^PRC(442,PRCHPO,6,PRCHAM,3,"AC",AMEND,3,CHANGE))
if CHANGE'>0
QUIT
Begin DoDot:1
+4 SET CHANGES=$GET(^PRC(442,PRCHPO,6,PRCHAM,3,CHANGE,0))
SET OLD=$GET(^PRC(442,PRCHPO,6,PRCHAM,3,CHANGE,1,1,0))
+5 SET NEW=$PIECE($GET(^PRC(442,PRCHPO,6,PRCHAM,0)),U,4)
+6 DO LINE^PRCHDP9(.LCNT,2)
+7 IF OLD=0
SET DATA=" *ADDED THROUGH AMENDMENT*"
DO DATA^PRCHDP9(.LCNT,DATA)
Begin DoDot:2
+8 SET DATA="Authority Edit is"
SET DT2=$PIECE(^PRCD(442.2,NEW,0),U,2)
Begin DoDot:3
+9 IF $LENGTH(DATA)+$LENGTH(DT2)>239
SET DATA=DATA_":"
DO DATA^PRCHDP9(.LCNT,DATA)
SET DATA=DT2
QUIT
+10 SET DATA=DATA_" "_DT2
End DoDot:3
DO DATA^PRCHDP9(.LCNT,DATA)
End DoDot:2
+11 IF OLD>0
SET DATA="Authority Edit "
Begin DoDot:2
+12 FOR I=1:1:3
SET DT2=$SELECT(I=1:$PIECE(^PRCD(442.2,OLD,0),U,2),I=2:" has been changed to ",I=3:$PIECE(^PRCD(442.2,NEW,0),U,2))
DO CHK(.DATA,DT2)
End DoDot:2
DO DATA(.LCNT,DATA)
+13 DO LCNT1^PRCHDP9(LCNT)
+14 QUIT
End DoDot:1
+15 QUIT
+16 ;
CHK(DATA,DT2) ;
+1 IF $LENGTH(DATA)+$LENGTH(DT2)<241
SET DATA=DATA_DT2
QUIT
+2 DO DATA(.LCNT,DATA)
SET DATA=DT2
+3 QUIT
E35 ;F.O.B. Point PRINT
+1 QUIT
+2 ;N CHANGE,OLD,NEW
+3 SET CHANGE=0
DO LCNT^PRCHDP9(.LCNT)
+4 FOR
SET CHANGE=$ORDER(^PRC(442,PRCHPO,6,PRCHAM,3,"AC",AMEND,6.4,CHANGE))
if CHANGE'>0
QUIT
Begin DoDot:1
+5 SET OLD=$GET(^PRC(442,PRCHPO,6,PRCHAM,3,CHANGE,1,1,0))
SET NEW=$PIECE($GET(^PRC(442,PRCHPO,1)),U,6)
+6 DO LINE^PRCHPAM5(.LCNT,2)
+7 SET DATA="F.O.B. Point "_OLD_" has been changed to "_NEW
DO DATA^PRCHDP9(.LCNT,DATA)
+8 DO LCNT1^PRCHDP9(LCNT)
+9 QUIT
End DoDot:1
+10 QUIT
+11 ;
E36 ;ITEM DISCOUNT Add/Edit PRINT
+1 NEW CHANGE,CHANGES,FIELD,OLD,NEW,ITEMD,ITEMD0,NEWI,NEWP,LCNT,DATA,DIS,DIS1,DIS2,PCT,PCT1,PCT2,FLAGDISC
+2 SET FIELD=0
KILL ITEMD
DO LCNT^PRCHDP9(.LCNT)
+3 FOR
SET FIELD=$ORDER(^PRC(442,PRCHPO,6,PRCHAM,3,"AC",AMEND,FIELD))
if FIELD'>0
QUIT
Begin DoDot:1
+4 SET CHANGE=0
FOR
SET CHANGE=$ORDER(^PRC(442,PRCHPO,6,PRCHAM,3,"AC",AMEND,FIELD,CHANGE))
if CHANGE'>0
QUIT
Begin DoDot:2
+5 SET CHANGES=$GET(^PRC(442,PRCHPO,6,PRCHAM,3,CHANGE,0))
+6 SET OLD=$GET(^PRC(442,PRCHPO,6,PRCHAM,3,CHANGE,1,1,0))
+7 ;Remove old values before they get reset in the loop.
KILL DIS2,PCT2
+8 if FIELD=.01
SET DIS2=OLD
+9 if FIELD=1
SET PCT2=OLD
+10 ;FLAGDISC=0 means a new entry,FLAGDISC=1 means an existing entry.
SET FLAGDISC=$SELECT(OLD=0:0,1:1)
+11 SET ITEMD=$PIECE(CHANGES,U,4)
if $DATA(ITEMD(ITEMD))
QUIT
SET ITEMD(ITEMD)=1
+12 SET ITEMD0=$GET(^PRC(442,PRCHPO,3,ITEMD,0))
IF ITEMD0=""
QUIT
+13 ;If an entry is found in 'AC' x-ref for PERCENT/DOLLAR AMOUNT field #1, then lookup for the ITEM field #.01 and for the same item define var DIS2.
+14 ;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
+15 ;.S DIS2=$G(^PRC(442,PRCHPO,6,PRCHAM,3,DIS,1,1,0)) Q
+16 ;If an entry is found in 'AC' x-ref for the ITEM field #.01, then lookup for PERCENT/DOLLAR AMOUNT field #1 and for the same item define var PCT2.
+17 IF FIELD=.01
SET PCT=0
FOR
SET PCT=$ORDER(^PRC(442,PRCHPO,6,PRCHAM,3,"AC",36,1,PCT))
if PCT'>0
QUIT
SET PCT1=$PIECE($GET(^PRC(442,PRCHPO,6,PRCHAM,3,PCT,0)),U,4)
IF PCT1=ITEMD
Begin DoDot:3
+18 SET PCT2=$GET(^PRC(442,PRCHPO,6,PRCHAM,3,PCT,1,1,0))
QUIT
End DoDot:3
QUIT
+19 SET NEW=$GET(^PRC(442,PRCHPO,3,ITEMD,0))
SET NEWP=$PIECE(NEW,U,2)
SET NEWI=$PIECE(NEW,U)
+20 DO LINE^PRCHDP9(.LCNT,2)
+21 SET DIS2=$GET(DIS2)
SET PCT2=$GET(PCT2)
+22 ;I DIS2=0 S DATA=" *ADDED THROUGH AMENDMENT*" D DATA^PRCHDP9(.LCNT,DATA) D
+23 IF FLAGDISC=0
SET DATA=" *ADDED THROUGH AMENDMENT*"
DO DATA^PRCHDP9(.LCNT,DATA)
Begin DoDot:3
+24 SET DATA=$SELECT(NEWP["$":NEWP,1:NEWP_"%")_" Discount For Item(s): "_NEWI
DO DATA^PRCHDP9(.LCNT,DATA)
QUIT
End DoDot:3
QUIT
+25 ;The new entry is completed with FLAGDISC=0, the existing entries will be dealt with the following conditional code
+26 IF DIS2]""
IF PCT2]""
SET DATA=$SELECT(PCT2["$":PCT2,1:PCT2_"%")_" Discount For Item(s): "_DIS2
DO DATA^PRCHDP9(.LCNT,DATA)
Begin DoDot:3
+27 SET DATA=" Will now be AMENDED to read "_$SELECT(NEWP["$":NEWP,1:NEWP_"%")_" discount for an item(s): "_NEWI
DO DATA^PRCHDP9(.LCNT,DATA)
QUIT
End DoDot:3
QUIT
+28 ;If only field PERCENT/DOLLAR AMOUNT #1 is changed.
+29 IF PCT2]""
SET DATA=" The discount on item(s) "_NEWI_" will now be AMENDED to read "_$SELECT(NEWP["$":NEWP,1:NEWP_"%")
DO DATA^PRCHDP9(.LCNT,DATA)
QUIT
+30 ;If only field ITEM #.01 is changed.
+31 IF DIS2]""
SET DATA=" The item(s) "_DIS2_" will now be AMENDED to read "_NEWI
DO DATA^PRCHDP9(.LCNT,DATA)
QUIT
End DoDot:2
+32 QUIT
End DoDot:1
+33 DO LCNT1^PRCHDP9(LCNT)
+34 QUIT
+35 ;
E37 ;ITEM DISCOUNT Delete PRINT
+1 ;N CHANGE,CHANGES,OLD,LCNT,DATA,DIS,ITEMD,ITEMD0
+2 SET FIELD=0
KILL ITEMD
DO LCNT^PRCHDP9(.LCNT)
+3 FOR
SET FIELD=$ORDER(^PRC(442,PRCHPO,6,PRCHAM,3,"AC",AMEND,FIELD))
if FIELD'>0
QUIT
Begin DoDot:1
+4 SET CHANGE=0
FOR
SET CHANGE=$ORDER(^PRC(442,PRCHPO,6,PRCHAM,3,"AC",AMEND,FIELD,CHANGE))
if CHANGE'>0
QUIT
Begin DoDot:2
+5 SET CHANGES=$GET(^PRC(442,PRCHPO,6,PRCHAM,3,CHANGE,0))
SET OLD=$GET(^PRC(442,PRCHPO,6,PRCHAM,3,CHANGE,1,1,0))
+6 SET ITEMD=$PIECE(CHANGES,U,4)
+7 SET ITEMD0=$GET(^PRC(442,PRCHPO,3,ITEMD,0))
IF ITEMD=""
QUIT
+8 SET DIS=$PIECE($GET(^PRC(442,PRCHPO,3,ITEMD,0)),U)
+9 DO LINE^PRCHDP9(.LCNT,2)
+10 SET DATA=" *DELETED THROUGH AMENDMENT*"
DO DATA^PRCHDP9(.LCNT,DATA)
+11 SET DATA=$SELECT(OLD["$":OLD,1:OLD_"%")_" Discount For Items: "_DIS_" is DELETED"
DO DATA^PRCHDP9(.LCNT,DATA)
DO LCNT1^PRCHDP9(LCNT)
+12 QUIT
End DoDot:2
+13 QUIT
End DoDot:1
+14 QUIT
LCNT(LCNT) ;FETCH THE CURRENT LINE COUNT FROM "W" ARRAY
+1 SET LCNT=+$GET(^TMP($JOB,"W",1))
+2 QUIT
+3 ;
LINE(LCNT,LINES) ;ADDS A NUMBER OF BLANK "LINES" INTO "W" ARRAY
+1 NEW I
+2 FOR I=1:1:LINES
SET LCNT=LCNT+1
SET ^TMP($JOB,"W",1,LCNT,0)=" "
+3 QUIT
+4 ;
DATA(LCNT,DATA) ;PLACES THE AMENDMENT LINE OF TEXT INTO THE "W" ARRAY
+1 SET LCNT=LCNT+1
SET ^TMP($JOB,"W",1,LCNT,0)=DATA
+2 QUIT
+3 ;
LCNT1(LCNT) ;PUT BACK LCNT INTO "W" ARRAY
+1 SET ^TMP($JOB,"W",1)=LCNT
+2 QUIT
