Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: PRCFFMOM

PRCFFMOM.m

Go to the documentation of this file. 
  1. PRCFFMOM ;WOIFO/SJG/AS-ROUTINE TO PROCESS AMENDMENT OBLIGATIONS ;3/8/05
  1. V ;;5.1;IFCAP;**81,180**;Oct 20, 2000;Build 5
  1.  ;Per VHA Directive 2004-038, this routine should not be modified.
  1.  ;
  1.  ;PRC*5.1*180 Added check for Delivery Date change to send document
  1.  ;            to FMS
  1.  ;
  1.  D ^PRCFSITE Q:'%  ; ask station
  1.  D OUT1 ; kill variables
  1.  ;
  1.  ; prompt for signature (E-Sig code for amendment)
  1.  S MESSAGE=""
  1.  D ESIG^PRCUESIG(DUZ,.MESSAGE)
  1.  I MESSAGE<1 D  G OUT1 ; exit if bad response
  1.  . I (MESSAGE=0)!(MESSAGE=-3) W !,$C(7),"  SIGNATURE CODE FAILURE " R X:3 ;3 TRIES or NO SIG ON FILE
  1.  . I (MESSAGE=-1)!(MESSAGE=-2) Q  ;ARROWED OUT or TIMED OUT
  1.  ;
  1. START ; get PO#
  1.  K PRCFA
  1.  K DIC("A")
  1.  S D="E"
  1.  S DIC=443.6
  1.  S DIC("S")="I +^(0)=PRC(""SITE"") S FSO=$O(^PRC(443.6,""D"",+Y,0)) I FSO=26!(FSO=31)!(FSO=36)!(FSO=45)!(FSO=71)"
  1.  S DIC("A")="Select Purchase Order Number: "
  1.  S DIC(0)="AEQZ"
  1.  D IX^DIC
  1.  K DIC("S"),DIC("A")
  1.  K FSO
  1.  G:+Y<0 OUT1
  1.  S FLG=0
  1.  S PO=Y,PO(0)=Y(0)
  1.  S PRCFA("PODA")=+Y
  1.  S PRCFPODA=+Y
  1.  I '$D(^PRC(443.6,+PO,6)) D NOA G OUT1 ; PO has no amendments
  1.  I $P(^PRC(443.6,+PO,6,0),"^",4)<0 D NOA G OUT1 ; PO has no amendments
  1.  I '$$VERIFY^PRCHES5(PRCFPODA) D MSG1 G OUT1 ; tampered PO
  1.  ;
  1.  ; get amendment #
  1. AMEND S DIC="^PRC(443.6,"_+PO_",6,"
  1.  S DIC("A")="Select AMENDMENT: "
  1.  S DIC(0)="AEMNZQ"
  1.  D ^DIC
  1.  K DIC("A")
  1.  G:Y<0 OUT1
  1.  S PO(6)=Y(0)
  1.  S PO(6,1)=^PRC(443.6,+PO,6,+Y,1)
  1.  S PRCFA("AMEND#")=+Y
  1.  S PRCFAA=+Y
  1.  ;
  1. DESC ; verify amendment is complete
  1.  I $$CHKAMEN^PRCFFU(+PO,PRCFAA) W !,?15,"Return Amendment to A&MM.",! G START
  1.  I $P($G(PO(6,1)),U,2)="" D  G START
  1.  . W ! D EN^DDIOL("This amendment is still awaiting signature by A&MM!")
  1.  . W !
  1.  ;
  1.  ; set up variables used in this option
  1.  S PRCFA("RETRAN")=0
  1.  S D0=+PO
  1.  S D1=+Y
  1.  S PRCHPO=PRCFPODA
  1.  S PRCHAM=PRCFAA
  1.  D ^PRCHSF3 ; sets up PRCH("AM") array
  1.  D ^PRCHDAM ; display amendment info
  1.  D DT442^PRCFFUD1(PRCFPODA,PO(0),443.6,PRCFA("AMEND#")) ; set up PRC array
  1. RETRAN ; Entry point for rebuild/transmit
  1.  S PRCFA("MOD")="M^1^Modification Entry"
  1.  ;
  1.  ; check amendment record for availability
  1.  L +^PRC(443.6,PRCFPODA):1
  1.  I $T=0 D  G OUT1
  1.  . W $C(7),!
  1.  . D EN^DDIOL("This amendment is being obligated by another user!")
  1.  ;
  1.  I 'PRCFA("RETRAN"),$O(^PRC(443.6,PRCFPODA,6,PRCFAA,3,"AC",32,0)) N P2237 S P2237=$P(^PRC(443.6,PRCFPODA,0),U,12) I P2237>0 I '$$VERIFY^PRCSC2(P2237) D MSG1 G OUT1 ; tampered PO
  1.  ;
  1.  I PRCFA("RETRAN") D DT442^PRCFFUD1(PRCFPODA,PO(0),442,PRCFA("AMEND#"))
  1.  ;
  1.  I $G(PRCRGS)<1 D OVCOM^PRCFFU10 I PRCFA("OVCOM")=1!(PRCFA("OVCOM")=2) D POFAIL^PRCFFU10,MSG G OUT1
  1.  ;
  1.  S PCP=+$P(PO(0),U,3)
  1.  S $P(PCP,U,2)=$S($D(^PRC(420,PRC("SITE"),1,+PCP,0)):$P(^(0),U,12),1:"")
  1. APP W !
  1.  D OKAM^PRCFFU I 'Y!($D(DIRUT)) G AMEND ; ask OK to amend?
  1.  D SC^PRCFFUA1 ; display FCP, cost ctr, PO/Req#
  1.  D CPBAL^PRCFFUA1 ; display cost & balances
  1.  D GET^PRCFFUA1 ; display amended (BOC) info
  1.  S FATAL=0
  1.  D OK^PRCFFUA ; ask if above BOC info is correct
  1.  S SAVEY=Y
  1.  I Y D  S Y=SAVEY K SAVEY I FATAL=1 D MSG10^PRCFFUA3 G APP1
  1.  . D GETBOC^PRCFFUA4
  1.  . D CHKBOC^PRCFFUA4
  1.  I 'Y!($D(DIRUT)) D  I FISCEDIT G RETRAN
  1.  .S FISCEDIT=0
  1.  .I $D(DIRUT) D MSG9^PRCFFUA3 Q
  1.  .I 'Y D MSG8^PRCFFUA3,POAM^PRCFFUA Q
  1.  .Q
  1.  D KILL^PRCFFUA
  1. APP1 I FATAL=1 G:PRCFA("RETRAN")=0 START Q:PRCFA("RETRAN")=1
  1.  I $D(^PRC(443.6,+PO,6)),$P(PO(6,1),"^",5)'="" D   I 'Y!($D(DIRUT)) G OUT1
  1.  . W !
  1.  . D OKAPP^PRCFFU ; amendment approved, ask 'continue?'
  1. PRT W !
  1.  D OKPRT^PRCFFU S:Y FLG=1 ; print amendment
  1.  S PRCFA("AMEND#")=PRCFAA
  1.  S PRCFA("BBFY")=$$BBFY^PRCFFU5(+PO)
  1.  S PRCFA("IDES")="Purchase Order Amendment Obligation"
  1.  S PRCFA("MP")=$P(PO(0),U,2)
  1.  S PRCFA("PODA")=PRCFPODA
  1.  S PRCFA("REF")=$P(PO(0),U)
  1.  ; the following line commented out in PRC*5*179
  1.  ; S PRCFA("SFC")=$P(PO(0),U,19)
  1.  S PRCFA("SYS")="FMS"
  1.  S PRCFA("TT")=$S(PRCFA("MP")=2:"SO",1:"MO")
  1.  I $D(GECSDATA),$E($G(GECSDATA(2100.1,GECSDATA,.01,"E")),1,3)="AR-" S PRCFA("TT")="AR"
  1. PRT1 I PRCFA("MP")=2&(PRCFA("TT")="SO") D  G:ACCEDIT=1 PRT1
  1.  . W !
  1.  . D EN^PRCFFU16(+PO)
  1. PRT11 I $D(PRCFA("RETRAN")),PRCFA("RETRAN")=1 D  G PRT2
  1.  . D RETRANM^PRCFFMO2
  1.  . S Y=PRCFA("OBLDATE")
  1.  S Y=$$DTOBL^PRCFFUD1(PRC("RBDT"),PRC("AMENDT"))
  1. PRT2 D D^PRCFQ
  1.  S %DT="AEX"
  1.  S %DT("A")="Select Obligation Processing Date: "
  1.  S %DT("B")=Y
  1.  W !
  1.  D ^%DT
  1.  K %DT
  1.  I Y<0 D MSG H 3 G OUT1
  1.  S PRCFA("OBLDATE")=Y
  1.  S EXIT=0
  1.  D ENM^PRCFFMO2
  1.  I EXIT D MSG,KILL^PRCFFMO2 H 3 G OUT1
  1.  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 PRT11
  1.  D GENDIQ^PRCFFU7(442,+PO,".1;.07;.03;17","IEN","")
  1. EDIT ; Get budget/accounting elements
  1.  N PARAM
  1.  S PARAM=+$P(PO(0),U,3)_"^"_PRC("FY")_"^"_PRCFA("BBFY")
  1.  S PRCFMO=$$ACC^PRC0C(PRC("SITE"),PARAM)
  1.  S IDFLAG="I"
  1.  S XRBLD=0
  1.  I PRCFA("RETRAN")=1 D EN^PRCFFUB ; if selected transaction to rebuild is a 'X' decrease or cancel, set XRBLD=1, set to 2 if it is the 'E'
  1.  ;
  1.  ; determine the correct transaction type if this is not an MO document
  1.  I PRCFA("TT")'="MO",XRBLD=0 D  I "^AR^SO^"'[("^"_$P(PRCFA("TT"),":",1)) D MSG,OUT1 Q
  1.  . N PRCFATT S PRCFATT=PRCFA("TT")
  1.  . D SOAR^PRC0E(PRCFA("PODA"),.PRCFATT,1) ; ask SO or AR, if appropriate
  1.  . S PRCFA("TT")=PRCFATT K PRCFATT
  1.  ;
  1.  I PRCFA("RETRAN")=1,$P(PRCFA("GECS"),"^")="AR",PRCFA("TT")="AR" D
  1.  . I $P(PRCFA("GECS"),"^",2)="E" S PRCFA("MOD")="E^0^Original Document"
  1.  . I $P(PRCFA("GECS"),"^",2)="M" S PRCFA("MOD")="M^1^Modification Document"
  1.  ;
  1.  I PRCFA("TT")="AR",XRBLD=0 D  I "EM"'[X D MSG,OUT1 Q
  1.  . S X="M"
  1.  . I PRCFA("RETRAN")=1,$P(PRCFA("GECS"),"^",2)="E" S X="E"
  1.  . D SC^PRC0A("",.Y,"Label document action as: ","AOM^E:Original Document;M:Modification Document",X)
  1.  . I $E(Y)="E" S PRCFA("MOD")="E^0^Original Document"
  1.  . I $E(Y)="M" S PRCFA("MOD")="M^1^Modification Document"
  1.  . S X=$E(Y)
  1.  . K Y
  1.  ;
  1.  ; check to see if transaction type or document type changed
  1.  S X=0
  1.  I XRBLD=0,$G(PRCFA("RETRAN"))=1,"^SO^AR"[("^"_$E(PRCFA("TT"),1,2)),$P(PRCFA("GECS"),"^",1,2)'=($E(PRCFA("TT"),1,2)_"^"_$E(PRCFA("MOD"))) D  I X="^" D MSG,PAUSE^PRCFFERU G OUT1
  1.  . S PRCFA("SIS")=$$GETTXNS^PRCFFERT(PO,PRCFA("AMEND#"),2) ; get other txns for this amendment
  1.  . S X=$$NEWCHK^PRCFFERT(PRCFA("TT"),$E(PRCFA("MOD"),1),PRCFA("SIS")) ; does selected txn exist?
  1.  . I X=0 S PRCFA("RETRAN")=2 ; txn doesn't exist, create
  1.  . I X'=0 S X=$$SWITCH^PRCFFERT(X,2,.GECSDATA) ; replace current GECSDATA values with values belonging to selected txn-- returns '^' if not switched
  1.  ;
  1. GO ; Prompt user for for final go-ahead for approval
  1.  D GO^PRCFFU
  1.  I 'Y!($D(DIRUT)) D MSG,OUT1 Q
  1. ESIG W !,"The Electronic Signature must now be entered to generate the "_PRCFA("TYPE")_" Document.",!
  1.  D SIG^PRCFFU4
  1.  I $D(PRCFA("SIGFAIL")) K PRCFA("SIGFAIL") H 3 G OUT1
  1.  S DA=PRCFA("PODA")
  1.  D REMOVE^PRCHES14(PRCFA("PODA"),PRCFA("AMEND#"))
  1.  S MESSAGE="" ; value not used but variable is needed by next call
  1.  D ENCODE^PRCHES14(PRCFA("PODA"),PRCFA("AMEND#"),DUZ,.MESSAGE)
  1.  ;
  1.  D DT442^PRCFFUD1(PRCFA("PODA"),"",442,PRCFA("AMEND#"))
  1.  S PRCOAMT=+^PRC(442,PRCFA("PODA"),0)
  1.  S $P(PRCOAMT,"^",2)=+$P(^PRC(442,PRCFA("PODA"),0),"^",3)
  1.  S $P(PRCOAMT,"^",3)=PRC("FYQDT")
  1.  S $P(PRCOAMT,"^",5)=-$P(^PRC(442,PRCFA("PODA"),0),"^",$P(PRCFMO,"^",12)="N"+15)
  1.  I $D(PRCFA("RETRAN")),PRCFA("RETRAN")>0 G TRANS1
  1. TRANS W !!,"...copying amendment information back to Purchase Order file...",! D WAIT^DICD
  1.  S ERFLAG=""
  1.  S PRCFA("DLVDATE")=$P(^PRC(442,PRCFA("PODA"),0),"^",10)
  1.  D CHECK^PRCHAMYA(PRCFA("PODA"),PRCFA("AMEND#"),.ERFLAG)
  1.  I ERFLAG W !!,"...ERROR IN COPYING AMENDMENT INFORMATION BACK TO PURCHASE ORDER FILE..." G OUT1
  1. TRANS1 D DT442^PRCFFUD1(PRCFA("PODA"),"",442,PRCFA("AMEND#"))
  1.  ;  transmit amendment from IFCAP to DynaMed   **81**
  1.  I $$GET^XPAR("SYS","PRCV COTS INVENTORY",1)=1 D
  1.  . ; No DynaMed interface if rebuild/retransmit
  1.  . I $D(PRCFA("RETRAN")),PRCFA("RETRAN")>0 Q
  1.  . D ENT^PRCVPOU(PRCFA("PODA"),PRCFA("AMEND#"))
  1.  S PRCFA("OLDPODA")=PRCFA("PODA")
  1.  S PRCFA("OLDREF")=PRCFA("REF")
  1.  I PRCFA("RETRAN")>0 I XRBLD=1!(XRBLD=2) D GO^PRCFFUB H 3 Q  ; if rebuilding a 'dependent' transaction, finish work here
  1.  D LIST^PRCFFU7(PRCFA("PODA"),PRCFA("AMEND#"))
  1.  I $P(^PRC(442,PRCFA("PODA"),0),U,20),($P(^PRC(442,PRCFA("PODA"),0),U,10)'=$P(^PRC(442,PRCFA("PODA"),0),U,20)) D       ;PRC*5.1*180 Check for Del Date change, if so, send doc to FMS
  1.  . S PRCFA("MOMREQ")=1,PRCFA("MOMNOTREQ")=0,PRCFA("ZERO")=""                      ;PRC*5.1*180 reset flag to send doc
  1.  I $G(PRCFA("RETRAN"))<1 D AMEND^PRCFFUD ; create entry in 410
  1.  I PRCFA("AUTHE") D FCP^PRCFFU11,PRINT G START
  1.  I 'PRCFA("MOMREQ") D MSG^PRCFFU8 G PRINT ; skip FMS transmit,fiscal updates
  1.  I $D(PRCFA("RETRAN")),PRCFA("RETRAN")=1 D SETPO^PRCFFERT
  1.  I $G(PRCFA("ACCEDIT"))=1 D TAG33^PRCFFU9
  1. TRANS2 K PO
  1.  D ^PRCFFM1M
  1.  L -^PRC(443.6,PRCFA("PODA"))
  1.  I $D(PRCFA("RETRAN")),PRCFA("RETRAN")=0 D OUT1^PRCFFM1M G START
  1.  QUIT
  1.  ;
  1. PRINT ; Print out copy of Purchase Order Amendment
  1.  G:'FLG OUT1
  1.  S PRCHQ="^PRCHPAM"
  1.  S PRCHQ("DEST")="S8"
  1.  S D0=PRCFA("PODA")
  1.  S D1=PRCFA("AMEND#")
  1.  D ^PRCHQUE
  1. OUT1 K FATAL,FLG,%,%Y,DIC,I,J,K,P,PRCFA,PRCFAA,PRCFPODA,PRCFCHG,X,XRBLD,Y,Z
  1.  Q
  1.  ; Message processing
  1. NOA D NOA^PRCFFM3M Q
  1. MSG D MSG^PRCFFM3M Q
  1. MSG1 D MSG1^PRCFFM3M Q