- 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 Feb 18, 2025@23:25:42 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