PRCB1D ;WISC/PLT-RESET FCP YEARLY FMS ACCOUNTING ELEMENT AND BBFY ACT CODE ; 03/14/94 2:06 PM
V ;;5.1;IFCAP;;Oct 20, 2000
;Per VHA Directive 10-93-142, this routine should not be modified.
QUIT ;invalid entry
;
EN N PRCRI,PRC,PRCZ,PRCDD,PRCDI,PRCQT,PRCB,PRCB1,PRCD,PRCD1,PRCSTU
N A,B,C,X,Y
F S PRCQT=1 D LG1 QUIT:PRCQT["^" D Q:PRCQT["^"&($G(PRCSTU)<2)
. F S PRCQT=2 D LG2 QUIT:PRCQT["^"
. QUIT
EXIT QUIT
;
LG1 K PRC S PRCDI="420;^PRC(420,;" D
. S PRCSTU=0,PRCRI(411)=0 F S PRCRI(411)=$O(^PRC(411,PRCRI(411))) Q:'PRCRI(411) S:$D(^PRC(420,PRCRI(411),2,DUZ)) PRCSTU=PRCSTU+1_"^"_PRCRI(411)
I 'PRCSTU D EN^DDIOL("Station access is not allowed") S PRCQT="^" G LG1X
I +PRCSTU=1 S PRC("SITE")=$P(^PRC(420,+$P(PRCSTU,"^",2),0),"^") D EN^DDIOL("STATION: "_PRC("SITE")) G LG1E
S X("S")="I $D(^PRC(420,+Y,2,DUZ))"
D LOOKUP^PRC0B(.X,.Y,PRCDI,"ACEFNO","Select Station: ")
S:X=""!(X["^") PRCQT="^"
S PRC("SITE")=$P(Y,"^",2)
LG1E S PRCRI(420)=+PRC("SITE"),PRCDI=PRCDI_PRCRI(420)_";"
LG1X QUIT
;
LG2 ;
S $P(PRCDI,"~",2)="420.01;"_$P($P(PRCDI,"~"),";",2)_PRCRI(420)_",1,;"
Q2 K PRCZ D EN^DDIOL($TR($J("",78)," ","-")) S X("S")="I ^(0)-9999"
D LOOKUP^PRC0B(.X,.Y,PRCDI,"AEOQS","Select Fund Control Point: ")
I Y<0!(X="") S PRCQT="^" QUIT
K X S PRCRI(420.01)=+Y,PRC("CP")=$P($P(Y,"^")," ")
S PRCDI=PRCDI_PRCRI(420.01)_";"
;
Q3 S E="O^2:4^K:X'?2N&(X'?4N) X",Y(1)="Enter a 2 or 4 digit year."
D FT^PRC0A(.X,.Y,"For Budget Fiscal Year",E,"")
G:X["^"!(X="") Q2
S PRC("FY")=$P($$YEAR^PRC0C(Y),"^",2),PRCRI(420.06)=PRC("FY")
S PRCD=$G(^PRC(420,PRCRI(420),1,PRCRI(420.01),4,PRCRI(420.06),2))
;I PRCD="" D EN^DDIOL(" The yearly FMS accounting elements are not in file yet.") G Q3
D DIS(PRC("SITE")_"^"_PRC("CP")_"^"_PRC("FY"))
Q4 D YN^PRC0A(.X,.Y,"Reset the fiscal year "_PRC("FY")_" Suballowance Account","O","NO")
G:X["^"!(X="")!(Y<1) Q2
S PRCZ(4)=Y
Q5 ;D SC^PRC0A(.X,.Y,"Select FMS SA-doc ACT code","OM^A:for suballowance account NOT in FMS yet;C:for suballowance account is in FMS","")
;G:X["^"!(X="") Q2
S Y="C"
S PRCZ(5)=Y
Q6 D YN^PRC0A(.X,.Y,"Ready to File","O","NO")
G:X["^"!(X="")!'Y Q2
I '$P(PRCB1,"^",11) D EN^DDIOL("BBFY missing in FCP set up") G Q2
S A=$$FUND^PRC0C($P(PRCB1,"^",10),$P(PRCB1,"^",11))
I 'A D EN^DDIOL("Fund code "_$P(PRCB1,"^",10)_" with beginning year "_$P(PRCB1,"^",11)_" is not in fund file (420.14)") G Q2
S PRC("BBFY")=$$BBFY^PRCSUT(PRCRI(420),PRC("FY"),PRCRI(420.01),1)
I $G(PRCZ(4))=1 D G:'$G(PRC("BBFY")) Q2
. S:$P(PRCD1,"^",10)="" $P(PRCD1,"^",10)=$P(PRCB1,"^",10) S A=$$FUND^PRC0C($P(PRCD1,"^",10),PRC("BBFY"))
. I 'A D EN^DDIOL("Fund code "_$P(PRCD1,"^",10)_" with beginning year "_PRC("BBFY")_" is not in fund file (420.14).") K PRC("BBFY")
. QUIT
S PRCLOCK=$P($P(PRCDI,"~",2),";",2)_PRCRI(420.01)_","
D ICLOCK^PRC0B(PRCLOCK,.Y)
I 'Y D EN^DDIOL("This FCP File is in use, please try later!") G Q2
D FILE D DCLOCK^PRC0B(PRCLOCK)
G Q2
;
FILE ;filing
I $G(PRCZ(4))=1 D
. ;delete old entry in file 420.141
. S C=$$ACC^PRC0C(PRC("SITE"),PRC("CP")_"^"_PRC("FY")_"^"_PRC("BBFY"))
. S A=$$FMSACC^PRC0D(PRC("SITE"),C)
. S B=$$FIRST^PRC0B1("^PRCD(420.141,""B"","""_A_""",",0)
. I B D DELETE^PRC0B1(.X,";^PRCD(420.141,;"_B)
. ;reset fiscal yearly accounting elements
. D:'$D(^PRC(420,PRCRI(420),1,PRCRI(420.01),4,PRCRI(420.06))) EBAL^PRCSEZ(PRCRI(420)_"^"_PRCRI(420.01)_"^"_PRCRI(420.06)_"^1^0","C")
. S ^PRC(420,PRCRI(420),1,PRCRI(420.01),4,PRCRI(420.06),2)=PRCB
;add new entry if action code is 'C', delete if code is A
S C=$$ACC^PRC0C(PRC("SITE"),PRC("CP")_"^"_PRC("FY")_"^"_PRC("BBFY"))
S A=$$FMSACC^PRC0D(PRC("SITE"),C)
S B=$$FIRST^PRC0B1("^PRCD(420.141,""B"","""_A_""",",0)
I $G(PRCZ(5))="A",B D DELETE^PRC0B1(.X,";^PRCD(420.141,;"_B)
I $G(PRCZ(5))="C",'B S B=$$A420D141^PRC0F(A,PRCRI(420.01))
QUIT
;
;PRCA data ^1=station, ^2=control point, ^3=fiscal year
DIS(PRCA) ;display fms accounting data
D ;get acc element from fcp
. N Z
. S Z("ST")=PRCRI(420),Z("CP")=PRCRI(420.01)
. S PRCB=$$SUBALL^PRCSEZ
. QUIT
S PRCD=$G(^PRC(420,PRCRI(420),1,PRCRI(420.01),4,PRCRI(420.06),2))
S PRCB1=$$ACC(PRCB),PRCD1=$$ACC(PRCD)
S A=$P($G(^PRC(420,PRCRI(420),1,PRCRI(420.01),5)),"^",8),$P(PRCB1,"^",11)=+$$DATE^PRC0C(A,"F")
S $P(PRCD1,"^",11)=PRC("FY")
W !,"CURRENT FCP ACCOUNTING ELEMENTS",?40,"FISCAL YEAR FCP ACCOUNTING ELEMENTS"
S B=0 F A=11,10,9,4:1:8 S B=B+1,C=$P("BBFY~FUND~APPROPRI~A/O~PROGRAM~FCP/PRJ~OBJECT CLASS~JOB","~",B) W !,$J(C,12),": ",$P(PRCB1,"^",A) S:C="BBFY" C="FISCAL YEAR" W ?40,$J(C,12),": ",$P(PRCD1,"^",A)
QUIT
;
ACC(A) ;get external format of prca
S:$P(A,"^",4) $P(A,"^",4)=$$NP^PRC0B("^PRCD(420.15,$P(A,""^"",4),",0,1)
S:$P(A,"^",5) $P(A,"^",5)=$$NP^PRC0B("^PRCD(420.13,$P(A,""^"",5),",0,1)
S:$P(A,"^",6) $P(A,"^",6)=$$NP^PRC0B("^PRCD(420.131,$P(A,""^"",6),",0,1)
S:$P(A,"^",7) $P(A,"^",7)=$$NP^PRC0B("^PRCD(420.132,$P(A,""^"",7),",0,1)
S:$P(A,"^",8) $P(A,"^",8)=$$NP^PRC0B("^PRCD(420.133,$P(A,""^"",8),",0,1)
QUIT A
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCB1D 5037 printed Dec 13, 2024@02:00:17 Page 2
PRCB1D ;WISC/PLT-RESET FCP YEARLY FMS ACCOUNTING ELEMENT AND BBFY ACT CODE ; 03/14/94 2:06 PM
V ;;5.1;IFCAP;;Oct 20, 2000
+1 ;Per VHA Directive 10-93-142, this routine should not be modified.
+2 ;invalid entry
QUIT
+3 ;
EN NEW PRCRI,PRC,PRCZ,PRCDD,PRCDI,PRCQT,PRCB,PRCB1,PRCD,PRCD1,PRCSTU
+1 NEW A,B,C,X,Y
+2 FOR
SET PRCQT=1
DO LG1
if PRCQT["^"
QUIT
Begin DoDot:1
+3 FOR
SET PRCQT=2
DO LG2
if PRCQT["^"
QUIT
+4 QUIT
End DoDot:1
if PRCQT["^"&($GET(PRCSTU)<2)
QUIT
EXIT QUIT
+1 ;
LG1 KILL PRC
SET PRCDI="420;^PRC(420,;"
Begin DoDot:1
+1 SET PRCSTU=0
SET PRCRI(411)=0
FOR
SET PRCRI(411)=$ORDER(^PRC(411,PRCRI(411)))
if 'PRCRI(411)
QUIT
if $DATA(^PRC(420,PRCRI(411),2,DUZ))
SET PRCSTU=PRCSTU+1_"^"_PRCRI(411)
End DoDot:1
+2 IF 'PRCSTU
DO EN^DDIOL("Station access is not allowed")
SET PRCQT="^"
GOTO LG1X
+3 IF +PRCSTU=1
SET PRC("SITE")=$PIECE(^PRC(420,+$PIECE(PRCSTU,"^",2),0),"^")
DO EN^DDIOL("STATION: "_PRC("SITE"))
GOTO LG1E
+4 SET X("S")="I $D(^PRC(420,+Y,2,DUZ))"
+5 DO LOOKUP^PRC0B(.X,.Y,PRCDI,"ACEFNO","Select Station: ")
+6 if X=""!(X["^")
SET PRCQT="^"
+7 SET PRC("SITE")=$PIECE(Y,"^",2)
LG1E SET PRCRI(420)=+PRC("SITE")
SET PRCDI=PRCDI_PRCRI(420)_";"
LG1X QUIT
+1 ;
LG2 ;
+1 SET $PIECE(PRCDI,"~",2)="420.01;"_$PIECE($PIECE(PRCDI,"~"),";",2)_PRCRI(420)_",1,;"
Q2 KILL PRCZ
DO EN^DDIOL($TRANSLATE($JUSTIFY("",78)," ","-"))
SET X("S")="I ^(0)-9999"
+1 DO LOOKUP^PRC0B(.X,.Y,PRCDI,"AEOQS","Select Fund Control Point: ")
+2 IF Y<0!(X="")
SET PRCQT="^"
QUIT
+3 KILL X
SET PRCRI(420.01)=+Y
SET PRC("CP")=$PIECE($PIECE(Y,"^")," ")
+4 SET PRCDI=PRCDI_PRCRI(420.01)_";"
+5 ;
Q3 SET E="O^2:4^K:X'?2N&(X'?4N) X"
SET Y(1)="Enter a 2 or 4 digit year."
+1 DO FT^PRC0A(.X,.Y,"For Budget Fiscal Year",E,"")
+2 if X["^"!(X="")
GOTO Q2
+3 SET PRC("FY")=$PIECE($$YEAR^PRC0C(Y),"^",2)
SET PRCRI(420.06)=PRC("FY")
+4 SET PRCD=$GET(^PRC(420,PRCRI(420),1,PRCRI(420.01),4,PRCRI(420.06),2))
+5 ;I PRCD="" D EN^DDIOL(" The yearly FMS accounting elements are not in file yet.") G Q3
+6 DO DIS(PRC("SITE")_"^"_PRC("CP")_"^"_PRC("FY"))
Q4 DO YN^PRC0A(.X,.Y,"Reset the fiscal year "_PRC("FY")_" Suballowance Account","O","NO")
+1 if X["^"!(X="")!(Y<1)
GOTO Q2
+2 SET PRCZ(4)=Y
Q5 ;D SC^PRC0A(.X,.Y,"Select FMS SA-doc ACT code","OM^A:for suballowance account NOT in FMS yet;C:for suballowance account is in FMS","")
+1 ;G:X["^"!(X="") Q2
+2 SET Y="C"
+3 SET PRCZ(5)=Y
Q6 DO YN^PRC0A(.X,.Y,"Ready to File","O","NO")
+1 if X["^"!(X="")!'Y
GOTO Q2
+2 IF '$PIECE(PRCB1,"^",11)
DO EN^DDIOL("BBFY missing in FCP set up")
GOTO Q2
+3 SET A=$$FUND^PRC0C($PIECE(PRCB1,"^",10),$PIECE(PRCB1,"^",11))
+4 IF 'A
DO EN^DDIOL("Fund code "_$PIECE(PRCB1,"^",10)_" with beginning year "_$PIECE(PRCB1,"^",11)_" is not in fund file (420.14)")
GOTO Q2
+5 SET PRC("BBFY")=$$BBFY^PRCSUT(PRCRI(420),PRC("FY"),PRCRI(420.01),1)
+6 IF $GET(PRCZ(4))=1
Begin DoDot:1
+7 if $PIECE(PRCD1,"^",10)=""
SET $PIECE(PRCD1,"^",10)=$PIECE(PRCB1,"^",10)
SET A=$$FUND^PRC0C($PIECE(PRCD1,"^",10),PRC("BBFY"))
+8 IF 'A
DO EN^DDIOL("Fund code "_$PIECE(PRCD1,"^",10)_" with beginning year "_PRC("BBFY")_" is not in fund file (420.14).")
KILL PRC("BBFY")
+9 QUIT
End DoDot:1
if '$GET(PRC("BBFY"))
GOTO Q2
+10 SET PRCLOCK=$PIECE($PIECE(PRCDI,"~",2),";",2)_PRCRI(420.01)_","
+11 DO ICLOCK^PRC0B(PRCLOCK,.Y)
+12 IF 'Y
DO EN^DDIOL("This FCP File is in use, please try later!")
GOTO Q2
+13 DO FILE
DO DCLOCK^PRC0B(PRCLOCK)
+14 GOTO Q2
+15 ;
FILE ;filing
+1 IF $GET(PRCZ(4))=1
Begin DoDot:1
+2 ;delete old entry in file 420.141
+3 SET C=$$ACC^PRC0C(PRC("SITE"),PRC("CP")_"^"_PRC("FY")_"^"_PRC("BBFY"))
+4 SET A=$$FMSACC^PRC0D(PRC("SITE"),C)
+5 SET B=$$FIRST^PRC0B1("^PRCD(420.141,""B"","""_A_""",",0)
+6 IF B
DO DELETE^PRC0B1(.X,";^PRCD(420.141,;"_B)
+7 ;reset fiscal yearly accounting elements
+8 if '$DATA(^PRC(420,PRCRI(420),1,PRCRI(420.01),4,PRCRI(420.06)))
DO EBAL^PRCSEZ(PRCRI(420)_"^"_PRCRI(420.01)_"^"_PRCRI(420.06)_"^1^0","C")
+9 SET ^PRC(420,PRCRI(420),1,PRCRI(420.01),4,PRCRI(420.06),2)=PRCB
End DoDot:1
+10 ;add new entry if action code is 'C', delete if code is A
+11 SET C=$$ACC^PRC0C(PRC("SITE"),PRC("CP")_"^"_PRC("FY")_"^"_PRC("BBFY"))
+12 SET A=$$FMSACC^PRC0D(PRC("SITE"),C)
+13 SET B=$$FIRST^PRC0B1("^PRCD(420.141,""B"","""_A_""",",0)
+14 IF $GET(PRCZ(5))="A"
IF B
DO DELETE^PRC0B1(.X,";^PRCD(420.141,;"_B)
+15 IF $GET(PRCZ(5))="C"
IF 'B
SET B=$$A420D141^PRC0F(A,PRCRI(420.01))
+16 QUIT
+17 ;
+18 ;PRCA data ^1=station, ^2=control point, ^3=fiscal year
DIS(PRCA) ;display fms accounting data
+1 ;get acc element from fcp
Begin DoDot:1
+2 NEW Z
+3 SET Z("ST")=PRCRI(420)
SET Z("CP")=PRCRI(420.01)
+4 SET PRCB=$$SUBALL^PRCSEZ
+5 QUIT
End DoDot:1
+6 SET PRCD=$GET(^PRC(420,PRCRI(420),1,PRCRI(420.01),4,PRCRI(420.06),2))
+7 SET PRCB1=$$ACC(PRCB)
SET PRCD1=$$ACC(PRCD)
+8 SET A=$PIECE($GET(^PRC(420,PRCRI(420),1,PRCRI(420.01),5)),"^",8)
SET $PIECE(PRCB1,"^",11)=+$$DATE^PRC0C(A,"F")
+9 SET $PIECE(PRCD1,"^",11)=PRC("FY")
+10 WRITE !,"CURRENT FCP ACCOUNTING ELEMENTS",?40,"FISCAL YEAR FCP ACCOUNTING ELEMENTS"
+11 SET B=0
FOR A=11,10,9,4:1:8
SET B=B+1
SET C=$PIECE("BBFY~FUND~APPROPRI~A/O~PROGRAM~FCP/PRJ~OBJECT CLASS~JOB","~",B)
WRITE !,$JUSTIFY(C,12),": ",$PIECE(PRCB1,"^",A)
if C="BBFY"
SET C="FISCAL YEAR"
WRITE ?40,$JUSTIFY(C,12),": ",$PIECE(PRCD1,"^",A)
+12 QUIT
+13 ;
ACC(A) ;get external format of prca
+1 if $PIECE(A,"^",4)
SET $PIECE(A,"^",4)=$$NP^PRC0B("^PRCD(420.15,$P(A,""^"",4),",0,1)
+2 if $PIECE(A,"^",5)
SET $PIECE(A,"^",5)=$$NP^PRC0B("^PRCD(420.13,$P(A,""^"",5),",0,1)
+3 if $PIECE(A,"^",6)
SET $PIECE(A,"^",6)=$$NP^PRC0B("^PRCD(420.131,$P(A,""^"",6),",0,1)
+4 if $PIECE(A,"^",7)
SET $PIECE(A,"^",7)=$$NP^PRC0B("^PRCD(420.132,$P(A,""^"",7),",0,1)
+5 if $PIECE(A,"^",8)
SET $PIECE(A,"^",8)=$$NP^PRC0B("^PRCD(420.133,$P(A,""^"",8),",0,1)
+6 QUIT A
+7 ;
