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

PRCFFU5.m

Go to the documentation of this file.
  1. PRCFFU5 ;WISC/SJG-OBLIGATION PROCESSING UTILITIES ;
  1. ;;5.1;IFCAP;;Oct 20, 2000
  1. ;Per VHA Directive 10-93-142, this routine should not be modified.
  1. ;
  1. QUIT
  1. FMSFCP(REQST,SPFCP,MP) ;
  1. ; REQST - 2237 Request
  1. ; MP - Method of Processing
  1. ; SPFCP - Supply Fund Control Point
  1. ; FLAG - Flag to indicate if CP has been updated
  1. ; - Flag = "Y" when FCP has been updated
  1. ; - Flag = "N" when FCP has not been updated
  1. ;
  1. N FLAG S FLAG="N"
  1. ; if supp fund, if meth of proc=cert, if 2237 req on PO, then flag="Y"
  1. ; if supp fund, if meth of proc=cert, if no 2237 req on PO, then flag ="N"
  1. I SPFCP=2,MP=2 S FLAG=$S($G(REQST):"Y",1:"N")
  1. ;
  1. ; if supp fund, if meth of proc'=cert, if 2237 request on PO, then flag="N"
  1. I SPFCP=2,MP'=2,$G(REQST) S FLAG="N"
  1. ;
  1. ; if not supp fund, if 2237 request on PO, then flag="Y"
  1. ; if not supp fund, if 2237 request not on PO, then flag="N"
  1. I SPFCP'=2 S FLAG=$S($G(REQST):"Y",1:"N")
  1. QUIT FLAG
  1. ;
  1. ASKSITE(FLAG) ; Interface with GECS to prompt for station/fcp
  1. N X,Y S ERROR=0
  1. D ^PRCSUT
  1. I '$D(PRC("SITE")) S ERROR=1 G EXIT
  1. I '$D(PRC("CP")) S ERROR=1 G EXIT
  1. S BUDSTR=$$ACC^PRC0C(PRC("SITE"),$P(PRC("CP")," ",1))
  1. EXIT QUIT
  1. ;
  1. NODE22 ; Called from PRCH58OB to build Node 22 for 1358 Obligations
  1. K PRCTMP
  1. N DA S DIC=442,DA=+PO,DIQ="PRCTMP(",DR="3;3.4;4;4.4;13;13.05" D EN^DIQ1 K DIC,DIQ,DR
  1. K NODE S NODE=$G(^PRC(442,DA,22,0)) I NODE="" S ^PRC(442,DA,22,0)="^"_$P(^DD(442,41,0),U,2)
  1. S STR="3;3.4^4;4.4^13.05;13"
  1. F CTR=1:1:3 D
  1. .K SUBSTR
  1. .S SUBSTR=$P(STR,U,CTR)
  1. .S BOC=+$G(PRCTMP(442,DA,$P(SUBSTR,";",1)))
  1. .S AMT=$G(PRCTMP(442,DA,$P(SUBSTR,";",2)))
  1. .I BOC D
  1. ..S DA(1)=DA
  1. ..S DIC="^PRC(442,"_DA(1)_",22,",DIC(0)="L",X=BOC
  1. ..K DD,DO D FILE^DICN
  1. ..N DA S FMSL=CTR,DIE=DIC,DA=+Y,DR="1////^S X=AMT;2////^S X=FMSL" D ^DIE
  1. ..K X,Y,DIE,DIC,DR
  1. K PRCTMP,FMSL,NODE,STR,SUBSTR
  1. QUIT
  1. BBFY(PO) ; Get FMS Beginning Budget Fiscal Year
  1. K PRCTEMP
  1. N DA,BBFY S DIC=442,DA=+PO,DIQ="PRCTEMP(",DIQ(0)="IEN",DR=26
  1. D EN^DIQ1 K DIC,DIQ,DR
  1. S BBFY=$G(PRCTEMP(442,+PO,26,"E")),BBFY=$TR(BBFY," ")
  1. K PRCTEMP
  1. Q BBFY
  1. ;
  1. DELSCH(XDATE) ; Get the Delivery Date from the latest of either the P.O.
  1. ; Delivery Date or the latest date in the Delivery Schedule
  1. N LOOP,LOOP1,LOOP2
  1. S DELSCH(9999999-DELDATE)="^^"_XDATE
  1. I $D(^PRC(442.8,"AC",PRCFA("REF"))) D
  1. .S LOOP=0 F S LOOP=$O(^PRC(442.8,"AC",PRCFA("REF"),LOOP)) Q:LOOP'>0 D
  1. ..S LOOP1=0 F S LOOP1=$O(^PRC(442.8,"AC",PRCFA("REF"),LOOP,LOOP1)) Q:LOOP1'>0 D
  1. ...S DELSCH("A",LOOP1)=^PRC(442.8,LOOP1,0)
  1. ...S YDATE=$P(DELSCH("A",LOOP1),U,3),DELSCH(9999999-YDATE)=DELSCH("A",LOOP1)
  1. S LOOP2="" S DELSCHL=$O(DELSCH(LOOP2))
  1. S XDATE=$P(DELSCH(DELSCHL),U,3)
  1. K DELSCH,DELSCHL
  1. Q XDATE
  1. ;
  1. UPPER(X) ; Convert to 'UPPER' case
  1. Q $TR(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
  1. ;
  1. LOWER(X) ; Convert to 'lower' case
  1. Q $TR(X,"ABCDEFGHIJKLMNOPQRSTUVWXYZ","abcdefghijklmnopqrstuvwxyz")