- PRCHAM ;WOIFO/ID/RSD,SF-ISC/TKW/BGJ/AS-AMENDMENTS TO P.O. ;3/8/05
- V ;;5.1;IFCAP;**14,38,81**;Oct 20, 2000
- ;Per VHA Directive 10-93-142, this routine should not be modified.
- ENAV 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,"Adjustment number: ",PRCHAN S %=1,%A=" Do you wish to continue",%B="" D ^PRCFYN G:%'=1 Q
- S:'$D(PRCHAM) PRCHAM=PRCHAN
- 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
- S PRCHLC=$P(PRCH(0),U,14) Q:$D(PRCHAV) G ^PRCHAM1
- EN S X=PRCHL1_PRCHO_PRCHL2_PRCHN,J=0,PRCHCHK=1 S:'$D(^PRC(443.6,PRCHPO,6,PRCHAN,2,0)) ^(0)="^^^^"_DT
- F I=0:0 S I=$O(^PRC(443.6,PRCHPO,6,PRCHAN,2,I)) Q:'I S J=J+1
- G:PRCHL1="*" EN1 S ^PRC(443.6,PRCHPO,6,PRCHAN,2,0)="^^"_($P(^PRC(443.6,PRCHPO,6,PRCHAN,2,0),U,3)+1)_U_($P(^(0),U,4)+1)_U_DT,^PRC(443.6,PRCHPO,6,PRCHAN,2,J+1,0)=" "_X I '$D(^TMP("PRCHW",$J)) S ^PRC(443.6,PRCHPO,6,PRCHAN,2,J+2,0)=" " Q
- EN1 F I=0:0 S I=$O(^TMP("PRCHW",$J,I)) Q:'I S X=^TMP("PRCHW",$J,I),J=J+1 S:($L(X)+1)'>255 X=" "_X S ^PRC(443.6,PRCHPO,6,PRCHAN,2,J,0)=X
- S ^PRC(443.6,PRCHPO,6,PRCHAN,2,0)="^^"_J_U_J_DT,^(J+1,0)=" " K ^TMP("PRCHW",$J) Q
- CHK G:PRCHCHK=0 Q I PRCHAREC W !?3,"Recalculating Discounts ..." D RECAL^PRCHAM3 I $D(^TMP("PRCHW",$J)) S PRCHL1="*",(PRCHN,PRCHO,PRCHL2)="" D EN
- S:PRCHAMT $P(^PRC(443.6,PRCHPO,6,PRCHAN,0),U,3)=PRCHAMT,$P(^(0),U,15)=$P(^PRC(443.6,PRCHPO,0),U,15)+PRCHAMT
- I PRCHDL D UPDT^PRCHAM3
- EN2 S $P(^PRC(443.6,PRCHPO,0),U,14)=PRCHLC,%=1,%B="",%A=" Review Adjustment " W ! D ^PRCFYN I %=1 S D0=PRCHPO,D1=PRCHAN,PRCH="^PRC(443.6," D ^PRCHDAM
- S %A=" Edit Description ",%=2,%B="Enter 'YES' to edit the Adjustment Description or 'NO' to continue." D ^PRCFYN I %=1 S DIE="^PRC(443.6,",DA=PRCHPO,DR="[PRCHAMDESC]" D ^DIE
- I $P(^PRC(443.6,PRCHPO,0),U,2)=25!($P(^(0),U,2)=26) S NOFISCAL=1
- S %A=" Approve and print"_$S('$G(NOFISCAL):" (in FISCAL and SUPPLY)",1:"")_" Adjustment no.: "_PRCHAN,%B="",%=2 D ^PRCFYN I %'=1 W !?10,"Adjustment Deleted !",$C(7) G Q
- S P=+$S($D(^PRC(443.6,PRCHPO,6,PRCHAN,1)):^(1),1:"") I P="" W !?5,"Purchasing Agent Field is undefined !",$C(7) G Q
- I P'=DUZ D ESIG^PRCHAM44
- S DA=PRCHPO S PRCSIG="" D ESIG^PRCUESIG(P,.PRCSIG) I PRCSIG<1 S ROUTINE="PRCUESIG" G QQ
- S PRCSUM=$$SUM^PRCUESIG(PRCHPO_"^"_$$STRING^PRCHES5(^PRC(442,PRCHPO,0),^PRC(442,PRCHPO,1),^PRC(442,PRCHPO,12)))
- S PRCSIG="" D ENCODE^PRCHES10(PRCHPO,PRCHAN,P,.PRCSIG) S ROUTINE="PRCHAM" G:PRCSIG<1 QQ S X=$P(^PRC(443.6,PRCHPO,6,PRCHAN,1),U,4) S:X]"" $P(^PRC(443.6,PRCHPO,7),U,1)=X
- S PRCSIG="" D RECODE^PRCHES12(PRCHPO,PRCSUM,.PRCSIG) S ROUTINE="PRCHAM" G:PRCSIG<1 QQ K PRCSUM
- F I=2,3,5,6 I $D(^PRC(443.6,PRCHPO,I,0))#2 S $P(^(0),U,2)=$P(",442.01IA,442.03A,,442.06A,442.07",",",I)
- I $D(^PRC(443.6,PRCHPO,7)) S X=+^(7),Y=X I X S DA=PRCHPO D UPD^PRCHSTAT S ^PRC(443.6,PRCHPO,7)=^PRC(442,PRCHPO,7)
- D WAIT^DICD
- ;
- ;Check for any Adjustment for PO. If any, save the Adjustment Number
- ;at Partial node and save the Partial Number at Adjustment Node.
- ;If no Adjustment on PO then skip it. Patch PRC*5.1*38
- ;
- ADJESIG G:'$D(^PRC(443.6,PRCHPO,6,0)) SKIPIT
- S ADJDATA=$G(^PRC(443.6,PRCHPO,6,PRCHAN,0))
- I $P(ADJDATA,U,8)'="Y" G SKIPIT
- S PRTDATA=$G(^PRC(443.6,PRCHPO,11,PRCHAV,0))
- S $P(PRTDATA,U,21)=PRCHAN
- S ^PRC(443.6,PRCHPO,11,PRCHAV,0)=PRTDATA
- S $P(ADJDATA,U,13)=PRCHAV
- S ^PRC(443.6,PRCHPO,6,PRCHAN,0)=ADJDATA
- K ADJDATA,PRTDATA
- ;
- SKIPIT D WAIT^DICD S %X="^PRC(443.6,PRCHPO,",%Y="^PRC(442,PRCHPO," D %XY^%RCR I $D(PRCHNPO) S $P(^PRC(442,PRCHNPO,0),U,1)=PRCHNPO(0)
- I $D(^PRC(442,PRCHPO,6,0)) D
- . S $P(^PRC(442,PRCHPO,6,PRCHAN,0),U,12)=""
- I '$D(PRCHAV) G JMP
- S PRCSUM=$$SUM^PRCUESIG(PRCHPO_"^"_$$STRING^PRCHES1(^PRC(442,PRCHPO,11,PRCHAV,0)))
- S PRCSIG="" D RECODE^PRCHES1(PRCHPO,PRCHAV,PRCSUM,.PRCSIG) S ROUTINE="PRCHAM" G:PRCSIG<1 QQ K PRCSUM
- ; Transmit RR Adj info to DynaMed **81**
- D:$$GET^XPAR("SYS","PRCV COTS INVENTORY",1)=1 ENT^PRCVRRA(PRCHPO,PRCHAV)
- ;
- I $P(^PRC(442,PRCHPO,11,PRCHAV,0),U,16)="" G JMP
- S PRCSUM=$$SUM^PRCUESIG(PRCHPO_"^"_$$STRING^PRCHES2(^PRC(442,PRCHPO,11,PRCHAV,0),^PRC(442,PRCHPO,11,PRCHAV,1)))
- S PRCSIG="" D RECODE^PRCHES2(PRCHPO,PRCHAV,PRCSUM,.PRCSIG) S ROUTINE="PRCHAM" G:PRCSIG<1 QQ K PRCSUM,PRCHNFLG
- JMP D SETC^PRCHAM4
- I $D(PRCHX) S I=0 F J=1:1 S I=$O(PRCHX(I)) Q:I="" S Z=I,Y=$O(PRCHX(Z,0)) I Z]"",Y]"" S X=Z K @PRCHX(Z,Y) S:Y'="@" X=Y,@PRCHX(Z,Y)=""
- S DA(1)=PRCHPO,N=0,DIK(1)=".01^C" F S N=$O(^PRC(442,DA(1),2,N)) Q:'N D
- .S DA=N,DIK="^PRC(442,"_DA(1)_",2," D EN^DIK
- K DA,DIK,N
- I '$D(DT) D NOW^%DTC S DT=$P(%,".",1)
- S PRCHCV=$S($D(^PRC(442,PRCHPO,1)):+^(1),1:0) ;I PRCHCV D ENUI^PRCHAM5
- S DA=PRCHPO D UPDATE^PRCPWIU
- W !?3,"SEND TO SUPPLY " S PRCHQ="^PRCHPAM",D0=PRCHPO,D1=PRCHAN D ^PRCHSF S D0=PRCHPO,D1=PRCHAN D ^PRCHQUE K ZTSK
- I $D(PRC("PARAM")),$P(PRC("PARAM"),U,4)="Y",'$G(NOFISCAL) W !?3,"SEND TO FISCAL ",! S PRCHQ="^PRCHPAM",PRCHQ("DEST")="F",D0=PRCHPO,D1=PRCHAN D ^PRCHQUE
- G Q
- QQ S:'$D(ROUTINE) ROUTINE=$T(+0)
- W !!,$$ERR^PRCHQQ(ROUTINE,PRCSIG) W:PRCSIG=0!(PRCSIG=-3) !,"Notify Application Coordinator!" W !," ADJUSTMENT VOUCHER DELETED",$C(7) S DIR(0)="EAO",DIR("A")="Press <Return> to continue " D ^DIR
- Q K ^PRC(443.6,PRCHPO),AMT,I,J,K,X,Y,Z,X1,X2,PRCH,PRCHCV,PRCHPO,PRCHAMT,PRCHAN,PRCHA,PRCHAV,PRCHAREC,PRCHL1,PRCHL2,PRCHLC,PRCHO,PRCHN,PRCHNPO,PRCHD0,PRCHP0,PRCHAC,PRCHACT,PRCHDA,PRCHDT,ROUTINE
- D KILL^PRCHAM44 K PRCHAVLD,PRCHCHK,PRCHII,PRCHITR,PRCHITSB,PRCHQTY,PRCHRPTN,PRCHRPTO,PRCHSAM1,PRCHSAM2,PRCHJJ,PRCHMM,PRCHSHIP,PRCHXX1,NOFISCAL L Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCHAM 5841 printed Mar 13, 2025@21:10:23 Page 2
- PRCHAM ;WOIFO/ID/RSD,SF-ISC/TKW/BGJ/AS-AMENDMENTS TO P.O. ;3/8/05
- V ;;5.1;IFCAP;**14,38,81**;Oct 20, 2000
- +1 ;Per VHA Directive 10-93-142, this routine should not be modified.
- ENAV 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
- +1 IF $DATA(^PRC(442,PRCHPO,6))
- FOR I=0:0
- SET I=$ORDER(^PRC(442,PRCHPO,6,I))
- if 'I
- QUIT
- SET PRCHAN=I
- +2 SET PRCHAN=PRCHAN+1
- WRITE !?5,"Adjustment number: ",PRCHAN
- SET %=1
- SET %A=" Do you wish to continue"
- SET %B=""
- DO ^PRCFYN
- if %'=1
- GOTO Q
- +3 if '$DATA(PRCHAM)
- SET PRCHAM=PRCHAN
- +4 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]"
- +5 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
- +6 SET PRCHLC=$PIECE(PRCH(0),U,14)
- if $DATA(PRCHAV)
- QUIT
- GOTO ^PRCHAM1
- EN SET X=PRCHL1_PRCHO_PRCHL2_PRCHN
- SET J=0
- SET PRCHCHK=1
- if '$DATA(^PRC(443.6,PRCHPO,6,PRCHAN,2,0))
- SET ^(0)="^^^^"_DT
- +1 FOR I=0:0
- SET I=$ORDER(^PRC(443.6,PRCHPO,6,PRCHAN,2,I))
- if 'I
- QUIT
- SET J=J+1
- +2 if PRCHL1="*"
- GOTO EN1
- SET ^PRC(443.6,PRCHPO,6,PRCHAN,2,0)="^^"_($PIECE(^PRC(443.6,PRCHPO,6,PRCHAN,2,0),U,3)+1)_U_($PIECE(^(0),U,4)+1)_U_DT
- SET ^PRC(443.6,PRCHPO,6,PRCHAN,2,J+1,0)=" "_X
- IF '$DATA(^TMP("PRCHW",$JOB))
- SET ^PRC(443.6,PRCHPO,6,PRCHAN,2,J+2,0)=" "
- QUIT
- EN1 FOR I=0:0
- SET I=$ORDER(^TMP("PRCHW",$JOB,I))
- if 'I
- QUIT
- SET X=^TMP("PRCHW",$JOB,I)
- SET J=J+1
- if ($LENGTH(X)+1)'>255
- SET X=" "_X
- SET ^PRC(443.6,PRCHPO,6,PRCHAN,2,J,0)=X
- +1 SET ^PRC(443.6,PRCHPO,6,PRCHAN,2,0)="^^"_J_U_J_DT
- SET ^(J+1,0)=" "
- KILL ^TMP("PRCHW",$JOB)
- QUIT
- CHK if PRCHCHK=0
- GOTO Q
- IF PRCHAREC
- WRITE !?3,"Recalculating Discounts ..."
- DO RECAL^PRCHAM3
- IF $DATA(^TMP("PRCHW",$JOB))
- SET PRCHL1="*"
- SET (PRCHN,PRCHO,PRCHL2)=""
- DO EN
- +1 if PRCHAMT
- SET $PIECE(^PRC(443.6,PRCHPO,6,PRCHAN,0),U,3)=PRCHAMT
- SET $PIECE(^(0),U,15)=$PIECE(^PRC(443.6,PRCHPO,0),U,15)+PRCHAMT
- +2 IF PRCHDL
- DO UPDT^PRCHAM3
- EN2 SET $PIECE(^PRC(443.6,PRCHPO,0),U,14)=PRCHLC
- SET %=1
- SET %B=""
- SET %A=" Review Adjustment "
- WRITE !
- DO ^PRCFYN
- IF %=1
- SET D0=PRCHPO
- SET D1=PRCHAN
- SET PRCH="^PRC(443.6,"
- DO ^PRCHDAM
- +1 SET %A=" Edit Description "
- SET %=2
- SET %B="Enter 'YES' to edit the Adjustment Description or 'NO' to continue."
- DO ^PRCFYN
- IF %=1
- SET DIE="^PRC(443.6,"
- SET DA=PRCHPO
- SET DR="[PRCHAMDESC]"
- DO ^DIE
- +2 IF $PIECE(^PRC(443.6,PRCHPO,0),U,2)=25!($PIECE(^(0),U,2)=26)
- SET NOFISCAL=1
- +3 SET %A=" Approve and print"_$SELECT('$GET(NOFISCAL):" (in FISCAL and SUPPLY)",1:"")_" Adjustment no.: "_PRCHAN
- SET %B=""
- SET %=2
- DO ^PRCFYN
- IF %'=1
- WRITE !?10,"Adjustment Deleted !",$CHAR(7)
- GOTO Q
- +4 SET P=+$SELECT($DATA(^PRC(443.6,PRCHPO,6,PRCHAN,1)):^(1),1:"")
- IF P=""
- WRITE !?5,"Purchasing Agent Field is undefined !",$CHAR(7)
- GOTO Q
- +5 IF P'=DUZ
- DO ESIG^PRCHAM44
- +6 SET DA=PRCHPO
- SET PRCSIG=""
- DO ESIG^PRCUESIG(P,.PRCSIG)
- IF PRCSIG<1
- SET ROUTINE="PRCUESIG"
- GOTO QQ
- +7 SET PRCSUM=$$SUM^PRCUESIG(PRCHPO_"^"_$$STRING^PRCHES5(^PRC(442,PRCHPO,0),^PRC(442,PRCHPO,1),^PRC(442,PRCHPO,12)))
- +8 SET PRCSIG=""
- DO ENCODE^PRCHES10(PRCHPO,PRCHAN,P,.PRCSIG)
- SET ROUTINE="PRCHAM"
- if PRCSIG<1
- GOTO QQ
- SET X=$PIECE(^PRC(443.6,PRCHPO,6,PRCHAN,1),U,4)
- if X]""
- SET $PIECE(^PRC(443.6,PRCHPO,7),U,1)=X
- +9 SET PRCSIG=""
- DO RECODE^PRCHES12(PRCHPO,PRCSUM,.PRCSIG)
- SET ROUTINE="PRCHAM"
- if PRCSIG<1
- GOTO QQ
- KILL PRCSUM
- +10 FOR I=2,3,5,6
- IF $DATA(^PRC(443.6,PRCHPO,I,0))#2
- SET $PIECE(^(0),U,2)=$PIECE(",442.01IA,442.03A,,442.06A,442.07",",",I)
- +11 IF $DATA(^PRC(443.6,PRCHPO,7))
- SET X=+^(7)
- SET Y=X
- IF X
- SET DA=PRCHPO
- DO UPD^PRCHSTAT
- SET ^PRC(443.6,PRCHPO,7)=^PRC(442,PRCHPO,7)
- +12 DO WAIT^DICD
- +13 ;
- +14 ;Check for any Adjustment for PO. If any, save the Adjustment Number
- +15 ;at Partial node and save the Partial Number at Adjustment Node.
- +16 ;If no Adjustment on PO then skip it. Patch PRC*5.1*38
- +17 ;
- ADJESIG if '$DATA(^PRC(443.6,PRCHPO,6,0))
- GOTO SKIPIT
- +1 SET ADJDATA=$GET(^PRC(443.6,PRCHPO,6,PRCHAN,0))
- +2 IF $PIECE(ADJDATA,U,8)'="Y"
- GOTO SKIPIT
- +3 SET PRTDATA=$GET(^PRC(443.6,PRCHPO,11,PRCHAV,0))
- +4 SET $PIECE(PRTDATA,U,21)=PRCHAN
- +5 SET ^PRC(443.6,PRCHPO,11,PRCHAV,0)=PRTDATA
- +6 SET $PIECE(ADJDATA,U,13)=PRCHAV
- +7 SET ^PRC(443.6,PRCHPO,6,PRCHAN,0)=ADJDATA
- +8 KILL ADJDATA,PRTDATA
- +9 ;
- SKIPIT DO WAIT^DICD
- SET %X="^PRC(443.6,PRCHPO,"
- SET %Y="^PRC(442,PRCHPO,"
- DO %XY^%RCR
- IF $DATA(PRCHNPO)
- SET $PIECE(^PRC(442,PRCHNPO,0),U,1)=PRCHNPO(0)
- +1 IF $DATA(^PRC(442,PRCHPO,6,0))
- Begin DoDot:1
- +2 SET $PIECE(^PRC(442,PRCHPO,6,PRCHAN,0),U,12)=""
- End DoDot:1
- +3 IF '$DATA(PRCHAV)
- GOTO JMP
- +4 SET PRCSUM=$$SUM^PRCUESIG(PRCHPO_"^"_$$STRING^PRCHES1(^PRC(442,PRCHPO,11,PRCHAV,0)))
- +5 SET PRCSIG=""
- DO RECODE^PRCHES1(PRCHPO,PRCHAV,PRCSUM,.PRCSIG)
- SET ROUTINE="PRCHAM"
- if PRCSIG<1
- GOTO QQ
- KILL PRCSUM
- +6 ; Transmit RR Adj info to DynaMed **81**
- +7 if $$GET^XPAR("SYS","PRCV COTS INVENTORY",1)=1
- DO ENT^PRCVRRA(PRCHPO,PRCHAV)
- +8 ;
- +9 IF $PIECE(^PRC(442,PRCHPO,11,PRCHAV,0),U,16)=""
- GOTO JMP
- +10 SET PRCSUM=$$SUM^PRCUESIG(PRCHPO_"^"_$$STRING^PRCHES2(^PRC(442,PRCHPO,11,PRCHAV,0),^PRC(442,PRCHPO,11,PRCHAV,1)))
- +11 SET PRCSIG=""
- DO RECODE^PRCHES2(PRCHPO,PRCHAV,PRCSUM,.PRCSIG)
- SET ROUTINE="PRCHAM"
- if PRCSIG<1
- GOTO QQ
- KILL PRCSUM,PRCHNFLG
- JMP DO SETC^PRCHAM4
- +1 IF $DATA(PRCHX)
- SET I=0
- FOR J=1:1
- SET I=$ORDER(PRCHX(I))
- if I=""
- QUIT
- SET Z=I
- SET Y=$ORDER(PRCHX(Z,0))
- IF Z]""
- IF Y]""
- SET X=Z
- KILL @PRCHX(Z,Y)
- if Y'="@"
- SET X=Y
- SET @PRCHX(Z,Y)=""
- +2 SET DA(1)=PRCHPO
- SET N=0
- SET DIK(1)=".01^C"
- FOR
- SET N=$ORDER(^PRC(442,DA(1),2,N))
- if 'N
- QUIT
- Begin DoDot:1
- +3 SET DA=N
- SET DIK="^PRC(442,"_DA(1)_",2,"
- DO EN^DIK
- End DoDot:1
- +4 KILL DA,DIK,N
- +5 IF '$DATA(DT)
- DO NOW^%DTC
- SET DT=$PIECE(%,".",1)
- +6 ;I PRCHCV D ENUI^PRCHAM5
- SET PRCHCV=$SELECT($DATA(^PRC(442,PRCHPO,1)):+^(1),1:0)
- +7 SET DA=PRCHPO
- DO UPDATE^PRCPWIU
- +8 WRITE !?3,"SEND TO SUPPLY "
- SET PRCHQ="^PRCHPAM"
- SET D0=PRCHPO
- SET D1=PRCHAN
- DO ^PRCHSF
- SET D0=PRCHPO
- SET D1=PRCHAN
- DO ^PRCHQUE
- KILL ZTSK
- +9 IF $DATA(PRC("PARAM"))
- IF $PIECE(PRC("PARAM"),U,4)="Y"
- IF '$GET(NOFISCAL)
- WRITE !?3,"SEND TO FISCAL ",!
- SET PRCHQ="^PRCHPAM"
- SET PRCHQ("DEST")="F"
- SET D0=PRCHPO
- SET D1=PRCHAN
- DO ^PRCHQUE
- +10 GOTO Q
- QQ if '$DATA(ROUTINE)
- SET ROUTINE=$TEXT(+0)
- +1 WRITE !!,$$ERR^PRCHQQ(ROUTINE,PRCSIG)
- if PRCSIG=0!(PRCSIG=-3)
- WRITE !,"Notify Application Coordinator!"
- WRITE !," ADJUSTMENT VOUCHER DELETED",$CHAR(7)
- SET DIR(0)="EAO"
- SET DIR("A")="Press <Return> to continue "
- DO ^DIR
- Q KILL ^PRC(443.6,PRCHPO),AMT,I,J,K,X,Y,Z,X1,X2,PRCH,PRCHCV,PRCHPO,PRCHAMT,PRCHAN,PRCHA,PRCHAV,PRCHAREC,PRCHL1,PRCHL2,PRCHLC,PRCHO,PRCHN,PRCHNPO,PRCHD0,PRCHP0,PRCHAC,PRCHACT,PRCHDA,PRCHDT,ROUTINE
- +1 DO KILL^PRCHAM44
- KILL PRCHAVLD,PRCHCHK,PRCHII,PRCHITR,PRCHITSB,PRCHQTY,PRCHRPTN,PRCHRPTO,PRCHSAM1,PRCHSAM2,PRCHJJ,PRCHMM,PRCHSHIP,PRCHXX1,NOFISCAL
- LOCK
- QUIT
