- PRCHAM5 ;WISC/AKS,ID/RSD,SF-ISC/TKW-CONT. OF AMENDMENTS ;7-2-91/15:40
- V ;;5.1;IFCAP;;Oct 20, 2000
- ;Per VHA Directive 10-93-142, this routine should not be modified.
- ENUI ; UPDATE FIELDS ON ITEM FILE THAT WERE CHANGED THROUGH AMENDMENT
- W !! D W W %B,! F I=0:0 S I=$O(%B(I)) Q:'I W %B(I),!
- D YN^PRCFYN Q:%'=1 S I=0 D UPI Q
- UPI S I=$O(^PRC(442,PRCHPO,2,I)) Q:'I S Y=^(I,0) G:'$D(^PRC(441,+$P(Y,U,5),0)) UPI S Z=$O(^PRC(442,PRCHPO,2,I,1,0)) G:'$D(^(Z,0)) UPI I ^(0)'["*AMENDED*" G UPI
- S:$P(Y,U,13)'="" $P(^PRC(441,+$P(Y,U,5),0),U,5)=$P(Y,U,13)
- G:'$D(^PRC(441,+$P(Y,U,5),2,PRCHCV,0)) UPI S X=^(0)
- S:$P(Y,U,3)'="" $P(X,U,7)=$P(Y,U,3) S:$P(Y,U,12) $P(X,U,8)=$P(Y,U,12) S:$P(Y,U,9) $P(X,U,2)=$P(Y,U,9),$P(X,U,6)=DT S:$P(Y,U,6)'="" $P(X,U,4)=$P(Y,U,6)
- I $D(^PRC(442,PRCHPO,2,I,2)) S Z=$P(^(2),U,2) I Z]"",$D(^PRC(442,PRCHPO,1)) S $P(X,U,3)=$O(^PRC(440,+^(1),4,"B",Z,0)) S Z=$O(^PRC(440,PRCHCV,4,"B",Z,0)) I Z S $P(X,U,3)=Z
- S ^PRC(441,+$P(Y,U,5),2,PRCHCV,0)=X
- G UPI
- EN7 ;PROMPT PAYMENT EDIT
- S DIC="^PRC(442,PRCHPO,5,",DIC(0)="AEQZ" D ^DIC Q:Y<0 S PRCHP=Y,PRCHP0=Y(0),PRCHO=$P(Y(0),U,1)_"/"_$P(Y(0),U,2)
- S %X="^PRC(442,PRCHPO,5,+PRCHP,",%Y="^PRC(443.6,PRCHPO,5,+PRCHP," D %XY^%RCR S ^PRC(443.6,PRCHPO,5,0)="^443.66A^"_$P(^PRC(442,PRCHPO,5,0),U,3,4)
- S DR="[PRCHAMPPP]",DIE="^PRC(443.6,",DA=PRCHPO D ^DIE K DIE
- S PRCHN=$S($D(^PRC(443.6,PRCHPO,5,+PRCHP,0)):$P(^(0),U,1)_"/"_$P(^(0),U,2),1:"@") Q:PRCHO=PRCHN
- S PRCHT=0 S:PRCHN="@" PRCHL1="*",^TMP("PRCHW",$J,1)="Prompt Payment "_PRCHO_" has been cancelled" Q
- PONO I $D(PRCHNRQ) S PRCHP("A")="REQUISITION NUMBER",PRCHP("T")=8,PRCHP("S")=1 D EN^PRCHPAT Q
- I $D(PRCHIMP) S PRCHP("A")="IMPREST FUND P.O.NO.: ",PRCHP("T")=7,PRCHP("S")=3 D EN^PRCHPAT Q
- D ENPO^PRCHUTL Q
- DOCID S Z=$P(^PRC(443.6,PRCHPO,0),"-",2),$P(^PRC(443.6,PRCHPO,18),"^",3)=$S(Z:$E(Z,2,6),1:$E(Z)_$E(Z,3,6)) K Z Q
- W S %B="You have the choice to let the system automatically update the Item Master",%B(1)="File with the amended data. If you choose to do this, the following",%B(2)="fields will be updated for ALL amended items on this order:"
- S %B(3)=" National Stock No.",%B(6)=" Vendor Stock No.",%B(7)=" Unit of Purchase",%B(8)=" Packaging Multiple",%B(9)=" Actual Unit Cost",%B(10)=" Contract Number."
- S %A="UPDATE ITEM FILE",%=2
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCHAM5 2295 printed Mar 13, 2025@21:10:29 Page 2
- PRCHAM5 ;WISC/AKS,ID/RSD,SF-ISC/TKW-CONT. OF AMENDMENTS ;7-2-91/15:40
- V ;;5.1;IFCAP;;Oct 20, 2000
- +1 ;Per VHA Directive 10-93-142, this routine should not be modified.
- ENUI ; UPDATE FIELDS ON ITEM FILE THAT WERE CHANGED THROUGH AMENDMENT
- +1 WRITE !!
- DO W
- WRITE %B,!
- FOR I=0:0
- SET I=$ORDER(%B(I))
- if 'I
- QUIT
- WRITE %B(I),!
- +2 DO YN^PRCFYN
- if %'=1
- QUIT
- SET I=0
- DO UPI
- QUIT
- UPI SET I=$ORDER(^PRC(442,PRCHPO,2,I))
- if 'I
- QUIT
- SET Y=^(I,0)
- if '$DATA(^PRC(441,+$PIECE(Y,U,5),0))
- GOTO UPI
- SET Z=$ORDER(^PRC(442,PRCHPO,2,I,1,0))
- if '$DATA(^(Z,0))
- GOTO UPI
- IF ^(0)'["*AMENDED*"
- GOTO UPI
- +1 if $PIECE(Y,U,13)'=""
- SET $PIECE(^PRC(441,+$PIECE(Y,U,5),0),U,5)=$PIECE(Y,U,13)
- +2 if '$DATA(^PRC(441,+$PIECE(Y,U,5),2,PRCHCV,0))
- GOTO UPI
- SET X=^(0)
- +3 if $PIECE(Y,U,3)'=""
- SET $PIECE(X,U,7)=$PIECE(Y,U,3)
- if $PIECE(Y,U,12)
- SET $PIECE(X,U,8)=$PIECE(Y,U,12)
- if $PIECE(Y,U,9)
- SET $PIECE(X,U,2)=$PIECE(Y,U,9)
- SET $PIECE(X,U,6)=DT
- if $PIECE(Y,U,6)'=""
- SET $PIECE(X,U,4)=$PIECE(Y,U,6)
- +4 IF $DATA(^PRC(442,PRCHPO,2,I,2))
- SET Z=$PIECE(^(2),U,2)
- IF Z]""
- IF $DATA(^PRC(442,PRCHPO,1))
- SET $PIECE(X,U,3)=$ORDER(^PRC(440,+^(1),4,"B",Z,0))
- SET Z=$ORDER(^PRC(440,PRCHCV,4,"B",Z,0))
- IF Z
- SET $PIECE(X,U,3)=Z
- +5 SET ^PRC(441,+$PIECE(Y,U,5),2,PRCHCV,0)=X
- +6 GOTO UPI
- EN7 ;PROMPT PAYMENT EDIT
- +1 SET DIC="^PRC(442,PRCHPO,5,"
- SET DIC(0)="AEQZ"
- DO ^DIC
- if Y<0
- QUIT
- SET PRCHP=Y
- SET PRCHP0=Y(0)
- SET PRCHO=$PIECE(Y(0),U,1)_"/"_$PIECE(Y(0),U,2)
- +2 SET %X="^PRC(442,PRCHPO,5,+PRCHP,"
- SET %Y="^PRC(443.6,PRCHPO,5,+PRCHP,"
- DO %XY^%RCR
- SET ^PRC(443.6,PRCHPO,5,0)="^443.66A^"_$PIECE(^PRC(442,PRCHPO,5,0),U,3,4)
- +3 SET DR="[PRCHAMPPP]"
- SET DIE="^PRC(443.6,"
- SET DA=PRCHPO
- DO ^DIE
- KILL DIE
- +4 SET PRCHN=$SELECT($DATA(^PRC(443.6,PRCHPO,5,+PRCHP,0)):$PIECE(^(0),U,1)_"/"_$PIECE(^(0),U,2),1:"@")
- if PRCHO=PRCHN
- QUIT
- +5 SET PRCHT=0
- if PRCHN="@"
- SET PRCHL1="*"
- SET ^TMP("PRCHW",$JOB,1)="Prompt Payment "_PRCHO_" has been cancelled"
- QUIT
- PONO IF $DATA(PRCHNRQ)
- SET PRCHP("A")="REQUISITION NUMBER"
- SET PRCHP("T")=8
- SET PRCHP("S")=1
- DO EN^PRCHPAT
- QUIT
- +1 IF $DATA(PRCHIMP)
- SET PRCHP("A")="IMPREST FUND P.O.NO.: "
- SET PRCHP("T")=7
- SET PRCHP("S")=3
- DO EN^PRCHPAT
- QUIT
- +2 DO ENPO^PRCHUTL
- QUIT
- DOCID SET Z=$PIECE(^PRC(443.6,PRCHPO,0),"-",2)
- SET $PIECE(^PRC(443.6,PRCHPO,18),"^",3)=$SELECT(Z:$EXTRACT(Z,2,6),1:$EXTRACT(Z)_$EXTRACT(Z,3,6))
- KILL Z
- QUIT
- W SET %B="You have the choice to let the system automatically update the Item Master"
- SET %B(1)="File with the amended data. If you choose to do this, the following"
- SET %B(2)="fields will be updated for ALL amended items on this order:"
- +1 SET %B(3)=" National Stock No."
- SET %B(6)=" Vendor Stock No."
- SET %B(7)=" Unit of Purchase"
- SET %B(8)=" Packaging Multiple"
- SET %B(9)=" Actual Unit Cost"
- SET %B(10)=" Contract Number."
- +2 SET %A="UPDATE ITEM FILE"
- SET %=2
- +3 QUIT
