PRCFAC01 ;WISC@ALTOONA/CTB-CONTINUATION OF OBLIGATION PROCESSING ;7/21/93 13:51
V ;;5.1;IFCAP;;Oct 20, 2000
;Per VHA Directive 10-93-142, this routine should not be modified.
;DISPLAY CONTROL POINT OFFICIALS BALANCES
W !!,"Net Cost of Order: ",?30,"$",$J($P(PO(0),U,16),10,2) D CPBAL I $D(PRCF("NOBAL")) K PRCF("NOBAL") G V1
V1 I $P(PRC("PARAM"),"^",17)="Y" W !!?15,"Fiscal Status of Funds for Control Point" W !,"Status of Funds Balance: ",?30,"$",$J($P(^PRC(420,PRC("SITE"),1,+$P(PO(0),U,3),0),U,7),10,2),!,"Estimated Balance:",?30,"$",$J($P(^(0),U,8),10,2)
W ! S %A="OK to Continue" S %=1,%B="" D ^PRCFYN I %'=1 D MSG G OUT3
;IF CP IS GENERAL POST FUND OR SUPPLY FUND, NO CODE SHEET IS GENERATED
G:+$P(PCP,"^",2)>0 NC
S P("DELDATE")=$P(PO(0),U,10),P("PODATE")=DT,PRCFA("SYS")="",PRCFA("REF")=$P($P(PO(0),"-",2),"^") I $P(^PRC(442,PRCFA("PODA"),1),"^",15)'="" S P("PODATE")=$P(^(1),"^",15)
S Y=P("PODATE") D D^PRCFQ S %DT="AEX",%DT("A")="Select Obligation Processing Date: ",%DT("B")=Y
W ! D ^%DT I Y<0 D MSG G OUT3
S PDATE=Y
S PRCFA("TTDATE")=$E(PDATE,4,7)_$E(PDATE,2,3),PRCFA("TT")="921.00" K PDATE D TT^PRCFAC I '% D MSG G OUT3
D NEWCS^PRCFAC I '$D(DA) D MSG G OUT3
S PRC("CP")=+$P(PO(0),"^",3) D ^PRCFALD
S PRCFA("SC")="" Q:'$D(^PRC(442,+PO,1)) S PRCFA("SC")=$S($D(^PRC(440,$P(^PRC(442,+PO,1),U,1),2)):$P(^(2),U,4),1:"")
I PRCFA("SC")="",$P(^PRC(442,PRCFA("PODA"),1),"^",7)'="" S PRCFA("SC")=$P(^PRCD(420.8,$P(^PRC(442,PRCFA("PODA"),1),"^",7),0),"^",3)
S X1=$P(PO(0),U,5),X=$S(X1="":"",$L(X1)>4:X1,1:X1_"00") K X1
S ^PRCF(423,DA,1)=PRCFA("YALD")_U_$E(P("DELDATE"),4,5)_U_PRCFA("SC")_U_$E(P("DELDATE"),4,7)_$E(P("DELDATE"),2,3)_U_$P($P(PO(0),U,3)," ",1)_U_X_U_U_$P(PO(0),U,6)_U_($P(PO(0),U,7)*100)
S $P(^PRCF(423,DA,1),"^",10)=$S(+$P(PO(0),U,8)>0:$P(PO(0),U,8),1:"$"),$P(^(1),U,11)=$S(+$P(PO(0),U,9)>0:$P(PO(0),U,9)*100,1:""),$P(^(1),"^",16)="$",$P(^("TRANS"),"^")=""
I PRCFA("EDIT")["921.00" D ^PRCFA921 G XM
S PRCFA("EDIT")=$P(^PRCD(420.4,PRCFA("TTDA"),0),U,3),Y(0)=^(0),^PRCF(423,DA,0)=$P(^PRCF(423,DA,0),U,1,2)_U_$P(Y(0),U,3)_U_$P(Y(0),U,1)_U_$P(^(0),U,5,99) K Y
S DIE="^PRCF(423,",DR=PRCFA("EDIT"),PRCFA("CSDA")=DA D ^DIE I $D(Y)'=0 D WAIT^PRCFYN,DEL,OUT3 G ^PRCFAC0
XM D ^PRCFACXM I $D(PRCFDEL)!$D(PRCFA("CSHOLD")) K PRCFDEL,PRCFA("CSHOLD") D MSG G ^PRCFAC0
S PRCOPODA=PRCFA("PODA") D WAIT^DICD,NEW^PRCOEDI
K PRCOPODA,IO("Q")
NC I $D(PRCFA("PODA")) D ^PRCFAC02
D OUT3 G ^PRCFAC0
OUT3 K %,AMT,C1,C,CSDA,D0,DA,DI,DIC,DEL,E,I,J,K,N1,N2,PCP,PO,PODA,PRCFA,PRCQ,PTYPE,T,T1,TIME,TRDA,Y,Z,Z5,ZX Q
MSG S X=" No Further Processing is being taken on this obligation.*" D MSG^PRCFQ Q
Q
SA ;LOOKUP FOR INVALID BOC
S %A="Invalid BOC number, OK to use anyway",%B="Answer 'NO' if you do yot wish to use this BOC."
S %=2 D ^PRCFYN I %'=1 K X Q
S X=ZC K ZC Q
DEL ;KILL THE CODE SHEET AND CROSS REFERENCES
D DEL^PRCFACXM Q
OUT W !,"No data posted to Control Point Files",$C(7) R X:3 Q
Q
CPBAL S:'$D(PQT) PQT=PRC("QTR") S X=$G(^PRC(420,PRC("SITE"),1,+PCP,4,PRC("FY"),0))
I X="" S X="No Control Point balances available at this time.*" D MSG^PRCFQ S PRCF("NOBAL")="" Q
S PRCS("C")=$P(X,"^",PQT+1),PRCS("O")=$P(X,"^",PQT+5)
W !!?15,"CPA Balances",!,"Uncommitted Balance: ",?30,"$"_$J(PRCS("C"),10,2),!,"Unobligated Balance: ",?30,"$"_$J(PRCS("O"),10,2) W !,"Committed, Not Obligated: ",?30,"$"_$J((PRCS("O")-PRCS("C")),10,2) K PRCS
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCFAC01 3405 printed Oct 16, 2024@18:02:34 Page 2
PRCFAC01 ;WISC@ALTOONA/CTB-CONTINUATION OF OBLIGATION PROCESSING ;7/21/93 13:51
V ;;5.1;IFCAP;;Oct 20, 2000
+1 ;Per VHA Directive 10-93-142, this routine should not be modified.
+2 ;DISPLAY CONTROL POINT OFFICIALS BALANCES
+3 WRITE !!,"Net Cost of Order: ",?30,"$",$JUSTIFY($PIECE(PO(0),U,16),10,2)
DO CPBAL
IF $DATA(PRCF("NOBAL"))
KILL PRCF("NOBAL")
GOTO V1
V1 IF $PIECE(PRC("PARAM"),"^",17)="Y"
WRITE !!?15,"Fiscal Status of Funds for Control Point"
WRITE !,"Status of Funds Balance: ",?30,"$",$JUSTIFY($PIECE(^PRC(420,PRC("SITE"),1,+$PIECE(PO(0),U,3),0),U,7),10,2),!,"Estimated Balance:",?30,"$",$JUSTIFY($PIECE(^(0),U,8),10,2)
+1 WRITE !
SET %A="OK to Continue"
SET %=1
SET %B=""
DO ^PRCFYN
IF %'=1
DO MSG
GOTO OUT3
+2 ;IF CP IS GENERAL POST FUND OR SUPPLY FUND, NO CODE SHEET IS GENERATED
+3 if +$PIECE(PCP,"^",2)>0
GOTO NC
+4 SET P("DELDATE")=$PIECE(PO(0),U,10)
SET P("PODATE")=DT
SET PRCFA("SYS")=""
SET PRCFA("REF")=$PIECE($PIECE(PO(0),"-",2),"^")
IF $PIECE(^PRC(442,PRCFA("PODA"),1),"^",15)'=""
SET P("PODATE")=$PIECE(^(1),"^",15)
+5 SET Y=P("PODATE")
DO D^PRCFQ
SET %DT="AEX"
SET %DT("A")="Select Obligation Processing Date: "
SET %DT("B")=Y
+6 WRITE !
DO ^%DT
IF Y<0
DO MSG
GOTO OUT3
+7 SET PDATE=Y
+8 SET PRCFA("TTDATE")=$EXTRACT(PDATE,4,7)_$EXTRACT(PDATE,2,3)
SET PRCFA("TT")="921.00"
KILL PDATE
DO TT^PRCFAC
IF '%
DO MSG
GOTO OUT3
+9 DO NEWCS^PRCFAC
IF '$DATA(DA)
DO MSG
GOTO OUT3
+10 SET PRC("CP")=+$PIECE(PO(0),"^",3)
DO ^PRCFALD
+11 SET PRCFA("SC")=""
if '$DATA(^PRC(442,+PO,1))
QUIT
SET PRCFA("SC")=$SELECT($DATA(^PRC(440,$PIECE(^PRC(442,+PO,1),U,1),2)):$PIECE(^(2),U,4),1:"")
+12 IF PRCFA("SC")=""
IF $PIECE(^PRC(442,PRCFA("PODA"),1),"^",7)'=""
SET PRCFA("SC")=$PIECE(^PRCD(420.8,$PIECE(^PRC(442,PRCFA("PODA"),1),"^",7),0),"^",3)
+13 SET X1=$PIECE(PO(0),U,5)
SET X=$SELECT(X1="":"",$LENGTH(X1)>4:X1,1:X1_"00")
KILL X1
+14 SET ^PRCF(423,DA,1)=PRCFA("YALD")_U_$EXTRACT(P("DELDATE"),4,5)_U_PRCFA("SC")_U_$EXTRACT(P("DELDATE"),4,7)_$EXTRACT(P("DELDATE"),2,3)_U_$PIECE($PIECE(PO(0),U,3)," ",1)_U_X_U_U_$PIECE(PO(0),U,6)_U_($PIECE(PO(0),U,7)*100)
+15 SET $PIECE(^PRCF(423,DA,1),"^",10)=$SELECT(+$PIECE(PO(0),U,8)>0:$PIECE(PO(0),U,8),1:"$")
SET $PIECE(^(1),U,11)=$SELECT(+$PIECE(PO(0),U,9)>0:$PIECE(PO(0),U,9)*100,1:"")
SET $PIECE(^(1),"^",16)="$"
SET $PIECE(^("TRANS"),"^")=""
+16 IF PRCFA("EDIT")["921.00"
DO ^PRCFA921
GOTO XM
+17 SET PRCFA("EDIT")=$PIECE(^PRCD(420.4,PRCFA("TTDA"),0),U,3)
SET Y(0)=^(0)
SET ^PRCF(423,DA,0)=$PIECE(^PRCF(423,DA,0),U,1,2)_U_$PIECE(Y(0),U,3)_U_$PIECE(Y(0),U,1)_U_$PIECE(^(0),U,5,99)
KILL Y
+18 SET DIE="^PRCF(423,"
SET DR=PRCFA("EDIT")
SET PRCFA("CSDA")=DA
DO ^DIE
IF $DATA(Y)'=0
DO WAIT^PRCFYN
DO DEL
DO OUT3
GOTO ^PRCFAC0
XM DO ^PRCFACXM
IF $DATA(PRCFDEL)!$DATA(PRCFA("CSHOLD"))
KILL PRCFDEL,PRCFA("CSHOLD")
DO MSG
GOTO ^PRCFAC0
+1 SET PRCOPODA=PRCFA("PODA")
DO WAIT^DICD
DO NEW^PRCOEDI
+2 KILL PRCOPODA,IO("Q")
NC IF $DATA(PRCFA("PODA"))
DO ^PRCFAC02
+1 DO OUT3
GOTO ^PRCFAC0
OUT3 KILL %,AMT,C1,C,CSDA,D0,DA,DI,DIC,DEL,E,I,J,K,N1,N2,PCP,PO,PODA,PRCFA,PRCQ,PTYPE,T,T1,TIME,TRDA,Y,Z,Z5,ZX
QUIT
MSG SET X=" No Further Processing is being taken on this obligation.*"
DO MSG^PRCFQ
QUIT
+1 QUIT
SA ;LOOKUP FOR INVALID BOC
+1 SET %A="Invalid BOC number, OK to use anyway"
SET %B="Answer 'NO' if you do yot wish to use this BOC."
+2 SET %=2
DO ^PRCFYN
IF %'=1
KILL X
QUIT
+3 SET X=ZC
KILL ZC
QUIT
DEL ;KILL THE CODE SHEET AND CROSS REFERENCES
+1 DO DEL^PRCFACXM
QUIT
OUT WRITE !,"No data posted to Control Point Files",$CHAR(7)
READ X:3
QUIT
+1 QUIT
CPBAL if '$DATA(PQT)
SET PQT=PRC("QTR")
SET X=$GET(^PRC(420,PRC("SITE"),1,+PCP,4,PRC("FY"),0))
+1 IF X=""
SET X="No Control Point balances available at this time.*"
DO MSG^PRCFQ
SET PRCF("NOBAL")=""
QUIT
+2 SET PRCS("C")=$PIECE(X,"^",PQT+1)
SET PRCS("O")=$PIECE(X,"^",PQT+5)
+3 WRITE !!?15,"CPA Balances",!,"Uncommitted Balance: ",?30,"$"_$JUSTIFY(PRCS("C"),10,2),!,"Unobligated Balance: ",?30,"$"_$JUSTIFY(PRCS("O"),10,2)
WRITE !,"Committed, Not Obligated: ",?30,"$"_$JUSTIFY((PRCS("O")-PRCS("C")),10,2)
KILL PRCS
+4 QUIT
