PRCB1A1 ;WISC/PLT-PRCB1A CONTINUED ; 06/16/94 2:16 PM
V ;;5.1;IFCAP;;Oct 20, 2000
;Per VHA Directive 10-93-142, this routine should not be modified.
QUIT ;invalid entry
;
ED0 S X=$P($T(EDDR+1),";",3,999) S:C]""&(PRCAED-1) X=C_X
F I=2:1 Q:$P($T(EDDR+I),";",3,999)="" S X(1,420.01,I-1)=$P($T(EDDR+I),";",3,999)
D EDIT^PRC0B(.X,PRCDI,"")
I X=0 S PRCQT=2 QUIT
I X=-1,PRCAED=1 D DELQ Q:PRCQT
I $P(^PRC(420,PRCRI(420),1,PRCRI(420.01),0),"^",3)'["_/_" D UNQCHK^PRCB1A(PRCK1,PRCK25D5,PRCK26,PRCK27,PRCK28,PRCK29) I PRCUNQ=1 D G ED0
. D EN^DDIOL("A single year fund control point must be unique!")
. S C="1;25.2;" F A=25.5,26:1:29 S:PRCRQ(A) C=C_A_";S Y=0;"
. Q
;required field check
S C="1~1;4;14;21;" F I=25.5,26:1:29 S:PRCRQ(I) C=C_I_";"
K A D PIECE^PRC0B(PRCDI,C,"I","A")
S C="" F A=1 S:$G(A(PRCDD,PRCRI(PRCDD),A,"I"))="" C=C_A_";"
F A=25.5,26:1:29 S:$G(A(PRCDD,PRCRI(PRCDD),A,"I"))=""&PRCRQ(A) C=C_A_";"
F A=14 S:$G(A(PRCDD,PRCRI(PRCDD),A,"I"))="" C=C_A_";"
I $$SFCP^PRC0D(PRCRI(420),PRCRI(420.01))'=2 F A=21 S:$G(A(PRCDD,PRCRI(PRCDD),A,"I"))="" C=C_A_";"
S:C["21;" C=C_"S:$P($G(^PRC(420,DA(1),1,DA,0)),""^"",20)'=1 Y=""@899"";22;@899;"
I C]"" K A D EN^DDIOL(" **** Missing Required Field(s) ****") S C=C_"S Y=0;" G ED0
I $G(A(PRCDD,PRCRI(PRCDD),4,"I"))["N" D EN^DDIOL("Notify users of this control point that the control point is non-automated!")
K A
I PRCAED=1 D FCP^PRCD3A(PRCRI(420),$E($$DATE^PRC0C("T","E"),3,4),PRCRI(420.01)),EN^DDIOL("Note: The new fund control point was initialized to enable the current"),EN^DDIOL("fiscal year FMS RECORDS to post correctly.")
QUIT
;
DELQ D YN^PRC0A(.X,.Y,"Delete this NEW entry","","No")
I Y=1 D DELETE I PRCAED=-1 D EN^DDIOL(" **** NEW ENTRY DELETED ****") S PRCQT=3 QUIT
D EN^DDIOL(" **** NEW ENTRY IS NOT DELETED ****")
QUIT
;
DELETE ;delete 420.01
D DELETE^PRC0B1(.X,PRCDI)
S:X=1 PRCAED=-1
QUIT
;
;
REQ ;get required fields
S:$D(DA(1)) PRCRI(420)=DA(1) S:$D(DA) PRCRI(420.01)=DA
REQ1 N A,B
S PRCRQ="" F B=25.5,26,27,28,29 S PRCRQ(B)=""
QUIT:'PRCRI(420)!'PRCRI(420.01)
S A=$G(^PRC(420,PRCRI(420),1,PRCRI(420.01),5))
S PRCFUND=$P(A,"^"),PRCBBFY=$P(A,"^",8)
Q:$G(PRCFUND)=""!($G(PRCBBFY)="")
S A=$$FUND^PRC0C(PRCFUND,+$$DATE^PRC0C(PRCBBFY,"I"))
D:+A
. N PRC1,PRC2
. F B="SPE","REV","GL" I $$REQ^PRC0C(+A,B,"JOB")="Y" S PRC2("JOB")="Y"
. D DOCREQ^PRC0C(+A,"AB","PRC1")
. D DOCREQ^PRC0C(+A,"SAB","PRC2")
. S:$O(PRC1(""))]""!($O(PRC2(""))]"") PRCRQ=1
. I PRCRQ F B="25.5^AO","26^PGM","27^FCPRJ","28^OC","29^JOB" S:$G(PRC1($P(B,U,2)))="Y"!($G(PRC2($P(B,U,2)))="Y") PRCRQ(+B)=1
. QUIT
QUIT
;
UNQMES N X D EN^DDIOL(" Warning: NOT UNIQUE for fund, a/o, program, fcp/prj, object class, and job!")
D EN^DDIOL(" See fund control point "_$P($G(^PRC(420,PRCRI(420),1,PRCUQ,0)),"^",1))
S PRCUNQ=1
QUIT
;
EDDR ;edit string
;;.5;1;S:$G(PRCFUND)="" Y=0;25.2;@9255;S:'PRCRQ(25.5) Y="@926";25.5;@926;S:'PRCRQ(26) Y="@927";26;@927;S:'PRCRQ(27) Y="@928";27;@928;S:'PRCRQ(28) Y="@929";28;@929;S:'PRCRQ(29) Y="@904";29;@904;4;12;6;13;
;;7;8;14;31;32;S:$$SFCP^PRC0D(PRCRI(420),PRCRI(420.01))=2 Y="@999";21;S:$P($G(^PRC(420,DA(1),1,DA,0)),"^",20)'=1 Y="@999";22;@999;
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCB1A1 3217 printed Nov 22, 2024@17:10:17 Page 2
PRCB1A1 ;WISC/PLT-PRCB1A CONTINUED ; 06/16/94 2:16 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 ;
ED0 SET X=$PIECE($TEXT(EDDR+1),";",3,999)
if C]""&(PRCAED-1)
SET X=C_X
+1 FOR I=2:1
if $PIECE($TEXT(EDDR+I),";",3,999)=""
QUIT
SET X(1,420.01,I-1)=$PIECE($TEXT(EDDR+I),";",3,999)
+2 DO EDIT^PRC0B(.X,PRCDI,"")
+3 IF X=0
SET PRCQT=2
QUIT
+4 IF X=-1
IF PRCAED=1
DO DELQ
if PRCQT
QUIT
+5 IF $PIECE(^PRC(420,PRCRI(420),1,PRCRI(420.01),0),"^",3)'["_/_"
DO UNQCHK^PRCB1A(PRCK1,PRCK25D5,PRCK26,PRCK27,PRCK28,PRCK29)
IF PRCUNQ=1
Begin DoDot:1
+6 DO EN^DDIOL("A single year fund control point must be unique!")
+7 SET C="1;25.2;"
FOR A=25.5,26:1:29
if PRCRQ(A)
SET C=C_A_";S Y=0;"
+8 QUIT
End DoDot:1
GOTO ED0
+9 ;required field check
+10 SET C="1~1;4;14;21;"
FOR I=25.5,26:1:29
if PRCRQ(I)
SET C=C_I_";"
+11 KILL A
DO PIECE^PRC0B(PRCDI,C,"I","A")
+12 SET C=""
FOR A=1
if $GET(A(PRCDD,PRCRI(PRCDD),A,"I"))=""
SET C=C_A_";"
+13 FOR A=25.5,26:1:29
if $GET(A(PRCDD,PRCRI(PRCDD),A,"I"))=""&PRCRQ(A)
SET C=C_A_";"
+14 FOR A=14
if $GET(A(PRCDD,PRCRI(PRCDD),A,"I"))=""
SET C=C_A_";"
+15 IF $$SFCP^PRC0D(PRCRI(420),PRCRI(420.01))'=2
FOR A=21
if $GET(A(PRCDD,PRCRI(PRCDD),A,"I"))=""
SET C=C_A_";"
+16 if C["21;"
SET C=C_"S:$P($G(^PRC(420,DA(1),1,DA,0)),""^"",20)'=1 Y=""@899"";22;@899;"
+17 IF C]""
KILL A
DO EN^DDIOL(" **** Missing Required Field(s) ****")
SET C=C_"S Y=0;"
GOTO ED0
+18 IF $GET(A(PRCDD,PRCRI(PRCDD),4,"I"))["N"
DO EN^DDIOL("Notify users of this control point that the control point is non-automated!")
+19 KILL A
+20 IF PRCAED=1
DO FCP^PRCD3A(PRCRI(420),$EXTRACT($$DATE^PRC0C("T","E"),3,4),PRCRI(420.01))
DO EN^DDIOL("Note: The new fund control point was initialized to enable the current")
DO EN^DDIOL("fiscal year FMS RECORDS to post correctly.")
+21 QUIT
+22 ;
DELQ DO YN^PRC0A(.X,.Y,"Delete this NEW entry","","No")
+1 IF Y=1
DO DELETE
IF PRCAED=-1
DO EN^DDIOL(" **** NEW ENTRY DELETED ****")
SET PRCQT=3
QUIT
+2 DO EN^DDIOL(" **** NEW ENTRY IS NOT DELETED ****")
+3 QUIT
+4 ;
DELETE ;delete 420.01
+1 DO DELETE^PRC0B1(.X,PRCDI)
+2 if X=1
SET PRCAED=-1
+3 QUIT
+4 ;
+5 ;
REQ ;get required fields
+1 if $DATA(DA(1))
SET PRCRI(420)=DA(1)
if $DATA(DA)
SET PRCRI(420.01)=DA
REQ1 NEW A,B
+1 SET PRCRQ=""
FOR B=25.5,26,27,28,29
SET PRCRQ(B)=""
+2 if 'PRCRI(420)!'PRCRI(420.01)
QUIT
+3 SET A=$GET(^PRC(420,PRCRI(420),1,PRCRI(420.01),5))
+4 SET PRCFUND=$PIECE(A,"^")
SET PRCBBFY=$PIECE(A,"^",8)
+5 if $GET(PRCFUND)=""!($GET(PRCBBFY)="")
QUIT
+6 SET A=$$FUND^PRC0C(PRCFUND,+$$DATE^PRC0C(PRCBBFY,"I"))
+7 if +A
Begin DoDot:1
+8 NEW PRC1,PRC2
+9 FOR B="SPE","REV","GL"
IF $$REQ^PRC0C(+A,B,"JOB")="Y"
SET PRC2("JOB")="Y"
+10 DO DOCREQ^PRC0C(+A,"AB","PRC1")
+11 DO DOCREQ^PRC0C(+A,"SAB","PRC2")
+12 if $ORDER(PRC1(""))]""!($ORDER(PRC2(""))]"")
SET PRCRQ=1
+13 IF PRCRQ
FOR B="25.5^AO","26^PGM","27^FCPRJ","28^OC","29^JOB"
if $GET(PRC1($PIECE(B,U,2)))="Y"!($GET(PRC2($PIECE(B,U,2)))="Y")
SET PRCRQ(+B)=1
+14 QUIT
End DoDot:1
+15 QUIT
+16 ;
UNQMES NEW X
DO EN^DDIOL(" Warning: NOT UNIQUE for fund, a/o, program, fcp/prj, object class, and job!")
+1 DO EN^DDIOL(" See fund control point "_$PIECE($GET(^PRC(420,PRCRI(420),1,PRCUQ,0)),"^",1))
+2 SET PRCUNQ=1
+3 QUIT
+4 ;
EDDR ;edit string
+1 ;;.5;1;S:$G(PRCFUND)="" Y=0;25.2;@9255;S:'PRCRQ(25.5) Y="@926";25.5;@926;S:'PRCRQ(26) Y="@927";26;@927;S:'PRCRQ(27) Y="@928";27;@928;S:'PRCRQ(28) Y="@929";28;@929;S:'PRCRQ(29) Y="@904";29;@904;4;12;6;13;
+2 ;;7;8;14;31;32;S:$$SFCP^PRC0D(PRCRI(420),PRCRI(420.01))=2 Y="@999";21;S:$P($G(^PRC(420,DA(1),1,DA,0)),"^",20)'=1 Y="@999";22;@999;
+3 ;
