PRCHESE ;WISC/AKS-Estimated Shipping Edit ;11/2/93 10:35
;;5.1;IFCAP;;Oct 20, 2000
;Per VHA Directive 10-93-142, this routine should not be modified.
S PRCF("X")="S" D ^PRCFSITE
EN K PRCHP Q:'$D(PRC("SITE")) S PRCHP("S")="$P(^(0),U,2)<8" S:$D(PRCHNRQ) PRCHP("A")="REQUISITION NO.: ",PRCHP("S")="$P(^(0),U,2)=8"
D EN3^PRCHPAT Q:'$D(PRCHPO) I X<20!(X=45) W $C(7)," ??" G EN
I X=28!(X=33) W $C(7),!,"Amendments not allowed until after order has been Obligated!!" G EN
D LCK^PRCHAM3 G:$T Q S PRCH(0)=Y(0),PRCH(1)=^PRC(442,PRCHPO,1),PRCH(7)=^(7),PRCH(12)=^(12),(PRCHAMT,PRCHAN,PRCHDL,PRCHAREC,PRCHCHK)=0
I $D(^PRC(442,PRCHPO,6)) F I=0:0 S I=$O(^PRC(442,PRCHPO,6,I)) Q:'I S PRCHAN=I
S PRCHAN=PRCHAN+1 W !?5,"Amendment number: ",PRCHAN S %=1,%A=" Do you wish to continue",%B="" D ^PRCFYN G:%'=1 Q
S ^PRC(443.6,PRCHPO,0)=PRCH(0),^(1)=PRCH(1),^(7)=PRCH(7),^(12)=PRCH(12),DIE="^PRC(443.6,",DR="[PRCHAMEND]" S:$D(PRCHAV) DR="[PRCHAMENDAV]"
D ^DIE G:$D(Y) Q I '$D(^PRC(443.6,PRCHPO,6,PRCHAN,1)) W !?5,"Can't continue without a Purchasing Agent !" G Q
ASK K ^TMP("PRCHW",$J) S DIC="^PRCD(442.2,",DIC("S")="I Y>19,($P(^(0),U,3)]"""")" S:$D(PRCHNRQ) DIC("S")=DIC("S")_",(""25;26;28;35;36""'[Y)" S DIC(0)="QEAZ"
D ^DIC G:Y<0 CHK^PRCHAM K DIC I '$D(^PRCD(442.2,+Y,1)) W !!?5,"Amendment Lines in file 442.2 not defined " G ASK
S ROU=$P(Y(0),U,3),PRCHL1=$P(^PRCD(442.2,+Y,1),U,1),PRCHL2=$P(^(1),U,2) I $L($T(@ROU))<2 W !!?5,"Routine line not defined " G ASK
S PRCHT=1 D @ROU G ASK:PRCHT D EN^PRCHAM G ASK
;S PRCHT=1 D @ROU S:'$D(PRCHT) PRCHT=1 G ASK:PRCHT D EN^PRCHAM G ASK
DIE S DIE="^PRC(443.6,",DA=PRCHPO D ^DIE K DIE Q
Q QUIT
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCHESE 1653 printed Sep 23, 2025@19:43:32 Page 2
PRCHESE ;WISC/AKS-Estimated Shipping Edit ;11/2/93 10:35
+1 ;;5.1;IFCAP;;Oct 20, 2000
+2 ;Per VHA Directive 10-93-142, this routine should not be modified.
+3 SET PRCF("X")="S"
DO ^PRCFSITE
EN KILL PRCHP
if '$DATA(PRC("SITE"))
QUIT
SET PRCHP("S")="$P(^(0),U,2)<8"
if $DATA(PRCHNRQ)
SET PRCHP("A")="REQUISITION NO.: "
SET PRCHP("S")="$P(^(0),U,2)=8"
+1 DO EN3^PRCHPAT
if '$DATA(PRCHPO)
QUIT
IF X<20!(X=45)
WRITE $CHAR(7)," ??"
GOTO EN
+2 IF X=28!(X=33)
WRITE $CHAR(7),!,"Amendments not allowed until after order has been Obligated!!"
GOTO EN
+3 DO LCK^PRCHAM3
if $TEST
GOTO Q
SET PRCH(0)=Y(0)
SET PRCH(1)=^PRC(442,PRCHPO,1)
SET PRCH(7)=^(7)
SET PRCH(12)=^(12)
SET (PRCHAMT,PRCHAN,PRCHDL,PRCHAREC,PRCHCHK)=0
+4 IF $DATA(^PRC(442,PRCHPO,6))
FOR I=0:0
SET I=$ORDER(^PRC(442,PRCHPO,6,I))
if 'I
QUIT
SET PRCHAN=I
+5 SET PRCHAN=PRCHAN+1
WRITE !?5,"Amendment number: ",PRCHAN
SET %=1
SET %A=" Do you wish to continue"
SET %B=""
DO ^PRCFYN
if %'=1
GOTO Q
+6 SET ^PRC(443.6,PRCHPO,0)=PRCH(0)
SET ^(1)=PRCH(1)
SET ^(7)=PRCH(7)
SET ^(12)=PRCH(12)
SET DIE="^PRC(443.6,"
SET DR="[PRCHAMEND]"
if $DATA(PRCHAV)
SET DR="[PRCHAMENDAV]"
+7 DO ^DIE
if $DATA(Y)
GOTO Q
IF '$DATA(^PRC(443.6,PRCHPO,6,PRCHAN,1))
WRITE !?5,"Can't continue without a Purchasing Agent !"
GOTO Q
ASK KILL ^TMP("PRCHW",$JOB)
SET DIC="^PRCD(442.2,"
SET DIC("S")="I Y>19,($P(^(0),U,3)]"""")"
if $DATA(PRCHNRQ)
SET DIC("S")=DIC("S")_",(""25;26;28;35;36""'[Y)"
SET DIC(0)="QEAZ"
+1 DO ^DIC
if Y<0
GOTO CHK^PRCHAM
KILL DIC
IF '$DATA(^PRCD(442.2,+Y,1))
WRITE !!?5,"Amendment Lines in file 442.2 not defined "
GOTO ASK
+2 SET ROU=$PIECE(Y(0),U,3)
SET PRCHL1=$PIECE(^PRCD(442.2,+Y,1),U,1)
SET PRCHL2=$PIECE(^(1),U,2)
IF $LENGTH($TEXT(@ROU))<2
WRITE !!?5,"Routine line not defined "
GOTO ASK
+3 SET PRCHT=1
DO @ROU
if PRCHT
GOTO ASK
DO EN^PRCHAM
GOTO ASK
+4 ;S PRCHT=1 D @ROU S:'$D(PRCHT) PRCHT=1 G ASK:PRCHT D EN^PRCHAM G ASK
DIE SET DIE="^PRC(443.6,"
SET DA=PRCHPO
DO ^DIE
KILL DIE
QUIT
Q QUIT
