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