PRCSUT ;WISC/SAW/DGL - CONTROL POINT ACTIVITY UTILITY PROGRAM ;9/14/00 15:49
V ;;5.1;IFCAP;**93,204**;Oct 20, 2000;Build 14
;Per VHA Directive 6402, this routine should not be modified.
;
ENF(PRCIPFLG) ;Entry point for Inv. Pt. selection
EN ;STA,FY,QTR,CP W/SCREEN FOR INACTIVE CP
I '$G(PRCIPFLG) N:'$D(PRCIPFLG) PRCIPFLG S PRCIPFLG=0
D STA G EX:'SI!(Y<0)
D FY G EX:PRC("FY")="^"
D QT G EX:PRC("QTR")="^"
S DIC("S")="I '$P(^(0),""^"",19),$D(^PRC(420,""A"",DUZ,PRC(""SITE""),+Y,1))!($D(^(2)))"
I $D(PRCSC),PRCSC D CPF^PRCSUT1(PRCIPFLG)
I '$D(PRCSC) D CPF(PRCIPFLG)
G EX:'SI!(Y<0)
G:'$$BBFY(PRC("SITE"),PRC("FY"),PRC("CP")) EX
G EN11
;
EN1F(PRCIPFLG) ; Entry point for Inv. Pt. selection
EN1 ;STA,FY,QTR,CP
I '$G(PRCIPFLG) N:'$D(PRCIPFLG) PRCIPFLG S PRCIPFLG=0
D STA G EX:'SI!(Y<0)
D FY G EX:PRC("FY")="^"
D QT G EX:PRC("QTR")="^"
I $D(PRCSC),PRCSC D CPF^PRCSUT1(PRCIPFLG)
I '$D(PRCSC) D CPF(PRCIPFLG)
G EX:'SI!(Y<0)
G:'$$BBFY(PRC("SITE"),PRC("FY"),PRC("CP")) EX
EN11 S Z=PRC("SITE")_"-"_PRC("FY")_"-"_PRC("QTR")_"-"_$P(PRC("CP")," ")
S X=$P(Z,"-",1,2)_"-"_$P(PRC("CP")," ")
G EXIT
;
EN2 ;STA,FY,QTR
D STA G EX:'SI!(Y<0)
D FY G EX:PRC("FY")="^"
D QT G EX:PRC("QTR")="^"
G EXIT
;
EN3F(PRCIPFLG) ; Entry point for Inv. Pt. selection
EN3 ;STA,CP
I '$G(PRCIPFLG) N:'$D(PRCIPFLG) PRCIPFLG S PRCIPFLG=0
D STA G EX:'SI!(Y<0)
I $D(PRCSC),PRCSC D CPF^PRCSUT1(PRCIPFLG)
D:'$D(PRCSC) CPF(PRCIPFLG)
G EX:'SI!(Y<0)
G EXIT
;
EN4 ;STA,FY,QTR,CC
D STA G EX:'SI!(Y<0)
D FY G EX:PRC("FY")="^"
D QT G EX:PRC("QTR")="^"
D CC
G EXIT
;
EN5 ;STA,FY,QTR,BOC
D STA G EX:'SI!(Y<0)
D FY G EX:PRC("FY")="^"
D QT G EX:PRC("QTR")="^"
D SUB
G EXIT
;
EN6F(PRCIPFLG) ; Entry point for Inv. Pt. selection
EN6 ;STA,CP,FY
I '$G(PRCIPFLG) N:'$D(PRCIPFLG) PRCIPFLG S PRCIPFLG=0
D STA G EX:'SI!(Y<0)
I $D(PRCSC),PRCSC D CPF^PRCSUT1(PRCIPFLG)
I '$D(PRCSC) D CPF(PRCIPFLG)
G EX:'SI!(Y<0)
D FY G EX:PRC("FY")="^"
G EXIT
;
;PRCSST is flag to not ask substation
;PRCSK is flag to allow selection of any station
STA ;SELECT STATION NUMBER
S N="",Y=0
I $D(PRCSK) S SI=2 ; if privilege flag is set, ask STATION
; else restrict station selection to user's authorized stations
E F SI=0:1:2 S N=$O(^PRC(420,"A",DUZ,N)) Q:N'>0 S N(1)=N
Q:'SI ; user not allowed to access any station
I SI>1 D
. S DIC="^PRC(420,",DIC(0)="AEMQ",DIC("A")="Select STATION NUMBER: "
. I '$D(PRCSK) S DIC("S")="I $D(^PRC(420,""A"",DUZ,+Y))"
. I $D(PRC("SITE")) S DIC("B")=PRC("SITE")
. S D="B^C"
. D MIX^DIC1 I Y>0 S PRC("SITE")=+Y
I SI=1 S PRC("SITE")=N(1)
I '$D(PRC("SITE")) S PRC("SITE")="",PRC("SST")=""
I PRC("SITE")=""!(Y<0) K DIC,N Q
; substation
I '$D(PRC("SST"))!'$D(^PRC(411,"UP",+PRC("SITE"))) S PRC("SST")=""
I '$G(PRCSST),$D(^PRC(411,"UP",+PRC("SITE"))) D
. S DIC("B")=PRC("SST")
. S DIC="^PRC(411,",DIC(0)="AEQZ",DIC("A")="Select SUBSTATION: "
. S DIC("S")="I $E($G(^PRC(411,+Y,0)),1,3)=PRC(""SITE"")"
. D ^DIC I Y>0 S PRC("SST")=+Y
K DIC,N
Q
;
FY ;SELECT FISCAL YEAR
D:'$D(DT) DT^DICRW
S FYT=$E(100+$E(DT,2,3)+$E(DT,4),2,3),PRC("FY")=FYT
W !,"Select FISCAL YEAR: ",FYT,"// " R PRC("FY"):DTIME
S:'$T PRC("FY")=U
S:PRC("FY")="" PRC("FY")=FYT
Q:PRC("FY")="^"
I PRC("FY")'?2N W $C(7),!,"Enter a two digit fiscal year (e.g., 87).",! G FY
Q
;
QT ;SELECT QUARTER
D:'$D(DT) DT^DICRW
I '$D(QTT) S:$D(PRC("QTR")) QTT=PRC("QTR") I '$D(QTT) S SI=$E(DT,4,5),QTT=$P("2^2^2^3^3^3^4^4^4^1^1^1","^",SI)
W !,"Select QUARTER: ",QTT,"// " R PRC("QTR"):DTIME
S:'$T PRC("QTR")=U
S:PRC("QTR")="" PRC("QTR")=QTT
Q:PRC("QTR")=U
I PRC("QTR")<1!(PRC("QTR")>4)!(PRC("QTR")'?1N) W $C(7),!,"Enter a single digit number from 1 to 4.",! G QT
Q
;
CPF(PRCIPFLG) ; Entry point for inv. pt. selection
CP ;SELECT CONTROL POINT
N FCPDA
K PRCSIP ; inventory distribution point variable
I '$G(PRCIPFLG) N:'$D(PRCIPFLG) PRCIPFLG S PRCIPFLG=0
S FCPDA=$O(^PRC(420,"A",DUZ,PRC("SITE"),0)) Q:'FCPDA ; no fcps
I '$O(^PRC(420,"A",DUZ,PRC("SITE"),FCPDA)) D Q ; access to 1 fcp
. S PRC("CP")=$P($G(^PRC(420,PRC("SITE"),1,FCPDA,0)),U)
. I PRC("CP"),PRCIPFLG D IP
; more than one fcp
S DIC="^PRC(420,"_PRC("SITE")_",1,"
S DIC(0)="AEMNQZ",DIC("A")="Select CONTROL POINT: "
I '$D(DIC("S")) S DIC("S")="I '$P(^(0),""^"",19),$D(^PRC(420,""A"",DUZ,PRC(""SITE""),+Y,1))!($D(^(2)))"
I $D(PRC("CP")),PRC("CP"),$D(^PRC(420,PRC("SITE"),1,PRC("CP"))) S DIC("B")=+PRC("CP")
S D="B^C" D MIX^DIC1 S:Y<0 PRC("CP")="^"
I Y>0 S PRC("CP")=$P(Y(0),"^") I PRCIPFLG=1 D IP
K DIC
Q
;
;A=station #, B=fiscal year, C=fcp #, PRCA=1 if no user interactive
BBFY(A,B,C,PRCA) ;extrinsic function of beginning budget fiscal year
N D,E,F,X,Y
K PRC("BBFY")
S E=$G(^PRC(420,A,1,+C,5))
I $P(E,"^")]"" S F=$O(^PRCD(420.3,"B",$P(E,"^"),"")) I F I $P(^PRCD(420.3,F,0),"^",8)="Y" S PRC("BBFY")=+$$DATE^PRC0C($P(E,"^",8),"I") QUIT PRC("BBFY")
S B=+$$YEAR^PRC0C(B)
S D=$$APP^PRC0C(A,$E(B,3,4),C)
I $P(D,"^")'["_/_" S PRC("BBFY")=B QUIT PRC("BBFY")
S F=$$BBFY^PRC0D(A,C,'$G(PRCA))
I F="",$G(PRCA)=1 S PRC("BBFY")=B QUIT PRC("BBFY")
I $G(PRCA)=1 S PRC("BBFY")=B-(B-$P(F,"~",2)#$P(F,"~",3)) QUIT PRC("BBFY")
BBFY1 S E="^2:4^K:X'?2N&(X'?4N) X I $G(X)]"""" S X=+$$YEAR^PRC0C(X) K:X-$P(F,""~"",2)#$P(F,""~"",3) X"
S Y(1)="Enter a 2 or 4 digit year."
D FT^PRC0A(.X,.Y,"First Year of the Multi-Appropriation ("_$P(D,"^")_")",E,$S(F="":B,1:B-(B-$P(F,"~",2)#$P(F,"~",3))))
I Y?2.4N S Y=+$$YEAR^PRC0C(Y) I B<Y!(Y+$P(F,"~",3)-1<B) D EN^DDIOL("You must enter a BBFY such that the document's fiscal year is between"),EN^DDIOL("beginning and ending budget fiscal years") G BBFY1
S PRC("BBFY")=$S(Y?4N:Y,1:""),PRCBBMY=1
QUIT PRC("BBFY")
;
CC ;SELECT COST CENTER
S DIC="^PRCD(420.1,",DIC(0)="AEMNQZ"
D ^DIC Q:Y<0
S PRCS("CC")=$P(Y(0),"^")
Q
;
SUB ;SELECT BOC
S DIC="^PRCD(420.2,",DIC(0)="AEMNQZ"
D ^DIC Q:Y<0
S PRCS("SUB")=$P(Y(0),"^")
Q
;
LOCK ;LOCK GLOBAL THAT IS BEING ACCESSED BY ANOTHER USER
N PRCLOCK
S PRCLOCK=DIC_DA_")" L +(@PRCLOCK):($G(DILOCKTM,15))
S PRCSL=$T
W:$T=0 !!,$C(7),"Sorry, record is being accessed by another user. Please try later."
Q
;
EX S Y=-1
K PRC("QTR"),PRC("FY"),PRC("BBFY"),SI,PRCBBMY
I $D(PRC("CP")) K:PRC("CP")="ALL"!(PRC("CP")="^") PRC("CP")
EXIT K FYT,SI,PRCSK,QTT,DIC("A")
Q
;
NSCRNF(PRCIPFLG) ; Entry point for Inv. Pt. selection
NSCRN ;STA,FY,QTR,CP
I '$G(PRCIPFLG) N:'$D(PRCIPFLG) PRCIPFLG S PRCIPFLG=0
D STA G EX:'SI!(Y<0)
D FY G EX:PRC("FY")="^"
D QT G EX:PRC("QTR")="^"
S PRCSC=4 D CPF^PRCSUT1(PRCIPFLG)
I '$D(PRCSC) D CPF(PRCIPFLG)
G EX:'SI!(Y<0)
G:'$$BBFY(PRC("SITE"),PRC("FY"),PRC("CP")) EX
QUIT
;
IP ; Get Inventory point
Q:'$D(PRC("SITE"))!('$D(PRC("CP")))
N CTR,I
K ^TMP($J,"PRCSUT")
S (CTR,I)=0,PRCSIP=""
F S I=$O(^PRC(420,"AF",PRC("SITE"),+PRC("CP"),I)) Q:'I S CTR=CTR+1,^TMP($J,"PRCSUT",CTR)=I_"^"_$P(^PRCP(445,I,0),"^")
I CTR=0 G IPQ
I CTR=1!$G(PRCRMPR) S PRCSIP=$P(^TMP($J,"PRCSUT",1),"^") G IPQ
F I=1:1:CTR D Q:$D(DIRUT)
. W !,?5,I,") ",$P(^TMP($J,"PRCSUT",I),"^",2)
. I I#(IOSL-2)=0 K DIR S DIR(0)="E" D ^DIR
S DIR(0)="NO^1:"_CTR_":0"
S DIR("A")="Select INVENTORY POINT"
S DIR("?",1)="Enter a number from 1 to "_CTR_" to select the displayed"
S DIR("?")="Inventory Point. This is an optional response."
D ^DIR K DIR
I Y>0 S PRCSIP=$P(^TMP($J,"PRCSUT",Y),"^") W " ",$P(^TMP($J,"PRCSUT",Y),"^",2),!
IPQ K ^TMP($J,"PRCSUT")
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCSUT 7517 printed Sep 23, 2025@19:55:11 Page 2
PRCSUT ;WISC/SAW/DGL - CONTROL POINT ACTIVITY UTILITY PROGRAM ;9/14/00 15:49
V ;;5.1;IFCAP;**93,204**;Oct 20, 2000;Build 14
+1 ;Per VHA Directive 6402, this routine should not be modified.
+2 ;
ENF(PRCIPFLG) ;Entry point for Inv. Pt. selection
EN ;STA,FY,QTR,CP W/SCREEN FOR INACTIVE CP
+1 IF '$GET(PRCIPFLG)
if '$DATA(PRCIPFLG)
NEW PRCIPFLG
SET PRCIPFLG=0
+2 DO STA
if 'SI!(Y<0)
GOTO EX
+3 DO FY
if PRC("FY")="^"
GOTO EX
+4 DO QT
if PRC("QTR")="^"
GOTO EX
+5 SET DIC("S")="I '$P(^(0),""^"",19),$D(^PRC(420,""A"",DUZ,PRC(""SITE""),+Y,1))!($D(^(2)))"
+6 IF $DATA(PRCSC)
IF PRCSC
DO CPF^PRCSUT1(PRCIPFLG)
+7 IF '$DATA(PRCSC)
DO CPF(PRCIPFLG)
+8 if 'SI!(Y<0)
GOTO EX
+9 if '$$BBFY(PRC("SITE"),PRC("FY"),PRC("CP"))
GOTO EX
+10 GOTO EN11
+11 ;
EN1F(PRCIPFLG) ; Entry point for Inv. Pt. selection
EN1 ;STA,FY,QTR,CP
+1 IF '$GET(PRCIPFLG)
if '$DATA(PRCIPFLG)
NEW PRCIPFLG
SET PRCIPFLG=0
+2 DO STA
if 'SI!(Y<0)
GOTO EX
+3 DO FY
if PRC("FY")="^"
GOTO EX
+4 DO QT
if PRC("QTR")="^"
GOTO EX
+5 IF $DATA(PRCSC)
IF PRCSC
DO CPF^PRCSUT1(PRCIPFLG)
+6 IF '$DATA(PRCSC)
DO CPF(PRCIPFLG)
+7 if 'SI!(Y<0)
GOTO EX
+8 if '$$BBFY(PRC("SITE"),PRC("FY"),PRC("CP"))
GOTO EX
EN11 SET Z=PRC("SITE")_"-"_PRC("FY")_"-"_PRC("QTR")_"-"_$PIECE(PRC("CP")," ")
+1 SET X=$PIECE(Z,"-",1,2)_"-"_$PIECE(PRC("CP")," ")
+2 GOTO EXIT
+3 ;
EN2 ;STA,FY,QTR
+1 DO STA
if 'SI!(Y<0)
GOTO EX
+2 DO FY
if PRC("FY")="^"
GOTO EX
+3 DO QT
if PRC("QTR")="^"
GOTO EX
+4 GOTO EXIT
+5 ;
EN3F(PRCIPFLG) ; Entry point for Inv. Pt. selection
EN3 ;STA,CP
+1 IF '$GET(PRCIPFLG)
if '$DATA(PRCIPFLG)
NEW PRCIPFLG
SET PRCIPFLG=0
+2 DO STA
if 'SI!(Y<0)
GOTO EX
+3 IF $DATA(PRCSC)
IF PRCSC
DO CPF^PRCSUT1(PRCIPFLG)
+4 if '$DATA(PRCSC)
DO CPF(PRCIPFLG)
+5 if 'SI!(Y<0)
GOTO EX
+6 GOTO EXIT
+7 ;
EN4 ;STA,FY,QTR,CC
+1 DO STA
if 'SI!(Y<0)
GOTO EX
+2 DO FY
if PRC("FY")="^"
GOTO EX
+3 DO QT
if PRC("QTR")="^"
GOTO EX
+4 DO CC
+5 GOTO EXIT
+6 ;
EN5 ;STA,FY,QTR,BOC
+1 DO STA
if 'SI!(Y<0)
GOTO EX
+2 DO FY
if PRC("FY")="^"
GOTO EX
+3 DO QT
if PRC("QTR")="^"
GOTO EX
+4 DO SUB
+5 GOTO EXIT
+6 ;
EN6F(PRCIPFLG) ; Entry point for Inv. Pt. selection
EN6 ;STA,CP,FY
+1 IF '$GET(PRCIPFLG)
if '$DATA(PRCIPFLG)
NEW PRCIPFLG
SET PRCIPFLG=0
+2 DO STA
if 'SI!(Y<0)
GOTO EX
+3 IF $DATA(PRCSC)
IF PRCSC
DO CPF^PRCSUT1(PRCIPFLG)
+4 IF '$DATA(PRCSC)
DO CPF(PRCIPFLG)
+5 if 'SI!(Y<0)
GOTO EX
+6 DO FY
if PRC("FY")="^"
GOTO EX
+7 GOTO EXIT
+8 ;
+9 ;PRCSST is flag to not ask substation
+10 ;PRCSK is flag to allow selection of any station
STA ;SELECT STATION NUMBER
+1 SET N=""
SET Y=0
+2 ; if privilege flag is set, ask STATION
IF $DATA(PRCSK)
SET SI=2
+3 ; else restrict station selection to user's authorized stations
+4 IF '$TEST
FOR SI=0:1:2
SET N=$ORDER(^PRC(420,"A",DUZ,N))
if N'>0
QUIT
SET N(1)=N
+5 ; user not allowed to access any station
if 'SI
QUIT
+6 IF SI>1
Begin DoDot:1
+7 SET DIC="^PRC(420,"
SET DIC(0)="AEMQ"
SET DIC("A")="Select STATION NUMBER: "
+8 IF '$DATA(PRCSK)
SET DIC("S")="I $D(^PRC(420,""A"",DUZ,+Y))"
+9 IF $DATA(PRC("SITE"))
SET DIC("B")=PRC("SITE")
+10 SET D="B^C"
+11 DO MIX^DIC1
IF Y>0
SET PRC("SITE")=+Y
End DoDot:1
+12 IF SI=1
SET PRC("SITE")=N(1)
+13 IF '$DATA(PRC("SITE"))
SET PRC("SITE")=""
SET PRC("SST")=""
+14 IF PRC("SITE")=""!(Y<0)
KILL DIC,N
QUIT
+15 ; substation
+16 IF '$DATA(PRC("SST"))!'$DATA(^PRC(411,"UP",+PRC("SITE")))
SET PRC("SST")=""
+17 IF '$GET(PRCSST)
IF $DATA(^PRC(411,"UP",+PRC("SITE")))
Begin DoDot:1
+18 SET DIC("B")=PRC("SST")
+19 SET DIC="^PRC(411,"
SET DIC(0)="AEQZ"
SET DIC("A")="Select SUBSTATION: "
+20 SET DIC("S")="I $E($G(^PRC(411,+Y,0)),1,3)=PRC(""SITE"")"
+21 DO ^DIC
IF Y>0
SET PRC("SST")=+Y
End DoDot:1
+22 KILL DIC,N
+23 QUIT
+24 ;
FY ;SELECT FISCAL YEAR
+1 if '$DATA(DT)
DO DT^DICRW
+2 SET FYT=$EXTRACT(100+$EXTRACT(DT,2,3)+$EXTRACT(DT,4),2,3)
SET PRC("FY")=FYT
+3 WRITE !,"Select FISCAL YEAR: ",FYT,"// "
READ PRC("FY"):DTIME
+4 if '$TEST
SET PRC("FY")=U
+5 if PRC("FY")=""
SET PRC("FY")=FYT
+6 if PRC("FY")="^"
QUIT
+7 IF PRC("FY")'?2N
WRITE $CHAR(7),!,"Enter a two digit fiscal year (e.g., 87).",!
GOTO FY
+8 QUIT
+9 ;
QT ;SELECT QUARTER
+1 if '$DATA(DT)
DO DT^DICRW
+2 IF '$DATA(QTT)
if $DATA(PRC("QTR"))
SET QTT=PRC("QTR")
IF '$DATA(QTT)
SET SI=$EXTRACT(DT,4,5)
SET QTT=$PIECE("2^2^2^3^3^3^4^4^4^1^1^1","^",SI)
+3 WRITE !,"Select QUARTER: ",QTT,"// "
READ PRC("QTR"):DTIME
+4 if '$TEST
SET PRC("QTR")=U
+5 if PRC("QTR")=""
SET PRC("QTR")=QTT
+6 if PRC("QTR")=U
QUIT
+7 IF PRC("QTR")<1!(PRC("QTR")>4)!(PRC("QTR")'?1N)
WRITE $CHAR(7),!,"Enter a single digit number from 1 to 4.",!
GOTO QT
+8 QUIT
+9 ;
CPF(PRCIPFLG) ; Entry point for inv. pt. selection
CP ;SELECT CONTROL POINT
+1 NEW FCPDA
+2 ; inventory distribution point variable
KILL PRCSIP
+3 IF '$GET(PRCIPFLG)
if '$DATA(PRCIPFLG)
NEW PRCIPFLG
SET PRCIPFLG=0
+4 ; no fcps
SET FCPDA=$ORDER(^PRC(420,"A",DUZ,PRC("SITE"),0))
if 'FCPDA
QUIT
+5 ; access to 1 fcp
IF '$ORDER(^PRC(420,"A",DUZ,PRC("SITE"),FCPDA))
Begin DoDot:1
+6 SET PRC("CP")=$PIECE($GET(^PRC(420,PRC("SITE"),1,FCPDA,0)),U)
+7 IF PRC("CP")
IF PRCIPFLG
DO IP
End DoDot:1
QUIT
+8 ; more than one fcp
+9 SET DIC="^PRC(420,"_PRC("SITE")_",1,"
+10 SET DIC(0)="AEMNQZ"
SET DIC("A")="Select CONTROL POINT: "
+11 IF '$DATA(DIC("S"))
SET DIC("S")="I '$P(^(0),""^"",19),$D(^PRC(420,""A"",DUZ,PRC(""SITE""),+Y,1))!($D(^(2)))"
+12 IF $DATA(PRC("CP"))
IF PRC("CP")
IF $DATA(^PRC(420,PRC("SITE"),1,PRC("CP")))
SET DIC("B")=+PRC("CP")
+13 SET D="B^C"
DO MIX^DIC1
if Y<0
SET PRC("CP")="^"
+14 IF Y>0
SET PRC("CP")=$PIECE(Y(0),"^")
IF PRCIPFLG=1
DO IP
+15 KILL DIC
+16 QUIT
+17 ;
+18 ;A=station #, B=fiscal year, C=fcp #, PRCA=1 if no user interactive
BBFY(A,B,C,PRCA) ;extrinsic function of beginning budget fiscal year
+1 NEW D,E,F,X,Y
+2 KILL PRC("BBFY")
+3 SET E=$GET(^PRC(420,A,1,+C,5))
+4 IF $PIECE(E,"^")]""
SET F=$ORDER(^PRCD(420.3,"B",$PIECE(E,"^"),""))
IF F
IF $PIECE(^PRCD(420.3,F,0),"^",8)="Y"
SET PRC("BBFY")=+$$DATE^PRC0C($PIECE(E,"^",8),"I")
QUIT PRC("BBFY")
+5 SET B=+$$YEAR^PRC0C(B)
+6 SET D=$$APP^PRC0C(A,$EXTRACT(B,3,4),C)
+7 IF $PIECE(D,"^")'["_/_"
SET PRC("BBFY")=B
QUIT PRC("BBFY")
+8 SET F=$$BBFY^PRC0D(A,C,'$GET(PRCA))
+9 IF F=""
IF $GET(PRCA)=1
SET PRC("BBFY")=B
QUIT PRC("BBFY")
+10 IF $GET(PRCA)=1
SET PRC("BBFY")=B-(B-$PIECE(F,"~",2)#$PIECE(F,"~",3))
QUIT PRC("BBFY")
BBFY1 SET E="^2:4^K:X'?2N&(X'?4N) X I $G(X)]"""" S X=+$$YEAR^PRC0C(X) K:X-$P(F,""~"",2)#$P(F,""~"",3) X"
+1 SET Y(1)="Enter a 2 or 4 digit year."
+2 DO FT^PRC0A(.X,.Y,"First Year of the Multi-Appropriation ("_$PIECE(D,"^")_")",E,$SELECT(F="":B,1:B-(B-$PIECE(F,"~",2)#$PIECE(F,"~",3))))
+3 IF Y?2.4N
SET Y=+$$YEAR^PRC0C(Y)
IF B<Y!(Y+$PIECE(F,"~",3)-1<B)
DO EN^DDIOL("You must enter a BBFY such that the document's fiscal year is between")
DO EN^DDIOL("beginning and ending budget fiscal years")
GOTO BBFY1
+4 SET PRC("BBFY")=$SELECT(Y?4N:Y,1:"")
SET PRCBBMY=1
+5 QUIT PRC("BBFY")
+6 ;
CC ;SELECT COST CENTER
+1 SET DIC="^PRCD(420.1,"
SET DIC(0)="AEMNQZ"
+2 DO ^DIC
if Y<0
QUIT
+3 SET PRCS("CC")=$PIECE(Y(0),"^")
+4 QUIT
+5 ;
SUB ;SELECT BOC
+1 SET DIC="^PRCD(420.2,"
SET DIC(0)="AEMNQZ"
+2 DO ^DIC
if Y<0
QUIT
+3 SET PRCS("SUB")=$PIECE(Y(0),"^")
+4 QUIT
+5 ;
LOCK ;LOCK GLOBAL THAT IS BEING ACCESSED BY ANOTHER USER
+1 NEW PRCLOCK
+2 SET PRCLOCK=DIC_DA_")"
LOCK +(@PRCLOCK):($GET(DILOCKTM,15))
+3 SET PRCSL=$TEST
+4 if $TEST=0
WRITE !!,$CHAR(7),"Sorry, record is being accessed by another user. Please try later."
+5 QUIT
+6 ;
EX SET Y=-1
+1 KILL PRC("QTR"),PRC("FY"),PRC("BBFY"),SI,PRCBBMY
+2 IF $DATA(PRC("CP"))
if PRC("CP")="ALL"!(PRC("CP")="^")
KILL PRC("CP")
EXIT KILL FYT,SI,PRCSK,QTT,DIC("A")
+1 QUIT
+2 ;
NSCRNF(PRCIPFLG) ; Entry point for Inv. Pt. selection
NSCRN ;STA,FY,QTR,CP
+1 IF '$GET(PRCIPFLG)
if '$DATA(PRCIPFLG)
NEW PRCIPFLG
SET PRCIPFLG=0
+2 DO STA
if 'SI!(Y<0)
GOTO EX
+3 DO FY
if PRC("FY")="^"
GOTO EX
+4 DO QT
if PRC("QTR")="^"
GOTO EX
+5 SET PRCSC=4
DO CPF^PRCSUT1(PRCIPFLG)
+6 IF '$DATA(PRCSC)
DO CPF(PRCIPFLG)
+7 if 'SI!(Y<0)
GOTO EX
+8 if '$$BBFY(PRC("SITE"),PRC("FY"),PRC("CP"))
GOTO EX
+9 QUIT
+10 ;
IP ; Get Inventory point
+1 if '$DATA(PRC("SITE"))!('$DATA(PRC("CP")))
QUIT
+2 NEW CTR,I
+3 KILL ^TMP($JOB,"PRCSUT")
+4 SET (CTR,I)=0
SET PRCSIP=""
+5 FOR
SET I=$ORDER(^PRC(420,"AF",PRC("SITE"),+PRC("CP"),I))
if 'I
QUIT
SET CTR=CTR+1
SET ^TMP($JOB,"PRCSUT",CTR)=I_"^"_$PIECE(^PRCP(445,I,0),"^")
+6 IF CTR=0
GOTO IPQ
+7 IF CTR=1!$GET(PRCRMPR)
SET PRCSIP=$PIECE(^TMP($JOB,"PRCSUT",1),"^")
GOTO IPQ
+8 FOR I=1:1:CTR
Begin DoDot:1
+9 WRITE !,?5,I,") ",$PIECE(^TMP($JOB,"PRCSUT",I),"^",2)
+10 IF I#(IOSL-2)=0
KILL DIR
SET DIR(0)="E"
DO ^DIR
End DoDot:1
if $DATA(DIRUT)
QUIT
+11 SET DIR(0)="NO^1:"_CTR_":0"
+12 SET DIR("A")="Select INVENTORY POINT"
+13 SET DIR("?",1)="Enter a number from 1 to "_CTR_" to select the displayed"
+14 SET DIR("?")="Inventory Point. This is an optional response."
+15 DO ^DIR
KILL DIR
+16 IF Y>0
SET PRCSIP=$PIECE(^TMP($JOB,"PRCSUT",Y),"^")
WRITE " ",$PIECE(^TMP($JOB,"PRCSUT",Y),"^",2),!
IPQ KILL ^TMP($JOB,"PRCSUT")
+1 QUIT
