PRCBE ;WISC@ALTOONA/CTB-EDIT ROUTINE FOR BUDGET MODULE OF ADMIN ACTIVITIES PACKAGE ; 04/07/94 1:43 PM
V ;;5.1;IFCAP;**139,196**;Oct 20, 2000;Build 15
;Per VA Directive 6402, this routine should not be modified.
;
;PRC*5.1*196 If the 'AD' x-ref for file 421, site-fy has no
; entries, find the last sequence number used and
; apply reverse entry to 'AD' x-ref site-fy,entry
;
W "ROUTINE CAN ONLY BE ENTERED THROUGH MENU MANAGER OR DRIVER",$C(7),!! Q
SEQNUM S:'$D(PRCF("SIFY")) PRCF("SIFY")=PRC("SITE")_"-"_PRC("FY") S X=$O(^PRCF(421,"AD",PRCF("SIFY"),0)) I X="" D WAIT^PRCFYN,ENIT G SEQNUM
E K ^PRCF(421,"AD",PRCF("SIFY"),X+30) S X=100000-X+1
S X="00000"_X,X=$E(X,$L(X)-4,$L(X)) S PRCB("TRANS")=PRC("SITE")_"-"_PRC("FY")_"-"_X,X=PRCB("TRANS")
Q
EN1 ;ENTER NEW TRANSACTION
S PRCF("X")="ABFS" D ^PRCFSITE G:'% OUT
SEQ D SEQNUM G:X="" OUT
W ! S %A="I am going to create a new transaction with the number "_X,%A(1)="IS THIS OK ",%B="",%=1 D ^PRCFYN I %'=1 W !!,"Transaction number ",X," has been deleted",$C(7) R X:2 G OUT
K DIC("A") S DIC=421,DIC(0)="LZ",DLAYGO=421 D ^DIC I $P(Y,"^",3)="" W !,X," has just been taken by someone else, please hold on while I get another one." G SEQ
G:+Y<0 OUT S DIE=DIC,DA=+Y,DR="[PRCB NEW TRANSACTION]" D ^DIE I $D(Y)=0,$P(^PRCF(421,DA,0),"^",2)]"",$P($G(^(0)),U,23) G EN1
I $P(^PRCF(421,DA,0),"^",2)="" W !,$C(7),"Control Point missing."
KILL W $C(7),!!,"Transaction terminated! ",!,"Transaction # ",PRCB("TRANS")," is being deleted." S DIK="^PRCF(421," D ^DIK
OUT K A,B,D,D0,DA,DIC,DIE,DIK,DLAYGO,DQ,DR,DWDL,J,PRCF,PRCB,X,Y Q
;
;
EN2 ;EDIT EXISTING, UNRELEASED TRANSACTION
S PRCF("X")="ABFS" D ^PRCFSITE Q:'%
S DR="[PRCB NEW TRANSACTION]",DIC("A")="Select Sequence Number for "_$S($D(PRCB("MDIV")):"Station "_PRC("SITE")_",",1:"")_" FY "_PRC("FY")_": "
D EN21 K %,PRCFEN,A,B,DA,DIC,DIE,DR,I,J,K,X,Y,PRCF,PRCB Q
EN21 W ! S DIC("S")="S ZX=^(0) I $P(ZX,U)[PRCF(""SIFY"")&($P(ZX,U,11)="""")&($P(ZX,U)'[""00000"")&(+$P(ZX,U,20)<1)&'$P(ZX,U,22)"
S DIC=421,DIC(0)="AEQZ",D="D" D IX^DIC K DIC Q:Y<0 S DA=+Y,DIE="^PRCF(421,"
D ^DIE S DIC("A")="Select Next Sequence Number for "_$S($D(PRCB("MDIV")):"Station "_PRC("SITE")_",",1:"")_" FY "_PRC("FY")_": "
G EN21
Q
;
EN3 ;DELETE AN UNRELEASED TRANSACTION
S PRCF("X")="ABFS" D ^PRCFSITE Q:'%
S DIC("A")="Select Sequence Number for "_$S($D(PRCB("MDIV")):"Station "_PRC("SITE")_",",1:"")_" FY "_PRC("FY")_": "
D EN31 K A,B,DA,DIC,DIK,DR,I,PRCB,X,Y,PRCF Q
EN31 W ! S DIC("S")="S ZX=^(0) I $P(ZX,U)[PRCF(""SIFY""),$P(ZX,U,11)="""",$P(ZX,U)'[""00000"",+$P(ZX,U,20)=0",DIC=421,DIC(0)="AEQZ",D="D" D IX^DIC K DIC,ZX Q:Y<0 S DA=+Y,DIK="^PRCF(421,"
S %A="ARE YOU SURE YOU WANT TO DELETE THIS TRANSACTION",%B="Enter 'YES' to delete.",%=2 D ^PRCFYN I %'=1 W " <NOTHING DELETED>",$C(7)
E S PRCB("TODA")=$P(^PRCF(421,DA,0),"^",22) D ^DIK S DA=PRCB("TODA") D:DA ^DIK S X=" Transaction Deleted.*" D MSG^PRCFQ
S %A="Do you wish to delete another transaction for "_PRCF("SIFY"),%B="" D ^PRCFYN Q:%'=1
S DIC("A")="Select Sequence Number for "_$S($D(PRCB("MDIV")):"Station "_PRC("SITE")_",",1:"")_" FY "_PRC("FY")_": "
G EN31
;
NA W !!,$C(7),"THIS OPTION IS UNDER DEVELOPMENT AND NOT YET AVAILABLE",!! H 2 Q
ERR S ^PRC(420,PRC("SITE"),1,9999,0)="9999 GRAND TOTAL",^PRC(420,PRC("SITE"),1,"B","9999 GRAND TOTAL",9999)="",^PRC(420,PRC("SITE"),1,"C","GRAND TOTAL",9999)="" Q
;W !,$C(7),"Control Point '9999 GRAND TOTAL' does not exist for station ",PRC("SITE"),!,"Check documentation and use the 'ADD/EDIT FUND CONTROL POINT' to establish. ",!," Further processing is terminated." R X:3 S %X=9999 Q
ENIT I '$D(^PRC(420,PRC("SITE"),1,9999)) D ERR
S X="00000",PRCB("TRANS")=PRC("SITE")_"-"_PRC("FY")_"-"_X,X=PRCB("TRANS") ;PRC*5.1*196
I $D(^PRCF(421,"B",X)) G ENIT1 ;PRC*5.1*196
K DIC("A") S DIC=421,DIC(0)="NL",DLAYGO=421 D ^DIC S DIE=DIC,DR="1////9999 GRAND TOTAL",DA=+Y ;PRC*5.1*196
D ^DIE S $P(^PRCF(421,DA,0),U,11)=.5
S X=$P(^PRCF(421,DA,0),"^",16) K:X]"" ^PRCF(421,"AG",X,DA) K X S $P(^PRCF(421,DA,0),"^",16)="",$P(^(0),"^",20)=2,^(4)="1^1^1^1",^PRCF(421,"AL",PRCF("SIFY"),2,DA)="" K ^PRCF(421,"AL",PRCF("SIFY"),0,DA) Q
ENIT1 ;SET LAST USED SITE-FY REVERSE TXIN 'AD' ;PRC*5.1*196
N PRCBA,PRCBB,PRCBX
S PRCBA=PRCF("SIFY"),PRCBB=100000,PRCBX=PRCBA
F I=1:1 S PRCBA=$O(^PRCF(421,"B",PRCBA)) Q:PRCBA=""!($P(PRCBA,"-",1,2)'=PRCBX) S PRCBB=+$P(PRCBA,"-",3)
S:PRCBB'=100000 PRCBB=100000-PRCBB
S ^PRCF(421,"AD",PRCBX,PRCBB)=""
Q
DOLLAR I $D(IOST),"C-PK-"[$E(IOST,1,2) S:X["$" X=$P(X,"$",2) W " $ ",$J(X,0,2)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCBE 4616 printed Dec 13, 2024@02:00:38 Page 2
PRCBE ;WISC@ALTOONA/CTB-EDIT ROUTINE FOR BUDGET MODULE OF ADMIN ACTIVITIES PACKAGE ; 04/07/94 1:43 PM
V ;;5.1;IFCAP;**139,196**;Oct 20, 2000;Build 15
+1 ;Per VA Directive 6402, this routine should not be modified.
+2 ;
+3 ;PRC*5.1*196 If the 'AD' x-ref for file 421, site-fy has no
+4 ; entries, find the last sequence number used and
+5 ; apply reverse entry to 'AD' x-ref site-fy,entry
+6 ;
+7 WRITE "ROUTINE CAN ONLY BE ENTERED THROUGH MENU MANAGER OR DRIVER",$CHAR(7),!!
QUIT
SEQNUM if '$DATA(PRCF("SIFY"))
SET PRCF("SIFY")=PRC("SITE")_"-"_PRC("FY")
SET X=$ORDER(^PRCF(421,"AD",PRCF("SIFY"),0))
IF X=""
DO WAIT^PRCFYN
DO ENIT
GOTO SEQNUM
+1 IF '$TEST
KILL ^PRCF(421,"AD",PRCF("SIFY"),X+30)
SET X=100000-X+1
+2 SET X="00000"_X
SET X=$EXTRACT(X,$LENGTH(X)-4,$LENGTH(X))
SET PRCB("TRANS")=PRC("SITE")_"-"_PRC("FY")_"-"_X
SET X=PRCB("TRANS")
+3 QUIT
EN1 ;ENTER NEW TRANSACTION
+1 SET PRCF("X")="ABFS"
DO ^PRCFSITE
if '%
GOTO OUT
SEQ DO SEQNUM
if X=""
GOTO OUT
+1 WRITE !
SET %A="I am going to create a new transaction with the number "_X
SET %A(1)="IS THIS OK "
SET %B=""
SET %=1
DO ^PRCFYN
IF %'=1
WRITE !!,"Transaction number ",X," has been deleted",$CHAR(7)
READ X:2
GOTO OUT
+2 KILL DIC("A")
SET DIC=421
SET DIC(0)="LZ"
SET DLAYGO=421
DO ^DIC
IF $PIECE(Y,"^",3)=""
WRITE !,X," has just been taken by someone else, please hold on while I get another one."
GOTO SEQ
+3 if +Y<0
GOTO OUT
SET DIE=DIC
SET DA=+Y
SET DR="[PRCB NEW TRANSACTION]"
DO ^DIE
IF $DATA(Y)=0
IF $PIECE(^PRCF(421,DA,0),"^",2)]""
IF $PIECE($GET(^(0)),U,23)
GOTO EN1
+4 IF $PIECE(^PRCF(421,DA,0),"^",2)=""
WRITE !,$CHAR(7),"Control Point missing."
KILL WRITE $CHAR(7),!!,"Transaction terminated! ",!,"Transaction # ",PRCB("TRANS")," is being deleted."
SET DIK="^PRCF(421,"
DO ^DIK
OUT KILL A,B,D,D0,DA,DIC,DIE,DIK,DLAYGO,DQ,DR,DWDL,J,PRCF,PRCB,X,Y
QUIT
+1 ;
+2 ;
EN2 ;EDIT EXISTING, UNRELEASED TRANSACTION
+1 SET PRCF("X")="ABFS"
DO ^PRCFSITE
if '%
QUIT
+2 SET DR="[PRCB NEW TRANSACTION]"
SET DIC("A")="Select Sequence Number for "_$SELECT($DATA(PRCB("MDIV")):"Station "_PRC("SITE")_",",1:"")_" FY "_PRC("FY")_": "
+3 DO EN21
KILL %,PRCFEN,A,B,DA,DIC,DIE,DR,I,J,K,X,Y,PRCF,PRCB
QUIT
EN21 WRITE !
SET DIC("S")="S ZX=^(0) I $P(ZX,U)[PRCF(""SIFY"")&($P(ZX,U,11)="""")&($P(ZX,U)'[""00000"")&(+$P(ZX,U,20)<1)&'$P(ZX,U,22)"
+1 SET DIC=421
SET DIC(0)="AEQZ"
SET D="D"
DO IX^DIC
KILL DIC
if Y<0
QUIT
SET DA=+Y
SET DIE="^PRCF(421,"
+2 DO ^DIE
SET DIC("A")="Select Next Sequence Number for "_$SELECT($DATA(PRCB("MDIV")):"Station "_PRC("SITE")_",",1:"")_" FY "_PRC("FY")_": "
+3 GOTO EN21
+4 QUIT
+5 ;
EN3 ;DELETE AN UNRELEASED TRANSACTION
+1 SET PRCF("X")="ABFS"
DO ^PRCFSITE
if '%
QUIT
+2 SET DIC("A")="Select Sequence Number for "_$SELECT($DATA(PRCB("MDIV")):"Station "_PRC("SITE")_",",1:"")_" FY "_PRC("FY")_": "
+3 DO EN31
KILL A,B,DA,DIC,DIK,DR,I,PRCB,X,Y,PRCF
QUIT
EN31 WRITE !
SET DIC("S")="S ZX=^(0) I $P(ZX,U)[PRCF(""SIFY""),$P(ZX,U,11)="""",$P(ZX,U)'[""00000"",+$P(ZX,U,20)=0"
SET DIC=421
SET DIC(0)="AEQZ"
SET D="D"
DO IX^DIC
KILL DIC,ZX
if Y<0
QUIT
SET DA=+Y
SET DIK="^PRCF(421,"
+1 SET %A="ARE YOU SURE YOU WANT TO DELETE THIS TRANSACTION"
SET %B="Enter 'YES' to delete."
SET %=2
DO ^PRCFYN
IF %'=1
WRITE " <NOTHING DELETED>",$CHAR(7)
+2 IF '$TEST
SET PRCB("TODA")=$PIECE(^PRCF(421,DA,0),"^",22)
DO ^DIK
SET DA=PRCB("TODA")
if DA
DO ^DIK
SET X=" Transaction Deleted.*"
DO MSG^PRCFQ
+3 SET %A="Do you wish to delete another transaction for "_PRCF("SIFY")
SET %B=""
DO ^PRCFYN
if %'=1
QUIT
+4 SET DIC("A")="Select Sequence Number for "_$SELECT($DATA(PRCB("MDIV")):"Station "_PRC("SITE")_",",1:"")_" FY "_PRC("FY")_": "
+5 GOTO EN31
+6 ;
NA WRITE !!,$CHAR(7),"THIS OPTION IS UNDER DEVELOPMENT AND NOT YET AVAILABLE",!!
HANG 2
QUIT
ERR SET ^PRC(420,PRC("SITE"),1,9999,0)="9999 GRAND TOTAL"
SET ^PRC(420,PRC("SITE"),1,"B","9999 GRAND TOTAL",9999)=""
SET ^PRC(420,PRC("SITE"),1,"C","GRAND TOTAL",9999)=""
QUIT
+1 ;W !,$C(7),"Control Point '9999 GRAND TOTAL' does not exist for station ",PRC("SITE"),!,"Check documentation and use the 'ADD/EDIT FUND CONTROL POINT' to establish. ",!," Further processing is terminated." R X:3 S %X=9999 Q
ENIT IF '$DATA(^PRC(420,PRC("SITE"),1,9999))
DO ERR
+1 ;PRC*5.1*196
SET X="00000"
SET PRCB("TRANS")=PRC("SITE")_"-"_PRC("FY")_"-"_X
SET X=PRCB("TRANS")
+2 ;PRC*5.1*196
IF $DATA(^PRCF(421,"B",X))
GOTO ENIT1
+3 ;PRC*5.1*196
KILL DIC("A")
SET DIC=421
SET DIC(0)="NL"
SET DLAYGO=421
DO ^DIC
SET DIE=DIC
SET DR="1////9999 GRAND TOTAL"
SET DA=+Y
+4 DO ^DIE
SET $PIECE(^PRCF(421,DA,0),U,11)=.5
+5 SET X=$PIECE(^PRCF(421,DA,0),"^",16)
if X]""
KILL ^PRCF(421,"AG",X,DA)
KILL X
SET $PIECE(^PRCF(421,DA,0),"^",16)=""
SET $PIECE(^(0),"^",20)=2
SET ^(4)="1^1^1^1"
SET ^PRCF(421,"AL",PRCF("SIFY"),2,DA)=""
KILL ^PRCF(421,"AL",PRCF("SIFY"),0,DA)
QUIT
ENIT1 ;SET LAST USED SITE-FY REVERSE TXIN 'AD' ;PRC*5.1*196
+1 NEW PRCBA,PRCBB,PRCBX
+2 SET PRCBA=PRCF("SIFY")
SET PRCBB=100000
SET PRCBX=PRCBA
+3 FOR I=1:1
SET PRCBA=$ORDER(^PRCF(421,"B",PRCBA))
if PRCBA=""!($PIECE(PRCBA,"-",1,2)'=PRCBX)
QUIT
SET PRCBB=+$PIECE(PRCBA,"-",3)
+4 if PRCBB'=100000
SET PRCBB=100000-PRCBB
+5 SET ^PRCF(421,"AD",PRCBX,PRCBB)=""
+6 QUIT
DOLLAR IF $DATA(IOST)
IF "C-PK-"[$EXTRACT(IOST,1,2)
if X["$"
SET X=$PIECE(X,"$",2)
WRITE " $ ",$JUSTIFY(X,0,2)
+1 QUIT
