PRCD3A ;WISC/PLT,DGL-Generate FUND FILE & REQUIRED TABLE for a new fical year ; [9/24/98 9:30am]
V ;;5.1;IFCAP;;Oct 20, 2000
;Per VHA Directive 10-93-142, this routine should not be modified.
QUIT ;invalid entry
;
EN N PRCA,PRCB,PRCC,PRCRI,PRCQT
N A,B,C,X,Y,Z
F S PRCQT=1 D LG1 QUIT:PRCQT["^" D:$P(PRCE,"^",2) LG2 QUIT
EXIT QUIT
LG1 S PRCD=1+$$DATE^PRC0C(+$H,"H"),$P(PRCD,"^",2)="NO"
S PRCE=PRCD,$P(PRCE,"^",2)=0
Q1 S Y(1)="ENTER 4-DIGIT BEGINNING BUDGET FISCAL YEAR"
D FT^PRC0A(.X,.Y,"For Beginning Budget Fiscal Year","O^4:4^I X'?4N K X",$P(PRCD,"^"))
I X=""!(X["^")!'Y S PRCQT="^" G LG1X
I PRCD-Y<-1 D EN^DDIOL("It is too early to generate fund/required table for this year.") G Q1
I PRCD-Y>1 D EN^DDIOL("It is too late to generate fund/required table for this year.") G Q1
S $P(PRCE,"^")=Y
Q2 S X(1)="Note: All ACTIVE SINGLE-YEAR FUND CONTROL POINTS will be initialized"
S X(2)=" to enable the new fiscal year FMS/820 RECORDS to post correctly."
D YN^PRC0A(.X,.Y,"Ready to Generate the fund code & Required Table for "_$P(PRCE,"^"),"O","NO")
I X=""!(X["^")!'Y S PRCQT="^" G LG1X
S $P(PRCE,"^",2)=Y
LG1X QUIT
;
LG2 ;
D FUND($P(PRCE,"^"))
S PRCRI(420)=0,PFLG=0
F S PRCRI(420)=$O(^PRC(420,PRCRI(420))) QUIT:'PRCRI(420) I PRCRI(420) W !,"Station: ",PRCRI(420) D
. S PRCRI(420.01)=0
. F S PRCRI(420.01)=$O(^PRC(420,PRCRI(420),1,PRCRI(420.01))) QUIT:PRCRI(420.01)>9998!'PRCRI(420.01) D
. . S X=$G(^PRC(420,PRCRI(420),1,PRCRI(420.01),0))
. . I X="" W !,"** No zero node exists for IEN ",PRCRI(420.01) S PFLG=PFLG+1 QUIT
. . I PRCRI(420.01)'=(X+0) W !,"** IEN ",PRCRI(420.01)," does not match FCP ",$P(X,U,1) S PFLG=PFLG+1 QUIT
. . I '$P(X,U,19) W !,$P(^(0),"^") D FCP(PRCRI(420),$E(PRCE,3,4),PRCRI(420.01))
. QUIT
I PFLG>0 W !!,"** NOTE: There were ",PFLG," entries with errors.",!," Please contact IRM about these discrepancies.",!," See patch PRC*5*168 documentation for instructions.",!
D EN^DDIOL("ALL DONE! ALL DONE! ALL DONE!")
QUIT
;
FCP(PRCA,PRCB,PRCC) ;set entry in file 420.141
;prca=station #, prcb=fiscal year(2-digit), prcc=fcp #
N PRCBBFY
N A,B,C
S PRCBBFY=$$BBFY^PRCSUT(PRCA,PRCB,PRCC,1)
S C=$$ACC^PRC0C(PRCA,PRCC_"^"_PRCB_"^"_PRCBBFY)
QUIT:$P(C,"^",6)'=$P(C,"^",7)
S A=$$FMSACC^PRC0D(PRCA,C)
S B=$$FIRST^PRC0B1("^PRCD(420.141,""B"","""_A_""",",0)
I 'B S B=$$A420D141^PRC0F(A,PRCC) D EBAL^PRCSEZ(PRCA_"^"_PRCC_"^"_PRCB_"^1^0","C")
QUIT
;
FUND(PRCA) ;PRCA = BEGINNING BUDGET FISCAL YEAR (4-DIGIT)
N PRCRI,PRCLOCK,PRCFUND,PRCBBFY,PRCEBFY
D ICLOCK^PRC0B("^PRCD(420.14,")
S PRCBBFY=PRCA-1
S PRCFUND="" F S PRCFUND=$O(^PRCD(420.14,"UNQ",PRCFUND)) QUIT:PRCFUND="" D
. S PRCEBFY="" F S PRCEBFY=$O(^PRCD(420.14,"UNQ",PRCFUND,PRCBBFY,PRCEBFY)) QUIT:'PRCEBFY D
.. S PRCRI("420.14A")=0
.. F S PRCRI("420.14A")=$O(^PRCD(420.14,"UNQ",PRCFUND,PRCBBFY,PRCEBFY,PRCRI("420.14A"))) QUIT:'PRCRI("420.14A") D AFUND(PRCRI("420.14A"))
.. QUIT
. QUIT
D DCLOCK^PRC0B("^PRCD(420.14,")
QUIT
;
AFUND(PRCRI) ;ADD NEW FUND ENTRY
N PRCA,PRCB
N A,B,C
S PRCA=^PRCD(420.14,PRCRI,0)
;fund with status 'O' not generated
S A=$P(PRCA,"^",6),A=$G(^PRCD(420.1999,A,0)) QUIT:$P(A,"^",4)="O"
S $P(PRCA,"^",3)=$P(PRCA,"^",3)+1,$P(PRCA,"^",4)=$P(PRCA,"^",4)+1
S PRCRI(420.14)=$O(^PRCD(420.14,"UNQ",$P(PRCA,"^"),$P(PRCA,"^",3),$P(PRCA,"^",4),""))
D:'PRCRI(420.14)
. D EN^DDIOL(PRCRI_" "_$P(PRCA,"^")_" "_$P(PRCA,"^",2)_" "_$P(PRCA,"^",3)_" - "_$P(PRCA,"^",4))
. K X S X=$P(PRCA,"^")
. S X("DR")="2///"_$P(PRCA,"^",3)_";3///"_$P(PRCA,"^",4)_";4.5///"_$P(PRCA,"^",7)_";4.7///"_$P(PRCA,"^",5)_";5///"_$P(PRCA,"^",6)_";1///"_$P(PRCA,"^",2)
. S Y="" D ADD^PRC0B1(.X,.Y,"420.14;^PRCD(420.14,") W " ",$P(Y,"^")
. S PRCRI(420.14)=+Y
. QUIT
D:PRCRI(420.14)&PRCRI REQ(PRCRI,PRCRI(420.14))
QUIT
;
REQ(PRCA,PRCB) ;copy fund required table from fund code RID# PRCA to PRCB
N PRCRI,PRCC
S PRCRI(420.18)=""
F S PRCRI(420.18)=$O(^PRCD(420.18,"B",PRCA,PRCRI(420.18))) QUIT:'PRCRI(420.18) D
. S PRCC=$G(^PRCD(420.18,PRCRI(420.18),0)) QUIT:'PRCC
. QUIT:$O(^PRCD(420.18,"UNQ",PRCB,$P(PRCC,"^",2),$P(PRCC,"^",3),""))
. W !,PRCC
. S $P(PRCC,"^",1)=PRCB
. W " *** ",PRCC
. K X S X=PRCB
. S X("DR")="1////"_$P(PRCC,"^",2)_";2////"_$P(PRCC,"^",3)_";3////"_$P(PRCC,"^",4)
. S Y="" D ADD^PRC0B1(.X,.Y,"420.18;^PRCD(420.18,") W " ",$P(Y,"^")
. QUIT
QUIT
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCD3A 4426 printed Jan 18, 2025@03:02:17 Page 2
PRCD3A ;WISC/PLT,DGL-Generate FUND FILE & REQUIRED TABLE for a new fical year ; [9/24/98 9:30am]
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 PRCA,PRCB,PRCC,PRCRI,PRCQT
+1 NEW A,B,C,X,Y,Z
+2 FOR
SET PRCQT=1
DO LG1
if PRCQT["^"
QUIT
if $PIECE(PRCE,"^",2)
DO LG2
QUIT
EXIT QUIT
LG1 SET PRCD=1+$$DATE^PRC0C(+$HOROLOG,"H")
SET $PIECE(PRCD,"^",2)="NO"
+1 SET PRCE=PRCD
SET $PIECE(PRCE,"^",2)=0
Q1 SET Y(1)="ENTER 4-DIGIT BEGINNING BUDGET FISCAL YEAR"
+1 DO FT^PRC0A(.X,.Y,"For Beginning Budget Fiscal Year","O^4:4^I X'?4N K X",$PIECE(PRCD,"^"))
+2 IF X=""!(X["^")!'Y
SET PRCQT="^"
GOTO LG1X
+3 IF PRCD-Y<-1
DO EN^DDIOL("It is too early to generate fund/required table for this year.")
GOTO Q1
+4 IF PRCD-Y>1
DO EN^DDIOL("It is too late to generate fund/required table for this year.")
GOTO Q1
+5 SET $PIECE(PRCE,"^")=Y
Q2 SET X(1)="Note: All ACTIVE SINGLE-YEAR FUND CONTROL POINTS will be initialized"
+1 SET X(2)=" to enable the new fiscal year FMS/820 RECORDS to post correctly."
+2 DO YN^PRC0A(.X,.Y,"Ready to Generate the fund code & Required Table for "_$PIECE(PRCE,"^"),"O","NO")
+3 IF X=""!(X["^")!'Y
SET PRCQT="^"
GOTO LG1X
+4 SET $PIECE(PRCE,"^",2)=Y
LG1X QUIT
+1 ;
LG2 ;
+1 DO FUND($PIECE(PRCE,"^"))
+2 SET PRCRI(420)=0
SET PFLG=0
+3 FOR
SET PRCRI(420)=$ORDER(^PRC(420,PRCRI(420)))
if 'PRCRI(420)
QUIT
IF PRCRI(420)
WRITE !,"Station: ",PRCRI(420)
Begin DoDot:1
+4 SET PRCRI(420.01)=0
+5 FOR
SET PRCRI(420.01)=$ORDER(^PRC(420,PRCRI(420),1,PRCRI(420.01)))
if PRCRI(420.01)>9998!'PRCRI(420.01)
QUIT
Begin DoDot:2
+6 SET X=$GET(^PRC(420,PRCRI(420),1,PRCRI(420.01),0))
+7 IF X=""
WRITE !,"** No zero node exists for IEN ",PRCRI(420.01)
SET PFLG=PFLG+1
QUIT
+8 IF PRCRI(420.01)'=(X+0)
WRITE !,"** IEN ",PRCRI(420.01)," does not match FCP ",$PIECE(X,U,1)
SET PFLG=PFLG+1
QUIT
+9 IF '$PIECE(X,U,19)
WRITE !,$PIECE(^(0),"^")
DO FCP(PRCRI(420),$EXTRACT(PRCE,3,4),PRCRI(420.01))
End DoDot:2
+10 QUIT
End DoDot:1
+11 IF PFLG>0
WRITE !!,"** NOTE: There were ",PFLG," entries with errors.",!," Please contact IRM about these discrepancies.",!," See patch PRC*5*168 documentation for instructions.",!
+12 DO EN^DDIOL("ALL DONE! ALL DONE! ALL DONE!")
+13 QUIT
+14 ;
FCP(PRCA,PRCB,PRCC) ;set entry in file 420.141
+1 ;prca=station #, prcb=fiscal year(2-digit), prcc=fcp #
+2 NEW PRCBBFY
+3 NEW A,B,C
+4 SET PRCBBFY=$$BBFY^PRCSUT(PRCA,PRCB,PRCC,1)
+5 SET C=$$ACC^PRC0C(PRCA,PRCC_"^"_PRCB_"^"_PRCBBFY)
+6 if $PIECE(C,"^",6)'=$PIECE(C,"^",7)
QUIT
+7 SET A=$$FMSACC^PRC0D(PRCA,C)
+8 SET B=$$FIRST^PRC0B1("^PRCD(420.141,""B"","""_A_""",",0)
+9 IF 'B
SET B=$$A420D141^PRC0F(A,PRCC)
DO EBAL^PRCSEZ(PRCA_"^"_PRCC_"^"_PRCB_"^1^0","C")
+10 QUIT
+11 ;
FUND(PRCA) ;PRCA = BEGINNING BUDGET FISCAL YEAR (4-DIGIT)
+1 NEW PRCRI,PRCLOCK,PRCFUND,PRCBBFY,PRCEBFY
+2 DO ICLOCK^PRC0B("^PRCD(420.14,")
+3 SET PRCBBFY=PRCA-1
+4 SET PRCFUND=""
FOR
SET PRCFUND=$ORDER(^PRCD(420.14,"UNQ",PRCFUND))
if PRCFUND=""
QUIT
Begin DoDot:1
+5 SET PRCEBFY=""
FOR
SET PRCEBFY=$ORDER(^PRCD(420.14,"UNQ",PRCFUND,PRCBBFY,PRCEBFY))
if 'PRCEBFY
QUIT
Begin DoDot:2
+6 SET PRCRI("420.14A")=0
+7 FOR
SET PRCRI("420.14A")=$ORDER(^PRCD(420.14,"UNQ",PRCFUND,PRCBBFY,PRCEBFY,PRCRI("420.14A")))
if 'PRCRI("420.14A")
QUIT
DO AFUND(PRCRI("420.14A"))
+8 QUIT
End DoDot:2
+9 QUIT
End DoDot:1
+10 DO DCLOCK^PRC0B("^PRCD(420.14,")
+11 QUIT
+12 ;
AFUND(PRCRI) ;ADD NEW FUND ENTRY
+1 NEW PRCA,PRCB
+2 NEW A,B,C
+3 SET PRCA=^PRCD(420.14,PRCRI,0)
+4 ;fund with status 'O' not generated
+5 SET A=$PIECE(PRCA,"^",6)
SET A=$GET(^PRCD(420.1999,A,0))
if $PIECE(A,"^",4)="O"
QUIT
+6 SET $PIECE(PRCA,"^",3)=$PIECE(PRCA,"^",3)+1
SET $PIECE(PRCA,"^",4)=$PIECE(PRCA,"^",4)+1
+7 SET PRCRI(420.14)=$ORDER(^PRCD(420.14,"UNQ",$PIECE(PRCA,"^"),$PIECE(PRCA,"^",3),$PIECE(PRCA,"^",4),""))
+8 if 'PRCRI(420.14)
Begin DoDot:1
+9 DO EN^DDIOL(PRCRI_" "_$PIECE(PRCA,"^")_" "_$PIECE(PRCA,"^",2)_" "_$PIECE(PRCA,"^",3)_" - "_$PIECE(PRCA,"^",4))
+10 KILL X
SET X=$PIECE(PRCA,"^")
+11 SET X("DR")="2///"_$PIECE(PRCA,"^",3)_";3///"_$PIECE(PRCA,"^",4)_";4.5///"_$PIECE(PRCA,"^",7)_";4.7///"_$PIECE(PRCA,"^",5)_";5///"_$PIECE(PRCA,"^",6)_";1///"_$PIECE(PRCA,"^",2)
+12 SET Y=""
DO ADD^PRC0B1(.X,.Y,"420.14;^PRCD(420.14,")
WRITE " ",$PIECE(Y,"^")
+13 SET PRCRI(420.14)=+Y
+14 QUIT
End DoDot:1
+15 if PRCRI(420.14)&PRCRI
DO REQ(PRCRI,PRCRI(420.14))
+16 QUIT
+17 ;
REQ(PRCA,PRCB) ;copy fund required table from fund code RID# PRCA to PRCB
+1 NEW PRCRI,PRCC
+2 SET PRCRI(420.18)=""
+3 FOR
SET PRCRI(420.18)=$ORDER(^PRCD(420.18,"B",PRCA,PRCRI(420.18)))
if 'PRCRI(420.18)
QUIT
Begin DoDot:1
+4 SET PRCC=$GET(^PRCD(420.18,PRCRI(420.18),0))
if 'PRCC
QUIT
+5 if $ORDER(^PRCD(420.18,"UNQ",PRCB,$PIECE(PRCC,"^",2),$PIECE(PRCC,"^",3),""))
QUIT
+6 WRITE !,PRCC
+7 SET $PIECE(PRCC,"^",1)=PRCB
+8 WRITE " *** ",PRCC
+9 KILL X
SET X=PRCB
+10 SET X("DR")="1////"_$PIECE(PRCC,"^",2)_";2////"_$PIECE(PRCC,"^",3)_";3////"_$PIECE(PRCC,"^",4)
+11 SET Y=""
DO ADD^PRC0B1(.X,.Y,"420.18;^PRCD(420.18,")
WRITE " ",$PIECE(Y,"^")
+12 QUIT
End DoDot:1
+13 QUIT
