- PRCFFM2M ;WOIFO/SJG/AS-ROUTINE TO PROCESS OBLIGATIONS ;3/8/05
- V ;;5.1;IFCAP;**81,120**;Oct 20, 2000;Build 27
- ;Per VHA Directive 2004-038, this routine should not be modified.
- ;
- SUPP ; Entry point for FMS Documents for Supply Fund Special Control Point
- ; Amendments
- ; Called from PRCHMA
- S DIC("S")="I +^(0)=PRC(""SITE"")",DIC=442,DIC(0)="NZ",X=PRCHPO
- D ^DIC K DIC G:+Y<0 EXIT
- S (XRBLD,FLG)=0,PO(0)=Y(0),PO=Y,PRCFA("PODA")=+Y,PCP=+$P(PO(0),"^",3),$P(PCP,"^",2)=$S($D(^PRC(420,PRC("SITE"),1,+PCP,0)):$P(^(0),"^",12),1:"")
- S MTOP=$P(^PRC(442,PRCFA("PODA"),0),"^",2)
- I $P($G(^PRC(443.6,PRCHPO,6,PRCHAM,1)),U,2)="" W !!,"PURCHASE ORDER HAS NOT BEEN PROPERLY SIGNED BY THE PURCHASING AGENT" Q
- D DT442^PRCFFUD1(PRCHPO,PO(0),443.6,PRCHAM)
- ;S PRCFA("OBLDATE")=$$EN^PRCFFUD1() D ENSFM^PRCFFMO2
- S PRCFA("OBLDATE")=$$DTOBL^PRCFFUD1(PRC("RBDT"),PRC("PODT"))
- S PRCFA("BBFY")=$$BBFY^PRCFFU5(+PO) ;D BBFYCHK^PRCFFU19(+PO)
- D GENDIQ^PRCFFU7(442,+PO,".1;.07;.03;17","IEN","")
- S IDFLAG="I",PRCFA("AMEND#")=PRCHAM
- N PARAM S PARAM=+PCP_"^"_PRC("FY")_"^"_PRCFA("BBFY")
- S PRCFMO=$$ACC^PRC0C(PRC("SITE"),PARAM)
- S PRCFA("MOD")="M^1^Modification Entry"
- S PRCFA("DLVDATE")=+$P(^PRC(442,PRCFA("PODA"),0),"^",10)
- S PRCFA("IDES")="Purchase Order Amendment Obligation"
- S PRCFA("REF")=$P(PO(0),U),PRCFA("SYS")="FMS"
- S PRCFA("SFC")=$P(PO(0),U,19),PRCFA("MP")=$P(PO(0),U,2)
- S PRCFA("TT")=$S(PRCFA("MP")=2:"SO",PRCFA("MP")=1:"MO",PRCFA("MP")=8:"MO",1:"MO")
- TRANS ; Transfer amendment entry from work file to Purchase Order file
- W !!,"...copying amendment information back to Purchase Order file...",! D WAIT^DICD
- D DT442^PRCFFUD1(PRCFA("PODA"),PO(0),442,"")
- S PRCOAMT=+^PRC(442,PRCFA("PODA"),0),$P(PRCOAMT,"^",2)=+$P(^(0),"^",3),$P(PRCOAMT,"^",3)=PRC("FYQDT"),$P(PRCOAMT,"^",5)=-$P(^(0),"^",$P(PRCFMO,"^",12)="N"+15)
- S ERFLAG=""
- D CHECK^PRCHAMYA(PRCFA("PODA"),PRCFA("AMEND#"),.ERFLAG)
- I ERFLAG W !!,"...ERROR IN COPYING AMENDMENT INFORMATION BACK TO PURCHASE ORDER FILE..." D MSG G EXIT
- D DT442^PRCFFUD1(PRCFA("PODA"),PO(0),442,PRCFA("AMEND#"))
- ; transmit amendment from IFCAP to DynaMed **81**
- D:$$GET^XPAR("SYS","PRCV COTS INVENTORY",1)=1 ENT^PRCVPOU(PRCFA("PODA"),PRCFA("AMEND#"))
- S PRCFA("OLDPODA")=PRCFA("PODA"),PRCFA("OLDREF")=PRCFA("REF")
- N PARAM S PARAM="^"_PRC("SITE")_"^"_+PCP_"^"_PRC("FY")_"^"_PRCFA("BBFY")
- D DOCREQ^PRC0C(PARAM,"SPE","PRCFMO")
- S (PRCFA("G/N"),PRCFMO("G/N"))=$P(PRCFMO,U,12)
- D LIST^PRCFFU7(PRCFA("PODA"),PRCFA("AMEND#"))
- ;PRC*5.1*120 => AUTOOBLG (set in PRCHSWCH) controls auto obligation of FCP UNOBL $$
- I MTOP'=25,($P($G(^PRC(442,PRCFA("PODA"),0)),U,19)=2!($G(AUTOOBLG)=1)),$G(PRCFA("AUTHE"))=1 D AMEND^PRCFFUD,FCP^PRCFFU11 G EXIT
- I MTOP'=25,'PRCFA("MOMREQ") D MSG^PRCFFU8 G EXIT
- D AMEND^PRCFFUD
- I MTOP'=25 D STACK^PRCFFM1M
- D EXIT QUIT
- MSG W ! S X="No further processing is being taken on this obligation.*" D MSG^PRCFQ
- Q
- EXIT K %,AMT,C1,C,D0,DA,DI,DIC,DEL,E,I,J,N1,N2,POP,PO,PODA,PRCFA,PRCFQ,MTOP,AUTOOBLG
- K PTYPE,T,T1,TIME,TRDA,Y,Z,Z5,ZX
- K PODATE,P,MO,GECSFMS
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCFFM2M 3060 printed Jan 18, 2025@03:04:38 Page 2
- PRCFFM2M ;WOIFO/SJG/AS-ROUTINE TO PROCESS OBLIGATIONS ;3/8/05
- V ;;5.1;IFCAP;**81,120**;Oct 20, 2000;Build 27
- +1 ;Per VHA Directive 2004-038, this routine should not be modified.
- +2 ;
- SUPP ; Entry point for FMS Documents for Supply Fund Special Control Point
- +1 ; Amendments
- +2 ; Called from PRCHMA
- +3 SET DIC("S")="I +^(0)=PRC(""SITE"")"
- SET DIC=442
- SET DIC(0)="NZ"
- SET X=PRCHPO
- +4 DO ^DIC
- KILL DIC
- if +Y<0
- GOTO EXIT
- +5 SET (XRBLD,FLG)=0
- SET PO(0)=Y(0)
- SET PO=Y
- SET PRCFA("PODA")=+Y
- SET PCP=+$PIECE(PO(0),"^",3)
- SET $PIECE(PCP,"^",2)=$SELECT($DATA(^PRC(420,PRC("SITE"),1,+PCP,0)):$PIECE(^(0),"^",12),1:"")
- +6 SET MTOP=$PIECE(^PRC(442,PRCFA("PODA"),0),"^",2)
- +7 IF $PIECE($GET(^PRC(443.6,PRCHPO,6,PRCHAM,1)),U,2)=""
- WRITE !!,"PURCHASE ORDER HAS NOT BEEN PROPERLY SIGNED BY THE PURCHASING AGENT"
- QUIT
- +8 DO DT442^PRCFFUD1(PRCHPO,PO(0),443.6,PRCHAM)
- +9 ;S PRCFA("OBLDATE")=$$EN^PRCFFUD1() D ENSFM^PRCFFMO2
- +10 SET PRCFA("OBLDATE")=$$DTOBL^PRCFFUD1(PRC("RBDT"),PRC("PODT"))
- +11 ;D BBFYCHK^PRCFFU19(+PO)
- SET PRCFA("BBFY")=$$BBFY^PRCFFU5(+PO)
- +12 DO GENDIQ^PRCFFU7(442,+PO,".1;.07;.03;17","IEN","")
- +13 SET IDFLAG="I"
- SET PRCFA("AMEND#")=PRCHAM
- +14 NEW PARAM
- SET PARAM=+PCP_"^"_PRC("FY")_"^"_PRCFA("BBFY")
- +15 SET PRCFMO=$$ACC^PRC0C(PRC("SITE"),PARAM)
- +16 SET PRCFA("MOD")="M^1^Modification Entry"
- +17 SET PRCFA("DLVDATE")=+$PIECE(^PRC(442,PRCFA("PODA"),0),"^",10)
- +18 SET PRCFA("IDES")="Purchase Order Amendment Obligation"
- +19 SET PRCFA("REF")=$PIECE(PO(0),U)
- SET PRCFA("SYS")="FMS"
- +20 SET PRCFA("SFC")=$PIECE(PO(0),U,19)
- SET PRCFA("MP")=$PIECE(PO(0),U,2)
- +21 SET PRCFA("TT")=$SELECT(PRCFA("MP")=2:"SO",PRCFA("MP")=1:"MO",PRCFA("MP")=8:"MO",1:"MO")
- TRANS ; Transfer amendment entry from work file to Purchase Order file
- +1 WRITE !!,"...copying amendment information back to Purchase Order file...",!
- DO WAIT^DICD
- +2 DO DT442^PRCFFUD1(PRCFA("PODA"),PO(0),442,"")
- +3 SET PRCOAMT=+^PRC(442,PRCFA("PODA"),0)
- SET $PIECE(PRCOAMT,"^",2)=+$PIECE(^(0),"^",3)
- SET $PIECE(PRCOAMT,"^",3)=PRC("FYQDT")
- SET $PIECE(PRCOAMT,"^",5)=-$PIECE(^(0),"^",$PIECE(PRCFMO,"^",12)="N"+15)
- +4 SET ERFLAG=""
- +5 DO CHECK^PRCHAMYA(PRCFA("PODA"),PRCFA("AMEND#"),.ERFLAG)
- +6 IF ERFLAG
- WRITE !!,"...ERROR IN COPYING AMENDMENT INFORMATION BACK TO PURCHASE ORDER FILE..."
- DO MSG
- GOTO EXIT
- +7 DO DT442^PRCFFUD1(PRCFA("PODA"),PO(0),442,PRCFA("AMEND#"))
- +8 ; transmit amendment from IFCAP to DynaMed **81**
- +9 if $$GET^XPAR("SYS","PRCV COTS INVENTORY",1)=1
- DO ENT^PRCVPOU(PRCFA("PODA"),PRCFA("AMEND#"))
- +10 SET PRCFA("OLDPODA")=PRCFA("PODA")
- SET PRCFA("OLDREF")=PRCFA("REF")
- +11 NEW PARAM
- SET PARAM="^"_PRC("SITE")_"^"_+PCP_"^"_PRC("FY")_"^"_PRCFA("BBFY")
- +12 DO DOCREQ^PRC0C(PARAM,"SPE","PRCFMO")
- +13 SET (PRCFA("G/N"),PRCFMO("G/N"))=$PIECE(PRCFMO,U,12)
- +14 DO LIST^PRCFFU7(PRCFA("PODA"),PRCFA("AMEND#"))
- +15 ;PRC*5.1*120 => AUTOOBLG (set in PRCHSWCH) controls auto obligation of FCP UNOBL $$
- +16 IF MTOP'=25
- IF ($PIECE($GET(^PRC(442,PRCFA("PODA"),0)),U,19)=2!($GET(AUTOOBLG)=1))
- IF $GET(PRCFA("AUTHE"))=1
- DO AMEND^PRCFFUD
- DO FCP^PRCFFU11
- GOTO EXIT
- +17 IF MTOP'=25
- IF 'PRCFA("MOMREQ")
- DO MSG^PRCFFU8
- GOTO EXIT
- +18 DO AMEND^PRCFFUD
- +19 IF MTOP'=25
- DO STACK^PRCFFM1M
- +20 DO EXIT
- QUIT
- MSG WRITE !
- SET X="No further processing is being taken on this obligation.*"
- DO MSG^PRCFQ
- +1 QUIT
- EXIT KILL %,AMT,C1,C,D0,DA,DI,DIC,DEL,E,I,J,N1,N2,POP,PO,PODA,PRCFA,PRCFQ,MTOP,AUTOOBLG
- +1 KILL PTYPE,T,T1,TIME,TRDA,Y,Z,Z5,ZX
- +2 KILL PODATE,P,MO,GECSFMS
- +3 QUIT