- PRCBR ;WISC@ALTOONA/CLH/CTB-ROUTINE TO RELEASE FUND DISTRIBUTION TRANSACTIONS ; 10 Apr 93 3:50 PM
- V ;;5.1;IFCAP;**139**;Oct 20, 2000;Build 16
- ;Per VHA Directive 2004-038, this routine should not be modified.
- N X,DIR,DIC,DR,DIE,DIK,PRC,PRCF,PRCB,PRCFA,%,Y,Z,Z1,Q,J,K,D,Y,FAIL
- S X="BUDGET RELEASE" D ^PRCFALCK I '% G KILL
- S PRCF("X")="ABFS" D ^PRCFSITE G:'% OUT
- S X=$O(^PRCF(421,"AL",PRCF("SIFY"),"")) I X'=0&(X'=1) W !!,$C(7),"There are no PENDING RELEASE transactions for FY: ",PRC("FY") R X:3 G OUT
- S K=0 I '$D(^PRC(420,PRC("SITE"),2,DUZ)) W !,"You are not authorized to release funds for station ",PRC("SITE"),",",!,"PLEASE CONTACT YOUR APPLICATION MANAGER.",$C(7) R X:3 G OUT
- D SIG^PRCFACX0 K PRCFK I $D(PRCFA("SIGFAIL")) K PRCFA("SIGFAIL") G OUT
- N DIR,Y,X
- S PRCB("CK")="" S DIR(0)="YO",DIR("A")="Do you wish to review/edit any transactions",DIR("B")="NO",DIR("?")="Enter yes to review/edit a transaction, '^' to quit" D ^DIR G:Y["^" OUT
- I Y D
- . S DR="[PRCB NEW TRANSACTION]",DIC("A")="Select Sequence Number for "_$S($D(PRCB("MDIV")):"Station "_PRC("SITE")_",",1:"")_" FY "_PRC("FY")_": "
- . S Z="",PRCFLAST=PRCB("LAST") D EN21^PRCBE S PRCB("LAST")=PRCFLAST K PRCFLAST I '$D(PRCF("SIFY")) S PRCF("SIFY")=PRC("SITE")_"-"_PRC("FY")
- ASK R !,"Enter Sequence Number of Transaction(s) to be Released: ",X:DTIME G:X["?" Q1 G:X["^" OUT G:X="ALL" ALL G:X["-" DASH G:X="" UNDO I X'?1.N W $C(7)," ??" G ASK
- S (Z,X1)=X D ZERO S X1=Z I '$D(^PRCF(421,"B",PRCF("SIFY")_"-"_X1)) W $C(7),!," ??" G Q1A
- S DA=$O(^PRCF(421,"B",PRCF("SIFY")_"-"_X1,0)) I $D(^PRCF(421,"AL",PRCF("SIFY"),2,DA)) W $C(7),!," THIS SEQUENCE HAS ALREADY BEEN RELEASED. RERELEASE IS NOT PERMITTED." G Q1A
- I $D(^PRCF(421,"AL",PRCF("SIFY"),1,DA)) W !,$C(7),"THIS TRANSACTION HAS ALREADY BEEN SELECTED FOR RELEASE. NO ACTION TAKEN." H 2 K PRCB("CK") G ASK
- W " OK" K PRCB("CK") D ONE
- G ASK
- UNDO I '$D(^PRCF(421,"AL",PRCF("SIFY"),1)) W !!,$C(7),"No transactions have been selected for releasing for FY: ",PRC("FY") G ASK
- W !!,"To not release a transaction already selected to be released"
- S DIC("A")="Enter the last 5 digits of the transaction for "_$S($D(PRCB("MDIV")):"Station "_PRC("SITE")_",",1:"")_" FY "_PRC("FY")_": "
- 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)",DIC=421,DIC(0)="AEQZ",D="D" D IX^DIC K DIC G:Y<0 DEV S DA=+Y
- D UNREL(DA)
- ;if transfer fund
- I $P(^PRCF(421,DA,0),"^",22) D UNREL($P(^(0),"^",22))
- G UNDO
- ;
- UNREL(DA) I $D(^PRCF(421,"AL",PRCF("SIFY"),1,DA)),'$D(^PRCF(421,"AL",PRCF("SIFY"),2,DA)) S DIE="^PRCF(421,",DR="11.5////^S X=0" D ^DIE K ^PRCF(421,"AL",PRCF("SIFY"),1,DA)
- QUIT
- DEV ;ask device
- G QDEV^PRCBR2
- Q1 F I=1:1 Q:$P($T(X+I),";",3,99)="" W !,$P($T(X+I),";",3,99)
- S DIR(0)="Y",DIR("A")="Do you wish to see the list of all unreleased transactions",DIR("?")="Enter yes to look at list, no or '^' to quit" D ^DIR G:'Y ASK
- Q1A W !!,"Unreleased Sequence Numbers for Station ",PRC("SITE"),", FY: ",PRC("FY"),! F I=0,40 W ?I," SEQ # TRANS # CP# TOTAL"
- W ! S N=0 F I=0:1 S N=$O(^PRCF(421,"AL",PRCF("SIFY"),0,N)) Q:'N D
- . S X1="",X=^PRCF(421,N,0) F J=7:1:10 S X1=X1+$P(X,"^",J)
- . W:'(I#2)*I ! W ?I#2*40,$J(+$P(X,"-",3),4,0)," ",$P(X,"^")," CP-",+$P(X,"^",2)," $",$J(X1,0,2) K X1,X,J
- . Q
- G ASK
- X ;;
- ;;Enter the Sequence Number, or indicate a range of sequence numbers by
- ;;separating the first and last numbers with a dash (-).
- ;;Type "ALL" to release all unreleased transactions.
- ;;
- ALL ;TRANSFER ALL TRANSACTIONS INTO ^TMP
- S DA=0 F I=1:1 S DA=$O(^PRCF(421,"AL",PRCF("SIFY"),0,DA)) Q:DA="" D ONE
- G UNDO
- ONE ;mark release status
- QUIT:$$FCPVAL^PRCBR2(DA)
- D REL(DA)
- ;if transfer fund
- I $P(^PRCF(421,DA,0),"^",22) D REL($P(^(0),"^",22))
- QUIT
- ;
- REL(DA) I '$D(^PRCF(421,"AL",PRCF("SIFY"),1,DA)),'$D(^PRCF(421,"AL",PRCF("SIFY"),2,DA)) S DIE="^PRCF(421,",DR="11.5////^S X=1" D ^DIE K ^PRCF(421,"AL",PRCF("SIFY"),0,DA)
- QUIT
- ;
- DASH ;release all transactions within a range of sequence numbers
- I X'?.N1"-".N W !,"Incorrect format. ",$C(7) G ASK
- S X1=+$P(X,"-",2),X=+$P(X,"-",1) I X'<X1 W !,"Illogical range, the first number is not less than the second.",$C(7),! G ASK
- I X>PRCB("LAST") W !,"First number in range is greater than highest defined sequence number in file, try again.",$C(7),! G ASK
- I X1>PRCB("LAST") S X1=PRCB("LAST") W !,"Second number in range greater than highest defined number, changing to highest number allowed: ",X1,$C(7)
- S PRCB("NUM")=0 S Q=X-1,Q1=X1-1 S Z=Q D ZERO S Q=Z,Z=Q1 D ZERO S Q1=Z,PRCB("LO")=$O(^PRCF(421,"B",PRCF("SIFY")_"-"_Q)) I PRCB("LO")="" W !,"No sequence numbers on file in range, try again.",$C(7),! G ASK
- S PRCB("LO")=$O(^PRCF(421,"B",PRCB("LO"),0)) I PRCB("LO")="" W !,"No sequence numbers in range specified. Please check your numbers and let's try again.",$C(7),! G ASK
- D1 S PRCB("HI")=$O(^PRCF(421,"B",PRCF("SIFY")_"-"_Q1))
- S PRCB("HI")=$O(^PRCF(421,"B",PRCB("HI"),0))
- S DA=PRCB("LO")-.5 F I=0:0 S DA=$O(^PRCF(421,"AL",PRCF("SIFY"),0,DA)) Q:DA=""!(DA>PRCB("HI")) D ONE
- W " DONE" K PRCB("CK") G ASK
- ZERO ;place up to 4 leading zeros onto a number
- S Z="0000"_Z,Z=$E(Z,$L(Z)-4,$L(Z)) Q
- ;
- OUT S X="BUDGET RELEASE" D UNLOCK^PRCFALCK
- KILL K DIRUT,DTOUT,DIROUT,DUOUT Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCBR 5298 printed Feb 18, 2025@23:27:10 Page 2
- PRCBR ;WISC@ALTOONA/CLH/CTB-ROUTINE TO RELEASE FUND DISTRIBUTION TRANSACTIONS ; 10 Apr 93 3:50 PM
- V ;;5.1;IFCAP;**139**;Oct 20, 2000;Build 16
- +1 ;Per VHA Directive 2004-038, this routine should not be modified.
- +2 NEW X,DIR,DIC,DR,DIE,DIK,PRC,PRCF,PRCB,PRCFA,%,Y,Z,Z1,Q,J,K,D,Y,FAIL
- +3 SET X="BUDGET RELEASE"
- DO ^PRCFALCK
- IF '%
- GOTO KILL
- +4 SET PRCF("X")="ABFS"
- DO ^PRCFSITE
- if '%
- GOTO OUT
- +5 SET X=$ORDER(^PRCF(421,"AL",PRCF("SIFY"),""))
- IF X'=0&(X'=1)
- WRITE !!,$CHAR(7),"There are no PENDING RELEASE transactions for FY: ",PRC("FY")
- READ X:3
- GOTO OUT
- +6 SET K=0
- IF '$DATA(^PRC(420,PRC("SITE"),2,DUZ))
- WRITE !,"You are not authorized to release funds for station ",PRC("SITE"),",",!,"PLEASE CONTACT YOUR APPLICATION MANAGER.",$CHAR(7)
- READ X:3
- GOTO OUT
- +7 DO SIG^PRCFACX0
- KILL PRCFK
- IF $DATA(PRCFA("SIGFAIL"))
- KILL PRCFA("SIGFAIL")
- GOTO OUT
- +8 NEW DIR,Y,X
- +9 SET PRCB("CK")=""
- SET DIR(0)="YO"
- SET DIR("A")="Do you wish to review/edit any transactions"
- SET DIR("B")="NO"
- SET DIR("?")="Enter yes to review/edit a transaction, '^' to quit"
- DO ^DIR
- if Y["^"
- GOTO OUT
- +10 IF Y
- Begin DoDot:1
- +11 SET DR="[PRCB NEW TRANSACTION]"
- SET DIC("A")="Select Sequence Number for "_$SELECT($DATA(PRCB("MDIV")):"Station "_PRC("SITE")_",",1:"")_" FY "_PRC("FY")_": "
- +12 SET Z=""
- SET PRCFLAST=PRCB("LAST")
- DO EN21^PRCBE
- SET PRCB("LAST")=PRCFLAST
- KILL PRCFLAST
- IF '$DATA(PRCF("SIFY"))
- SET PRCF("SIFY")=PRC("SITE")_"-"_PRC("FY")
- End DoDot:1
- ASK READ !,"Enter Sequence Number of Transaction(s) to be Released: ",X:DTIME
- if X["?"
- GOTO Q1
- if X["^"
- GOTO OUT
- if X="ALL"
- GOTO ALL
- if X["-"
- GOTO DASH
- if X=""
- GOTO UNDO
- IF X'?1.N
- WRITE $CHAR(7)," ??"
- GOTO ASK
- +1 SET (Z,X1)=X
- DO ZERO
- SET X1=Z
- IF '$DATA(^PRCF(421,"B",PRCF("SIFY")_"-"_X1))
- WRITE $CHAR(7),!," ??"
- GOTO Q1A
- +2 SET DA=$ORDER(^PRCF(421,"B",PRCF("SIFY")_"-"_X1,0))
- IF $DATA(^PRCF(421,"AL",PRCF("SIFY"),2,DA))
- WRITE $CHAR(7),!," THIS SEQUENCE HAS ALREADY BEEN RELEASED. RERELEASE IS NOT PERMITTED."
- GOTO Q1A
- +3 IF $DATA(^PRCF(421,"AL",PRCF("SIFY"),1,DA))
- WRITE !,$CHAR(7),"THIS TRANSACTION HAS ALREADY BEEN SELECTED FOR RELEASE. NO ACTION TAKEN."
- HANG 2
- KILL PRCB("CK")
- GOTO ASK
- +4 WRITE " OK"
- KILL PRCB("CK")
- DO ONE
- +5 GOTO ASK
- UNDO IF '$DATA(^PRCF(421,"AL",PRCF("SIFY"),1))
- WRITE !!,$CHAR(7),"No transactions have been selected for releasing for FY: ",PRC("FY")
- GOTO ASK
- +1 WRITE !!,"To not release a transaction already selected to be released"
- +2 SET DIC("A")="Enter the last 5 digits of the transaction for "_$SELECT($DATA(PRCB("MDIV")):"Station "_PRC("SITE")_",",1:"")_" FY "_PRC("FY")_": "
- +3 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)"
- SET DIC=421
- SET DIC(0)="AEQZ"
- SET D="D"
- DO IX^DIC
- KILL DIC
- if Y<0
- GOTO DEV
- SET DA=+Y
- +4 DO UNREL(DA)
- +5 ;if transfer fund
- +6 IF $PIECE(^PRCF(421,DA,0),"^",22)
- DO UNREL($PIECE(^(0),"^",22))
- +7 GOTO UNDO
- +8 ;
- UNREL(DA) IF $DATA(^PRCF(421,"AL",PRCF("SIFY"),1,DA))
- IF '$DATA(^PRCF(421,"AL",PRCF("SIFY"),2,DA))
- SET DIE="^PRCF(421,"
- SET DR="11.5////^S X=0"
- DO ^DIE
- KILL ^PRCF(421,"AL",PRCF("SIFY"),1,DA)
- +1 QUIT
- DEV ;ask device
- +1 GOTO QDEV^PRCBR2
- Q1 FOR I=1:1
- if $PIECE($TEXT(X+I),";",3,99)=""
- QUIT
- WRITE !,$PIECE($TEXT(X+I),";",3,99)
- +1 SET DIR(0)="Y"
- SET DIR("A")="Do you wish to see the list of all unreleased transactions"
- SET DIR("?")="Enter yes to look at list, no or '^' to quit"
- DO ^DIR
- if 'Y
- GOTO ASK
- Q1A WRITE !!,"Unreleased Sequence Numbers for Station ",PRC("SITE"),", FY: ",PRC("FY"),!
- FOR I=0,40
- WRITE ?I," SEQ # TRANS # CP# TOTAL"
- +1 WRITE !
- SET N=0
- FOR I=0:1
- SET N=$ORDER(^PRCF(421,"AL",PRCF("SIFY"),0,N))
- if 'N
- QUIT
- Begin DoDot:1
- +2 SET X1=""
- SET X=^PRCF(421,N,0)
- FOR J=7:1:10
- SET X1=X1+$PIECE(X,"^",J)
- +3 if '(I#2)*I
- WRITE !
- WRITE ?I#2*40,$JUSTIFY(+$PIECE(X,"-",3),4,0)," ",$PIECE(X,"^")," CP-",+$PIECE(X,"^",2)," $",$JUSTIFY(X1,0,2)
- KILL X1,X,J
- +4 QUIT
- End DoDot:1
- +5 GOTO ASK
- X ;;
- +1 ;;Enter the Sequence Number, or indicate a range of sequence numbers by
- +2 ;;separating the first and last numbers with a dash (-).
- +3 ;;Type "ALL" to release all unreleased transactions.
- +4 ;;
- ALL ;TRANSFER ALL TRANSACTIONS INTO ^TMP
- +1 SET DA=0
- FOR I=1:1
- SET DA=$ORDER(^PRCF(421,"AL",PRCF("SIFY"),0,DA))
- if DA=""
- QUIT
- DO ONE
- +2 GOTO UNDO
- ONE ;mark release status
- +1 if $$FCPVAL^PRCBR2(DA)
- QUIT
- +2 DO REL(DA)
- +3 ;if transfer fund
- +4 IF $PIECE(^PRCF(421,DA,0),"^",22)
- DO REL($PIECE(^(0),"^",22))
- +5 QUIT
- +6 ;
- REL(DA) IF '$DATA(^PRCF(421,"AL",PRCF("SIFY"),1,DA))
- IF '$DATA(^PRCF(421,"AL",PRCF("SIFY"),2,DA))
- SET DIE="^PRCF(421,"
- SET DR="11.5////^S X=1"
- DO ^DIE
- KILL ^PRCF(421,"AL",PRCF("SIFY"),0,DA)
- +1 QUIT
- +2 ;
- DASH ;release all transactions within a range of sequence numbers
- +1 IF X'?.N1"-".N
- WRITE !,"Incorrect format. ",$CHAR(7)
- GOTO ASK
- +2 SET X1=+$PIECE(X,"-",2)
- SET X=+$PIECE(X,"-",1)
- IF X'<X1
- WRITE !,"Illogical range, the first number is not less than the second.",$CHAR(7),!
- GOTO ASK
- +3 IF X>PRCB("LAST")
- WRITE !,"First number in range is greater than highest defined sequence number in file, try again.",$CHAR(7),!
- GOTO ASK
- +4 IF X1>PRCB("LAST")
- SET X1=PRCB("LAST")
- WRITE !,"Second number in range greater than highest defined number, changing to highest number allowed: ",X1,$CHAR(7)
- +5 SET PRCB("NUM")=0
- SET Q=X-1
- SET Q1=X1-1
- SET Z=Q
- DO ZERO
- SET Q=Z
- SET Z=Q1
- DO ZERO
- SET Q1=Z
- SET PRCB("LO")=$ORDER(^PRCF(421,"B",PRCF("SIFY")_"-"_Q))
- IF PRCB("LO")=""
- WRITE !,"No sequence numbers on file in range, try again.",$CHAR(7),!
- GOTO ASK
- +6 SET PRCB("LO")=$ORDER(^PRCF(421,"B",PRCB("LO"),0))
- IF PRCB("LO")=""
- WRITE !,"No sequence numbers in range specified. Please check your numbers and let's try again.",$CHAR(7),!
- GOTO ASK
- D1 SET PRCB("HI")=$ORDER(^PRCF(421,"B",PRCF("SIFY")_"-"_Q1))
- +1 SET PRCB("HI")=$ORDER(^PRCF(421,"B",PRCB("HI"),0))
- +2 SET DA=PRCB("LO")-.5
- FOR I=0:0
- SET DA=$ORDER(^PRCF(421,"AL",PRCF("SIFY"),0,DA))
- if DA=""!(DA>PRCB("HI"))
- QUIT
- DO ONE
- +3 WRITE " DONE"
- KILL PRCB("CK")
- GOTO ASK
- ZERO ;place up to 4 leading zeros onto a number
- +1 SET Z="0000"_Z
- SET Z=$EXTRACT(Z,$LENGTH(Z)-4,$LENGTH(Z))
- QUIT
- +2 ;
- OUT SET X="BUDGET RELEASE"
- DO UNLOCK^PRCFALCK
- KILL KILL DIRUT,DTOUT,DIROUT,DUOUT
- QUIT
