source: WorldVistAEHR/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRC0F.m@ 1500

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

initial load of WorldVistAEHR

File size: 2.9 KB
Line 
1PRC0F ;WISC/PLT/BGJ-IFCAP A/E/D FILE UTILITY ;10/19/95 9:15 AM
2V ;;5.1;IFCAP;**28**;Oct 20, 2000
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4 QUIT ;invalid entry
5 ;
6DINUM ;called from ^dd(,.01,0)
7 S DINUM=+X
8 QUIT
9 ;
10INP411 ;
11 ;Entry for 'Station Number'(D0) must match entry for 'Station'(X)
12 I $G(D0),X'=D0 S X="" Q
13 N Y
14 S Y="" I X?3N D DIC^PRCFU S:+Y<1 X="" I +Y>0 S:$P(^DIC(4,+Y,99),U)?3N PRCF("INST")=+Y,X=$P(^DIC(4,+Y,99),U),DINUM=X S:$P(^DIC(4,+Y,99),U)'?3N X=""
15 QUIT
16 ;
17 ;add FMS sub-allowance account in file 420.141
18 ;PRCA is data ~1=station #,~2=bbfy,~3=fund,~4=a/o,~5=program
19 ; ~6=fcp/prj,~7=object class,~8=job
20 ;PRCB=fund control number
21A420D141(PRCA,PRCB) ;add new record in file 420.141
22 S $P(PRCA,"~",2)=$P($$YEAR^PRC0C($P(PRCA,"~",2)),"^",1)
23 S PRCA("DR")="1///"_PRCB
24 D ADD^PRC0B1(.PRCA,.A,"420.141;^PRCD(420.141,")
25 QUIT A
26 ;
27 ;get appropriation for file 421 TDAs
28 ;A - DA number B - Station Number
29 ;C - four digit BBFY D - two digit fiscal year
30 ;E - fund control point
31 ;F - returns site-fiscal year-appropriation-program
32APP421(A) ; determine appropriation for file 421
33 N B,C,D,E,F,X
34 S X=^PRCF(421,A,0)
35 S B=$P(X,"-"),D=$P(X,"-",2),E=$P(+$P(X,"^",2)," ")
36 S C=$E($P(X,"^",23),2,3),C=+$$YEAR^PRC0C(C)
37 S F=$$ACC^PRC0C(B,E_"^"_D_"^"_C),F=B_"-"_D_"-"_$P(F,"^",11)_"-"_$P(F,"^",5)_"-"_$P(F,"^",2)
38 QUIT F
39 ;
40 ;PRCA DATA ^1=STATION #, ^2=CP #, ^3=txn type code (410,1)
41 ; ^4= form type # (optional), ^5 obl date, ^6=obl amt, ^7 p.o/obl # free text (410,24)
42 ; ^8= prority of request (410,7.5) optional
43 ; ^9=FILE 442 ri (optional), ^10=fy/qtr date
44 ; ^11=BBFY (4-DIGIT)
45 ;.x - returned value = file 410 ri
46A410(X,PRCA) ;add obligated entry in file 410
47 N PRC,PRCIRI,PRCB
48 N A,B,Y,Z
49 K X
50 S:$P(PRCA,"^",8)="" $P(PRCA,"^",8)="ST"
51 S PRC("SITE")=$P(PRCA,"^"),PRCRI(420)=+PRC("SITE"),PRCRI(420.01)=+$P(PRCA,"^",2)
52 S PRC("CP")=$P($G(^PRC(420,PRCRI(420),1,PRCRI(420.01),0)),"^")
53 S PRCB=$S($P(PRCA,"^",10):$P(PRCA,"^",10),1:$P(PRCA,"^",5))
54 S PRCB=$$DATE^PRC0C(PRCB,"I"),PRC("FY")=$E(PRCB,3,4),PRC("QTR")=$P(PRCB,"^",2)
55 S PRC("BBFY")=$S($P(PRCA,"^",11):$P(PRCA,"^",11),1:$$BBFY^PRCSUT(PRC("SITE"),PRC("FY"),PRC("CP"),1))
56 S X=PRC("SITE")_"-"_PRC("FY")_"-"_$P(PRC("CP")," ")
57 S Z=PRC("SITE")_"-"_PRC("FY")_"-"_PRC("QTR")_"-"_$P(PRC("CP")," ")
58 D EN1^PRCSUT3,EN2^PRCSUT3 S:'$D(DA) DA="" S PRCRI(410)=DA
59 I 'PRCRI(410) S X=PRCRI(410) QUIT
60 S X="1////"_$P(PRCA,"^",3)_";3////"_$P(PRCA,"^",4)_";5////"_$P(PRCA,"^",5)_";7.5////"_$P(PRCA,"^",8)_";7////"_$P(PRCA,"^",5)_";30////"_$P(PRCA,"^",6)_";40////"_$G(DUZ)_";450////O"
61 S X(1,410,1)="26////"_$P(PRCA,"^",5)_";25////"_$P(PRCA,"^",6)_";23////"_$P(PRCA,"^",5)_";24////"_$P(PRCA,"^",7)
62 D EDIT^PRC0B(.X,"410;^PRCS(410,;"_PRCRI(410),"")
63 I $G(PRCFA("PODA"))'="",$P($G(^PRC(442,PRCFA("PODA"),0)),"^",2)=25 F I=1,3,8 S $P(^PRCS(410,PRCRI(410),4),"^",I)=0
64 S X=PRCRI(410)
65 K I QUIT
Note: See TracBrowser for help on using the repository browser.