source: WorldVistAEHR/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCFFMO1.m@ 619

Last change on this file since 619 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR

File size: 5.6 KB
Line 
1PRCFFMO1 ;WISC/SJG-CONTINUATION OF OBLIGATION PROCESSING ;4/24/96 8:54 AM
2V ;;5.1;IFCAP;**58,79**;Oct 20, 2000
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4 ;DISPLAY CONTROL POINT OFFICIALS BALANCES
5 W !!,"Net Cost of Order: ",?30,"$",$J($P(PO(0),U,16),10,2)
6 D CPBAL
7 I $D(PRCF("NOBAL")) K PRCF("NOBAL")
8V1 I $P(PRC("PARAM"),"^",17)="Y" D
9 . W !!,"Fiscal Status of Funds for Control Point"
10 . W !!,"Status of Funds Balance: "
11 . W ?30,"$",$J($P(^PRC(420,PRC("SITE"),1,+$P(PO(0),U,3),0),U,7),10,2)
12 . W !,"Estimated Balance:"
13 . W ?30,"$",$J($P(^(0),U,8),10,2)
14 I $G(PRCRGS)<1 D OVCOM^PRCFFU10 I PRCFA("OVCOM")=1!(PRCFA("OVCOM")=2) D POFAIL^PRCFFU10,MSG H 3 G OUT3
15 S PRCFA("IDES")="Purchase Order Obligation"
16 W ! D OKAY2^PRCFFU ; ask 'OK to continue?'
17 I 'Y!($D(DIRUT)) D MSG H 3 G OUT3
18VAR S P("DELDATE")=$P(PO(0),U,10)
19 S P("PODATE")=DT
20 I $P(^PRC(442,PRCFA("PODA"),1),"^",15)'="" S P("PODATE")=$P(^(1),"^",15)
21 S PRCFA("MOD")="E^0^Original Entry"
22 S PRCFA("MP")=$P(PO(0),U,2)
23 S PRCFA("REF")=$P(PO(0),"^")
24 S PRCFA("SFC")=$P(PO(0),U,19)
25 S PRCFA("SYS")="FMS"
26 S PRCFA("TT")=$S(PRCFA("MP")=2:"SO",1:"MO")
27 W !
28 I $D(PRCFA("RETRAN")),'PRCFA("RETRAN") D REVIEW^PRCFFU I Y N D0 S D0=PRCFA("PODA") D ^PRCHDP1
29VAR1 I PRCFA("MP")=2,PRCFA("TT")'="MO" D G:ACCEDIT=1 VAR1
30 . W !
31 . D EN^PRCFFU16(+PO)
32 . D MSG6^PRCFFU16
33VAR11 I $D(PRCFA("RETRAN")),PRCFA("RETRAN")=1 D G VAR2
34 . D RETRANO^PRCFFMO2 S Y=PRCFA("OBLDATE")
35 S Y=$$DTOBL^PRCFFUD1(PRC("RBDT"),PRC("PODT"))
36VAR2 D D^PRCFQ
37 S %DT="AEX"
38 S %DT("A")="Select Obligation Processing Date: "
39 S %DT("B")=Y
40 W ! D ^%DT K %DT
41 I Y<0 D MSG H 3 D OUT3 Q
42 S PRCFA("OBLDATE")=Y
43 S EXIT=0
44 D ENO^PRCFFMO2
45 I EXIT D MSG,KILL^PRCFFMO2 H 3 D OUT3 Q
46 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
47 S PRCFA("SC")=""
48 Q:'$D(^PRC(442,+PO,1))
49 S PRCFA("SC")=$S($D(^PRC(440,$P(^PRC(442,+PO,1),U,1),2)):$P(^(2),U,4),1:"")
50 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)
51 S PRCFA("BBFY")=$$BBFY^PRCFFU5(PRCFA("PODA"))
52 D GENDIQ^PRCFFU7(442,PRCFA("PODA"),".1;.07;.03;17","IEN","")
53 ;
54EDIT ; Check fund/year dictionary for required FMS fields
55 D EDIT^PRCFFU ; sets up PRCFMO array based upon required fields
56 ;
57GO ; Prompt user for final go-ahead for the document creation
58 D GO^PRCFFU I 'Y!($D(DIRUT)) D MSG,OUT3 H 3 Q
59 ;
60ESIG ; Enter the Electronic Signature and away it goes!
61 W !,"The Electronic Signature must now be entered to generate the "_PRCFA("TYPE")_" Document.",!
62 D SIG^PRCFFU4
63 I $D(PRCFA("SIGFAIL")) K PRCFA("SIGFAIL") D MSG1(ESIGMSG),OUT3 H 3 Q
64 ;
65 I $G(PRCTMP(442,+PO,.07,"I"))="" D NEW410^PRCFFUD
66 D PO^PRCFFUD
67 S IDFLAG="I" ; flag to indicate $ increase to FMS
68 I $D(PRCFA("RETRAN")),PRCFA("RETRAN")=1 D
69 . D SETPO^PRCFFERT ; rebuild txn
70 ;
71STACK ; Create entry in GECS Stack File
72 D STACK^PRCFFU(0) ; build CTL,DOC segs, (0) means generate no batch#
73 ;
74SEGS ; Create entry into TMP($J, for remaining segments
75 K ^TMP($J,"PRCMO")
76 N FMSINT S FMSINT=+PO,FMSMOD=$P(PRCFA("MOD"),U,1)
77 D NEW^PRCFFU1(FMSINT,PRCFA("TT"),FMSMOD) ; create remaining segs
78 ;
79 ; Transfer nodes from TMP($J, into GECS stack file
80 N LOOP S LOOP=0 F S LOOP=$O(^TMP($J,"PRCMO",GECSFMS("DA"),LOOP)) Q:'LOOP D SETCS^GECSSTAA(GECSFMS("DA"),^(LOOP))
81 K ^TMP($J,"PRCMO")
82 ;
83TRANS ; Mark the document as queued for transmission
84 D SETSTAT^GECSSTAA(GECSFMS("DA"),"Q")
85 N P2 S P2=+PO,$P(P2,"/",5)=$P($G(PRCFA("ACCPD")),U),$P(P2,"/",6)=PRCFA("OBLDATE")
86 D SETPARAM^GECSSDCT(GECSFMS("DA"),P2)
87 ;
88POOBL ; Enter Obligation Data into Purchase Order record
89 I '$D(POESIG) I $D(PRCFA("PODA")),+PRCFA("PODA")>0 S POESIG=1
90 N FMSDOCT S FMSDOCT=$P(PRCFA("REF"),"-",2)
91 D EN7^PRCFFU41(PRCFA("TT"),FMSMOD,PRCFA("OBLDATE"),FMSDOCT) ; log txn
92 ;
93 ; continue processing if this is not a rebuild
94 I $D(PRCFA("RETRAN")),PRCFA("RETRAN") D OUT3 Q
95 ;
96FISCST ; Post to Fiscal Status of Funds Tracker
97 I $P(PRC("PARAM"),U,17)["Y" D FISC^PRCFFU4
98 ;
99PHA ; Generate PHA transaction
100 S PRCOPODA=PRCFA("PODA") W ! D WAIT^DICD W !!,"...now generating the PHA transaction"
101 S FILE=442 S PRCHPO=PRCFA("PODA") D CHECK^PRCHSWCH K FILE
102 D:'$G(PRCHOBL) NEW^PRCOEDI W !
103 ; PRC*5.1*79: let the user know that a message is going out, except for
104 ; Requisitions.
105 D:$D(^PRC(442,PRCHPO,25)) EN^DDIOL("...now generating the FPDS message for the AAC","","!"),EN^DDIOL(" ")
106 ;
107 K PRCOPODA,IO("Q")
108 ;
109NC I $D(PRCFA("PODA")) D ^PRCFAC02
110 ; Generate FPDS HL7 message for the AAC, PRC*5.1*79
111 I $P(^PRC(442,PRCHPO,0),U,15)>0,$D(^PRC(442,PRCHPO,25)) D AAC^PRCHAAC
112 ; End of changes for PRC*5.1*79
113 Q
114 ;
115OUT3 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
116 Q
117MSG W !! S X="No further processing is being taken on this obligation." D EN^DDIOL(X) Q
118 Q
119MSG1(MSG) S:'$D(ROUTINE) ROUTINE="PRCUESIG"
120 W !!,$$ERROR^PRCFFU13(ROUTINE,MSG)
121 D MSG Q
122OUT W !,"No data posted to Control Point Files",$C(7) R X:3 Q
123 Q
124CPBAL N A,B
125 ;
126 ; **Add call to OBLDAT^PRCFFUD1 as part of PRC*5.1*58
127 S A=$$DATE^PRC0C($$OBLDAT^PRCFFUD1(PRC("RBDT"),$G(PRC("AMENDT"))),"I")
128 K OBLDAT
129 ; **End PRC*5.1*58
130 ;
131 S B=$P(A,"^",2)
132 S A=$E(A,3,4)
133 S:'$D(PQT) PQT=PRC("QTR")
134 S X=$G(^PRC(420,PRC("SITE"),1,+PCP,4,A,0))
135 I X="" W !! S X="No Control Point balances available at this time." D EN^DDIOL(X) S PRCF("NOBAL")="" Q
136 S PRCS("C")=$P(X,"^",B+1)
137 S PRCS("O")=$P(X,"^",B+5)
138 W !!,"Control Point Balances"
139 W !!,"Uncommitted Balance: "
140 W ?30,"$"_$J(PRCS("C"),10,2)
141 W !,"Unobligated Balance: "
142 W ?30,"$"_$J(PRCS("O"),10,2)
143 W !,"Committed, Not Obligated: "
144 W ?30,"$"_$J((PRCS("O")-PRCS("C")),10,2)
145 K PRCS
146 Q
Note: See TracBrowser for help on using the repository browser.