- 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 Feb 18, 2025@23:33:12 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