- PRC0D ;WISC/PLT-IFCAP UTILITY ; 04/14/94 1:21 PM
- V ;;5.1;IFCAP;;Oct 20, 2000
- ;Per VHA Directive 10-93-142, this routine should not be modified.
- QUIT ;invalid entry
- ;
- ;A=station #,B=acc^prc0c string
- FMSACC(A,B) ;EF - value=field .01 of rile 420.141
- ;~1=station 3, ~2=bbbfy, ~3=fund code, ~4=a/o, ~5=program,
- ;~6=fcp/prj, ~7=object clas, ~8=job #
- N C
- S C=A,$P(C,"~",2)=$P(B,"^",6),$P(C,"~",3)=$P(B,"^",5)
- S $P(C,"~",4)=$P(B,"^"),$P(C,"~",5)=$P(B,"^",2),$P(C,"~",6)=$P(B,"^",3)
- S $P(C,"~",7)=$P(B,"^",4),$P(C,"~",8)=$P(B,"^",10)
- QUIT C
- ;
- ;A=station, B=fcp#, C=fy, D=1 if obligate balance, 2 if comm, 3 if scp comm
- ;return value data ^1=1st qtr bal, ^2=2nd, ^3=3rd, ^4=4th
- FCPBAL(A,B,C,D) ;EF get fcp balance
- S A=$G(^PRC(420,+A,1,+B,4,C,$S(D=3:1,1:0)))
- Q $S(D=1:$P(A,"^",6,9),1:$P(A,"^",2,5))
- ;
- ;A=station, B=fcp#
- ;return value 1=gpf, 2=supp, 3=casca/canteen
- SFCP(A,B) ;EF get special control point code
- Q $P($G(^PRC(420,+A,1,+B,0)),"^",12)
- ;
- ;A is data, ^1=nil,^2=station #,^3=fcp#,^4=fy,^5=bbfy
- FCPVAL(A) ;EF validate fcp, EF value=1 if invalid
- N PRCA,PRCB,B,C,Z
- D DOCREQ^PRC0C(A,"AB","PRCA"),DOCREQ^PRC0C(A,"SAB","PRCB")
- S Z=""
- S:'$P(PRCA,"^",9)!'$P(PRCA,"^",6) Z=1
- 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
- D:'Z
- . S C="" F B="SPE","REV","GL" S C=C_$$REQ^PRC0C($P(PRCA,"^",9),B,"JOB")
- . I C["Y",$P(PRCA,"^",10)="" S Z=1
- . I 'Z I C'["Y",$P(PRCA,"^",10)]"" S Z=1
- . QUIT
- QUIT Z
- ;
- ;A=station #, B data=^1 fcp1, ^2 fy, ^3 bbfy, ^4 fcp2
- FCPTRF(A,B) ;EF compare fms accounts value =1 if allow transfer
- N C,D,Z
- S Z=""
- S C=$$ACC^PRC0C(A,$P(B,"^",1,3)),D=$$ACC^PRC0C(A,$P(B,"^",4)_"^"_$P(B,"^",2,3))
- S B=$P(C,"^",8),C=$$FMSACC(A,C),D=$$FMSACC(A,D)
- I $P(C,"~",1,5)=$P(D,"~",1,5) S Z=1
- E I B="Y",$P(C,"~",1,4)=$P(D,"~",1,4) S Z=1
- QUIT Z
- ;
- ;A=fy, B=quarter
- QTRDATE(A,B) ;EF value=$$DATE^PRC0C - the first date of the quarter
- S A=$$YEAR^PRC0C(A)-(B<2),B=$P("10~1~4~7","~",B)_"/1/"_A
- QUIT $$DATE^PRC0C(B,"E")
- ;
- ;A=station #, B=fcp#, C=1 if display available year
- BBFY(A,B,C) ;EF value ~1=0-node of file 420.14, ~2=fcp bbfy, ~3=length of fund, ~4=default year
- N D,E,F,G,H,I,J
- S D=$G(^PRC(420,+A,1,+B,5)) I D="" QUIT ""
- S E=+$$DATE^PRC0C($P(D,"^",8),"I")
- S F=$$FUND^PRC0C($P(D,"^",1),E) I F="" QUIT ""
- S $P(F,"~",2)=E,G=$P(F,"^",5)-$P(F,"^",4)+1,$P(F,"~",3)=G
- S J=+$$DATE^PRC0C($H,"H")
- I G<2 D:C EN^DDIOL("Warning: Selected Fund Control Point has a single year fund with multi-appropriation set up.")
- F I=J:-1:J-G+1 Q:I-E#G=0
- S E=I,I="" F H=-3*G+E:G:3*G+E S I=I_H_" " S:H'>J $P(F,"~",4)=H
- D:C EN^DDIOL("Enter a year in the following sequence of years.")
- D:C EN^DDIOL("..."_I_"...")
- QUIT F
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRC0D 2834 printed Jan 18, 2025@03:00:29 Page 2
- PRC0D ;WISC/PLT-IFCAP UTILITY ; 04/14/94 1:21 PM
- V ;;5.1;IFCAP;;Oct 20, 2000
- +1 ;Per VHA Directive 10-93-142, this routine should not be modified.
- +2 ;invalid entry
- QUIT
- +3 ;
- +4 ;A=station #,B=acc^prc0c string
- FMSACC(A,B) ;EF - value=field .01 of rile 420.141
- +1 ;~1=station 3, ~2=bbbfy, ~3=fund code, ~4=a/o, ~5=program,
- +2 ;~6=fcp/prj, ~7=object clas, ~8=job #
- +3 NEW C
- +4 SET C=A
- SET $PIECE(C,"~",2)=$PIECE(B,"^",6)
- SET $PIECE(C,"~",3)=$PIECE(B,"^",5)
- +5 SET $PIECE(C,"~",4)=$PIECE(B,"^")
- SET $PIECE(C,"~",5)=$PIECE(B,"^",2)
- SET $PIECE(C,"~",6)=$PIECE(B,"^",3)
- +6 SET $PIECE(C,"~",7)=$PIECE(B,"^",4)
- SET $PIECE(C,"~",8)=$PIECE(B,"^",10)
- +7 QUIT C
- +8 ;
- +9 ;A=station, B=fcp#, C=fy, D=1 if obligate balance, 2 if comm, 3 if scp comm
- +10 ;return value data ^1=1st qtr bal, ^2=2nd, ^3=3rd, ^4=4th
- FCPBAL(A,B,C,D) ;EF get fcp balance
- +1 SET A=$GET(^PRC(420,+A,1,+B,4,C,$SELECT(D=3:1,1:0)))
- +2 QUIT $SELECT(D=1:$PIECE(A,"^",6,9),1:$PIECE(A,"^",2,5))
- +3 ;
- +4 ;A=station, B=fcp#
- +5 ;return value 1=gpf, 2=supp, 3=casca/canteen
- SFCP(A,B) ;EF get special control point code
- +1 QUIT $PIECE($GET(^PRC(420,+A,1,+B,0)),"^",12)
- +2 ;
- +3 ;A is data, ^1=nil,^2=station #,^3=fcp#,^4=fy,^5=bbfy
- FCPVAL(A) ;EF validate fcp, EF value=1 if invalid
- +1 NEW PRCA,PRCB,B,C,Z
- +2 DO DOCREQ^PRC0C(A,"AB","PRCA")
- DO DOCREQ^PRC0C(A,"SAB","PRCB")
- +3 SET Z=""
- +4 if '$PIECE(PRCA,"^",9)!'$PIECE(PRCA,"^",6)
- SET Z=1
- +5 IF 'Z
- FOR B=1:1:4
- SET C=$PIECE("AO^PGM^FCPRJ^OC","^",B)
- if $GET(PRCA(C))="Y"!($GET(PRCB(C))="Y")&($PIECE(PRCA,"^",B)="")!($GET(PRCA(C))="N"&($GET(PRCB(C))="N")&($PIECE(PRCA,"^",B)]""))
- SET Z=1
- if Z
- QUIT
- +6 if 'Z
- Begin DoDot:1
- +7 SET C=""
- FOR B="SPE","REV","GL"
- SET C=C_$$REQ^PRC0C($PIECE(PRCA,"^",9),B,"JOB")
- +8 IF C["Y"
- IF $PIECE(PRCA,"^",10)=""
- SET Z=1
- +9 IF 'Z
- IF C'["Y"
- IF $PIECE(PRCA,"^",10)]""
- SET Z=1
- +10 QUIT
- End DoDot:1
- +11 QUIT Z
- +12 ;
- +13 ;A=station #, B data=^1 fcp1, ^2 fy, ^3 bbfy, ^4 fcp2
- FCPTRF(A,B) ;EF compare fms accounts value =1 if allow transfer
- +1 NEW C,D,Z
- +2 SET Z=""
- +3 SET C=$$ACC^PRC0C(A,$PIECE(B,"^",1,3))
- SET D=$$ACC^PRC0C(A,$PIECE(B,"^",4)_"^"_$PIECE(B,"^",2,3))
- +4 SET B=$PIECE(C,"^",8)
- SET C=$$FMSACC(A,C)
- SET D=$$FMSACC(A,D)
- +5 IF $PIECE(C,"~",1,5)=$PIECE(D,"~",1,5)
- SET Z=1
- +6 IF '$TEST
- IF B="Y"
- IF $PIECE(C,"~",1,4)=$PIECE(D,"~",1,4)
- SET Z=1
- +7 QUIT Z
- +8 ;
- +9 ;A=fy, B=quarter
- QTRDATE(A,B) ;EF value=$$DATE^PRC0C - the first date of the quarter
- +1 SET A=$$YEAR^PRC0C(A)-(B<2)
- SET B=$PIECE("10~1~4~7","~",B)_"/1/"_A
- +2 QUIT $$DATE^PRC0C(B,"E")
- +3 ;
- +4 ;A=station #, B=fcp#, C=1 if display available year
- BBFY(A,B,C) ;EF value ~1=0-node of file 420.14, ~2=fcp bbfy, ~3=length of fund, ~4=default year
- +1 NEW D,E,F,G,H,I,J
- +2 SET D=$GET(^PRC(420,+A,1,+B,5))
- IF D=""
- QUIT ""
- +3 SET E=+$$DATE^PRC0C($PIECE(D,"^",8),"I")
- +4 SET F=$$FUND^PRC0C($PIECE(D,"^",1),E)
- IF F=""
- QUIT ""
- +5 SET $PIECE(F,"~",2)=E
- SET G=$PIECE(F,"^",5)-$PIECE(F,"^",4)+1
- SET $PIECE(F,"~",3)=G
- +6 SET J=+$$DATE^PRC0C($HOROLOG,"H")
- +7 IF G<2
- if C
- DO EN^DDIOL("Warning: Selected Fund Control Point has a single year fund with multi-appropriation set up.")
- +8 FOR I=J:-1:J-G+1
- if I-E#G=0
- QUIT
- +9 SET E=I
- SET I=""
- FOR H=-3*G+E:G:3*G+E
- SET I=I_H_" "
- if H'>J
- SET $PIECE(F,"~",4)=H
- +10 if C
- DO EN^DDIOL("Enter a year in the following sequence of years.")
- +11 if C
- DO EN^DDIOL("..."_I_"...")
- +12 QUIT F