- 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 Feb 18, 2025@23:43:42 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