PRC0F ;WISC/PLT/BGJ-IFCAP A/E/D FILE UTILITY ;10/19/95 9:15 AM
V ;;5.1;IFCAP;**28**;Oct 20, 2000
;Per VHA Directive 10-93-142, this routine should not be modified.
QUIT ;invalid entry
;
DINUM ;called from ^dd(,.01,0)
S DINUM=+X
QUIT
;
INP411 ;
;Entry for 'Station Number'(D0) must match entry for 'Station'(X)
I $G(D0),X'=D0 S X="" Q
N Y
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=""
QUIT
;
;add FMS sub-allowance account in file 420.141
;PRCA is data ~1=station #,~2=bbfy,~3=fund,~4=a/o,~5=program
; ~6=fcp/prj,~7=object class,~8=job
;PRCB=fund control number
A420D141(PRCA,PRCB) ;add new record in file 420.141
S $P(PRCA,"~",2)=$P($$YEAR^PRC0C($P(PRCA,"~",2)),"^",1)
S PRCA("DR")="1///"_PRCB
D ADD^PRC0B1(.PRCA,.A,"420.141;^PRCD(420.141,")
QUIT A
;
;get appropriation for file 421 TDAs
;A - DA number B - Station Number
;C - four digit BBFY D - two digit fiscal year
;E - fund control point
;F - returns site-fiscal year-appropriation-program
APP421(A) ; determine appropriation for file 421
N B,C,D,E,F,X
S X=^PRCF(421,A,0)
S B=$P(X,"-"),D=$P(X,"-",2),E=$P(+$P(X,"^",2)," ")
S C=$E($P(X,"^",23),2,3),C=+$$YEAR^PRC0C(C)
S F=$$ACC^PRC0C(B,E_"^"_D_"^"_C),F=B_"-"_D_"-"_$P(F,"^",11)_"-"_$P(F,"^",5)_"-"_$P(F,"^",2)
QUIT F
;
;PRCA DATA ^1=STATION #, ^2=CP #, ^3=txn type code (410,1)
; ^4= form type # (optional), ^5 obl date, ^6=obl amt, ^7 p.o/obl # free text (410,24)
; ^8= prority of request (410,7.5) optional
; ^9=FILE 442 ri (optional), ^10=fy/qtr date
; ^11=BBFY (4-DIGIT)
;.x - returned value = file 410 ri
A410(X,PRCA) ;add obligated entry in file 410
N PRC,PRCIRI,PRCB
N A,B,Y,Z
K X
S:$P(PRCA,"^",8)="" $P(PRCA,"^",8)="ST"
S PRC("SITE")=$P(PRCA,"^"),PRCRI(420)=+PRC("SITE"),PRCRI(420.01)=+$P(PRCA,"^",2)
S PRC("CP")=$P($G(^PRC(420,PRCRI(420),1,PRCRI(420.01),0)),"^")
S PRCB=$S($P(PRCA,"^",10):$P(PRCA,"^",10),1:$P(PRCA,"^",5))
S PRCB=$$DATE^PRC0C(PRCB,"I"),PRC("FY")=$E(PRCB,3,4),PRC("QTR")=$P(PRCB,"^",2)
S PRC("BBFY")=$S($P(PRCA,"^",11):$P(PRCA,"^",11),1:$$BBFY^PRCSUT(PRC("SITE"),PRC("FY"),PRC("CP"),1))
S X=PRC("SITE")_"-"_PRC("FY")_"-"_$P(PRC("CP")," ")
S Z=PRC("SITE")_"-"_PRC("FY")_"-"_PRC("QTR")_"-"_$P(PRC("CP")," ")
D EN1^PRCSUT3,EN2^PRCSUT3 S:'$D(DA) DA="" S PRCRI(410)=DA
I 'PRCRI(410) S X=PRCRI(410) QUIT
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"
S X(1,410,1)="26////"_$P(PRCA,"^",5)_";25////"_$P(PRCA,"^",6)_";23////"_$P(PRCA,"^",5)_";24////"_$P(PRCA,"^",7)
D EDIT^PRC0B(.X,"410;^PRCS(410,;"_PRCRI(410),"")
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
S X=PRCRI(410)
K I QUIT
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRC0F 2990 printed Apr 09, 2024@21:15:51 Page 2
PRC0F ;WISC/PLT/BGJ-IFCAP A/E/D FILE UTILITY ;10/19/95 9:15 AM
V ;;5.1;IFCAP;**28**;Oct 20, 2000
+1 ;Per VHA Directive 10-93-142, this routine should not be modified.
+2 ;invalid entry
QUIT
+3 ;
DINUM ;called from ^dd(,.01,0)
+1 SET DINUM=+X
+2 QUIT
+3 ;
INP411 ;
+1 ;Entry for 'Station Number'(D0) must match entry for 'Station'(X)
+2 IF $GET(D0)
IF X'=D0
SET X=""
QUIT
+3 NEW Y
+4 SET Y=""
IF X?3N
DO DIC^PRCFU
if +Y<1
SET X=""
IF +Y>0
if $PIECE(^DIC(4,+Y,99),U)?3N
SET PRCF("INST")=+Y
SET X=$PIECE(^DIC(4,+Y,99),U)
SET DINUM=X
if $PIECE(^DIC(4,+Y,99),U)'?3N
SET X=""
+5 QUIT
+6 ;
+7 ;add FMS sub-allowance account in file 420.141
+8 ;PRCA is data ~1=station #,~2=bbfy,~3=fund,~4=a/o,~5=program
+9 ; ~6=fcp/prj,~7=object class,~8=job
+10 ;PRCB=fund control number
A420D141(PRCA,PRCB) ;add new record in file 420.141
+1 SET $PIECE(PRCA,"~",2)=$PIECE($$YEAR^PRC0C($PIECE(PRCA,"~",2)),"^",1)
+2 SET PRCA("DR")="1///"_PRCB
+3 DO ADD^PRC0B1(.PRCA,.A,"420.141;^PRCD(420.141,")
+4 QUIT A
+5 ;
+6 ;get appropriation for file 421 TDAs
+7 ;A - DA number B - Station Number
+8 ;C - four digit BBFY D - two digit fiscal year
+9 ;E - fund control point
+10 ;F - returns site-fiscal year-appropriation-program
APP421(A) ; determine appropriation for file 421
+1 NEW B,C,D,E,F,X
+2 SET X=^PRCF(421,A,0)
+3 SET B=$PIECE(X,"-")
SET D=$PIECE(X,"-",2)
SET E=$PIECE(+$PIECE(X,"^",2)," ")
+4 SET C=$EXTRACT($PIECE(X,"^",23),2,3)
SET C=+$$YEAR^PRC0C(C)
+5 SET F=$$ACC^PRC0C(B,E_"^"_D_"^"_C)
SET F=B_"-"_D_"-"_$PIECE(F,"^",11)_"-"_$PIECE(F,"^",5)_"-"_$PIECE(F,"^",2)
+6 QUIT F
+7 ;
+8 ;PRCA DATA ^1=STATION #, ^2=CP #, ^3=txn type code (410,1)
+9 ; ^4= form type # (optional), ^5 obl date, ^6=obl amt, ^7 p.o/obl # free text (410,24)
+10 ; ^8= prority of request (410,7.5) optional
+11 ; ^9=FILE 442 ri (optional), ^10=fy/qtr date
+12 ; ^11=BBFY (4-DIGIT)
+13 ;.x - returned value = file 410 ri
A410(X,PRCA) ;add obligated entry in file 410
+1 NEW PRC,PRCIRI,PRCB
+2 NEW A,B,Y,Z
+3 KILL X
+4 if $PIECE(PRCA,"^",8)=""
SET $PIECE(PRCA,"^",8)="ST"
+5 SET PRC("SITE")=$PIECE(PRCA,"^")
SET PRCRI(420)=+PRC("SITE")
SET PRCRI(420.01)=+$PIECE(PRCA,"^",2)
+6 SET PRC("CP")=$PIECE($GET(^PRC(420,PRCRI(420),1,PRCRI(420.01),0)),"^")
+7 SET PRCB=$SELECT($PIECE(PRCA,"^",10):$PIECE(PRCA,"^",10),1:$PIECE(PRCA,"^",5))
+8 SET PRCB=$$DATE^PRC0C(PRCB,"I")
SET PRC("FY")=$EXTRACT(PRCB,3,4)
SET PRC("QTR")=$PIECE(PRCB,"^",2)
+9 SET PRC("BBFY")=$SELECT($PIECE(PRCA,"^",11):$PIECE(PRCA,"^",11),1:$$BBFY^PRCSUT(PRC("SITE"),PRC("FY"),PRC("CP"),1))
+10 SET X=PRC("SITE")_"-"_PRC("FY")_"-"_$PIECE(PRC("CP")," ")
+11 SET Z=PRC("SITE")_"-"_PRC("FY")_"-"_PRC("QTR")_"-"_$PIECE(PRC("CP")," ")
+12 DO EN1^PRCSUT3
DO EN2^PRCSUT3
if '$DATA(DA)
SET DA=""
SET PRCRI(410)=DA
+13 IF 'PRCRI(410)
SET X=PRCRI(410)
QUIT
+14 SET X="1////"_$PIECE(PRCA,"^",3)_";3////"_$PIECE(PRCA,"^",4)_";5////"_$PIECE(PRCA,"^",5)_";7.5////"_$PIECE(PRCA,"^",8)_";7////"_$PIECE(PRCA,"^",5)_";30////"_$PIECE(PRCA,"^",6)_";40////"_$GET(DUZ)_";450////O"
+15 SET X(1,410,1)="26////"_$PIECE(PRCA,"^",5)_";25////"_$PIECE(PRCA,"^",6)_";23////"_$PIECE(PRCA,"^",5)_";24////"_$PIECE(PRCA,"^",7)
+16 DO EDIT^PRC0B(.X,"410;^PRCS(410,;"_PRCRI(410),"")
+17 IF $GET(PRCFA("PODA"))'=""
IF $PIECE($GET(^PRC(442,PRCFA("PODA"),0)),"^",2)=25
FOR I=1,3,8
SET $PIECE(^PRCS(410,PRCRI(410),4),"^",I)=0
+18 SET X=PRCRI(410)
+19 KILL I
QUIT
