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