- 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 Feb 18, 2025@23:35:23 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