Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: PRC0F

PRC0F.m

Go to the documentation of this file.
  1. PRC0F ;WISC/PLT/BGJ-IFCAP A/E/D FILE UTILITY ;10/19/95 9:15 AM
  1. V ;;5.1;IFCAP;**28**;Oct 20, 2000
  1. ;Per VHA Directive 10-93-142, this routine should not be modified.
  1. QUIT ;invalid entry
  1. ;
  1. DINUM ;called from ^dd(,.01,0)
  1. S DINUM=+X
  1. QUIT
  1. ;
  1. INP411 ;
  1. ;Entry for 'Station Number'(D0) must match entry for 'Station'(X)
  1. I $G(D0),X'=D0 S X="" Q
  1. N Y
  1. 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=""
  1. QUIT
  1. ;
  1. ;add FMS sub-allowance account in file 420.141
  1. ;PRCA is data ~1=station #,~2=bbfy,~3=fund,~4=a/o,~5=program
  1. ; ~6=fcp/prj,~7=object class,~8=job
  1. ;PRCB=fund control number
  1. A420D141(PRCA,PRCB) ;add new record in file 420.141
  1. S $P(PRCA,"~",2)=$P($$YEAR^PRC0C($P(PRCA,"~",2)),"^",1)
  1. S PRCA("DR")="1///"_PRCB
  1. D ADD^PRC0B1(.PRCA,.A,"420.141;^PRCD(420.141,")
  1. QUIT A
  1. ;
  1. ;get appropriation for file 421 TDAs
  1. ;A - DA number B - Station Number
  1. ;C - four digit BBFY D - two digit fiscal year
  1. ;E - fund control point
  1. ;F - returns site-fiscal year-appropriation-program
  1. APP421(A) ; determine appropriation for file 421
  1. N B,C,D,E,F,X
  1. S X=^PRCF(421,A,0)
  1. S B=$P(X,"-"),D=$P(X,"-",2),E=$P(+$P(X,"^",2)," ")
  1. S C=$E($P(X,"^",23),2,3),C=+$$YEAR^PRC0C(C)
  1. S F=$$ACC^PRC0C(B,E_"^"_D_"^"_C),F=B_"-"_D_"-"_$P(F,"^",11)_"-"_$P(F,"^",5)_"-"_$P(F,"^",2)
  1. QUIT F
  1. ;
  1. ;PRCA DATA ^1=STATION #, ^2=CP #, ^3=txn type code (410,1)
  1. ; ^4= form type # (optional), ^5 obl date, ^6=obl amt, ^7 p.o/obl # free text (410,24)
  1. ; ^8= prority of request (410,7.5) optional
  1. ; ^9=FILE 442 ri (optional), ^10=fy/qtr date
  1. ; ^11=BBFY (4-DIGIT)
  1. ;.x - returned value = file 410 ri
  1. A410(X,PRCA) ;add obligated entry in file 410
  1. N PRC,PRCIRI,PRCB
  1. N A,B,Y,Z
  1. K X
  1. S:$P(PRCA,"^",8)="" $P(PRCA,"^",8)="ST"
  1. S PRC("SITE")=$P(PRCA,"^"),PRCRI(420)=+PRC("SITE"),PRCRI(420.01)=+$P(PRCA,"^",2)
  1. S PRC("CP")=$P($G(^PRC(420,PRCRI(420),1,PRCRI(420.01),0)),"^")
  1. S PRCB=$S($P(PRCA,"^",10):$P(PRCA,"^",10),1:$P(PRCA,"^",5))
  1. S PRCB=$$DATE^PRC0C(PRCB,"I"),PRC("FY")=$E(PRCB,3,4),PRC("QTR")=$P(PRCB,"^",2)
  1. S PRC("BBFY")=$S($P(PRCA,"^",11):$P(PRCA,"^",11),1:$$BBFY^PRCSUT(PRC("SITE"),PRC("FY"),PRC("CP"),1))
  1. S X=PRC("SITE")_"-"_PRC("FY")_"-"_$P(PRC("CP")," ")
  1. S Z=PRC("SITE")_"-"_PRC("FY")_"-"_PRC("QTR")_"-"_$P(PRC("CP")," ")
  1. D EN1^PRCSUT3,EN2^PRCSUT3 S:'$D(DA) DA="" S PRCRI(410)=DA
  1. I 'PRCRI(410) S X=PRCRI(410) QUIT
  1. 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"
  1. S X(1,410,1)="26////"_$P(PRCA,"^",5)_";25////"_$P(PRCA,"^",6)_";23////"_$P(PRCA,"^",5)_";24////"_$P(PRCA,"^",7)
  1. D EDIT^PRC0B(.X,"410;^PRCS(410,;"_PRCRI(410),"")
  1. 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
  1. S X=PRCRI(410)
  1. K I QUIT