146 lines
5.1 KiB
Mathematica
146 lines
5.1 KiB
Mathematica
PRCFFMO ;WISC/SJG-ROUTINE TO PROCESS OBLIGATIONS ;4/27/94 11:30
|
|
V ;;5.1;IFCAP;;Oct 20, 2000
|
|
;Per VHA Directive 10-93-142, this routine should not be modified.
|
|
S PRCF("X")="AS" D ^PRCFSITE ; ask station
|
|
G:'% EXIT D EXIT
|
|
K DIC("A") S D="C"
|
|
S DIC("A")="Select Purchase Order Number: "
|
|
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"
|
|
S DIC=442,DIC(0)="AEQZ"
|
|
D IX^DIC K DIC("S"),DIC("A"),FSO
|
|
G:+Y<0 EXIT
|
|
S PO=Y,PO(0)=Y(0)
|
|
S PRCFA("PODA")=+Y
|
|
S PCP=+$P(PO(0),"^",3)
|
|
S $P(PCP,"^",2)=$S($D(^PRC(420,PRC("SITE"),1,+PCP,0)):$P(^(0),"^",12),1:"")
|
|
S PRCFA("RETRAN")=0
|
|
;
|
|
RETRAN ; Entry point for rebuild/retransmit
|
|
S PRCFA("MOD")="E^0^Original Entry"
|
|
L +^PRC(442,PRCFA("PODA")):1
|
|
I $T=0 D G EXIT
|
|
. W $C(7),!
|
|
. D EN^DDIOL("This Purchase Order/Requisition is being obligated by another user!")
|
|
;
|
|
; NOTE: a document cannot be returned to supply once it is obligated.
|
|
; Therefore the messages below pertain to documents not being rebuilt.
|
|
; Rebuilt documents will hit the message if someone modified a file
|
|
; through FileMan. If the checks are here to catch errors in both
|
|
; cases, the message should be changed, otherwise the checks should
|
|
; be placed before the RETRAN tag.
|
|
;
|
|
I +$P(PO(0),U,3)=0!('$D(^PRC(420,PRC("SITE"),1,+PCP,0))) D G EXIT
|
|
. W $C(7)
|
|
. W "PURCHASE ORDER DOES NOT CONTAIN A CONTROL POINT.",!
|
|
. W "UNABLE TO PROCESS - PLEASE RETURN TO SUPPLY FOR CORRECTION!"
|
|
;
|
|
I $P(PO(0),U,5)="",$P(PCP,"^",2)<2 D G EXIT
|
|
. W $C(7),!
|
|
. W "Purchase Order does not contain a Cost Center"
|
|
. W !,"Unable to process - please return to supply for correction!"
|
|
;
|
|
D DT442^PRCFFUD1(PRCFA("PODA"),PO(0))
|
|
;
|
|
I +$P(PO(0),"^",16)=0 D G V
|
|
. ; S PRCFA("N/C")=1
|
|
. W !
|
|
. D NC
|
|
. I 'Y!($D(DIRUT)) D MSG QUIT
|
|
. I Y D NC2
|
|
. D EXIT
|
|
. Q
|
|
;
|
|
I '$D(^PRC(442,PRCFA("PODA"),22)),$P(PCP,"^",2)="" D G EXIT
|
|
. W $C(7)
|
|
. W !!,"Purchase Order does not contain any BOC data.",!
|
|
. W "Unable to process - please return to supply for correction!"
|
|
;
|
|
SC ; Display Obligation Data
|
|
I '$D(IOF)!('$D(IOM)) S IOP="HOME" D ^%ZIS K POP
|
|
D SC^PRCFFUA1
|
|
I $D(^PRC(442,PRCFA("PODA"),13)) W !! D ^PRCFAC0J
|
|
W ! D OKAY^PRCFFU
|
|
I $D(DIRUT) D MSG G EXIT
|
|
I 'Y S FISCEDIT=0 D PO^PRCFFU12 I FISCEDIT G SC
|
|
S Z=PRC("SITE")_"-"_PRC("FY")_"-"_PRC("QTR")_"-"_$P($P(PO(0),"^",3)," "),C1=1
|
|
D ^PRCFFMO1
|
|
L -^PRC(442,PRCFA("PODA"))
|
|
I $D(PRCFA("RETRAN")),PRCFA("RETRAN")=0 D EXIT G V
|
|
D EXIT
|
|
QUIT
|
|
EXIT ;
|
|
K %,AMT,C1,C,CSDA,D0,DA,DI,DIC,DEL,E,I,J,K,N1,N2,POP,PO,PODA,PRCFA,PRCFQ
|
|
K PTYPE,T,T1,TIME,TRDA,Y,Z,Z5,ZX
|
|
K PODATE,P,M0,GECSFMS
|
|
Q
|
|
NC ; Prompt for 'NO CHARGE' orders
|
|
S DIR(0)="Y",DIR("B")="YES"
|
|
S DIR("A",1)="This order appears to be a 'NO CHARGE' order. Do you still need to take"
|
|
S DIR("A")="any action on this order"
|
|
S DIR("?")="Enter 'YES' or 'Y' or 'RETURN' to continue processing."
|
|
S DIR("?",1)="Enter 'NO' or 'N' or '^' to exit this option."
|
|
S DIR("??")="^D NC1^PRCFFMO" D ^DIR K DIR
|
|
Q
|
|
NC1 ; Additional help for N/C
|
|
K MSG S MSG(1)="When processing continues on this 'NO CHARGE' order, the Electronic Signature"
|
|
S MSG(2)="will be applied and the Fund Control Point balance will be updated."
|
|
S MSG(3)="There will be no FMS document generated.",MSG(4)=" "
|
|
S MSG(5)="If exiting, there will be no further action taken on this order."
|
|
W !! D EN^DDIOL(.MSG) K MSG
|
|
Q
|
|
NC2 ; Processing for N/C
|
|
S %=1 W ! D SIG^PRCFFU4 I $D(PRCFA("SIGFAIL")) K PRCFA("SIGFAIL") S %=-1 D MSG1^PRCFFMO1(ESIGMSG) H 3 Q
|
|
S PRCFA("BBFY")=$$BBFY^PRCFFU5(+PO)
|
|
D GENDIQ^PRCFFU7(442,+PO,".1;.07;.03;17","IEN","")
|
|
S PRCFA("OBLDATE")=$$DTOBL^PRCFFUD1(PRC("RBDT"),PRC("PODT"))
|
|
D EDIT^PRCFFU ; set up PRCFMO array based upon fund/year required fields table
|
|
D VAR ; continues set up of PRCFA array
|
|
S FMSMOD=$P(PRCFA("MOD"),U)
|
|
D POOBL^PRCFFMO1
|
|
W ! D MSG1
|
|
I $G(PRCTMP(442,+PO,.07,"I"))="" D NEW410^PRCFFUD
|
|
D PO^PRCFFUD
|
|
Q
|
|
MSG W !! S X="No further processing is being taken on this obligation."
|
|
D EN^DDIOL(X) H 3
|
|
Q
|
|
MSG1 D EN^DDIOL("...no FMS Document has been generated...") W !
|
|
Q
|
|
SUPP ; Entry point for FMS Documents for Supply Fund Special Control Point
|
|
; Called from PRCHNPO4
|
|
S DIC("S")="I +^(0)=PRC(""SITE"")"
|
|
S DIC=442,DIC(0)="NZ",X=PRCHPO
|
|
D ^DIC K DIC G:+Y<0 EXIT
|
|
S PO(0)=Y(0),PO=Y
|
|
S PRCFA("PODA")=+Y
|
|
S PCP=+$P(PO(0),"^",3)
|
|
S $P(PCP,"^",2)=$S($D(^PRC(420,PRC("SITE"),1,+PCP,0)):$P(^(0),"^",12),1:"")
|
|
D DT442^PRCFFUD1(PRCFA("PODA"),PO(0))
|
|
S PRCFA("OBLDATE")=$$DTOBL^PRCFFUD1(PRC("RBDT"),PRC("PODT"))
|
|
D ENSFO^PRCFFMO2
|
|
S PRCFA("BBFY")=$$BBFY^PRCFFU5(+PO)
|
|
D GENDIQ^PRCFFU7(442,+PO,".1;.07;.03;17","IEN","")
|
|
S IDFLAG="I"
|
|
S PARAM1="^"_PRC("SITE")_"^"_+PCP_"^"_PRC("FY")_"^"_PRCFA("BBFY")
|
|
D DOCREQ^PRC0C(PARAM1,"SPE","PRCFMO")
|
|
S PRCFMO("G/N")=$P(PRCFMO,U,12)
|
|
D VAR
|
|
I +$P(PO(0),U,16)=0 D
|
|
. S FMSMOD=$P(PRCFA("MOD"),U)
|
|
. D POOBL^PRCFFMO1
|
|
. D MSG1
|
|
I $G(PRCTMP(442,+PO,.07,"I"))="" D NEW410^PRCFFUD
|
|
D PO^PRCFFUD
|
|
I +$P(PO(0),U,16)=0 W ! D EXIT QUIT
|
|
D STACK^PRCFFMO1,EXIT
|
|
QUIT
|
|
VAR ; Set up variables
|
|
S PRCFA("IDES")="Purchase Order"
|
|
S PRCFA("MOD")="E^0^Original Entry"
|
|
S PRCFA("MP")=$P(PO(0),U,2)
|
|
S PRCFA("REF")=$P(PO(0),U)
|
|
; S PRCFA("SFC")=$P(PO(0),U,19)
|
|
S PRCFA("SYS")="FMS"
|
|
S PRCFA("TT")=$S(PRCFA("MP")=2:"SO",1:"MO")
|
|
Q
|