PRCSECP ;SFISC/KSS,LJP/DAP - COPY A TRANSACTION ;7/9/13 16:02
V ;;5.1;IFCAP;**81,148,174**;Oct 20, 2000;Build 23
;;Per VHA Directive 2004-038, this routine should not be modified.
A I '$D(DT) S %DT="",X="T" D ^%DT S DT=Y
W @IOF,!!
B D EN3^PRCSUT ;GO GET STATION AND CONTROL POINT
I '$D(PRC("SITE"))!('$D(PRC("CP")))!(Y<0)!('$D(X))!($G(X)[U) D END Q
N GET,GET1 S DIC="^PRCS(410,",DIC(0)="AEQM"
S DIC("S")="S PRCST=$P(^(0),U,2) I $D(^(3)),+^(3)=+PRC(""CP""),$P(^(0),""^"",5)=PRC(""SITE"") I $D(^PRC(420,""A"",DUZ,PRC(""SITE""),+PRC(""CP""),1))!($D(^(2))) I PRCST=""O""!(PRCST=""CA"")"
S DIC("A")="Select the Transaction to be copied: "
C W ! D ^PRCSDIC K PRCST
I (X[U)!(Y<0) D END Q
S DA=+Y
S PRCVFT=$P(^PRCS(410,DA,0),"^",4)
;if 2237 transaction (Form Type IEN 2,3, or 4), do required field checks (PRC*5.1*174)
I $G(PRCVFT)>1&($G(PRCVFT)<5) D
. N PRCWARN
. ;warn user if required fields are missing from transaction that is going to be copied
. I '$$REQCHECK^PRCHJUTL($G(DA),.PRCWARN) D
. . W !?15,"********** WARNING **********",*7,!
. . W !,"Transaction to be copied ("_$$GET1^DIQ(410,$G(DA),.01)_") is missing required data!"
. . N PRCIDX S PRCIDX=0
. . F S PRCIDX=$O(PRCWARN(PRCIDX)) Q:'PRCIDX D
. . . W !?2,">>> "_$G(PRCWARN(PRCIDX))
. . W !,"This data will be required when entering information for the"
. . W !,"new transaction number.",!
;
;prompt user to review this request
D W1
;
;*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 W3 G:%'=1 END W !! K PRCS,PRCS2 G B
;
PROCEED ;modified prompt and added help (PRC*5.1*174)
W !!,"Would you like to proceed with copying this request"
S %=1 D YN^DICN
I %=0 D G PROCEED
. W !?2,"Enter 'Yes' to proceed with copying transaction "_$$GET1^DIQ(410,$G(DA),.01)_"."
. W !?2,"Enter 'No' or '^' to abort copying this transaction."
I %'=1 D G C
. W !!?2,">>> Transaction "_$$GET1^DIQ(410,$G(DA),.01)_" data was not copied.",!
;
S DIC="^PRCS(410," L +^PRCS(410,DA):15 G END:$T=0
S T1=DA,T2=^PRCS(410,DA,0),T5=$P(T2,U,4),T4=$P(T2,U,2),T2=$P(T2,U),T3=$P(^(3),U)
K ^TMP($J)
S ^TMP($J,"OLDDA")=DA,^("OLDTXN")=$P(T2,U,1),^("OLDFCP")=PRC("CP")
W !!,"Now enter the information for the new transaction number.",!
;L -^PRCS(410,DA)
K DA,DIC,Y D EN1^PRCSUT K DA,DIC
I ('$D(PRC("SITE")))!('$D(PRC("QTR")))!('$D(PRC("CP"))) G UNLKEND
I $P($G(^PRCS(410,T1,0)),"^",4)=1,$$Q1358^PRCEN(PRC("SITE"),PRC("CP")) G UNLKEND
S X1=X,PRCSAPP=$P(^PRC(420,PRC("SITE"),1,+PRC("CP"),0),U,3)
I PRC("CP")'=T3,PRCSAPP["_" D PRCFY^PRCSUT2 I (PRCSAPP["_") G UNLKEND
S X=X1 D EN1^PRCSUT3 I 'X G UNLKEND
S X1=X D EN2^PRCSUT3 I ('$D(X1)) G UNLKEND
S (X,^TMP($J,"NEWTXN"))=X1
W !!,"This transaction is assigned transaction number: ",X
;L +^PRCS(410,DA):15 G B:$T=0
I $D(^PRC(420,PRC("SITE"),1,+PRC("CP"),0)) S:$P(^(0),U,11)="Y" PRCS2=1
TYPE ;
S PRCSX=$P(^PRCS(410,T1,0),"^",4)
;*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>(.5)&(Y<5)",PRCVY="The Issue Book and NO FORM types are no longer used."
I $$GET^XPAR("SYS","PRCV COTS INVENTORY",1,"Q")'=1 S PRCVX="I Y>(.5)",PRCVY="The NO FORM type is no longer used."
I PRCSX<1 W !,PRCVY,!,"Please enter another form type.",! S PRCDAA=DA,DIC="^PRCS(410.5,",DIC("S")=PRCVX,DIC("A")="FORM TYPE: ",DIC(0)="AEQZ" D ^DIC S:Y=-1 Y=2 S DA=PRCDAA,PRCSX=+Y
S (DIE,DIC)="^PRCS(410,"
K PRCVX,PRCVY
S $P(^PRCS(410,DA,0),"^",4)=PRCSX
W !,"The form type for this request is: ",$P($G(^PRCS(410.5,PRCSX,0)),"^"),!
W !,?10,"Transaction data is being copied...",!
D @$S(PRCSX=1:"S1^PRCSECP1",1:"S2^PRCSECP1") S DIK="^PRCS(410," D IX^DIK
S (DIC,DIE)="^PRCS(410,"
;P182--removed warning about changed CC/BOC;replaced w/following call
S X=$$CHGCCBOC^PRCSCK(^TMP($J,"OLDTXN"),^TMP($J,"NEWTXN"),^TMP($J,"OLDFCP"),0)
S X=PRCSX S:'$D(PRCS2)&(X>2) $P(^PRCS(410,DA,0),"^",4)=2,X=2
S (PRCSDR,DR)="["_$S(X=1:"PRCE NEW 1358",X=2:"PRCSEN2237B",X=3:"PRCSENPR",X=4:"PRCSENR&NR",X=5:"PRCSENIB",1:"PRCSENCOD")_"]"
D K DTOUT,DUOUT,Y S COPYDA=DA D ^DIE I $D(Y)!($D(DTOUT)) S DA=COPYDA G END
S DA=COPYDA D RL^PRCSUT1
D ^PRCSCK I $D(PRCSERR),PRCSERR G D
K PRCSERR
I PRCSDR="[PRCSENCOD]" D W7^PRCSEB0 D:$D(PRCSOB) ENOD1^PRCSEB1 K PRCSOB
D:PRCSDR'="[PRCSENCOD]" W1 I PRCSDR'="[PRCSENCOD]",$D(PRCS2),+^PRCS(410,DA,0) D W6^PRCSEB
S DA=COPYDA L -^PRCS(410,DA) D W3 G END:%'=1 W !! K PRCS,PRCS2
G B
;
UNLKEND S DA=^TMP($J,"OLDDA") L -^PRCS(410,DA)
END K %,D0,DA,DIC,DIE,DIK,DR,N,P,PRCSAPP,COPYDA,PRCSDR,PRCSERR,PRCSI,PRCSIP,PRCSJ,PRCSJ,PRCSL,PRCST1,PRCSTMP,PRCSTT,PRCSX,PRCSZ,T1,T2,T3,T4,T5,X,X1,Y,PRCVZ,PRCVFT
K ^TMP($J)
Q
W1 W !!,"Would you like to review this request" S %=2 D YN^DICN G W1:%=0 Q:%'=1 S (N,PRCSZ)=DA,PRCSF=1 D PRF1^PRCSP1 S DA=PRCSZ K X,PRCSF,PRCSZ Q
W3 W !!,"Would you like to copy another request" S %=1 D YN^DICN G W3:%=0 Q
;
GETCCCNT(STA,FCP) ;How many valid Cost Centers for this Control Point
;return count and first CC
N GOODCC,CC,FIRSTCC
S GOODCC=0,(CC,FIRSTCC)=""
F S CC=$O(^PRC(420,+STA,1,+FCP,2,CC)) Q:CC="" D
. I $$VALIDCC(STA,FCP,CC) S GOODCC=GOODCC+1 I FIRSTCC="" S FIRSTCC=$E($P(^PRCD(420.1,+CC,0),U,1),1,23)
Q GOODCC_"^"_FIRSTCC
;
VALIDCC(STA,FCP,CC) ;Is this STATION,FCP,COST CENTER combination valid?
;To be valid, station/FCP must point to CC, CC must be active,CC must
;point to some active BOC
N X,VALID,BOC,GOODBOC
S BOC="",GOODBOC=0
S X=$G(^PRC(420,+STA,1,+FCP,2,+CC,0)) I (+X=+CC) D ;FCP => CC
. S X=$G(^PRCD(420.1,CC,0)) I X]"",'$P(X,U,2) D ; CC IS ACTIVE
.. F S BOC=$O(^PRCD(420.1,+CC,1,BOC)) Q:BOC=""!GOODBOC D
... S X=$G(^PRCD(420.2,+BOC,0)) I X]"",'$P(X,U,2) S GOODBOC=1
Q GOODBOC
;
GETBOCNT(STA,FCP,CC) ;How many valid BOCs for this STATION,FCP,COST CENTER
;To be valid, station/FCP must point to CC, CC must be active,CC must
;point to some active BOC
N X,VALID,BOC,GOODBOC,TOTBOCS,FIRSTBOC
S BOC="",GOODBOC=0,TOTBOCS=0,FIRSTBOC=""
S X=$G(^PRC(420,+STA,1,+FCP,2,+CC,0)) I (+X=+CC) D ;FCP => CC
. S X=$G(^PRCD(420.1,CC,0)) I X]"",'$P(X,U,2) D ; CC IS ACTIVE
.. F S BOC=$O(^PRCD(420.1,+CC,1,BOC)) Q:BOC="" D
... S X=$G(^PRCD(420.2,+BOC,0)) I X]"",'$P(X,U,2) D
.... S TOTBOCS=TOTBOCS+1 I FIRSTBOC="" S FIRSTBOC=$E($P(^PRCD(420.2,+BOC,0),U,1),1,23)
Q TOTBOCS_"^"_FIRSTBOC
;
VALIDBOC(STA,FCP,CC,BOC) ;Is this STATION,FCP,COST CENTER,BOC VALID?
;To be valid, station/FCP must point to CC, CC must be active,CC must
;point to BOC,and BOC must be active
N X,VALID,GOODBOC
S GOODBOC=0
S X=$G(^PRC(420,+STA,1,+FCP,2,+CC,0))
I (+X=+CC) S X=$G(^PRCD(420.1,+CC,0)) I X]"",'$P(X,U,2) D
. S X=$G(^PRCD(420.1,+CC,1,+BOC,0))
. I X]"" S X=$G(^PRCD(420.2,+BOC,0)) I X]"",'$P(X,U,2) S GOODBOC=1
Q GOODBOC
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCSECP 7089 printed Oct 16, 2024@18:18:19 Page 2
PRCSECP ;SFISC/KSS,LJP/DAP - COPY A TRANSACTION ;7/9/13 16:02
V ;;5.1;IFCAP;**81,148,174**;Oct 20, 2000;Build 23
+1 ;;Per VHA Directive 2004-038, this routine should not be modified.
A IF '$DATA(DT)
SET %DT=""
SET X="T"
DO ^%DT
SET DT=Y
+1 WRITE @IOF,!!
B ;GO GET STATION AND CONTROL POINT
DO EN3^PRCSUT
+1 IF '$DATA(PRC("SITE"))!('$DATA(PRC("CP")))!(Y<0)!('$DATA(X))!($GET(X)[U)
DO END
QUIT
+2 NEW GET,GET1
SET DIC="^PRCS(410,"
SET DIC(0)="AEQM"
+3 SET DIC("S")="S PRCST=$P(^(0),U,2) I $D(^(3)),+^(3)=+PRC(""CP""),$P(^(0),""^"",5)=PRC(""SITE"") I $D(^PRC(420,""A"",DUZ,PRC(""SITE""),+PRC(""CP""),1))!($D(^(2))) I PRCST=""O""!(PRCST=""CA"")"
+4 SET DIC("A")="Select the Transaction to be copied: "
C WRITE !
DO ^PRCSDIC
KILL PRCST
+1 IF (X[U)!(Y<0)
DO END
QUIT
+2 SET DA=+Y
+3 SET PRCVFT=$PIECE(^PRCS(410,DA,0),"^",4)
+4 ;if 2237 transaction (Form Type IEN 2,3, or 4), do required field checks (PRC*5.1*174)
+5 IF $GET(PRCVFT)>1&($GET(PRCVFT)<5)
Begin DoDot:1
+6 NEW PRCWARN
+7 ;warn user if required fields are missing from transaction that is going to be copied
+8 IF '$$REQCHECK^PRCHJUTL($GET(DA),.PRCWARN)
Begin DoDot:2
+9 WRITE !?15,"********** WARNING **********",*7,!
+10 WRITE !,"Transaction to be copied ("_$$GET1^DIQ(410,$GET(DA),.01)_") is missing required data!"
+11 NEW PRCIDX
SET PRCIDX=0
+12 FOR
SET PRCIDX=$ORDER(PRCWARN(PRCIDX))
if 'PRCIDX
QUIT
Begin DoDot:3
+13 WRITE !?2,">>> "_$GET(PRCWARN(PRCIDX))
End DoDot:3
+14 WRITE !,"This data will be required when entering information for the"
+15 WRITE !,"new transaction number.",!
End DoDot:2
End DoDot:1
+16 ;
+17 ;prompt user to review this request
+18 DO W1
+19 ;
+20 ;*81 Check site parameter to see if Issue Books are allowed
+21 IF $$GET^XPAR("SYS","PRCV COTS INVENTORY",1,"Q")=1
SET PRCVZ=1
+22 IF $$GET^XPAR("SYS","PRCV COTS INVENTORY",1,"Q")'=1
SET PRCVZ=0
+23 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 W3
if %'=1
GOTO END
WRITE !!
KILL PRCS,PRCS2
GOTO B
+24 ;
PROCEED ;modified prompt and added help (PRC*5.1*174)
+1 WRITE !!,"Would you like to proceed with copying this request"
+2 SET %=1
DO YN^DICN
+3 IF %=0
Begin DoDot:1
+4 WRITE !?2,"Enter 'Yes' to proceed with copying transaction "_$$GET1^DIQ(410,$GET(DA),.01)_"."
+5 WRITE !?2,"Enter 'No' or '^' to abort copying this transaction."
End DoDot:1
GOTO PROCEED
+6 IF %'=1
Begin DoDot:1
+7 WRITE !!?2,">>> Transaction "_$$GET1^DIQ(410,$GET(DA),.01)_" data was not copied.",!
End DoDot:1
GOTO C
+8 ;
+9 SET DIC="^PRCS(410,"
LOCK +^PRCS(410,DA):15
if $TEST=0
GOTO END
+10 SET T1=DA
SET T2=^PRCS(410,DA,0)
SET T5=$PIECE(T2,U,4)
SET T4=$PIECE(T2,U,2)
SET T2=$PIECE(T2,U)
SET T3=$PIECE(^(3),U)
+11 KILL ^TMP($JOB)
+12 SET ^TMP($JOB,"OLDDA")=DA
SET ^("OLDTXN")=$PIECE(T2,U,1)
SET ^("OLDFCP")=PRC("CP")
+13 WRITE !!,"Now enter the information for the new transaction number.",!
+14 ;L -^PRCS(410,DA)
+15 KILL DA,DIC,Y
DO EN1^PRCSUT
KILL DA,DIC
+16 IF ('$DATA(PRC("SITE")))!('$DATA(PRC("QTR")))!('$DATA(PRC("CP")))
GOTO UNLKEND
+17 IF $PIECE($GET(^PRCS(410,T1,0)),"^",4)=1
IF $$Q1358^PRCEN(PRC("SITE"),PRC("CP"))
GOTO UNLKEND
+18 SET X1=X
SET PRCSAPP=$PIECE(^PRC(420,PRC("SITE"),1,+PRC("CP"),0),U,3)
+19 IF PRC("CP")'=T3
IF PRCSAPP["_"
DO PRCFY^PRCSUT2
IF (PRCSAPP["_")
GOTO UNLKEND
+20 SET X=X1
DO EN1^PRCSUT3
IF 'X
GOTO UNLKEND
+21 SET X1=X
DO EN2^PRCSUT3
IF ('$DATA(X1))
GOTO UNLKEND
+22 SET (X,^TMP($JOB,"NEWTXN"))=X1
+23 WRITE !!,"This transaction is assigned transaction number: ",X
+24 ;L +^PRCS(410,DA):15 G B:$T=0
+25 IF $DATA(^PRC(420,PRC("SITE"),1,+PRC("CP"),0))
if $PIECE(^(0),U,11)="Y"
SET PRCS2=1
TYPE ;
+1 SET PRCSX=$PIECE(^PRCS(410,T1,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>(.5)&(Y<5)"
SET PRCVY="The Issue Book and NO FORM types are no longer used."
+4 IF $$GET^XPAR("SYS","PRCV COTS INVENTORY",1,"Q")'=1
SET PRCVX="I Y>(.5)"
SET PRCVY="The NO FORM type is no longer used."
+5 IF PRCSX<1
WRITE !,PRCVY,!,"Please enter another form type.",!
SET PRCDAA=DA
SET DIC="^PRCS(410.5,"
SET DIC("S")=PRCVX
SET DIC("A")="FORM TYPE: "
SET DIC(0)="AEQZ"
DO ^DIC
if Y=-1
SET Y=2
SET DA=PRCDAA
SET PRCSX=+Y
+6 SET (DIE,DIC)="^PRCS(410,"
+7 KILL PRCVX,PRCVY
+8 SET $PIECE(^PRCS(410,DA,0),"^",4)=PRCSX
+9 WRITE !,"The form type for this request is: ",$PIECE($GET(^PRCS(410.5,PRCSX,0)),"^"),!
+10 WRITE !,?10,"Transaction data is being copied...",!
+11 DO @$SELECT(PRCSX=1:"S1^PRCSECP1",1:"S2^PRCSECP1")
SET DIK="^PRCS(410,"
DO IX^DIK
+12 SET (DIC,DIE)="^PRCS(410,"
+13 ;P182--removed warning about changed CC/BOC;replaced w/following call
+14 SET X=$$CHGCCBOC^PRCSCK(^TMP($JOB,"OLDTXN"),^TMP($JOB,"NEWTXN"),^TMP($JOB,"OLDFCP"),0)
+15 SET X=PRCSX
if '$DATA(PRCS2)&(X>2)
SET $PIECE(^PRCS(410,DA,0),"^",4)=2
SET X=2
+16 SET (PRCSDR,DR)="["_$SELECT(X=1:"PRCE NEW 1358",X=2:"PRCSEN2237B",X=3:"PRCSENPR",X=4:"PRCSENR&NR",X=5:"PRCSENIB",1:"PRCSENCOD")_"]"
D KILL DTOUT,DUOUT,Y
SET COPYDA=DA
DO ^DIE
IF $DATA(Y)!($DATA(DTOUT))
SET DA=COPYDA
GOTO END
+1 SET DA=COPYDA
DO RL^PRCSUT1
+2 DO ^PRCSCK
IF $DATA(PRCSERR)
IF PRCSERR
GOTO D
+3 KILL PRCSERR
+4 IF PRCSDR="[PRCSENCOD]"
DO W7^PRCSEB0
if $DATA(PRCSOB)
DO ENOD1^PRCSEB1
KILL PRCSOB
+5 if PRCSDR'="[PRCSENCOD]"
DO W1
IF PRCSDR'="[PRCSENCOD]"
IF $DATA(PRCS2)
IF +^PRCS(410,DA,0)
DO W6^PRCSEB
+6 SET DA=COPYDA
LOCK -^PRCS(410,DA)
DO W3
if %'=1
GOTO END
WRITE !!
KILL PRCS,PRCS2
+7 GOTO B
+8 ;
UNLKEND SET DA=^TMP($JOB,"OLDDA")
LOCK -^PRCS(410,DA)
END KILL %,D0,DA,DIC,DIE,DIK,DR,N,P,PRCSAPP,COPYDA,PRCSDR,PRCSERR,PRCSI,PRCSIP,PRCSJ,PRCSJ,PRCSL,PRCST1,PRCSTMP,PRCSTT,PRCSX,PRCSZ,T1,T2,T3,T4,T5,X,X1,Y,PRCVZ,PRCVFT
+1 KILL ^TMP($JOB)
+2 QUIT
W1 WRITE !!,"Would you like to review this request"
SET %=2
DO YN^DICN
if %=0
GOTO W1
if %'=1
QUIT
SET (N,PRCSZ)=DA
SET PRCSF=1
DO PRF1^PRCSP1
SET DA=PRCSZ
KILL X,PRCSF,PRCSZ
QUIT
W3 WRITE !!,"Would you like to copy another request"
SET %=1
DO YN^DICN
if %=0
GOTO W3
QUIT
+1 ;
GETCCCNT(STA,FCP) ;How many valid Cost Centers for this Control Point
+1 ;return count and first CC
+2 NEW GOODCC,CC,FIRSTCC
+3 SET GOODCC=0
SET (CC,FIRSTCC)=""
+4 FOR
SET CC=$ORDER(^PRC(420,+STA,1,+FCP,2,CC))
if CC=""
QUIT
Begin DoDot:1
+5 IF $$VALIDCC(STA,FCP,CC)
SET GOODCC=GOODCC+1
IF FIRSTCC=""
SET FIRSTCC=$EXTRACT($PIECE(^PRCD(420.1,+CC,0),U,1),1,23)
End DoDot:1
+6 QUIT GOODCC_"^"_FIRSTCC
+7 ;
VALIDCC(STA,FCP,CC) ;Is this STATION,FCP,COST CENTER combination valid?
+1 ;To be valid, station/FCP must point to CC, CC must be active,CC must
+2 ;point to some active BOC
+3 NEW X,VALID,BOC,GOODBOC
+4 SET BOC=""
SET GOODBOC=0
+5 ;FCP => CC
SET X=$GET(^PRC(420,+STA,1,+FCP,2,+CC,0))
IF (+X=+CC)
Begin DoDot:1
+6 ; CC IS ACTIVE
SET X=$GET(^PRCD(420.1,CC,0))
IF X]""
IF '$PIECE(X,U,2)
Begin DoDot:2
+7 FOR
SET BOC=$ORDER(^PRCD(420.1,+CC,1,BOC))
if BOC=""!GOODBOC
QUIT
Begin DoDot:3
+8 SET X=$GET(^PRCD(420.2,+BOC,0))
IF X]""
IF '$PIECE(X,U,2)
SET GOODBOC=1
End DoDot:3
End DoDot:2
End DoDot:1
+9 QUIT GOODBOC
+10 ;
GETBOCNT(STA,FCP,CC) ;How many valid BOCs for this STATION,FCP,COST CENTER
+1 ;To be valid, station/FCP must point to CC, CC must be active,CC must
+2 ;point to some active BOC
+3 NEW X,VALID,BOC,GOODBOC,TOTBOCS,FIRSTBOC
+4 SET BOC=""
SET GOODBOC=0
SET TOTBOCS=0
SET FIRSTBOC=""
+5 ;FCP => CC
SET X=$GET(^PRC(420,+STA,1,+FCP,2,+CC,0))
IF (+X=+CC)
Begin DoDot:1
+6 ; CC IS ACTIVE
SET X=$GET(^PRCD(420.1,CC,0))
IF X]""
IF '$PIECE(X,U,2)
Begin DoDot:2
+7 FOR
SET BOC=$ORDER(^PRCD(420.1,+CC,1,BOC))
if BOC=""
QUIT
Begin DoDot:3
+8 SET X=$GET(^PRCD(420.2,+BOC,0))
IF X]""
IF '$PIECE(X,U,2)
Begin DoDot:4
+9 SET TOTBOCS=TOTBOCS+1
IF FIRSTBOC=""
SET FIRSTBOC=$EXTRACT($PIECE(^PRCD(420.2,+BOC,0),U,1),1,23)
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+10 QUIT TOTBOCS_"^"_FIRSTBOC
+11 ;
VALIDBOC(STA,FCP,CC,BOC) ;Is this STATION,FCP,COST CENTER,BOC VALID?
+1 ;To be valid, station/FCP must point to CC, CC must be active,CC must
+2 ;point to BOC,and BOC must be active
+3 NEW X,VALID,GOODBOC
+4 SET GOODBOC=0
+5 SET X=$GET(^PRC(420,+STA,1,+FCP,2,+CC,0))
+6 IF (+X=+CC)
SET X=$GET(^PRCD(420.1,+CC,0))
IF X]""
IF '$PIECE(X,U,2)
Begin DoDot:1
+7 SET X=$GET(^PRCD(420.1,+CC,1,+BOC,0))
+8 IF X]""
SET X=$GET(^PRCD(420.2,+BOC,0))
IF X]""
IF '$PIECE(X,U,2)
SET GOODBOC=1
End DoDot:1
+9 QUIT GOODBOC
+10 ;
