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 Oct 16, 2024@18:06:21 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
