- 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 Feb 18, 2025@23:29:52 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