PRCSCPY ;WISC/KMB/DXH/DAP - COPY OLD TEMP. REQUEST TO NEW ; 7.23.99
V ;;5.1;IFCAP;**81**;Oct 20, 2000
;Per VHA Directive 10-93-142, this routine should not be modified.
;
N X3,T,T1,PRCSDR,OLDA,NEWDA,PRCDAA,PRCSAPP,PRCSK,NEWTEMP,OLD0NODE,OLD3NODE,I,J,PRCK,PRCHFLG
;
START ;
W !!
; S PRCSK=1 ; flag to allow any user to select any site
; next line commented out in PRC*5*140 - user responses not used
; D EN1F^PRCSUT(1) G W2:'$D(PRC("SITE")) G EXIT:Y<0
S X3="H",DIC="^PRCS(410,",DIC(0)="AEQ",DIC("A")="Select transaction to be copied: "
S DIC("S")="I $P(^(0),U,3)'="""",^PRCS(410,""H"",$P(^(0),U,3),+Y)=DUZ!(^(+Y)="""")" ; request must be authored by user or be unauthored
D ^PRCSDIC K DIC("A"),DIC("S")
G EXIT:Y<0 ; user entered '^'
S (OLDA,DA)=+Y ; subscript/internal# to file 410
L +^PRCS(410,DA):1 I $T=0 D EN^DDIOL("File being accessed...please try later") Q
D REVIEW
S PRCVFT=$P(^PRCS(410,DA,0),"^",4)
;*81 Check site parameter to see if Issue Books are allowed
I $$GET^XPAR("SYS","PRCV COTS INVENTORY",1,"Q")=1 S PRCVZ=1
I $$GET^XPAR("SYS","PRCV COTS INVENTORY",1,"Q")'=1 S PRCVZ=0
I PRCVZ=1,PRCVFT=5 W !,"All Supply Warehouse requests must be processed in the new Inventory System.",!!,"Please cancel this IFCAP Issue Book order." D CLEAN G START
K DA,DIC,PRCVFT,PRCVZ
I $D(%) G EXIT:%=-1
ENTRY ;
D EN^DDIOL("Please enter information for the transaction being created.")
W !
S PRCSK=1 ; allow user to select any station on system
D EN1F^PRCSUT(1) ;ask site, FY, QRTR, CP & store in PRC array, set up PRCSIP
G W2:'$D(PRC("SITE")) ; only happens if there are no stations on system?
G EXIT:Y<0
EN1 D EN^DDIOL("Please enter a new transaction in the format 'A1234'")
W !
S DIC("A")="Enter new temporary transaction number: "
S DLAYGO=410,DIC="^PRCS(410,",DIC(0)="L",D="H"
S DIC("S")="I '^(0),$P(^(0),U,3)'="""",^PRCS(410,""H"",$P(^(0),U,3),+Y)=DUZ!(^(+Y)="""")" ; only requests authored by user or unauthored will display on partial match, display doesn't filter for station,CP,FY,or QRTR
D ^PRCSDIC S NEWTEMP=X K DLAYGO,DIC("A"),DIC("S") G:Y<0 EXIT
I $D(^PRCS(410,"H",$P(Y,U,2)))
I D EN^DDIOL("Must be a new and different temporary number.","","!!") G EN1
S (NEWDA,T1,DA)=+Y ; subscript/internal# to file 410 for new txn
;
PROCESS ;ERC-10/96 Revised copy of fields into new transaction
L +^PRCS(410,NEWDA):1 ; lock file being created
I $T=0 D EN^DDIOL("File being accessed...please try a different number or try later") G EN1
D EN^DDIOL("Transaction data is being copied.","","!?10") W !
S T(2)=NEWTEMP
D EN2A^PRCSUT3 ; sets up sta,substa,BBFY,author,CP,ACC,rb code,etc
S OLD0NODE=^PRCS(410,OLDA,0),OLD3NODE=^PRCS(410,OLDA,3)
F I=2,4 S $P(^PRCS(410,NEWDA,0),U,I)=$P(OLD0NODE,U,I) ; txn type,format
; note that for any FCP that is not automated,the form type is not forced to be non repetitive. This may be because full implementation of IFCAP is mandatory.
I $D(PRCSIP) S $P(^PRCS(410,NEWDA,0),U,6)=PRCSIP ; inventory distrib point, 'AO' xref will be set by XREF subroutine
S %DT="X",X="T" D ^%DT ; get today in internal date format
S $P(^PRCS(410,NEWDA,1),U)=Y ; & store as date of request
I $D(^PRCS(410,OLDA,2)) S ^PRCS(410,NEWDA,2)=^PRCS(410,OLDA,2) ; vendor info may not be on 1358's
F I=4:1:10 S $P(^PRCS(410,NEWDA,3),U,I)=$P(OLD3NODE,U,I)
I $P(OLD3NODE,U)'=PRC("CP") S PRCHFLG=1 ; different CP
E S $P(^PRCS(410,NEWDA,3),U,3)=$P(OLD3NODE,U,3)
F I=4,10 I $D(^PRCS(410,OLDA,I)) S $P(^PRCS(410,NEWDA,I),U)=$P(^PRCS(410,OLDA,I),U)
I $P(^PRCS(410,NEWDA,0),U,4)=1 ;1358 needs Date Committed
I S $P(^PRCS(410,NEWDA,4),U,2)=$E($P(^PRCS(410,NEWDA,1),U),1,5)_"01"
S $P(^PRCS(410,DA,7),U)=DUZ ; PRC140 - this line moved from FINAL
S $P(^PRCS(410,DA,14),U)=DUZ
I $D(^PRCS(410,OLDA,"RM",0)) S ^PRCS(410,NEWDA,"RM",0)=$P(^PRCS(410,OLDA,"RM",0),U,1,4)_"^"_DT,PRCK=0 D
. F J=0:0 S PRCK=$O(^PRCS(410,OLDA,"RM",PRCK)) Q:'PRCK S:$D(^PRCS(410,OLDA,"RM",PRCK,0)) ^PRCS(410,NEWDA,"RM",PRCK,0)=$P(^PRCS(410,OLDA,"RM",PRCK,0),U)
S T1=OLDA,DA=NEWDA
D S7^PRCSECP1 ; copy 'IT' subnode from the old transaction
;new transaction has different FCP from old txn
I +$G(PRCHFLG) S PRCHFLG=$$CHGCCBOC^PRCSCK($P($G(^PRCS(410,T1,0)),U),$P($G(^PRCS(410,NEWDA,0)),U),$P($G(^PRCS(410,OLDA,3)),U,3),0)
;I '$G(PRCHFLG) G P2 ; new transaction has same CP as original
;D SRCH I X'="" S:X'=1 $P(^PRCS(410,NEWDA,3),U,3)=X G P1
;S DA=NEWDA,DR=15.5,DIE="^PRCS(410," D ^DIE ; ask cost center
;I $D(Y)'=0 D XREF G EXIT ; user entered '^'
I ($G(PRCHFLG)<-1) D XREF G EXIT ; user entered '^'
P1 K PRCHFLG
P2 S DIC(0)="AEMQ",DIE=DIC,DR=7 D ^DIE ; ask Date required
I $D(Y)'=0 D XREF G EXIT ; user entered '^'
D XREF G EDIT
XREF S DA=NEWDA,DIK="^PRCS(410," D IX^DIK ; set up X-refs for new transaction
Q
EDIT ;
S %=2 D EN^DDIOL("Would you like to edit this entry")
D YN^DICN G EDIT:%=0 G EXIT:%=-1 G:%=2 FINAL
EDIT1 ;
S X=+$P($G(^PRCS(410,DA,0)),"^",4) ; X is form type
;*81 Check site parameter to see if issue books should be allowed
I $$GET^XPAR("SYS","PRCV COTS INVENTORY",1,"Q")=1 S PRCVX="I Y>1&(Y<5)",PRCVY="The Issue Book and NO FORM types are not valid in this option."
I $$GET^XPAR("SYS","PRCV COTS INVENTORY",1,"Q")'=1 S PRCVX="I Y>1",PRCVY="The NO FORM type is not valid in this option."
I X<1 D
. S DA=NEWDA
. D EN^DDIOL(PRCVY)
. D EN^DDIOL("Please enter another form type.","","!!")
. W !
. S DIC="^PRCS(410.5,"
. S DIC("A")="FORM TYPE: "
. S DIC(0)="AEQZ"
. S DIC("S")=PRCVX
. D ^DIC
. S:Y=-1 Y=2
. S $P(^PRCS(410,NEWDA,0),"^",4)=+Y,X=+Y
. K DIC,PRCVX,PRCVY
D EN^DDIOL("The form type of this request is "_$P($G(^PRCS(410.5,X,0)),"^"))
; PRC140 - 2237 form types now use temporary transaction templates
S (PRCSDR,DR)="["_$S(X=1:"PRCE NEW 1358S",X=2:"PRCSEN2237S",X=3:"PRCSENPRS",X=4:"PRCSENR&NRS",X=5:"PRCSENIBS",1:"PRCSENCOD")_"]"
K DTOUT,DUOUT,Y
S (DIE,DIC)="^PRCS(410,"
D ^DIE I $D(Y)!($D(DTOUT)) G EXIT
I +$P($G(^PRCS(410,DA,0)),"^",4)=1 G FINAL ; skip line item processing if this is a 1358
S DA=NEWDA D RL^PRCSUT1
D ^PRCSCK I $D(PRCSERR),PRCSERR G EDIT1
;
FINAL ;
W !! D CLEAN G START
;
REVIEW W !!,"Would you like to review this request" S %=2
D YN^DICN G REVIEW:%=0 I %'=1 Q
S PRC("SITE")=+$P(^PRCS(410,DA,0),"^",5)
S PRC("CP")=$P(^PRCS(410,DA,3),"^")
S (N,PRCSZ)=DA,PRCSF=1 D PRF1^PRCSP1 S DA=OLDA K X,PRCSF,PRCSZ Q
;
W2 D EN^DDIOL("You are not an authorized control point user.","","!!")
D EN^DDIOL("Contact your control point official")
R X:5 G EXIT
W3 Q ;can this be deleted? - commented out in patch PRC*5*140
D EN^DDIOL("Would you like to copy another request","","!!")
S %=1 D YN^DICN G W3:%=0 G START:%=1 Q
;
SRCH ;FIND COST CENTER
; returns x="" if there are multiple cc's, x=1 if no cc, x=cc if only 1
S X=0
SRCH1 S X=$O(^PRC(420,PRC("SITE"),1,+PRC("CP"),2,X))
I X=""!(+X'=X) D EN^DDIOL("Transaction will be created but this control point has no active cost center","","!!") S X=1 Q
I '$D(^PRCD(420.1,X,0)) G SRCH1
I $P(^PRCD(420.1,X,0),U,2)=1 G SRCH1
S Y=X ; found 1 cost center
SRCH2 S X=$O(^PRC(420,PRC("SITE"),1,+PRC("CP"),2,X))
I X=""!(+X'=X) S X=$P(^PRCD(420.1,Y,0),U) Q ; save cost center
I '$D(^PRCD(420.1,X,0)) G SRCH2
I $P(^PRCD(420.1,X,0),U,2)=1 G SRCH2
S X="" ; system can't select cost center - there is more than 1
Q
CLEAN I $D(OLDA) L -^PRCS(410,OLDA)
I $D(NEWDA)=1 L -^PRCS(410,NEWDA)
K %,DA,DIC,X,Y,PRCSERR
Q
;
EXIT D CLEAN
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCSCPY 7514 printed Dec 13, 2024@02:17:19 Page 2
PRCSCPY ;WISC/KMB/DXH/DAP - COPY OLD TEMP. REQUEST TO NEW ; 7.23.99
V ;;5.1;IFCAP;**81**;Oct 20, 2000
+1 ;Per VHA Directive 10-93-142, this routine should not be modified.
+2 ;
+3 NEW X3,T,T1,PRCSDR,OLDA,NEWDA,PRCDAA,PRCSAPP,PRCSK,NEWTEMP,OLD0NODE,OLD3NODE,I,J,PRCK,PRCHFLG
+4 ;
START ;
+1 WRITE !!
+2 ; S PRCSK=1 ; flag to allow any user to select any site
+3 ; next line commented out in PRC*5*140 - user responses not used
+4 ; D EN1F^PRCSUT(1) G W2:'$D(PRC("SITE")) G EXIT:Y<0
+5 SET X3="H"
SET DIC="^PRCS(410,"
SET DIC(0)="AEQ"
SET DIC("A")="Select transaction to be copied: "
+6 ; request must be authored by user or be unauthored
SET DIC("S")="I $P(^(0),U,3)'="""",^PRCS(410,""H"",$P(^(0),U,3),+Y)=DUZ!(^(+Y)="""")"
+7 DO ^PRCSDIC
KILL DIC("A"),DIC("S")
+8 ; user entered '^'
if Y<0
GOTO EXIT
+9 ; subscript/internal# to file 410
SET (OLDA,DA)=+Y
+10 LOCK +^PRCS(410,DA):1
IF $TEST=0
DO EN^DDIOL("File being accessed...please try later")
QUIT
+11 DO REVIEW
+12 SET PRCVFT=$PIECE(^PRCS(410,DA,0),"^",4)
+13 ;*81 Check site parameter to see if Issue Books are allowed
+14 IF $$GET^XPAR("SYS","PRCV COTS INVENTORY",1,"Q")=1
SET PRCVZ=1
+15 IF $$GET^XPAR("SYS","PRCV COTS INVENTORY",1,"Q")'=1
SET PRCVZ=0
+16 IF PRCVZ=1
IF PRCVFT=5
WRITE !,"All Supply Warehouse requests must be processed in the new Inventory System.",!!,"Please cancel this IFCAP Issue Book order."
DO CLEAN
GOTO START
+17 KILL DA,DIC,PRCVFT,PRCVZ
+18 IF $DATA(%)
if %=-1
GOTO EXIT
ENTRY ;
+1 DO EN^DDIOL("Please enter information for the transaction being created.")
+2 WRITE !
+3 ; allow user to select any station on system
SET PRCSK=1
+4 ;ask site, FY, QRTR, CP & store in PRC array, set up PRCSIP
DO EN1F^PRCSUT(1)
+5 ; only happens if there are no stations on system?
if '$DATA(PRC("SITE"))
GOTO W2
+6 if Y<0
GOTO EXIT
EN1 DO EN^DDIOL("Please enter a new transaction in the format 'A1234'")
+1 WRITE !
+2 SET DIC("A")="Enter new temporary transaction number: "
+3 SET DLAYGO=410
SET DIC="^PRCS(410,"
SET DIC(0)="L"
SET D="H"
+4 ; only requests authored by user or unauthored will display on partial match, display doesn't filter for station,CP,FY,or QRTR
SET DIC("S")="I '^(0),$P(^(0),U,3)'="""",^PRCS(410,""H"",$P(^(0),U,3),+Y)=DUZ!(^(+Y)="""")"
+5 DO ^PRCSDIC
SET NEWTEMP=X
KILL DLAYGO,DIC("A"),DIC("S")
if Y<0
GOTO EXIT
+6 IF $DATA(^PRCS(410,"H",$PIECE(Y,U,2)))
+7 IF $TEST
DO EN^DDIOL("Must be a new and different temporary number.","","!!")
GOTO EN1
+8 ; subscript/internal# to file 410 for new txn
SET (NEWDA,T1,DA)=+Y
+9 ;
PROCESS ;ERC-10/96 Revised copy of fields into new transaction
+1 ; lock file being created
LOCK +^PRCS(410,NEWDA):1
+2 IF $TEST=0
DO EN^DDIOL("File being accessed...please try a different number or try later")
GOTO EN1
+3 DO EN^DDIOL("Transaction data is being copied.","","!?10")
WRITE !
+4 SET T(2)=NEWTEMP
+5 ; sets up sta,substa,BBFY,author,CP,ACC,rb code,etc
DO EN2A^PRCSUT3
+6 SET OLD0NODE=^PRCS(410,OLDA,0)
SET OLD3NODE=^PRCS(410,OLDA,3)
+7 ; txn type,format
FOR I=2,4
SET $PIECE(^PRCS(410,NEWDA,0),U,I)=$PIECE(OLD0NODE,U,I)
+8 ; note that for any FCP that is not automated,the form type is not forced to be non repetitive. This may be because full implementation of IFCAP is mandatory.
+9 ; inventory distrib point, 'AO' xref will be set by XREF subroutine
IF $DATA(PRCSIP)
SET $PIECE(^PRCS(410,NEWDA,0),U,6)=PRCSIP
+10 ; get today in internal date format
SET %DT="X"
SET X="T"
DO ^%DT
+11 ; & store as date of request
SET $PIECE(^PRCS(410,NEWDA,1),U)=Y
+12 ; vendor info may not be on 1358's
IF $DATA(^PRCS(410,OLDA,2))
SET ^PRCS(410,NEWDA,2)=^PRCS(410,OLDA,2)
+13 FOR I=4:1:10
SET $PIECE(^PRCS(410,NEWDA,3),U,I)=$PIECE(OLD3NODE,U,I)
+14 ; different CP
IF $PIECE(OLD3NODE,U)'=PRC("CP")
SET PRCHFLG=1
+15 IF '$TEST
SET $PIECE(^PRCS(410,NEWDA,3),U,3)=$PIECE(OLD3NODE,U,3)
+16 FOR I=4,10
IF $DATA(^PRCS(410,OLDA,I))
SET $PIECE(^PRCS(410,NEWDA,I),U)=$PIECE(^PRCS(410,OLDA,I),U)
+17 ;1358 needs Date Committed
IF $PIECE(^PRCS(410,NEWDA,0),U,4)=1
+18 IF $TEST
SET $PIECE(^PRCS(410,NEWDA,4),U,2)=$EXTRACT($PIECE(^PRCS(410,NEWDA,1),U),1,5)_"01"
+19 ; PRC140 - this line moved from FINAL
SET $PIECE(^PRCS(410,DA,7),U)=DUZ
+20 SET $PIECE(^PRCS(410,DA,14),U)=DUZ
+21 IF $DATA(^PRCS(410,OLDA,"RM",0))
SET ^PRCS(410,NEWDA,"RM",0)=$PIECE(^PRCS(410,OLDA,"RM",0),U,1,4)_"^"_DT
SET PRCK=0
Begin DoDot:1
+22 FOR J=0:0
SET PRCK=$ORDER(^PRCS(410,OLDA,"RM",PRCK))
if 'PRCK
QUIT
if $DATA(^PRCS(410,OLDA,"RM",PRCK,0))
SET ^PRCS(410,NEWDA,"RM",PRCK,0)=$PIECE(^PRCS(410,OLDA,"RM",PRCK,0),U)
End DoDot:1
+23 SET T1=OLDA
SET DA=NEWDA
+24 ; copy 'IT' subnode from the old transaction
DO S7^PRCSECP1
+25 ;new transaction has different FCP from old txn
+26 IF +$GET(PRCHFLG)
SET PRCHFLG=$$CHGCCBOC^PRCSCK($PIECE($GET(^PRCS(410,T1,0)),U),$PIECE($GET(^PRCS(410,NEWDA,0)),U),$PIECE($GET(^PRCS(410,OLDA,3)),U,3),0)
+27 ;I '$G(PRCHFLG) G P2 ; new transaction has same CP as original
+28 ;D SRCH I X'="" S:X'=1 $P(^PRCS(410,NEWDA,3),U,3)=X G P1
+29 ;S DA=NEWDA,DR=15.5,DIE="^PRCS(410," D ^DIE ; ask cost center
+30 ;I $D(Y)'=0 D XREF G EXIT ; user entered '^'
+31 ; user entered '^'
IF ($GET(PRCHFLG)<-1)
DO XREF
GOTO EXIT
P1 KILL PRCHFLG
P2 ; ask Date required
SET DIC(0)="AEMQ"
SET DIE=DIC
SET DR=7
DO ^DIE
+1 ; user entered '^'
IF $DATA(Y)'=0
DO XREF
GOTO EXIT
+2 DO XREF
GOTO EDIT
XREF ; set up X-refs for new transaction
SET DA=NEWDA
SET DIK="^PRCS(410,"
DO IX^DIK
+1 QUIT
EDIT ;
+1 SET %=2
DO EN^DDIOL("Would you like to edit this entry")
+2 DO YN^DICN
if %=0
GOTO EDIT
if %=-1
GOTO EXIT
if %=2
GOTO FINAL
EDIT1 ;
+1 ; X is form type
SET X=+$PIECE($GET(^PRCS(410,DA,0)),"^",4)
+2 ;*81 Check site parameter to see if issue books should be allowed
+3 IF $$GET^XPAR("SYS","PRCV COTS INVENTORY",1,"Q")=1
SET PRCVX="I Y>1&(Y<5)"
SET PRCVY="The Issue Book and NO FORM types are not valid in this option."
+4 IF $$GET^XPAR("SYS","PRCV COTS INVENTORY",1,"Q")'=1
SET PRCVX="I Y>1"
SET PRCVY="The NO FORM type is not valid in this option."
+5 IF X<1
Begin DoDot:1
+6 SET DA=NEWDA
+7 DO EN^DDIOL(PRCVY)
+8 DO EN^DDIOL("Please enter another form type.","","!!")
+9 WRITE !
+10 SET DIC="^PRCS(410.5,"
+11 SET DIC("A")="FORM TYPE: "
+12 SET DIC(0)="AEQZ"
+13 SET DIC("S")=PRCVX
+14 DO ^DIC
+15 if Y=-1
SET Y=2
+16 SET $PIECE(^PRCS(410,NEWDA,0),"^",4)=+Y
SET X=+Y
+17 KILL DIC,PRCVX,PRCVY
End DoDot:1
+18 DO EN^DDIOL("The form type of this request is "_$PIECE($GET(^PRCS(410.5,X,0)),"^"))
+19 ; PRC140 - 2237 form types now use temporary transaction templates
+20 SET (PRCSDR,DR)="["_$SELECT(X=1:"PRCE NEW 1358S",X=2:"PRCSEN2237S",X=3:"PRCSENPRS",X=4:"PRCSENR&NRS",X=5:"PRCSENIBS",1:"PRCSENCOD")_"]"
+21 KILL DTOUT,DUOUT,Y
+22 SET (DIE,DIC)="^PRCS(410,"
+23 DO ^DIE
IF $DATA(Y)!($DATA(DTOUT))
GOTO EXIT
+24 ; skip line item processing if this is a 1358
IF +$PIECE($GET(^PRCS(410,DA,0)),"^",4)=1
GOTO FINAL
+25 SET DA=NEWDA
DO RL^PRCSUT1
+26 DO ^PRCSCK
IF $DATA(PRCSERR)
IF PRCSERR
GOTO EDIT1
+27 ;
FINAL ;
+1 WRITE !!
DO CLEAN
GOTO START
+2 ;
REVIEW WRITE !!,"Would you like to review this request"
SET %=2
+1 DO YN^DICN
if %=0
GOTO REVIEW
IF %'=1
QUIT
+2 SET PRC("SITE")=+$PIECE(^PRCS(410,DA,0),"^",5)
+3 SET PRC("CP")=$PIECE(^PRCS(410,DA,3),"^")
+4 SET (N,PRCSZ)=DA
SET PRCSF=1
DO PRF1^PRCSP1
SET DA=OLDA
KILL X,PRCSF,PRCSZ
QUIT
+5 ;
W2 DO EN^DDIOL("You are not an authorized control point user.","","!!")
+1 DO EN^DDIOL("Contact your control point official")
+2 READ X:5
GOTO EXIT
W3 ;can this be deleted? - commented out in patch PRC*5*140
QUIT
+1 DO EN^DDIOL("Would you like to copy another request","","!!")
+2 SET %=1
DO YN^DICN
if %=0
GOTO W3
if %=1
GOTO START
QUIT
+3 ;
SRCH ;FIND COST CENTER
+1 ; returns x="" if there are multiple cc's, x=1 if no cc, x=cc if only 1
+2 SET X=0
SRCH1 SET X=$ORDER(^PRC(420,PRC("SITE"),1,+PRC("CP"),2,X))
+1 IF X=""!(+X'=X)
DO EN^DDIOL("Transaction will be created but this control point has no active cost center","","!!")
SET X=1
QUIT
+2 IF '$DATA(^PRCD(420.1,X,0))
GOTO SRCH1
+3 IF $PIECE(^PRCD(420.1,X,0),U,2)=1
GOTO SRCH1
+4 ; found 1 cost center
SET Y=X
SRCH2 SET X=$ORDER(^PRC(420,PRC("SITE"),1,+PRC("CP"),2,X))
+1 ; save cost center
IF X=""!(+X'=X)
SET X=$PIECE(^PRCD(420.1,Y,0),U)
QUIT
+2 IF '$DATA(^PRCD(420.1,X,0))
GOTO SRCH2
+3 IF $PIECE(^PRCD(420.1,X,0),U,2)=1
GOTO SRCH2
+4 ; system can't select cost center - there is more than 1
SET X=""
+5 QUIT
CLEAN IF $DATA(OLDA)
LOCK -^PRCS(410,OLDA)
+1 IF $DATA(NEWDA)=1
LOCK -^PRCS(410,NEWDA)
+2 KILL %,DA,DIC,X,Y,PRCSERR
+3 QUIT
+4 ;
EXIT DO CLEAN
+1 QUIT