PRCFY ;WISC@ALTOONA/CTB/DL-PLACE FY INFO INTO APPROPRIATION SYMBOL ; 1/30/98 0845
V ;;5.1;IFCAP;;Oct 20, 2000
;Per VHA Directive 10-93-142, this routine should not be modified.
;REQUIRES FOLLOWING LOCAL VARIABLES
; PRC("APP")= APPROPRIATION SYMBOL, FROM CONTROL POINT FILE
; PRC("FY")=FISCAL YEAR TO BE PLACED INTO APPROPRIATION SYMBOL
;RETURNS COMPLETED SYMBOL IN PRC("APP")
;
SE S U="^" I '$D(PRC("FY")) S %DT="",X="T" D ^%DT S A=$E(Y,2,3),B=$E(Y,4,5),PRC("FY")=$E(100+$S(+B>9:A+1,1:A),2,3)
I '$D(PRC("APP")) W !,"NO ACTION TAKEN, INCOMPLETE DATA GIVEN",!! Q
S A=PRC("APP"),B=$S(A["_/_":"EN1",A["_":"EN2",1:"EN3")
D @(B) S PRC("APP")=B Q
EN1 ;TWO YEAR APPROPRIATION
I '$D(PRC("FYI")) W !!,"ENTER FIRST YEAR OF THIS TWO YEAR APPROPRIATION: ",PRC("FY")," // " R X:$S($D(DTIME):DTIME,1:300) Q:X=U I X["?"!(X'?.4N) W !,"ENTER FISCAL YEAR IN FORMAT '1' '81' OR '1981'",!! G EN1
S:$D(PRC("FYI")) X=PRC("FYI") S:X="" X=PRC("FY") S X=$E(X,$L(X)),B=$P(A,"_",1)_X_"/"_(X+1#10)_$P(A,"_",3) Q
EN2 ; SINGLE YEAR APPROPRIATION
S X="" I '$D(PRC("FY")) W !!,"ENTER FISCAL YEAR: " R X:$S($D(DTIME):DTIME,1:300) Q:X=U!(X="") I X["?"!(X'?.4N) W !,"ENTER FISCAL YEAR IN FORMAT '1', '81', OR '1981'",!! G EN2
I X=""&($D(PRC("FY"))) S X=PRC("FY")
S X=$E(X,$L(X)),B=+A_X_$P(A,"_",2) Q
EN3 ; MULTI YEAR APPROPRIATION OR FUND
S B=PRC("APP") Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCFY 1364 printed Sep 23, 2025@19:40:38 Page 2
PRCFY ;WISC@ALTOONA/CTB/DL-PLACE FY INFO INTO APPROPRIATION SYMBOL ; 1/30/98 0845
V ;;5.1;IFCAP;;Oct 20, 2000
+1 ;Per VHA Directive 10-93-142, this routine should not be modified.
+2 ;REQUIRES FOLLOWING LOCAL VARIABLES
+3 ; PRC("APP")= APPROPRIATION SYMBOL, FROM CONTROL POINT FILE
+4 ; PRC("FY")=FISCAL YEAR TO BE PLACED INTO APPROPRIATION SYMBOL
+5 ;RETURNS COMPLETED SYMBOL IN PRC("APP")
+6 ;
SE SET U="^"
IF '$DATA(PRC("FY"))
SET %DT=""
SET X="T"
DO ^%DT
SET A=$EXTRACT(Y,2,3)
SET B=$EXTRACT(Y,4,5)
SET PRC("FY")=$EXTRACT(100+$SELECT(+B>9:A+1,1:A),2,3)
+1 IF '$DATA(PRC("APP"))
WRITE !,"NO ACTION TAKEN, INCOMPLETE DATA GIVEN",!!
QUIT
+2 SET A=PRC("APP")
SET B=$SELECT(A["_/_":"EN1",A["_":"EN2",1:"EN3")
+3 DO @(B)
SET PRC("APP")=B
QUIT
EN1 ;TWO YEAR APPROPRIATION
+1 IF '$DATA(PRC("FYI"))
WRITE !!,"ENTER FIRST YEAR OF THIS TWO YEAR APPROPRIATION: ",PRC("FY")," // "
READ X:$SELECT($DATA(DTIME):DTIME,1:300)
if X=U
QUIT
IF X["?"!(X'?.4N)
WRITE !,"ENTER FISCAL YEAR IN FORMAT '1' '81' OR '1981'",!!
GOTO EN1
+2 if $DATA(PRC("FYI"))
SET X=PRC("FYI")
if X=""
SET X=PRC("FY")
SET X=$EXTRACT(X,$LENGTH(X))
SET B=$PIECE(A,"_",1)_X_"/"_(X+1#10)_$PIECE(A,"_",3)
QUIT
EN2 ; SINGLE YEAR APPROPRIATION
+1 SET X=""
IF '$DATA(PRC("FY"))
WRITE !!,"ENTER FISCAL YEAR: "
READ X:$SELECT($DATA(DTIME):DTIME,1:300)
if X=U!(X="")
QUIT
IF X["?"!(X'?.4N)
WRITE !,"ENTER FISCAL YEAR IN FORMAT '1', '81', OR '1981'",!!
GOTO EN2
+2 IF X=""&($DATA(PRC("FY")))
SET X=PRC("FY")
+3 SET X=$EXTRACT(X,$LENGTH(X))
SET B=+A_X_$PIECE(A,"_",2)
QUIT
EN3 ; MULTI YEAR APPROPRIATION OR FUND
+1 SET B=PRC("APP")
QUIT
