PRCHNPO8 ;WISC/RHD/DL-MISCELLANEOUS ROUTINES FROM P.O.ADD/EDIT 443.6 ;9/5/00 12:30
V ;;5.1;IFCAP;**113**;Oct 20, 2000;Build 4
;Per VHA Directive 2004-038, this routine should not be modified.
;
EN1 ;FILE 443.6, FCP #1
N Y
S Z0=$E($P(^PRC(443.6,DA,0),"-",2),1,2),Z1=+X D EN4^PRCHNPO6 I '$T K X,Z0,Z1 Q
S DIC="^PRC(420,PRC(""SITE""),1,",DIC(0)="QEMNZ",D="B^C" D MIX^DIC1 K:Y<0!('$D(PRC("FY"))) X K DIC,Z0,Z1 Q:'$D(X)
N CCNODE S CCNODE=$G(^PRC(420,PRC("SITE"),1,+Y,2,0)) I $P(CCNODE,U,4)'>0!(CCNODE="") W !,"The Fund Control Point selected by you, does not have any",!,"Cost Centers listed under it.",! K X Q
I $P(Y(0),U,12)'=2,$P(Y(0),U,18)="" W $C(7),!,"LOG Department Number is missing!!" K X Q
S Z0=$P(^PRC(443.6,DA,0),U,2),Z1=$P(Y(0),U,12) I Z1 I Z0=4!((Z0=3)&(Z1=3)) S Z0=$P(^PRCD(442.5,Z0,0),U,1) W $C(7),!,"Fund Control Point not valid for a "_Z0_" order." K Z0,Z1,X Q
S Z0=$P(Y(0),U,1) S:$P(Y(0),U,10)]"" PRCHN("SVC")=$P($G(^DIC(49,+$P(Y(0),U,10),0)),U,1)
S PRC("FY")=$E(100+$E(PRC("FY"),2,3)+$E(PRC("FY"),4),2,3)
I $D(^PRC(420,PRC("SITE"),1,+Y,2,0)),$P(^(0),U,4)=1,$D(^($P(^(0),U,3),0)),$D(^PRCD(420.1,+^(0),0)) S PRCHN("CC")=$P(^(0)," ",1)
S PRC("APP")="",X=Z0,PRC("BBFY")=$$BBFY^PRCSUT(PRC("SITE"),PRC("FY"),+X) I PRC("BBFY")="" Q
S PRC("APP")=$P($$ACC^PRC0C(PRC("SITE"),+X_"^"_PRC("FY")_"^"_PRC("BBFY")),U,11) K Z0,Z1
I $P($G(^PRC(420,PRC("SITE"),1,+X,0)),U,19)=1 W !,"Sorry, this FCP is inactive!",! K X Q
Q
;
EN2 ;UPDATE BOC #3.5
D VEN^PRCHNPO7 Q:'$D(X)!($P(^PRC(442,DA(1),2,DA,0),U,5)="")
S:'$D(PRC("SITE")) PRC("SITE")=$P($P(^PRC(442,DA(1),0),U,1),"-",1)
S PRCHCV=$P(^PRC(442,DA(1),1),U),PRCHCI=$P(^(2,DA,0),U,5)
D EN13^PRCHCRD1
Q
;
BBFY(PO) ;BEGINING BUDGET FISCAL YEAR CHECK/UPDATE
; ENTERED:
; PO = FILE 442 INTERNAL RECORD NUMBER
;
; RETURNED:
; PRC("BBFY") = FOUR DIGIT YEAR (1995)
;
; PO IS UNCHANGED BY THIS CALL
;
N BBFY,N0,N1,FY,P2237,SFCP,DIE,DA,DR,X,FLAG
S N0=$G(^PRC(442,PO,0)),N1=$G(^PRC(442,PO,1))
S FY=$P(N1,U,15),FY=$E(100+$E(FY,2,3)+$E(FY,4),2,3)
S FLAG="",P2237=$P(N0,U,12) I P2237>0 D G:FLAG=1 T1
.S FY=$$NP^PRC0B("^PRCS(410,"_P2237_",",3,11)
.I FY?2N S FY=1700+$E(FY,1,3),PRC("BBFY")=FY,FLAG=1 Q
.S FY=$$NP^PRC0B("^PRCS(410,"_P2237_",",0,1)
.S FY=$P(FY,"-",2)
.Q
S FY=$$BBFY^PRCSUT(+N0,FY,+$P(N0,U,3),1)
T1 S SFCP=$P(N0,U,19) I SFCP=1!(SFCP=2) S (PRC("BBFY"),FY)=1994
I FY?2N S DIE="^PRC(442,",DA=PO,DR="26///^S X=FY" D ^DIE
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCHNPO8 2458 printed Oct 16, 2024@18:09:45 Page 2
PRCHNPO8 ;WISC/RHD/DL-MISCELLANEOUS ROUTINES FROM P.O.ADD/EDIT 443.6 ;9/5/00 12:30
V ;;5.1;IFCAP;**113**;Oct 20, 2000;Build 4
+1 ;Per VHA Directive 2004-038, this routine should not be modified.
+2 ;
EN1 ;FILE 443.6, FCP #1
+1 NEW Y
+2 SET Z0=$EXTRACT($PIECE(^PRC(443.6,DA,0),"-",2),1,2)
SET Z1=+X
DO EN4^PRCHNPO6
IF '$TEST
KILL X,Z0,Z1
QUIT
+3 SET DIC="^PRC(420,PRC(""SITE""),1,"
SET DIC(0)="QEMNZ"
SET D="B^C"
DO MIX^DIC1
if Y<0!('$DATA(PRC("FY")))
KILL X
KILL DIC,Z0,Z1
if '$DATA(X)
QUIT
+4 NEW CCNODE
SET CCNODE=$GET(^PRC(420,PRC("SITE"),1,+Y,2,0))
IF $PIECE(CCNODE,U,4)'>0!(CCNODE="")
WRITE !,"The Fund Control Point selected by you, does not have any",!,"Cost Centers listed under it.",!
KILL X
QUIT
+5 IF $PIECE(Y(0),U,12)'=2
IF $PIECE(Y(0),U,18)=""
WRITE $CHAR(7),!,"LOG Department Number is missing!!"
KILL X
QUIT
+6 SET Z0=$PIECE(^PRC(443.6,DA,0),U,2)
SET Z1=$PIECE(Y(0),U,12)
IF Z1
IF Z0=4!((Z0=3)&(Z1=3))
SET Z0=$PIECE(^PRCD(442.5,Z0,0),U,1)
WRITE $CHAR(7),!,"Fund Control Point not valid for a "_Z0_" order."
KILL Z0,Z1,X
QUIT
+7 SET Z0=$PIECE(Y(0),U,1)
if $PIECE(Y(0),U,10)]""
SET PRCHN("SVC")=$PIECE($GET(^DIC(49,+$PIECE(Y(0),U,10),0)),U,1)
+8 SET PRC("FY")=$EXTRACT(100+$EXTRACT(PRC("FY"),2,3)+$EXTRACT(PRC("FY"),4),2,3)
+9 IF $DATA(^PRC(420,PRC("SITE"),1,+Y,2,0))
IF $PIECE(^(0),U,4)=1
IF $DATA(^($PIECE(^(0),U,3),0))
IF $DATA(^PRCD(420.1,+^(0),0))
SET PRCHN("CC")=$PIECE(^(0)," ",1)
+10 SET PRC("APP")=""
SET X=Z0
SET PRC("BBFY")=$$BBFY^PRCSUT(PRC("SITE"),PRC("FY"),+X)
IF PRC("BBFY")=""
QUIT
+11 SET PRC("APP")=$PIECE($$ACC^PRC0C(PRC("SITE"),+X_"^"_PRC("FY")_"^"_PRC("BBFY")),U,11)
KILL Z0,Z1
+12 IF $PIECE($GET(^PRC(420,PRC("SITE"),1,+X,0)),U,19)=1
WRITE !,"Sorry, this FCP is inactive!",!
KILL X
QUIT
+13 QUIT
+14 ;
EN2 ;UPDATE BOC #3.5
+1 DO VEN^PRCHNPO7
if '$DATA(X)!($PIECE(^PRC(442,DA(1),2,DA,0),U,5)="")
QUIT
+2 if '$DATA(PRC("SITE"))
SET PRC("SITE")=$PIECE($PIECE(^PRC(442,DA(1),0),U,1),"-",1)
+3 SET PRCHCV=$PIECE(^PRC(442,DA(1),1),U)
SET PRCHCI=$PIECE(^(2,DA,0),U,5)
+4 DO EN13^PRCHCRD1
+5 QUIT
+6 ;
BBFY(PO) ;BEGINING BUDGET FISCAL YEAR CHECK/UPDATE
+1 ; ENTERED:
+2 ; PO = FILE 442 INTERNAL RECORD NUMBER
+3 ;
+4 ; RETURNED:
+5 ; PRC("BBFY") = FOUR DIGIT YEAR (1995)
+6 ;
+7 ; PO IS UNCHANGED BY THIS CALL
+8 ;
+9 NEW BBFY,N0,N1,FY,P2237,SFCP,DIE,DA,DR,X,FLAG
+10 SET N0=$GET(^PRC(442,PO,0))
SET N1=$GET(^PRC(442,PO,1))
+11 SET FY=$PIECE(N1,U,15)
SET FY=$EXTRACT(100+$EXTRACT(FY,2,3)+$EXTRACT(FY,4),2,3)
+12 SET FLAG=""
SET P2237=$PIECE(N0,U,12)
IF P2237>0
Begin DoDot:1
+13 SET FY=$$NP^PRC0B("^PRCS(410,"_P2237_",",3,11)
+14 IF FY?2N
SET FY=1700+$EXTRACT(FY,1,3)
SET PRC("BBFY")=FY
SET FLAG=1
QUIT
+15 SET FY=$$NP^PRC0B("^PRCS(410,"_P2237_",",0,1)
+16 SET FY=$PIECE(FY,"-",2)
+17 QUIT
End DoDot:1
if FLAG=1
GOTO T1
+18 SET FY=$$BBFY^PRCSUT(+N0,FY,+$PIECE(N0,U,3),1)
T1 SET SFCP=$PIECE(N0,U,19)
IF SFCP=1!(SFCP=2)
SET (PRC("BBFY"),FY)=1994
+1 IF FY?2N
SET DIE="^PRC(442,"
SET DA=PO
SET DR="26///^S X=FY"
DO ^DIE
+2 QUIT
