source: WorldVistAEHR/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCFFU5.m@ 619

Last change on this file since 619 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR

File size: 2.8 KB
Line 
1PRCFFU5 ;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
6FMSFCP(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 ;
27ASKSITE(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))
33EXIT QUIT
34 ;
35NODE22 ; 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
53BBFY(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 ;
61DELSCH(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 ;
75UPPER(X) ; Convert to 'UPPER' case
76 Q $TR(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
77 ;
78LOWER(X) ; Convert to 'lower' case
79 Q $TR(X,"ABCDEFGHIJKLMNOPQRSTUVWXYZ","abcdefghijklmnopqrstuvwxyz")
Note: See TracBrowser for help on using the repository browser.