PRCFFMO1 ;WISC/SJG-CONTINUATION OF OBLIGATION PROCESSING ;4/24/96 8:54 AM
V ;;5.1;IFCAP;**58,79,220**;Oct 20, 2000;Build 23
;Per VA Directive 6402, this routine should not be modified.
;
;PRC*5.1*220 Comment out line related to FPDS message generation
;
;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")
V1 I $P(PRC("PARAM"),"^",17)="Y" D
. W !!,"Fiscal Status of Funds for Control Point"
. W !!,"Status of Funds Balance: "
. W ?30,"$",$J($P(^PRC(420,PRC("SITE"),1,+$P(PO(0),U,3),0),U,7),10,2)
. W !,"Estimated Balance:"
. W ?30,"$",$J($P(^(0),U,8),10,2)
I $G(PRCRGS)<1 D OVCOM^PRCFFU10 I PRCFA("OVCOM")=1!(PRCFA("OVCOM")=2) D POFAIL^PRCFFU10,MSG H 3 G OUT3
S PRCFA("IDES")="Purchase Order Obligation"
W ! D OKAY2^PRCFFU ; ask 'OK to continue?'
I 'Y!($D(DIRUT)) D MSG H 3 G OUT3
VAR S P("DELDATE")=$P(PO(0),U,10)
S P("PODATE")=DT
I $P(^PRC(442,PRCFA("PODA"),1),"^",15)'="" S P("PODATE")=$P(^(1),"^",15)
S PRCFA("MOD")="E^0^Original Entry"
S PRCFA("MP")=$P(PO(0),U,2)
S PRCFA("REF")=$P(PO(0),"^")
S PRCFA("SFC")=$P(PO(0),U,19)
S PRCFA("SYS")="FMS"
S PRCFA("TT")=$S(PRCFA("MP")=2:"SO",1:"MO")
W !
I $D(PRCFA("RETRAN")),'PRCFA("RETRAN") D REVIEW^PRCFFU I Y N D0 S D0=PRCFA("PODA") D ^PRCHDP1
VAR1 I PRCFA("MP")=2,PRCFA("TT")'="MO" D G:ACCEDIT=1 VAR1
. W !
. D EN^PRCFFU16(+PO)
. D MSG6^PRCFFU16
VAR11 I $D(PRCFA("RETRAN")),PRCFA("RETRAN")=1 D G VAR2
. D RETRANO^PRCFFMO2 S Y=PRCFA("OBLDATE")
S Y=$$DTOBL^PRCFFUD1(PRC("RBDT"),PRC("PODT"))
VAR2 D D^PRCFQ
S %DT="AEX"
S %DT("A")="Select Obligation Processing Date: "
S %DT("B")=Y
W ! D ^%DT K %DT
I Y<0 D MSG H 3 D OUT3 Q
S PRCFA("OBLDATE")=Y
S EXIT=0
D ENO^PRCFFMO2
I EXIT D MSG,KILL^PRCFFMO2 H 3 D OUT3 Q
I PRC("RBDT")'<$P(^PRC(420,PRC("SITE"),0),"^",9),$P($$DATE^PRC0C(PRCFA("OBLDATE"),"I"),U,1,2)'=$P($$DATE^PRC0C(PRC("RBDT"),"I"),U,1,2) D MSG1^PRCFFUD G VAR11
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 PRCFA("BBFY")=$$BBFY^PRCFFU5(PRCFA("PODA"))
D GENDIQ^PRCFFU7(442,PRCFA("PODA"),".1;.07;.03;17","IEN","")
;
EDIT ; Check fund/year dictionary for required FMS fields
D EDIT^PRCFFU ; sets up PRCFMO array based upon required fields
;
GO ; Prompt user for final go-ahead for the document creation
D GO^PRCFFU I 'Y!($D(DIRUT)) D MSG,OUT3 H 3 Q
;
ESIG ; Enter the Electronic Signature and away it goes!
W !,"The Electronic Signature must now be entered to generate the "_PRCFA("TYPE")_" Document.",!
D SIG^PRCFFU4
I $D(PRCFA("SIGFAIL")) K PRCFA("SIGFAIL") D MSG1(ESIGMSG),OUT3 H 3 Q
;
I $G(PRCTMP(442,+PO,.07,"I"))="" D NEW410^PRCFFUD
D PO^PRCFFUD
S IDFLAG="I" ; flag to indicate $ increase to FMS
I $D(PRCFA("RETRAN")),PRCFA("RETRAN")=1 D
. D SETPO^PRCFFERT ; rebuild txn
;
STACK ; Create entry in GECS Stack File
D STACK^PRCFFU(0) ; build CTL,DOC segs, (0) means generate no batch#
;
SEGS ; Create entry into TMP($J, for remaining segments
K ^TMP($J,"PRCMO")
N FMSINT S FMSINT=+PO,FMSMOD=$P(PRCFA("MOD"),U,1)
D NEW^PRCFFU1(FMSINT,PRCFA("TT"),FMSMOD) ; create remaining segs
;
; Transfer nodes from TMP($J, into GECS stack file
N LOOP S LOOP=0 F S LOOP=$O(^TMP($J,"PRCMO",GECSFMS("DA"),LOOP)) Q:'LOOP D SETCS^GECSSTAA(GECSFMS("DA"),^(LOOP))
K ^TMP($J,"PRCMO")
;
TRANS ; Mark the document as queued for transmission
D SETSTAT^GECSSTAA(GECSFMS("DA"),"Q")
N P2 S P2=+PO,$P(P2,"/",5)=$P($G(PRCFA("ACCPD")),U),$P(P2,"/",6)=PRCFA("OBLDATE")
D SETPARAM^GECSSDCT(GECSFMS("DA"),P2)
;
POOBL ; Enter Obligation Data into Purchase Order record
I '$D(POESIG) I $D(PRCFA("PODA")),+PRCFA("PODA")>0 S POESIG=1
N FMSDOCT S FMSDOCT=$P(PRCFA("REF"),"-",2)
D EN7^PRCFFU41(PRCFA("TT"),FMSMOD,PRCFA("OBLDATE"),FMSDOCT) ; log txn
;
; continue processing if this is not a rebuild
I $D(PRCFA("RETRAN")),PRCFA("RETRAN") D OUT3 Q
;
FISCST ; Post to Fiscal Status of Funds Tracker
I $P(PRC("PARAM"),U,17)["Y" D FISC^PRCFFU4
;
PHA ; Generate PHA transaction
S PRCOPODA=PRCFA("PODA") W ! D WAIT^DICD W !!,"...now generating the PHA transaction"
S FILE=442 S PRCHPO=PRCFA("PODA") D CHECK^PRCHSWCH K FILE
D:'$G(PRCHOBL) NEW^PRCOEDI W !
; PRC*5.1*79: let the user know that a message is going out, except for
; Requisitions.
;D:$D(^PRC(442,PRCHPO,25)) EN^DDIOL("...now generating the FPDS message for the AAC","","!"),EN^DDIOL(" ") ;PRC*5.1*220
;
K PRCOPODA,IO("Q")
;
NC I $D(PRCFA("PODA")) D ^PRCFAC02
; Generate FPDS HL7 message for the AAC, PRC*5.1*79
I $P(^PRC(442,PRCHPO,0),U,15)>0,$D(^PRC(442,PRCHPO,25)) D AAC^PRCHAAC
; End of changes for PRC*5.1*79
Q
;
OUT3 K %,AMT,C1,C,CSDA,D0,DA,DI,DIC,DEL,E,I,J,K,N1,N2,PCP,PO,PODA,PRCQ,PTYPE,T,T1,TIME,TRDA,Y,Z,Z5,ZX
Q
MSG W !! S X="No further processing is being taken on this obligation." D EN^DDIOL(X) Q
Q
MSG1(MSG) S:'$D(ROUTINE) ROUTINE="PRCUESIG"
W !!,$$ERROR^PRCFFU13(ROUTINE,MSG)
D MSG Q
OUT W !,"No data posted to Control Point Files",$C(7) R X:3 Q
Q
CPBAL N A,B
;
; **Add call to OBLDAT^PRCFFUD1 as part of PRC*5.1*58
S A=$$DATE^PRC0C($$OBLDAT^PRCFFUD1(PRC("RBDT"),$G(PRC("AMENDT"))),"I")
K OBLDAT
; **End PRC*5.1*58
;
S B=$P(A,"^",2)
S A=$E(A,3,4)
S:'$D(PQT) PQT=PRC("QTR")
S X=$G(^PRC(420,PRC("SITE"),1,+PCP,4,A,0))
I X="" W !! S X="No Control Point balances available at this time." D EN^DDIOL(X) S PRCF("NOBAL")="" Q
S PRCS("C")=$P(X,"^",B+1)
S PRCS("O")=$P(X,"^",B+5)
W !!,"Control Point Balances"
W !!,"Uncommitted Balance: "
W ?30,"$"_$J(PRCS("C"),10,2)
W !,"Unobligated Balance: "
W ?30,"$"_$J(PRCS("O"),10,2)
W !,"Committed, Not Obligated: "
W ?30,"$"_$J((PRCS("O")-PRCS("C")),10,2)
K PRCS
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCFFMO1 5957 printed Apr 09, 2024@21:08:58 Page 2
PRCFFMO1 ;WISC/SJG-CONTINUATION OF OBLIGATION PROCESSING ;4/24/96 8:54 AM
V ;;5.1;IFCAP;**58,79,220**;Oct 20, 2000;Build 23
+1 ;Per VA Directive 6402, this routine should not be modified.
+2 ;
+3 ;PRC*5.1*220 Comment out line related to FPDS message generation
+4 ;
+5 ;DISPLAY CONTROL POINT OFFICIALS BALANCES
+6 WRITE !!,"Net Cost of Order: ",?30,"$",$JUSTIFY($PIECE(PO(0),U,16),10,2)
+7 DO CPBAL
+8 IF $DATA(PRCF("NOBAL"))
KILL PRCF("NOBAL")
V1 IF $PIECE(PRC("PARAM"),"^",17)="Y"
Begin DoDot:1
+1 WRITE !!,"Fiscal Status of Funds for Control Point"
+2 WRITE !!,"Status of Funds Balance: "
+3 WRITE ?30,"$",$JUSTIFY($PIECE(^PRC(420,PRC("SITE"),1,+$PIECE(PO(0),U,3),0),U,7),10,2)
+4 WRITE !,"Estimated Balance:"
+5 WRITE ?30,"$",$JUSTIFY($PIECE(^(0),U,8),10,2)
End DoDot:1
+6 IF $GET(PRCRGS)<1
DO OVCOM^PRCFFU10
IF PRCFA("OVCOM")=1!(PRCFA("OVCOM")=2)
DO POFAIL^PRCFFU10
DO MSG
HANG 3
GOTO OUT3
+7 SET PRCFA("IDES")="Purchase Order Obligation"
+8 ; ask 'OK to continue?'
WRITE !
DO OKAY2^PRCFFU
+9 IF 'Y!($DATA(DIRUT))
DO MSG
HANG 3
GOTO OUT3
VAR SET P("DELDATE")=$PIECE(PO(0),U,10)
+1 SET P("PODATE")=DT
+2 IF $PIECE(^PRC(442,PRCFA("PODA"),1),"^",15)'=""
SET P("PODATE")=$PIECE(^(1),"^",15)
+3 SET PRCFA("MOD")="E^0^Original Entry"
+4 SET PRCFA("MP")=$PIECE(PO(0),U,2)
+5 SET PRCFA("REF")=$PIECE(PO(0),"^")
+6 SET PRCFA("SFC")=$PIECE(PO(0),U,19)
+7 SET PRCFA("SYS")="FMS"
+8 SET PRCFA("TT")=$SELECT(PRCFA("MP")=2:"SO",1:"MO")
+9 WRITE !
+10 IF $DATA(PRCFA("RETRAN"))
IF 'PRCFA("RETRAN")
DO REVIEW^PRCFFU
IF Y
NEW D0
SET D0=PRCFA("PODA")
DO ^PRCHDP1
VAR1 IF PRCFA("MP")=2
IF PRCFA("TT")'="MO"
Begin DoDot:1
+1 WRITE !
+2 DO EN^PRCFFU16(+PO)
+3 DO MSG6^PRCFFU16
End DoDot:1
if ACCEDIT=1
GOTO VAR1
VAR11 IF $DATA(PRCFA("RETRAN"))
IF PRCFA("RETRAN")=1
Begin DoDot:1
+1 DO RETRANO^PRCFFMO2
SET Y=PRCFA("OBLDATE")
End DoDot:1
GOTO VAR2
+2 SET Y=$$DTOBL^PRCFFUD1(PRC("RBDT"),PRC("PODT"))
VAR2 DO D^PRCFQ
+1 SET %DT="AEX"
+2 SET %DT("A")="Select Obligation Processing Date: "
+3 SET %DT("B")=Y
+4 WRITE !
DO ^%DT
KILL %DT
+5 IF Y<0
DO MSG
HANG 3
DO OUT3
QUIT
+6 SET PRCFA("OBLDATE")=Y
+7 SET EXIT=0
+8 DO ENO^PRCFFMO2
+9 IF EXIT
DO MSG
DO KILL^PRCFFMO2
HANG 3
DO OUT3
QUIT
+10 IF PRC("RBDT")'<$PIECE(^PRC(420,PRC("SITE"),0),"^",9)
IF $PIECE($$DATE^PRC0C(PRCFA("OBLDATE"),"I"),U,1,2)'=$PIECE($$DATE^PRC0C(PRC("RBDT"),"I"),U,1,2)
DO MSG1^PRCFFUD
GOTO VAR11
+11 SET PRCFA("SC")=""
+12 if '$DATA(^PRC(442,+PO,1))
QUIT
+13 SET PRCFA("SC")=$SELECT($DATA(^PRC(440,$PIECE(^PRC(442,+PO,1),U,1),2)):$PIECE(^(2),U,4),1:"")
+14 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)
+15 SET PRCFA("BBFY")=$$BBFY^PRCFFU5(PRCFA("PODA"))
+16 DO GENDIQ^PRCFFU7(442,PRCFA("PODA"),".1;.07;.03;17","IEN","")
+17 ;
EDIT ; Check fund/year dictionary for required FMS fields
+1 ; sets up PRCFMO array based upon required fields
DO EDIT^PRCFFU
+2 ;
GO ; Prompt user for final go-ahead for the document creation
+1 DO GO^PRCFFU
IF 'Y!($DATA(DIRUT))
DO MSG
DO OUT3
HANG 3
QUIT
+2 ;
ESIG ; Enter the Electronic Signature and away it goes!
+1 WRITE !,"The Electronic Signature must now be entered to generate the "_PRCFA("TYPE")_" Document.",!
+2 DO SIG^PRCFFU4
+3 IF $DATA(PRCFA("SIGFAIL"))
KILL PRCFA("SIGFAIL")
DO MSG1(ESIGMSG)
DO OUT3
HANG 3
QUIT
+4 ;
+5 IF $GET(PRCTMP(442,+PO,.07,"I"))=""
DO NEW410^PRCFFUD
+6 DO PO^PRCFFUD
+7 ; flag to indicate $ increase to FMS
SET IDFLAG="I"
+8 IF $DATA(PRCFA("RETRAN"))
IF PRCFA("RETRAN")=1
Begin DoDot:1
+9 ; rebuild txn
DO SETPO^PRCFFERT
End DoDot:1
+10 ;
STACK ; Create entry in GECS Stack File
+1 ; build CTL,DOC segs, (0) means generate no batch#
DO STACK^PRCFFU(0)
+2 ;
SEGS ; Create entry into TMP($J, for remaining segments
+1 KILL ^TMP($JOB,"PRCMO")
+2 NEW FMSINT
SET FMSINT=+PO
SET FMSMOD=$PIECE(PRCFA("MOD"),U,1)
+3 ; create remaining segs
DO NEW^PRCFFU1(FMSINT,PRCFA("TT"),FMSMOD)
+4 ;
+5 ; Transfer nodes from TMP($J, into GECS stack file
+6 NEW LOOP
SET LOOP=0
FOR
SET LOOP=$ORDER(^TMP($JOB,"PRCMO",GECSFMS("DA"),LOOP))
if 'LOOP
QUIT
DO SETCS^GECSSTAA(GECSFMS("DA"),^(LOOP))
+7 KILL ^TMP($JOB,"PRCMO")
+8 ;
TRANS ; Mark the document as queued for transmission
+1 DO SETSTAT^GECSSTAA(GECSFMS("DA"),"Q")
+2 NEW P2
SET P2=+PO
SET $PIECE(P2,"/",5)=$PIECE($GET(PRCFA("ACCPD")),U)
SET $PIECE(P2,"/",6)=PRCFA("OBLDATE")
+3 DO SETPARAM^GECSSDCT(GECSFMS("DA"),P2)
+4 ;
POOBL ; Enter Obligation Data into Purchase Order record
+1 IF '$DATA(POESIG)
IF $DATA(PRCFA("PODA"))
IF +PRCFA("PODA")>0
SET POESIG=1
+2 NEW FMSDOCT
SET FMSDOCT=$PIECE(PRCFA("REF"),"-",2)
+3 ; log txn
DO EN7^PRCFFU41(PRCFA("TT"),FMSMOD,PRCFA("OBLDATE"),FMSDOCT)
+4 ;
+5 ; continue processing if this is not a rebuild
+6 IF $DATA(PRCFA("RETRAN"))
IF PRCFA("RETRAN")
DO OUT3
QUIT
+7 ;
FISCST ; Post to Fiscal Status of Funds Tracker
+1 IF $PIECE(PRC("PARAM"),U,17)["Y"
DO FISC^PRCFFU4
+2 ;
PHA ; Generate PHA transaction
+1 SET PRCOPODA=PRCFA("PODA")
WRITE !
DO WAIT^DICD
WRITE !!,"...now generating the PHA transaction"
+2 SET FILE=442
SET PRCHPO=PRCFA("PODA")
DO CHECK^PRCHSWCH
KILL FILE
+3 if '$GET(PRCHOBL)
DO NEW^PRCOEDI
WRITE !
+4 ; PRC*5.1*79: let the user know that a message is going out, except for
+5 ; Requisitions.
+6 ;D:$D(^PRC(442,PRCHPO,25)) EN^DDIOL("...now generating the FPDS message for the AAC","","!"),EN^DDIOL(" ") ;PRC*5.1*220
+7 ;
+8 KILL PRCOPODA,IO("Q")
+9 ;
NC IF $DATA(PRCFA("PODA"))
DO ^PRCFAC02
+1 ; Generate FPDS HL7 message for the AAC, PRC*5.1*79
+2 IF $PIECE(^PRC(442,PRCHPO,0),U,15)>0
IF $DATA(^PRC(442,PRCHPO,25))
DO AAC^PRCHAAC
+3 ; End of changes for PRC*5.1*79
+4 QUIT
+5 ;
OUT3 KILL %,AMT,C1,C,CSDA,D0,DA,DI,DIC,DEL,E,I,J,K,N1,N2,PCP,PO,PODA,PRCQ,PTYPE,T,T1,TIME,TRDA,Y,Z,Z5,ZX
+1 QUIT
MSG WRITE !!
SET X="No further processing is being taken on this obligation."
DO EN^DDIOL(X)
QUIT
+1 QUIT
MSG1(MSG) if '$DATA(ROUTINE)
SET ROUTINE="PRCUESIG"
+1 WRITE !!,$$ERROR^PRCFFU13(ROUTINE,MSG)
+2 DO MSG
QUIT
OUT WRITE !,"No data posted to Control Point Files",$CHAR(7)
READ X:3
QUIT
+1 QUIT
CPBAL NEW A,B
+1 ;
+2 ; **Add call to OBLDAT^PRCFFUD1 as part of PRC*5.1*58
+3 SET A=$$DATE^PRC0C($$OBLDAT^PRCFFUD1(PRC("RBDT"),$GET(PRC("AMENDT"))),"I")
+4 KILL OBLDAT
+5 ; **End PRC*5.1*58
+6 ;
+7 SET B=$PIECE(A,"^",2)
+8 SET A=$EXTRACT(A,3,4)
+9 if '$DATA(PQT)
SET PQT=PRC("QTR")
+10 SET X=$GET(^PRC(420,PRC("SITE"),1,+PCP,4,A,0))
+11 IF X=""
WRITE !!
SET X="No Control Point balances available at this time."
DO EN^DDIOL(X)
SET PRCF("NOBAL")=""
QUIT
+12 SET PRCS("C")=$PIECE(X,"^",B+1)
+13 SET PRCS("O")=$PIECE(X,"^",B+5)
+14 WRITE !!,"Control Point Balances"
+15 WRITE !!,"Uncommitted Balance: "
+16 WRITE ?30,"$"_$JUSTIFY(PRCS("C"),10,2)
+17 WRITE !,"Unobligated Balance: "
+18 WRITE ?30,"$"_$JUSTIFY(PRCS("O"),10,2)
+19 WRITE !,"Committed, Not Obligated: "
+20 WRITE ?30,"$"_$JUSTIFY((PRCS("O")-PRCS("C")),10,2)
+21 KILL PRCS
+22 QUIT
