PRCFFU ;WISC/SJG-CONTINUATION OF OBLIGATION PROCESSING ;7/21/93 13:51
V ;;5.1;IFCAP;**196**;Oct 20, 2000;Build 15
;Per VA Directive 6402, this routine should not be modified.
;
;PRC*5.1*196 Send order obligation date to GECS for creation
; of the SO document CTL segment with correct date
QUIT
; No top level entry point
OKAY ;
S DIR(0)="Y",DIR("A",1)="The information listed above is recorded on this "_PRCFA("IDES")_"."
S DIR("A")="Is the above information correct",DIR("B")="YES"
S DIR("?")="Enter 'NO' or 'N' to edit the Cost Center or BOC."
S DIR("?",1)="Enter '^' to exit this option."
S DIR("?",2)="Enter 'YES' or 'Y' or 'RETURN' to continue processing this obligation."
D ^DIR K DIR
QUIT
;
OKAY2 ;
S DIR(0)="Y",DIR("A")="OK to Continue",DIR("B")="YES"
S DIR("?")="Enter 'NO' or 'N' or '^' to exit this option."
S DIR("?",1)="Enter 'YES' or 'Y' or 'RETURN' to continue processing this obligation."
D ^DIR K DIR
QUIT
;
EDIT ; Set up PRCFMO array to indicate required FMS fields
S PARAM1="^"_PRC("SITE")_"^"_+$P(PO(0),U,3)_"^"_PRC("FY")_"^"_PRCFA("BBFY")
; build PRCFMO array to use when creating LIN string of FMS transaction
; PARAM1=^STATION^FCP^FY^BBFY
; SPE means spending documents
D DOCREQ^PRC0C(PARAM1,"SPE","PRCFMO")
S PRCFMO("G/N")=$P(PRCFMO,U,12)
QUIT
;
GO ; Prompt user for final go-ahead for the document creation
S PRCFA("FDES")=$S(PRCFA("TT")="MO":"Miscellaneous Order (MO)",PRCFA("TT")="SO":"Service (SO) Order",PRCFA("TT")="AR":"Receiver Accrual (AR)")
N POSIT S POSIT=$F(PRCFA("FDES"),"(")
S PRCFA("TYPE")=$E(PRCFA("FDES"),POSIT,POSIT+1)
S DIR(0)="Y"
S DIR("A")="Transmit this Document to FMS"
S DIR("B")="YES"
S DIR("A",1)=" "
S DIR("A",2)="This "_PRCFA("IDES")_" will now generate the "
S DIR("A",3)=$P(PRCFA("MOD"),U,3)_" "_PRCFA("FDES")_" Document. The "_PRCFA("TYPE")_" Document"
S DIR("A",4)="will be marked for transmission to FMS."
S DIR("A",5)=" "
S DIR("?")="Enter 'NO' or 'N' or '^' to exit this option."
S DIR("?",1)="Enter 'YES' or 'Y' or 'RETURN' to transmit this Document."
D ^DIR K DIR
QUIT
;
STACK(MOD) ; Create entry in GECS Stack File
I $D(PRCFA("CONVS")),PRCFA("CONVS")=1 G STACK1
I $D(PRCFA("CONVG")),PRCFA("CONVG")=1 G STACK1
W !!,"...now generating the FMS "
W $S(PRCFA("TT")="MO":"Miscellaneous Order (MO) Document",PRCFA("TT")="SO":"Service Order (SO) Document",PRCFA("TT")="AR":"Receiver Accrual (AR) Document",1:"Document")
W "...",! D WAIT^DICD
STACK1 N FMSSYS,FMSSTA,FMSDOC,FMSTRA,FMSSEC,FMSMOD,FMSFCP,FMSDES,FMSCOMDT
I $D(PRCFA("RETRAN")),PRCFA("RETRAN")=1 Q
K GECSUFMS("DA") ; delete current ien to get new ien
S FMSDES=PRCFA("IDES")
S FMSDOC=PRCFA("REF")
S FMSMOD=MOD
I PRCFA("TT")="AR" D
. S FMSDOC=FMSDOC_12
. S FMSMOD=1
S FMSSEC=$$SEC1^PRC0C(PRC("SITE"))
S FMSSTA=PRC("SITE")
S FMSSYS="I"
S FMSTRA=PRCFA("TT")
S FMSCOMDT=PRCFA("OBLDATE") ;PRC*5.1*196
D CONTROL^GECSUFMS(FMSSYS,FMSSTA,FMSDOC,FMSTRA,FMSSEC,FMSMOD,"Y",FMSDES,FMSCOMDT)
QUIT
;
OKAM ; Reader for prompt to approve amendment
S DIR(0)="Y"
S DIR("A",1)="The information listed above is recorded on this Purchase Order amendment."
S DIR("A")="Are you ready to approve and obligate this amendment"
S DIR("B")="YES"
S DIR("?")="Enter 'NO' or 'N' or '^' to exit this option."
S DIR("?",1)="Enter 'YES' or 'Y' or 'RETURN' to continue processing this amendment obligation."
D ^DIR K DIR
QUIT
;
OKAPP ; Reader for prompt that amendment has already been approved
S DIR(0)="Y"
S DIR("A",1)="This amendment has already been approved by Fiscal."
S DIR("A")="Are you sure that you wish to continue"
S DIR("B")="NO"
S DIR("?")="Enter 'YES' or 'Y' to continue."
S DIR("?",1)="Enter 'NO' or 'N' or '^' or 'RETURN' to exit this option."
D ^DIR K DIR
QUIT
;
OKPRT ; Reader to prompt user to print the amendment
S DIR(0)="Y"
S DIR("A")="Would you like to print this amendment"
S DIR("B")="YES"
S DIR("?")="Enter 'YES' or 'Y' or 'RETURN' to print this amendment."
S DIR("?",1)="Enter 'NO' or 'N' or '^' if printing in not desired."
D ^DIR K DIR
QUIT
;
REVIEW ; Reader to prompt user to review the PO before obligation
N LABEL S LABEL=$S((PRCFA("MP")=1)!(PRCFA("MP")=2):"Purchase Order",PRCFA("MP")=8:"Requisition",1:"Purchase Order")
S DIR(0)="Y"
S DIR("A")="Would you like to review the entire "_LABEL
S DIR("B")="YES"
S DIR("?")="Enter 'NO' or 'N' or '^' if the "_LABEL_" review is not necessary."
S DIR("?",1)="Enter 'YES' or 'Y' or 'RETURN' to display the "_LABEL_"."
D ^DIR K DIR
Q
;
; PO is the ien of the 443.6 file
; AMNUM is the amendment number
CHKAMEN(PO,AMNUM) ; checks PO completeness, looks for missing data
N CNT,J,INUM,CHNG,STARTFLG,TYPAM,MSG,PRPAYFLG
S CNT=0
S STARTFLG=0
S PRPAYFLG=0
F CHNG=0:0 S CHNG=$O(^PRC(443.6,+PO,6,AMNUM,3,CHNG)) Q:CHNG'>0 D
. S CHNG=^(CHNG,0)
. ;
. ;Has the data in any of the following fields been deleted?
. ;Ship To Address, Inv. Address, Prompt Pay. Terms, or F.O.B.Point.
. S TYPAM=$P($G(CHNG),U,2)
. I TYPAM=20,$P(^PRC(443.6,+PO,1),U,3)="" D
. . S MSG="Ship To Address."
. . S $P(^PRC(443.6,+PO,1),U,3)=$P(^PRC(442,+PO,1),U,3)
. I TYPAM=25,$P(^PRC(443.6,+PO,12),U,6)="" D
. . S MSG="Invoice Address."
. . S $P(^PRC(443.6,+PO,12),U,6)=$P(^PRC(442,+PO,12),U,6)
. I TYPAM=33,^PRC(443.6,+PO,5,0)="" D
. . S MSG="Prompt Payment Terms."
. . S ^PRC(443.6,+PO,5,0)=^PRC(442,+PO,5,0)
. . S I=0 F J=0:0 S I=$O(^PRC(443.6,+PO,5,I)) Q:I="" S ^PRC(443.6,+PO,5,I,0)=^PRC(442,+PO,5,I,0)
. . Q
. I TYPAM=35,$P(^PRC(443.6,+PO,1),U,6)="" D
. . S MSG="F.O.B. Point."
. . S $P(^PRC(443.6,+PO,1),U,6)=$P(^PRC(442,+PO,1),U,6)
. I $G(MSG)]"" D
. . I TYPAM=33&'PRPAYFLG!(TYPAM'=33) W !?10,"This amendment is missing it's ",MSG,"!" K MSG
. . I TYPAM=33 S PRPAYFLG=1
. . S STARTFLG=1
. Q
. ;
. I $P($P(CHNG,U,3),":",2)=40,($P($P(CHNG,U,3),";"))=1 S INUM=$P(CHNG,U,4) I $G(INUM)]"" D
. . ; for each item , check description
. . S J=0 S J=$O(^PRC(443.6,+PO,2,INUM,1,J)) I J>0&(^(J,0)="") D
. . . I CNT>22 N DIR S DIR(0)="E" D ^DIR S CNT=0
. . . W !,?10,"Line item ",INUM," is missing it's description!"
. . . S CNT=CNT+2,STARTFLG=1
. . . Q
. . Q
. Q
Q STARTFLG
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCFFU 6300 printed Sep 23, 2025@19:39:36 Page 2
PRCFFU ;WISC/SJG-CONTINUATION OF OBLIGATION PROCESSING ;7/21/93 13:51
V ;;5.1;IFCAP;**196**;Oct 20, 2000;Build 15
+1 ;Per VA Directive 6402, this routine should not be modified.
+2 ;
+3 ;PRC*5.1*196 Send order obligation date to GECS for creation
+4 ; of the SO document CTL segment with correct date
+5 QUIT
+6 ; No top level entry point
OKAY ;
+1 SET DIR(0)="Y"
SET DIR("A",1)="The information listed above is recorded on this "_PRCFA("IDES")_"."
+2 SET DIR("A")="Is the above information correct"
SET DIR("B")="YES"
+3 SET DIR("?")="Enter 'NO' or 'N' to edit the Cost Center or BOC."
+4 SET DIR("?",1)="Enter '^' to exit this option."
+5 SET DIR("?",2)="Enter 'YES' or 'Y' or 'RETURN' to continue processing this obligation."
+6 DO ^DIR
KILL DIR
+7 QUIT
+8 ;
OKAY2 ;
+1 SET DIR(0)="Y"
SET DIR("A")="OK to Continue"
SET DIR("B")="YES"
+2 SET DIR("?")="Enter 'NO' or 'N' or '^' to exit this option."
+3 SET DIR("?",1)="Enter 'YES' or 'Y' or 'RETURN' to continue processing this obligation."
+4 DO ^DIR
KILL DIR
+5 QUIT
+6 ;
EDIT ; Set up PRCFMO array to indicate required FMS fields
+1 SET PARAM1="^"_PRC("SITE")_"^"_+$PIECE(PO(0),U,3)_"^"_PRC("FY")_"^"_PRCFA("BBFY")
+2 ; build PRCFMO array to use when creating LIN string of FMS transaction
+3 ; PARAM1=^STATION^FCP^FY^BBFY
+4 ; SPE means spending documents
+5 DO DOCREQ^PRC0C(PARAM1,"SPE","PRCFMO")
+6 SET PRCFMO("G/N")=$PIECE(PRCFMO,U,12)
+7 QUIT
+8 ;
GO ; Prompt user for final go-ahead for the document creation
+1 SET PRCFA("FDES")=$SELECT(PRCFA("TT")="MO":"Miscellaneous Order (MO)",PRCFA("TT")="SO":"Service (SO) Order",PRCFA("TT")="AR":"Receiver Accrual (AR)")
+2 NEW POSIT
SET POSIT=$FIND(PRCFA("FDES"),"(")
+3 SET PRCFA("TYPE")=$EXTRACT(PRCFA("FDES"),POSIT,POSIT+1)
+4 SET DIR(0)="Y"
+5 SET DIR("A")="Transmit this Document to FMS"
+6 SET DIR("B")="YES"
+7 SET DIR("A",1)=" "
+8 SET DIR("A",2)="This "_PRCFA("IDES")_" will now generate the "
+9 SET DIR("A",3)=$PIECE(PRCFA("MOD"),U,3)_" "_PRCFA("FDES")_" Document. The "_PRCFA("TYPE")_" Document"
+10 SET DIR("A",4)="will be marked for transmission to FMS."
+11 SET DIR("A",5)=" "
+12 SET DIR("?")="Enter 'NO' or 'N' or '^' to exit this option."
+13 SET DIR("?",1)="Enter 'YES' or 'Y' or 'RETURN' to transmit this Document."
+14 DO ^DIR
KILL DIR
+15 QUIT
+16 ;
STACK(MOD) ; Create entry in GECS Stack File
+1 IF $DATA(PRCFA("CONVS"))
IF PRCFA("CONVS")=1
GOTO STACK1
+2 IF $DATA(PRCFA("CONVG"))
IF PRCFA("CONVG")=1
GOTO STACK1
+3 WRITE !!,"...now generating the FMS "
+4 WRITE $SELECT(PRCFA("TT")="MO":"Miscellaneous Order (MO) Document",PRCFA("TT")="SO":"Service Order (SO) Document",PRCFA("TT")="AR":"Receiver Accrual (AR) Document",1:"Document")
+5 WRITE "...",!
DO WAIT^DICD
STACK1 NEW FMSSYS,FMSSTA,FMSDOC,FMSTRA,FMSSEC,FMSMOD,FMSFCP,FMSDES,FMSCOMDT
+1 IF $DATA(PRCFA("RETRAN"))
IF PRCFA("RETRAN")=1
QUIT
+2 ; delete current ien to get new ien
KILL GECSUFMS("DA")
+3 SET FMSDES=PRCFA("IDES")
+4 SET FMSDOC=PRCFA("REF")
+5 SET FMSMOD=MOD
+6 IF PRCFA("TT")="AR"
Begin DoDot:1
+7 SET FMSDOC=FMSDOC_12
+8 SET FMSMOD=1
End DoDot:1
+9 SET FMSSEC=$$SEC1^PRC0C(PRC("SITE"))
+10 SET FMSSTA=PRC("SITE")
+11 SET FMSSYS="I"
+12 SET FMSTRA=PRCFA("TT")
+13 ;PRC*5.1*196
SET FMSCOMDT=PRCFA("OBLDATE")
+14 DO CONTROL^GECSUFMS(FMSSYS,FMSSTA,FMSDOC,FMSTRA,FMSSEC,FMSMOD,"Y",FMSDES,FMSCOMDT)
+15 QUIT
+16 ;
OKAM ; Reader for prompt to approve amendment
+1 SET DIR(0)="Y"
+2 SET DIR("A",1)="The information listed above is recorded on this Purchase Order amendment."
+3 SET DIR("A")="Are you ready to approve and obligate this amendment"
+4 SET DIR("B")="YES"
+5 SET DIR("?")="Enter 'NO' or 'N' or '^' to exit this option."
+6 SET DIR("?",1)="Enter 'YES' or 'Y' or 'RETURN' to continue processing this amendment obligation."
+7 DO ^DIR
KILL DIR
+8 QUIT
+9 ;
OKAPP ; Reader for prompt that amendment has already been approved
+1 SET DIR(0)="Y"
+2 SET DIR("A",1)="This amendment has already been approved by Fiscal."
+3 SET DIR("A")="Are you sure that you wish to continue"
+4 SET DIR("B")="NO"
+5 SET DIR("?")="Enter 'YES' or 'Y' to continue."
+6 SET DIR("?",1)="Enter 'NO' or 'N' or '^' or 'RETURN' to exit this option."
+7 DO ^DIR
KILL DIR
+8 QUIT
+9 ;
OKPRT ; Reader to prompt user to print the amendment
+1 SET DIR(0)="Y"
+2 SET DIR("A")="Would you like to print this amendment"
+3 SET DIR("B")="YES"
+4 SET DIR("?")="Enter 'YES' or 'Y' or 'RETURN' to print this amendment."
+5 SET DIR("?",1)="Enter 'NO' or 'N' or '^' if printing in not desired."
+6 DO ^DIR
KILL DIR
+7 QUIT
+8 ;
REVIEW ; Reader to prompt user to review the PO before obligation
+1 NEW LABEL
SET LABEL=$SELECT((PRCFA("MP")=1)!(PRCFA("MP")=2):"Purchase Order",PRCFA("MP")=8:"Requisition",1:"Purchase Order")
+2 SET DIR(0)="Y"
+3 SET DIR("A")="Would you like to review the entire "_LABEL
+4 SET DIR("B")="YES"
+5 SET DIR("?")="Enter 'NO' or 'N' or '^' if the "_LABEL_" review is not necessary."
+6 SET DIR("?",1)="Enter 'YES' or 'Y' or 'RETURN' to display the "_LABEL_"."
+7 DO ^DIR
KILL DIR
+8 QUIT
+9 ;
+10 ; PO is the ien of the 443.6 file
+11 ; AMNUM is the amendment number
CHKAMEN(PO,AMNUM) ; checks PO completeness, looks for missing data
+1 NEW CNT,J,INUM,CHNG,STARTFLG,TYPAM,MSG,PRPAYFLG
+2 SET CNT=0
+3 SET STARTFLG=0
+4 SET PRPAYFLG=0
+5 FOR CHNG=0:0
SET CHNG=$ORDER(^PRC(443.6,+PO,6,AMNUM,3,CHNG))
if CHNG'>0
QUIT
Begin DoDot:1
+6 SET CHNG=^(CHNG,0)
+7 ;
+8 ;Has the data in any of the following fields been deleted?
+9 ;Ship To Address, Inv. Address, Prompt Pay. Terms, or F.O.B.Point.
+10 SET TYPAM=$PIECE($GET(CHNG),U,2)
+11 IF TYPAM=20
IF $PIECE(^PRC(443.6,+PO,1),U,3)=""
Begin DoDot:2
+12 SET MSG="Ship To Address."
+13 SET $PIECE(^PRC(443.6,+PO,1),U,3)=$PIECE(^PRC(442,+PO,1),U,3)
End DoDot:2
+14 IF TYPAM=25
IF $PIECE(^PRC(443.6,+PO,12),U,6)=""
Begin DoDot:2
+15 SET MSG="Invoice Address."
+16 SET $PIECE(^PRC(443.6,+PO,12),U,6)=$PIECE(^PRC(442,+PO,12),U,6)
End DoDot:2
+17 IF TYPAM=33
IF ^PRC(443.6,+PO,5,0)=""
Begin DoDot:2
+18 SET MSG="Prompt Payment Terms."
+19 SET ^PRC(443.6,+PO,5,0)=^PRC(442,+PO,5,0)
+20 SET I=0
FOR J=0:0
SET I=$ORDER(^PRC(443.6,+PO,5,I))
if I=""
QUIT
SET ^PRC(443.6,+PO,5,I,0)=^PRC(442,+PO,5,I,0)
+21 QUIT
End DoDot:2
+22 IF TYPAM=35
IF $PIECE(^PRC(443.6,+PO,1),U,6)=""
Begin DoDot:2
+23 SET MSG="F.O.B. Point."
+24 SET $PIECE(^PRC(443.6,+PO,1),U,6)=$PIECE(^PRC(442,+PO,1),U,6)
End DoDot:2
+25 IF $GET(MSG)]""
Begin DoDot:2
+26 IF TYPAM=33&'PRPAYFLG!(TYPAM'=33)
WRITE !?10,"This amendment is missing it's ",MSG,"!"
KILL MSG
+27 IF TYPAM=33
SET PRPAYFLG=1
+28 SET STARTFLG=1
End DoDot:2
+29 QUIT
+30 ;
+31 IF $PIECE($PIECE(CHNG,U,3),":",2)=40
IF ($PIECE($PIECE(CHNG,U,3),";"))=1
SET INUM=$PIECE(CHNG,U,4)
IF $GET(INUM)]""
Begin DoDot:2
+32 ; for each item , check description
+33 SET J=0
SET J=$ORDER(^PRC(443.6,+PO,2,INUM,1,J))
IF J>0&(^(J,0)="")
Begin DoDot:3
+34 IF CNT>22
NEW DIR
SET DIR(0)="E"
DO ^DIR
SET CNT=0
+35 WRITE !,?10,"Line item ",INUM," is missing it's description!"
+36 SET CNT=CNT+2
SET STARTFLG=1
+37 QUIT
End DoDot:3
+38 QUIT
End DoDot:2
+39 QUIT
End DoDot:1
+40 QUIT STARTFLG
