source: WorldVistAEHR/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCFFMO.m@ 1078

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

initial load of WorldVistAEHR
File size: 5.1 KB
Line 
1PRCFFMO ;WISC/SJG-ROUTINE TO PROCESS OBLIGATIONS ;4/27/94 11:30
2V ;;5.1;IFCAP;;Oct 20, 2000
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4 S PRCF("X")="AS" D ^PRCFSITE ; ask station
5 G:'% EXIT D EXIT
6 K DIC("A") S D="C"
7 S DIC("A")="Select Purchase Order Number: "
8 S DIC("S")="I $D(^(7)),+^(0)=PRC(""SITE""),$D(^PRCD(442.3,+^(7),0)) S FSO=$P(^(0),U,3) I FSO>9,FSO<21"
9 S DIC=442,DIC(0)="AEQZ"
10 D IX^DIC K DIC("S"),DIC("A"),FSO
11 G:+Y<0 EXIT
12 S PO=Y,PO(0)=Y(0)
13 S PRCFA("PODA")=+Y
14 S PCP=+$P(PO(0),"^",3)
15 S $P(PCP,"^",2)=$S($D(^PRC(420,PRC("SITE"),1,+PCP,0)):$P(^(0),"^",12),1:"")
16 S PRCFA("RETRAN")=0
17 ;
18RETRAN ; Entry point for rebuild/retransmit
19 S PRCFA("MOD")="E^0^Original Entry"
20 L +^PRC(442,PRCFA("PODA")):1
21 I $T=0 D G EXIT
22 . W $C(7),!
23 . D EN^DDIOL("This Purchase Order/Requisition is being obligated by another user!")
24 ;
25 ; NOTE: a document cannot be returned to supply once it is obligated.
26 ; Therefore the messages below pertain to documents not being rebuilt.
27 ; Rebuilt documents will hit the message if someone modified a file
28 ; through FileMan. If the checks are here to catch errors in both
29 ; cases, the message should be changed, otherwise the checks should
30 ; be placed before the RETRAN tag.
31 ;
32 I +$P(PO(0),U,3)=0!('$D(^PRC(420,PRC("SITE"),1,+PCP,0))) D G EXIT
33 . W $C(7)
34 . W "PURCHASE ORDER DOES NOT CONTAIN A CONTROL POINT.",!
35 . W "UNABLE TO PROCESS - PLEASE RETURN TO SUPPLY FOR CORRECTION!"
36 ;
37 I $P(PO(0),U,5)="",$P(PCP,"^",2)<2 D G EXIT
38 . W $C(7),!
39 . W "Purchase Order does not contain a Cost Center"
40 . W !,"Unable to process - please return to supply for correction!"
41 ;
42 D DT442^PRCFFUD1(PRCFA("PODA"),PO(0))
43 ;
44 I +$P(PO(0),"^",16)=0 D G V
45 . ; S PRCFA("N/C")=1
46 . W !
47 . D NC
48 . I 'Y!($D(DIRUT)) D MSG QUIT
49 . I Y D NC2
50 . D EXIT
51 . Q
52 ;
53 I '$D(^PRC(442,PRCFA("PODA"),22)),$P(PCP,"^",2)="" D G EXIT
54 . W $C(7)
55 . W !!,"Purchase Order does not contain any BOC data.",!
56 . W "Unable to process - please return to supply for correction!"
57 ;
58SC ; Display Obligation Data
59 I '$D(IOF)!('$D(IOM)) S IOP="HOME" D ^%ZIS K POP
60 D SC^PRCFFUA1
61 I $D(^PRC(442,PRCFA("PODA"),13)) W !! D ^PRCFAC0J
62 W ! D OKAY^PRCFFU
63 I $D(DIRUT) D MSG G EXIT
64 I 'Y S FISCEDIT=0 D PO^PRCFFU12 I FISCEDIT G SC
65 S Z=PRC("SITE")_"-"_PRC("FY")_"-"_PRC("QTR")_"-"_$P($P(PO(0),"^",3)," "),C1=1
66 D ^PRCFFMO1
67 L -^PRC(442,PRCFA("PODA"))
68 I $D(PRCFA("RETRAN")),PRCFA("RETRAN")=0 D EXIT G V
69 D EXIT
70 QUIT
71EXIT ;
72 K %,AMT,C1,C,CSDA,D0,DA,DI,DIC,DEL,E,I,J,K,N1,N2,POP,PO,PODA,PRCFA,PRCFQ
73 K PTYPE,T,T1,TIME,TRDA,Y,Z,Z5,ZX
74 K PODATE,P,M0,GECSFMS
75 Q
76NC ; Prompt for 'NO CHARGE' orders
77 S DIR(0)="Y",DIR("B")="YES"
78 S DIR("A",1)="This order appears to be a 'NO CHARGE' order. Do you still need to take"
79 S DIR("A")="any action on this order"
80 S DIR("?")="Enter 'YES' or 'Y' or 'RETURN' to continue processing."
81 S DIR("?",1)="Enter 'NO' or 'N' or '^' to exit this option."
82 S DIR("??")="^D NC1^PRCFFMO" D ^DIR K DIR
83 Q
84NC1 ; Additional help for N/C
85 K MSG S MSG(1)="When processing continues on this 'NO CHARGE' order, the Electronic Signature"
86 S MSG(2)="will be applied and the Fund Control Point balance will be updated."
87 S MSG(3)="There will be no FMS document generated.",MSG(4)=" "
88 S MSG(5)="If exiting, there will be no further action taken on this order."
89 W !! D EN^DDIOL(.MSG) K MSG
90 Q
91NC2 ; Processing for N/C
92 S %=1 W ! D SIG^PRCFFU4 I $D(PRCFA("SIGFAIL")) K PRCFA("SIGFAIL") S %=-1 D MSG1^PRCFFMO1(ESIGMSG) H 3 Q
93 S PRCFA("BBFY")=$$BBFY^PRCFFU5(+PO)
94 D GENDIQ^PRCFFU7(442,+PO,".1;.07;.03;17","IEN","")
95 S PRCFA("OBLDATE")=$$DTOBL^PRCFFUD1(PRC("RBDT"),PRC("PODT"))
96 D EDIT^PRCFFU ; set up PRCFMO array based upon fund/year required fields table
97 D VAR ; continues set up of PRCFA array
98 S FMSMOD=$P(PRCFA("MOD"),U)
99 D POOBL^PRCFFMO1
100 W ! D MSG1
101 I $G(PRCTMP(442,+PO,.07,"I"))="" D NEW410^PRCFFUD
102 D PO^PRCFFUD
103 Q
104MSG W !! S X="No further processing is being taken on this obligation."
105 D EN^DDIOL(X) H 3
106 Q
107MSG1 D EN^DDIOL("...no FMS Document has been generated...") W !
108 Q
109SUPP ; Entry point for FMS Documents for Supply Fund Special Control Point
110 ; Called from PRCHNPO4
111 S DIC("S")="I +^(0)=PRC(""SITE"")"
112 S DIC=442,DIC(0)="NZ",X=PRCHPO
113 D ^DIC K DIC G:+Y<0 EXIT
114 S PO(0)=Y(0),PO=Y
115 S PRCFA("PODA")=+Y
116 S PCP=+$P(PO(0),"^",3)
117 S $P(PCP,"^",2)=$S($D(^PRC(420,PRC("SITE"),1,+PCP,0)):$P(^(0),"^",12),1:"")
118 D DT442^PRCFFUD1(PRCFA("PODA"),PO(0))
119 S PRCFA("OBLDATE")=$$DTOBL^PRCFFUD1(PRC("RBDT"),PRC("PODT"))
120 D ENSFO^PRCFFMO2
121 S PRCFA("BBFY")=$$BBFY^PRCFFU5(+PO)
122 D GENDIQ^PRCFFU7(442,+PO,".1;.07;.03;17","IEN","")
123 S IDFLAG="I"
124 S PARAM1="^"_PRC("SITE")_"^"_+PCP_"^"_PRC("FY")_"^"_PRCFA("BBFY")
125 D DOCREQ^PRC0C(PARAM1,"SPE","PRCFMO")
126 S PRCFMO("G/N")=$P(PRCFMO,U,12)
127 D VAR
128 I +$P(PO(0),U,16)=0 D
129 . S FMSMOD=$P(PRCFA("MOD"),U)
130 . D POOBL^PRCFFMO1
131 . D MSG1
132 I $G(PRCTMP(442,+PO,.07,"I"))="" D NEW410^PRCFFUD
133 D PO^PRCFFUD
134 I +$P(PO(0),U,16)=0 W ! D EXIT QUIT
135 D STACK^PRCFFMO1,EXIT
136 QUIT
137VAR ; Set up variables
138 S PRCFA("IDES")="Purchase Order"
139 S PRCFA("MOD")="E^0^Original Entry"
140 S PRCFA("MP")=$P(PO(0),U,2)
141 S PRCFA("REF")=$P(PO(0),U)
142 ; S PRCFA("SFC")=$P(PO(0),U,19)
143 S PRCFA("SYS")="FMS"
144 S PRCFA("TT")=$S(PRCFA("MP")=2:"SO",1:"MO")
145 Q
Note: See TracBrowser for help on using the repository browser.