| 1 | PRCFFU5 ;WISC/SJG-OBLIGATION PROCESSING UTILITIES ;
|
|---|
| 2 | ;;5.1;IFCAP;;Oct 20, 2000
|
|---|
| 3 | ;Per VHA Directive 10-93-142, this routine should not be modified.
|
|---|
| 4 | ;
|
|---|
| 5 | QUIT
|
|---|
| 6 | FMSFCP(REQST,SPFCP,MP) ;
|
|---|
| 7 | ; REQST - 2237 Request
|
|---|
| 8 | ; MP - Method of Processing
|
|---|
| 9 | ; SPFCP - Supply Fund Control Point
|
|---|
| 10 | ; FLAG - Flag to indicate if CP has been updated
|
|---|
| 11 | ; - Flag = "Y" when FCP has been updated
|
|---|
| 12 | ; - Flag = "N" when FCP has not been updated
|
|---|
| 13 | ;
|
|---|
| 14 | N FLAG S FLAG="N"
|
|---|
| 15 | ; if supp fund, if meth of proc=cert, if 2237 req on PO, then flag="Y"
|
|---|
| 16 | ; if supp fund, if meth of proc=cert, if no 2237 req on PO, then flag ="N"
|
|---|
| 17 | I SPFCP=2,MP=2 S FLAG=$S($G(REQST):"Y",1:"N")
|
|---|
| 18 | ;
|
|---|
| 19 | ; if supp fund, if meth of proc'=cert, if 2237 request on PO, then flag="N"
|
|---|
| 20 | I SPFCP=2,MP'=2,$G(REQST) S FLAG="N"
|
|---|
| 21 | ;
|
|---|
| 22 | ; if not supp fund, if 2237 request on PO, then flag="Y"
|
|---|
| 23 | ; if not supp fund, if 2237 request not on PO, then flag="N"
|
|---|
| 24 | I SPFCP'=2 S FLAG=$S($G(REQST):"Y",1:"N")
|
|---|
| 25 | QUIT FLAG
|
|---|
| 26 | ;
|
|---|
| 27 | ASKSITE(FLAG) ; Interface with GECS to prompt for station/fcp
|
|---|
| 28 | N X,Y S ERROR=0
|
|---|
| 29 | D ^PRCSUT
|
|---|
| 30 | I '$D(PRC("SITE")) S ERROR=1 G EXIT
|
|---|
| 31 | I '$D(PRC("CP")) S ERROR=1 G EXIT
|
|---|
| 32 | S BUDSTR=$$ACC^PRC0C(PRC("SITE"),$P(PRC("CP")," ",1))
|
|---|
| 33 | EXIT QUIT
|
|---|
| 34 | ;
|
|---|
| 35 | NODE22 ; Called from PRCH58OB to build Node 22 for 1358 Obligations
|
|---|
| 36 | K PRCTMP
|
|---|
| 37 | 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
|
|---|
| 38 | 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)
|
|---|
| 39 | S STR="3;3.4^4;4.4^13.05;13"
|
|---|
| 40 | F CTR=1:1:3 D
|
|---|
| 41 | .K SUBSTR
|
|---|
| 42 | .S SUBSTR=$P(STR,U,CTR)
|
|---|
| 43 | .S BOC=+$G(PRCTMP(442,DA,$P(SUBSTR,";",1)))
|
|---|
| 44 | .S AMT=$G(PRCTMP(442,DA,$P(SUBSTR,";",2)))
|
|---|
| 45 | .I BOC D
|
|---|
| 46 | ..S DA(1)=DA
|
|---|
| 47 | ..S DIC="^PRC(442,"_DA(1)_",22,",DIC(0)="L",X=BOC
|
|---|
| 48 | ..K DD,DO D FILE^DICN
|
|---|
| 49 | ..N DA S FMSL=CTR,DIE=DIC,DA=+Y,DR="1////^S X=AMT;2////^S X=FMSL" D ^DIE
|
|---|
| 50 | ..K X,Y,DIE,DIC,DR
|
|---|
| 51 | K PRCTMP,FMSL,NODE,STR,SUBSTR
|
|---|
| 52 | QUIT
|
|---|
| 53 | BBFY(PO) ; Get FMS Beginning Budget Fiscal Year
|
|---|
| 54 | K PRCTEMP
|
|---|
| 55 | N DA,BBFY S DIC=442,DA=+PO,DIQ="PRCTEMP(",DIQ(0)="IEN",DR=26
|
|---|
| 56 | D EN^DIQ1 K DIC,DIQ,DR
|
|---|
| 57 | S BBFY=$G(PRCTEMP(442,+PO,26,"E")),BBFY=$TR(BBFY," ")
|
|---|
| 58 | K PRCTEMP
|
|---|
| 59 | Q BBFY
|
|---|
| 60 | ;
|
|---|
| 61 | DELSCH(XDATE) ; Get the Delivery Date from the latest of either the P.O.
|
|---|
| 62 | ; Delivery Date or the latest date in the Delivery Schedule
|
|---|
| 63 | N LOOP,LOOP1,LOOP2
|
|---|
| 64 | S DELSCH(9999999-DELDATE)="^^"_XDATE
|
|---|
| 65 | I $D(^PRC(442.8,"AC",PRCFA("REF"))) D
|
|---|
| 66 | .S LOOP=0 F S LOOP=$O(^PRC(442.8,"AC",PRCFA("REF"),LOOP)) Q:LOOP'>0 D
|
|---|
| 67 | ..S LOOP1=0 F S LOOP1=$O(^PRC(442.8,"AC",PRCFA("REF"),LOOP,LOOP1)) Q:LOOP1'>0 D
|
|---|
| 68 | ...S DELSCH("A",LOOP1)=^PRC(442.8,LOOP1,0)
|
|---|
| 69 | ...S YDATE=$P(DELSCH("A",LOOP1),U,3),DELSCH(9999999-YDATE)=DELSCH("A",LOOP1)
|
|---|
| 70 | S LOOP2="" S DELSCHL=$O(DELSCH(LOOP2))
|
|---|
| 71 | S XDATE=$P(DELSCH(DELSCHL),U,3)
|
|---|
| 72 | K DELSCH,DELSCHL
|
|---|
| 73 | Q XDATE
|
|---|
| 74 | ;
|
|---|
| 75 | UPPER(X) ; Convert to 'UPPER' case
|
|---|
| 76 | Q $TR(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
|
|---|
| 77 | ;
|
|---|
| 78 | LOWER(X) ; Convert to 'lower' case
|
|---|
| 79 | Q $TR(X,"ABCDEFGHIJKLMNOPQRSTUVWXYZ","abcdefghijklmnopqrstuvwxyz")
|
|---|
