| 1 | PRC0D ;WISC/PLT-IFCAP UTILITY ; 04/14/94 1:21 PM
|
|---|
| 2 | V ;;5.1;IFCAP;;Oct 20, 2000
|
|---|
| 3 | ;Per VHA Directive 10-93-142, this routine should not be modified.
|
|---|
| 4 | QUIT ;invalid entry
|
|---|
| 5 | ;
|
|---|
| 6 | ;A=station #,B=acc^prc0c string
|
|---|
| 7 | FMSACC(A,B) ;EF - value=field .01 of rile 420.141
|
|---|
| 8 | ;~1=station 3, ~2=bbbfy, ~3=fund code, ~4=a/o, ~5=program,
|
|---|
| 9 | ;~6=fcp/prj, ~7=object clas, ~8=job #
|
|---|
| 10 | N C
|
|---|
| 11 | S C=A,$P(C,"~",2)=$P(B,"^",6),$P(C,"~",3)=$P(B,"^",5)
|
|---|
| 12 | S $P(C,"~",4)=$P(B,"^"),$P(C,"~",5)=$P(B,"^",2),$P(C,"~",6)=$P(B,"^",3)
|
|---|
| 13 | S $P(C,"~",7)=$P(B,"^",4),$P(C,"~",8)=$P(B,"^",10)
|
|---|
| 14 | QUIT C
|
|---|
| 15 | ;
|
|---|
| 16 | ;A=station, B=fcp#, C=fy, D=1 if obligate balance, 2 if comm, 3 if scp comm
|
|---|
| 17 | ;return value data ^1=1st qtr bal, ^2=2nd, ^3=3rd, ^4=4th
|
|---|
| 18 | FCPBAL(A,B,C,D) ;EF get fcp balance
|
|---|
| 19 | S A=$G(^PRC(420,+A,1,+B,4,C,$S(D=3:1,1:0)))
|
|---|
| 20 | Q $S(D=1:$P(A,"^",6,9),1:$P(A,"^",2,5))
|
|---|
| 21 | ;
|
|---|
| 22 | ;A=station, B=fcp#
|
|---|
| 23 | ;return value 1=gpf, 2=supp, 3=casca/canteen
|
|---|
| 24 | SFCP(A,B) ;EF get special control point code
|
|---|
| 25 | Q $P($G(^PRC(420,+A,1,+B,0)),"^",12)
|
|---|
| 26 | ;
|
|---|
| 27 | ;A is data, ^1=nil,^2=station #,^3=fcp#,^4=fy,^5=bbfy
|
|---|
| 28 | FCPVAL(A) ;EF validate fcp, EF value=1 if invalid
|
|---|
| 29 | N PRCA,PRCB,B,C,Z
|
|---|
| 30 | D DOCREQ^PRC0C(A,"AB","PRCA"),DOCREQ^PRC0C(A,"SAB","PRCB")
|
|---|
| 31 | S Z=""
|
|---|
| 32 | S:'$P(PRCA,"^",9)!'$P(PRCA,"^",6) Z=1
|
|---|
| 33 | I 'Z F B=1:1:4 S C=$P("AO^PGM^FCPRJ^OC","^",B) S:$G(PRCA(C))="Y"!($G(PRCB(C))="Y")&($P(PRCA,"^",B)="")!($G(PRCA(C))="N"&($G(PRCB(C))="N")&($P(PRCA,"^",B)]"")) Z=1 QUIT:Z
|
|---|
| 34 | D:'Z
|
|---|
| 35 | . S C="" F B="SPE","REV","GL" S C=C_$$REQ^PRC0C($P(PRCA,"^",9),B,"JOB")
|
|---|
| 36 | . I C["Y",$P(PRCA,"^",10)="" S Z=1
|
|---|
| 37 | . I 'Z I C'["Y",$P(PRCA,"^",10)]"" S Z=1
|
|---|
| 38 | . QUIT
|
|---|
| 39 | QUIT Z
|
|---|
| 40 | ;
|
|---|
| 41 | ;A=station #, B data=^1 fcp1, ^2 fy, ^3 bbfy, ^4 fcp2
|
|---|
| 42 | FCPTRF(A,B) ;EF compare fms accounts value =1 if allow transfer
|
|---|
| 43 | N C,D,Z
|
|---|
| 44 | S Z=""
|
|---|
| 45 | S C=$$ACC^PRC0C(A,$P(B,"^",1,3)),D=$$ACC^PRC0C(A,$P(B,"^",4)_"^"_$P(B,"^",2,3))
|
|---|
| 46 | S B=$P(C,"^",8),C=$$FMSACC(A,C),D=$$FMSACC(A,D)
|
|---|
| 47 | I $P(C,"~",1,5)=$P(D,"~",1,5) S Z=1
|
|---|
| 48 | E I B="Y",$P(C,"~",1,4)=$P(D,"~",1,4) S Z=1
|
|---|
| 49 | QUIT Z
|
|---|
| 50 | ;
|
|---|
| 51 | ;A=fy, B=quarter
|
|---|
| 52 | QTRDATE(A,B) ;EF value=$$DATE^PRC0C - the first date of the quarter
|
|---|
| 53 | S A=$$YEAR^PRC0C(A)-(B<2),B=$P("10~1~4~7","~",B)_"/1/"_A
|
|---|
| 54 | QUIT $$DATE^PRC0C(B,"E")
|
|---|
| 55 | ;
|
|---|
| 56 | ;A=station #, B=fcp#, C=1 if display available year
|
|---|
| 57 | BBFY(A,B,C) ;EF value ~1=0-node of file 420.14, ~2=fcp bbfy, ~3=length of fund, ~4=default year
|
|---|
| 58 | N D,E,F,G,H,I,J
|
|---|
| 59 | S D=$G(^PRC(420,+A,1,+B,5)) I D="" QUIT ""
|
|---|
| 60 | S E=+$$DATE^PRC0C($P(D,"^",8),"I")
|
|---|
| 61 | S F=$$FUND^PRC0C($P(D,"^",1),E) I F="" QUIT ""
|
|---|
| 62 | S $P(F,"~",2)=E,G=$P(F,"^",5)-$P(F,"^",4)+1,$P(F,"~",3)=G
|
|---|
| 63 | S J=+$$DATE^PRC0C($H,"H")
|
|---|
| 64 | I G<2 D:C EN^DDIOL("Warning: Selected Fund Control Point has a single year fund with multi-appropriation set up.")
|
|---|
| 65 | F I=J:-1:J-G+1 Q:I-E#G=0
|
|---|
| 66 | S E=I,I="" F H=-3*G+E:G:3*G+E S I=I_H_" " S:H'>J $P(F,"~",4)=H
|
|---|
| 67 | D:C EN^DDIOL("Enter a year in the following sequence of years.")
|
|---|
| 68 | D:C EN^DDIOL("..."_I_"...")
|
|---|
| 69 | QUIT F
|
|---|
