- PRCHDSP5 ;WISC/DJM-PRINT AMENDMENT, ROUTINE #2 ;9/15/95 11:43 AM
- V ;;5.1;IFCAP;**21**;Oct 20, 2000
- ;Per VHA Directive 10-93-142, this routine should not be modified.
- ;
- E22 ;LINE ITEM Delete PRINT
- N FIELD,CHANGE,CHANGES,OLD,ITEM,ITEM0,ITEM1,ITEM2,LCNT,DATA,I,UOP
- S FIELD=0 K ITEM D LCNT^PRCHPAM5(.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=^PRC(442,PRCHPO,6,PRCHAM,3,CHANGE,0),OLD=^PRC(442,PRCHPO,6,PRCHAM,3,CHANGE,1,1,0)
- ..S ITEM=$P(CHANGES,U,4) Q:$D(ITEM(ITEM)) S ITEM(ITEM)=1
- ..S ITEM0=$G(^PRC(442,PRCHPO,2,ITEM,0))
- ..I ITEM0="" Q
- ..S ITEM1=$G(^PRC(442,PRCHPO,2,ITEM,1,1,0))
- ..D LINE^PRCHPAM5(.LCNT,2) S DATA="The following line item has been cancelled:" D DATA^PRCHPAM5(.LCNT,DATA)
- ..S DATA="Item No. "_$P(ITEM0,U)_" Item Master File No. "
- ..S DATA=DATA_$P(ITEM0,U,5)_" BOC: "_+$P(ITEM0,U,4)
- ..S DATA=DATA_" CONTRACT: "_$P($G(^PRC(442,PRCHPO,2,ITEM,2)),U,2)
- ..D DATA^PRCHPAM5(.LCNT,DATA)
- ..D NEW^PRCHDSP6
- ..S UOP=$S($P(ITEM0,U,3)>0:$P($G(^PRCD(420.5,$P(ITEM0,U,3),0)),U),1:"")
- ..S DATA=" Items per "_UOP_": "_$P(ITEM0,U,12)
- ..F I=1:1:26-$L(DATA) S DATA=DATA_" "
- ..S DATA=DATA_"NSN: "_$P(ITEM0,U,13) D DATA^PRCHPAM5(.LCNT,DATA)
- ..I $P(ITEM0,U,6)]"" S DATA=" STK#: "_$P(ITEM0,U,6) D DATA^PRCHPAM5(.LCNT,DATA)
- ..S QTY=$$FETCH(2,ITEM)
- ..S AUC=$$FETCH(5,ITEM)
- ..S UOP=$S($P(ITEM0,U,3)>0:$P($G(^PRCD(420.5,$P(ITEM0,U,3),0)),U),1:"")
- ..S DATA=" "_QTY_" "_UOP_" at $"_$J(AUC,12,4)_" = $"_$J(QTY*AUC,9,2) D DATA^PRCHPAM5(.LCNT,DATA),LCNT1^PRCHPAM5(LCNT)
- Q
- ;
- E23 ;LINE ITEM Edit PRINT
- N FIELD,CHANGE,CHANGES,IMF,BOC,OLD,ITEM,ITEM0,ITEM1,ITEMZ,QTY,AUC,UOP,UOP1,NSN,UCF,LCNT,DATA,DES,VAL,PRCHLN,ABC,VSN,CONOLD,CON442
- S FIELD=0 K ITEM D LCNT^PRCHPAM5(.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=^PRC(442,PRCHPO,6,PRCHAM,3,CHANGE,0),OLD=^PRC(442,PRCHPO,6,PRCHAM,3,CHANGE,1,1,0)
- ..S ITEM=$P(CHANGES,U,4) Q:$D(ITEM(ITEM)) S ITEM(ITEM)=1
- ..S ITEM0=$G(^PRC(442,PRCHPO,2,ITEM,0))
- ..I ITEM0="" Q
- ..I $P(ITEM0,U,2)=0,$P(ITEM0,U,9)=0 Q
- ..S ITEM1=$G(^PRC(442,PRCHPO,2,ITEM,1,1,0))
- ..S (ABC,DES)=$$FETCH(1,ITEM) S PRCHLN=VAL
- ..S IMF=$$FETCH(1.5,ITEM) I IMF'>0 S IMF=$P(ITEM0,U,5)
- ..S BOC=+$$FETCH(3.5,ITEM) I BOC'>0 S BOC=+$P(ITEM0,U,4)
- ..S QTY=$$FETCH(2,ITEM) I QTY'>0 S QTY=$P(ITEM0,U,2)
- ..S AUC=$$FETCH(5,ITEM) I AUC="" S AUC=$P(ITEM0,U,9)
- ..S UOP=$$FETCH(3,ITEM) I UOP'>0 S UOP=$P(ITEM0,U,3)
- ..S NSN=$$FETCH(9.5,ITEM) I NSN="" S NSN=$P(ITEM0,U,13)
- ..S UCF=$$FETCH(3.1,ITEM) I UCF'>0 S UCF=$P(ITEM0,U,12)
- ..S VSN=$$FETCH(9,ITEM) I VSN="" S VSN=$P(ITEM0,U,6)
- ..S CONOLD=$$FETCH(4,ITEM)
- ..S CON442=$P($G(^PRC(442,PRCHPO,2,ITEM,2)),U,2)
- ..I CONOLD="",CON442'="" S CONOLD=CON442
- ..D LINE^PRCHPAM5(.LCNT,2) S DATA="**Currently:"
- ..D DATA^PRCHPAM5(.LCNT,DATA)
- ..S DATA="Item No. "_$P(ITEM0,U)_" Item Master File No. "
- ..S DATA=DATA_IMF_" BOC: "_BOC_" CONTRACT: "_CONOLD
- ..D DATA^PRCHPAM5(.LCNT,DATA)
- ..I $L(ABC)>0 D OLD^PRCHDSP6
- ..I $L(ABC)'>0 S ITEMZ=ITEM1 D NEW^PRCHDSP6
- ..S UOP1=$S($L(UOP)>0:$P($G(^PRCD(420.5,UOP,0)),U),1:"")
- ..S DATA=" Items per "_UOP1_": "_UCF
- ..F I=1:1:26-$L(DATA) S DATA=DATA_" "
- ..S DATA=DATA_"NSN: "_NSN D DATA^PRCHPAM5(.LCNT,DATA)
- ..I $L(VSN)>0 S DATA=" STK#: "_VSN D DATA^PRCHPAM5(.LCNT,DATA)
- ..S UOP1=$S($L(UOP)>0:$P($G(^PRCD(420.5,UOP,0)),U),1:"")
- ..S DATA=" "_QTY_" "_UOP1_" at $"_$J(AUC,12,2)_" = $"_$J(QTY*AUC,9,2) D DATA^PRCHPAM5(.LCNT,DATA)
- ..S DATA=" "
- ..D DATA^PRCHPAM5(.LCNT,DATA)
- ..S DATA=" **Will now be AMENDED to read:" D DATA^PRCHPAM5(.LCNT,DATA)
- ..S DATA="Item No. "_$P(ITEM0,U)_" Item Master File No. "
- ..S DATA=DATA_$P(ITEM0,U,5)_" BOC: "_+$P(ITEM0,U,4)
- ..S DATA=DATA_" CONTRACT: "_CON442
- ..D DATA^PRCHPAM5(.LCNT,DATA)
- ..S:$D(ITEMZ) ITEM1=ITEMZ D NEW^PRCHDSP6
- ..S UOP1=$S($P(ITEM0,U,3)>0:$P($G(^PRCD(420.5,$P(ITEM0,U,3),0)),U),1:"")
- ..S DATA=" Items per "_UOP1_": "_$P(ITEM0,U,12)
- ..F I=1:1:26-$L(DATA) S DATA=DATA_" "
- ..S DATA=DATA_"NSN: "_$P(ITEM0,U,13) D DATA^PRCHPAM5(.LCNT,DATA)
- ..I $P(ITEM0,U,6)]"" S DATA=" STK#: "_$P(ITEM0,U,6) D DATA^PRCHPAM5(.LCNT,DATA)
- ..S UOP1=$S($P(ITEM0,U,3)>0:$P($G(^PRCD(420.5,$P(ITEM0,U,3),0)),U),1:"")
- ..S DATA=" "_$P(ITEM0,U,2)_" "_UOP1_" $"_$J($P(ITEM0,U,9),12,4)_" = $"_$J($P(ITEM0,U,2)*$P(ITEM0,U,9),9,2)
- ..D DATA^PRCHPAM5(.LCNT,DATA),LCNT1^PRCHPAM5(LCNT)
- Q
- ;
- FETCH(FIELD,ITEM) ;EXTRINSIC FUNCTION TO RETURN THE 'VALUE' FOR A FIELD FROM 'LINE ITEM
- ;AMENDMENT' OPTIONS.
- N VAL1
- S VAL=0 F S VAL=$O(^PRC(442,PRCHPO,6,PRCHAM,3,"AC",21,FIELD,VAL)) Q:VAL'>0 S VAL1=$P(^PRC(442,PRCHPO,6,PRCHAM,3,VAL,0),U,4) I VAL1=ITEM S VAL1=0 G EXIT
- S VAL=0 F S VAL=$O(^PRC(442,PRCHPO,6,PRCHAM,3,"AC",22,FIELD,VAL)) Q:VAL'>0 S VAL1=$P(^PRC(442,PRCHPO,6,PRCHAM,3,VAL,0),U,4) I VAL1=ITEM D G EXIT
- .S VAL1=^PRC(442,PRCHPO,6,PRCHAM,3,VAL,1,1,0)
- .Q
- S VAL=0 F S VAL=$O(^PRC(442,PRCHPO,6,PRCHAM,3,"AC",23,FIELD,VAL)) Q:VAL'>0 S VAL1=$P(^PRC(442,PRCHPO,6,PRCHAM,3,VAL,0),U,4) I VAL1=ITEM D G EXIT
- .S VAL1=^PRC(442,PRCHPO,6,PRCHAM,3,VAL,1,1,0)
- .Q
- S VAL1=""
- EXIT Q VAL1
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCHDSP5 5397 printed Jan 18, 2025@03:08:09 Page 2
- PRCHDSP5 ;WISC/DJM-PRINT AMENDMENT, ROUTINE #2 ;9/15/95 11:43 AM
- V ;;5.1;IFCAP;**21**;Oct 20, 2000
- +1 ;Per VHA Directive 10-93-142, this routine should not be modified.
- +2 ;
- E22 ;LINE ITEM Delete PRINT
- +1 NEW FIELD,CHANGE,CHANGES,OLD,ITEM,ITEM0,ITEM1,ITEM2,LCNT,DATA,I,UOP
- +2 SET FIELD=0
- KILL ITEM
- DO LCNT^PRCHPAM5(.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=^PRC(442,PRCHPO,6,PRCHAM,3,CHANGE,0)
- SET OLD=^PRC(442,PRCHPO,6,PRCHAM,3,CHANGE,1,1,0)
- +6 SET ITEM=$PIECE(CHANGES,U,4)
- if $DATA(ITEM(ITEM))
- QUIT
- SET ITEM(ITEM)=1
- +7 SET ITEM0=$GET(^PRC(442,PRCHPO,2,ITEM,0))
- +8 IF ITEM0=""
- QUIT
- +9 SET ITEM1=$GET(^PRC(442,PRCHPO,2,ITEM,1,1,0))
- +10 DO LINE^PRCHPAM5(.LCNT,2)
- SET DATA="The following line item has been cancelled:"
- DO DATA^PRCHPAM5(.LCNT,DATA)
- +11 SET DATA="Item No. "_$PIECE(ITEM0,U)_" Item Master File No. "
- +12 SET DATA=DATA_$PIECE(ITEM0,U,5)_" BOC: "_+$PIECE(ITEM0,U,4)
- +13 SET DATA=DATA_" CONTRACT: "_$PIECE($GET(^PRC(442,PRCHPO,2,ITEM,2)),U,2)
- +14 DO DATA^PRCHPAM5(.LCNT,DATA)
- +15 DO NEW^PRCHDSP6
- +16 SET UOP=$SELECT($PIECE(ITEM0,U,3)>0:$PIECE($GET(^PRCD(420.5,$PIECE(ITEM0,U,3),0)),U),1:"")
- +17 SET DATA=" Items per "_UOP_": "_$PIECE(ITEM0,U,12)
- +18 FOR I=1:1:26-$LENGTH(DATA)
- SET DATA=DATA_" "
- +19 SET DATA=DATA_"NSN: "_$PIECE(ITEM0,U,13)
- DO DATA^PRCHPAM5(.LCNT,DATA)
- +20 IF $PIECE(ITEM0,U,6)]""
- SET DATA=" STK#: "_$PIECE(ITEM0,U,6)
- DO DATA^PRCHPAM5(.LCNT,DATA)
- +21 SET QTY=$$FETCH(2,ITEM)
- +22 SET AUC=$$FETCH(5,ITEM)
- +23 SET UOP=$SELECT($PIECE(ITEM0,U,3)>0:$PIECE($GET(^PRCD(420.5,$PIECE(ITEM0,U,3),0)),U),1:"")
- +24 SET DATA=" "_QTY_" "_UOP_" at $"_$JUSTIFY(AUC,12,4)_" = $"_$JUSTIFY(QTY*AUC,9,2)
- DO DATA^PRCHPAM5(.LCNT,DATA)
- DO LCNT1^PRCHPAM5(LCNT)
- End DoDot:2
- End DoDot:1
- +25 QUIT
- +26 ;
- E23 ;LINE ITEM Edit PRINT
- +1 NEW FIELD,CHANGE,CHANGES,IMF,BOC,OLD,ITEM,ITEM0,ITEM1,ITEMZ,QTY,AUC,UOP,UOP1,NSN,UCF,LCNT,DATA,DES,VAL,PRCHLN,ABC,VSN,CONOLD,CON442
- +2 SET FIELD=0
- KILL ITEM
- DO LCNT^PRCHPAM5(.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=^PRC(442,PRCHPO,6,PRCHAM,3,CHANGE,0)
- SET OLD=^PRC(442,PRCHPO,6,PRCHAM,3,CHANGE,1,1,0)
- +6 SET ITEM=$PIECE(CHANGES,U,4)
- if $DATA(ITEM(ITEM))
- QUIT
- SET ITEM(ITEM)=1
- +7 SET ITEM0=$GET(^PRC(442,PRCHPO,2,ITEM,0))
- +8 IF ITEM0=""
- QUIT
- +9 IF $PIECE(ITEM0,U,2)=0
- IF $PIECE(ITEM0,U,9)=0
- QUIT
- +10 SET ITEM1=$GET(^PRC(442,PRCHPO,2,ITEM,1,1,0))
- +11 SET (ABC,DES)=$$FETCH(1,ITEM)
- SET PRCHLN=VAL
- +12 SET IMF=$$FETCH(1.5,ITEM)
- IF IMF'>0
- SET IMF=$PIECE(ITEM0,U,5)
- +13 SET BOC=+$$FETCH(3.5,ITEM)
- IF BOC'>0
- SET BOC=+$PIECE(ITEM0,U,4)
- +14 SET QTY=$$FETCH(2,ITEM)
- IF QTY'>0
- SET QTY=$PIECE(ITEM0,U,2)
- +15 SET AUC=$$FETCH(5,ITEM)
- IF AUC=""
- SET AUC=$PIECE(ITEM0,U,9)
- +16 SET UOP=$$FETCH(3,ITEM)
- IF UOP'>0
- SET UOP=$PIECE(ITEM0,U,3)
- +17 SET NSN=$$FETCH(9.5,ITEM)
- IF NSN=""
- SET NSN=$PIECE(ITEM0,U,13)
- +18 SET UCF=$$FETCH(3.1,ITEM)
- IF UCF'>0
- SET UCF=$PIECE(ITEM0,U,12)
- +19 SET VSN=$$FETCH(9,ITEM)
- IF VSN=""
- SET VSN=$PIECE(ITEM0,U,6)
- +20 SET CONOLD=$$FETCH(4,ITEM)
- +21 SET CON442=$PIECE($GET(^PRC(442,PRCHPO,2,ITEM,2)),U,2)
- +22 IF CONOLD=""
- IF CON442'=""
- SET CONOLD=CON442
- +23 DO LINE^PRCHPAM5(.LCNT,2)
- SET DATA="**Currently:"
- +24 DO DATA^PRCHPAM5(.LCNT,DATA)
- +25 SET DATA="Item No. "_$PIECE(ITEM0,U)_" Item Master File No. "
- +26 SET DATA=DATA_IMF_" BOC: "_BOC_" CONTRACT: "_CONOLD
- +27 DO DATA^PRCHPAM5(.LCNT,DATA)
- +28 IF $LENGTH(ABC)>0
- DO OLD^PRCHDSP6
- +29 IF $LENGTH(ABC)'>0
- SET ITEMZ=ITEM1
- DO NEW^PRCHDSP6
- +30 SET UOP1=$SELECT($LENGTH(UOP)>0:$PIECE($GET(^PRCD(420.5,UOP,0)),U),1:"")
- +31 SET DATA=" Items per "_UOP1_": "_UCF
- +32 FOR I=1:1:26-$LENGTH(DATA)
- SET DATA=DATA_" "
- +33 SET DATA=DATA_"NSN: "_NSN
- DO DATA^PRCHPAM5(.LCNT,DATA)
- +34 IF $LENGTH(VSN)>0
- SET DATA=" STK#: "_VSN
- DO DATA^PRCHPAM5(.LCNT,DATA)
- +35 SET UOP1=$SELECT($LENGTH(UOP)>0:$PIECE($GET(^PRCD(420.5,UOP,0)),U),1:"")
- +36 SET DATA=" "_QTY_" "_UOP1_" at $"_$JUSTIFY(AUC,12,2)_" = $"_$JUSTIFY(QTY*AUC,9,2)
- DO DATA^PRCHPAM5(.LCNT,DATA)
- +37 SET DATA=" "
- +38 DO DATA^PRCHPAM5(.LCNT,DATA)
- +39 SET DATA=" **Will now be AMENDED to read:"
- DO DATA^PRCHPAM5(.LCNT,DATA)
- +40 SET DATA="Item No. "_$PIECE(ITEM0,U)_" Item Master File No. "
- +41 SET DATA=DATA_$PIECE(ITEM0,U,5)_" BOC: "_+$PIECE(ITEM0,U,4)
- +42 SET DATA=DATA_" CONTRACT: "_CON442
- +43 DO DATA^PRCHPAM5(.LCNT,DATA)
- +44 if $DATA(ITEMZ)
- SET ITEM1=ITEMZ
- DO NEW^PRCHDSP6
- +45 SET UOP1=$SELECT($PIECE(ITEM0,U,3)>0:$PIECE($GET(^PRCD(420.5,$PIECE(ITEM0,U,3),0)),U),1:"")
- +46 SET DATA=" Items per "_UOP1_": "_$PIECE(ITEM0,U,12)
- +47 FOR I=1:1:26-$LENGTH(DATA)
- SET DATA=DATA_" "
- +48 SET DATA=DATA_"NSN: "_$PIECE(ITEM0,U,13)
- DO DATA^PRCHPAM5(.LCNT,DATA)
- +49 IF $PIECE(ITEM0,U,6)]""
- SET DATA=" STK#: "_$PIECE(ITEM0,U,6)
- DO DATA^PRCHPAM5(.LCNT,DATA)
- +50 SET UOP1=$SELECT($PIECE(ITEM0,U,3)>0:$PIECE($GET(^PRCD(420.5,$PIECE(ITEM0,U,3),0)),U),1:"")
- +51 SET DATA=" "_$PIECE(ITEM0,U,2)_" "_UOP1_" $"_$JUSTIFY($PIECE(ITEM0,U,9),12,4)_" = $"_$JUSTIFY($PIECE(ITEM0,U,2)*$PIECE(ITEM0,U,9),9,2)
- +52 DO DATA^PRCHPAM5(.LCNT,DATA)
- DO LCNT1^PRCHPAM5(LCNT)
- End DoDot:2
- End DoDot:1
- +53 QUIT
- +54 ;
- FETCH(FIELD,ITEM) ;EXTRINSIC FUNCTION TO RETURN THE 'VALUE' FOR A FIELD FROM 'LINE ITEM
- +1 ;AMENDMENT' OPTIONS.
- +2 NEW VAL1
- +3 SET VAL=0
- FOR
- SET VAL=$ORDER(^PRC(442,PRCHPO,6,PRCHAM,3,"AC",21,FIELD,VAL))
- if VAL'>0
- QUIT
- SET VAL1=$PIECE(^PRC(442,PRCHPO,6,PRCHAM,3,VAL,0),U,4)
- IF VAL1=ITEM
- SET VAL1=0
- GOTO EXIT
- +4 SET VAL=0
- FOR
- SET VAL=$ORDER(^PRC(442,PRCHPO,6,PRCHAM,3,"AC",22,FIELD,VAL))
- if VAL'>0
- QUIT
- SET VAL1=$PIECE(^PRC(442,PRCHPO,6,PRCHAM,3,VAL,0),U,4)
- IF VAL1=ITEM
- Begin DoDot:1
- +5 SET VAL1=^PRC(442,PRCHPO,6,PRCHAM,3,VAL,1,1,0)
- +6 QUIT
- End DoDot:1
- GOTO EXIT
- +7 SET VAL=0
- FOR
- SET VAL=$ORDER(^PRC(442,PRCHPO,6,PRCHAM,3,"AC",23,FIELD,VAL))
- if VAL'>0
- QUIT
- SET VAL1=$PIECE(^PRC(442,PRCHPO,6,PRCHAM,3,VAL,0),U,4)
- IF VAL1=ITEM
- Begin DoDot:1
- +8 SET VAL1=^PRC(442,PRCHPO,6,PRCHAM,3,VAL,1,1,0)
- +9 QUIT
- End DoDot:1
- GOTO EXIT
- +10 SET VAL1=""
- EXIT QUIT VAL1