- PRCSREC2 ;WISC/KMB/DL-UPDATE 420 BALANCES FOR ISSUE BOOK,CONVERSION ;1/28/98 1400
- ;;5.1;IFCAP;**55,155,213**;4/21/95;Build 19
- ;;Per VA Directive 6402, this routine should not be modified.
- ;
- ;PRC*5.1*213 Modify FCP Cost Center verification to
- ; use ^TMP workfile to handle FCP's with
- ; large number of attached cost centers
- ;
- ISSUES(STATION,FY,CP,QUARTER,AMOUNT) ;
- N A
- S A=+STATION_"^"_(+CP)_"^"_FY_"^"_QUARTER_"^"_AMOUNT
- D EBAL^PRCSEZ(A,"O")
- QUIT
- COST(STATION,CP) ;
- ;return FCP cost centers ;PRC*5.1*213
- K ^TMP($J,"PRCCC")
- N CC
- I '$D(^PRC(420,STATION,1,+CP,2)) Q
- S CC=0 F S CC=$O(^PRC(420,STATION,1,+CP,2,CC)) Q:'CC I $D(^PRCD(420.1,CC,0)),'$P(^PRCD(420.1,CC,0),U,2) S ^TMP($J,"PRCCC",CC)=""
- QUIT
- ;
- CONV(STRING,AMOUNT,COMMENT) ;
- ;after V5 installation, reconcile CP with adjustment trans.
- N A,CPNAME,IT,PRC,T,X,X1,Z
- Q:'$D(STRING)
- S PRC("SITE")=$P(STRING,"-"),PRC("FY")=$P(STRING,"-",2),PRC("QTR")=$P(STRING,"-",3),PRC("CP")=$P(STRING,"-",4)
- S T(2)="A" D:'$D(DT) DT^DICRW
- S PRC("BBFY")=+$$YEAR^PRC0C(PRC("FY"))
- S X=PRC("SITE")_"-"_PRC("FY")_"-"_PRC("CP"),Z=STRING
- D EN1^PRCSUT3 Q:'$D(X)
- S X1=X D EN2^PRCSUT3 Q:'$D(X1)
- L +^PRCS(410,DA):15 Q:'$T
- S $P(^PRCS(410,DA,5),"^")=AMOUNT,$P(^(5),"^",2)=DT,$P(^(4),"^",2)=DT
- F IT=1,4 S $P(^PRCS(410,DA,IT),"^",4)=DT,$P(^(1),"^",IT)=DT
- F IT=1,3,8 S $P(^PRCS(410,DA,4),"^",IT)=AMOUNT
- S CPNAME=$P(^PRC(420,PRC("SITE"),1,+PRC("CP"),0),"^"),CPNAME=$E(CPNAME,1,30)
- S $P(^PRCS(410,DA,3),"^")=CPNAME
- S $P(^PRCS(410,DA,0),"^",2)="A",$P(^PRCS(410,DA,0),"^",4)=2,$P(^PRCS(410,DA,1),"^",3)="ST"
- S DA(1)=DA,DIC("P")=$P(^DD(410,60,0),"^",2),DIC="^PRCS(410,DA(1),""CO"","
- S DLAYGO=410,DIC(0)="LX",X=COMMENT D ^DIC
- L -^PRCS(410,DA)
- ;update 420 balance here
- S A=PRC("SITE")_"^"_+PRC("CP")_"^"_PRC("FY")_"^"_PRC("QTR")_"^"_AMOUNT
- D EBAL^PRCSEZ(A,"O"),EBAL^PRCSEZ(A,"C")
- K DIC,DLAYGO,DA QUIT
- CREATE(STRING) ;create CP for user, return -1 if none created
- Q:'$D(STRING)
- N STATION,FUND,AO,OCP,OBJC,BFY,JOB,PROG,A,B,X,Y
- S X=$P(STRING,"-",2) K %DT D ^%DT
- S STATION=$P(STRING,"-"),BFY=$E(Y,1,3)+1700,FUND=$P(STRING,"-",3),AO=$P(STRING,"-",4),OCP=$P(STRING,"-",5),PROG=$E(OCP,1,4)
- S (OBJC,JOB)=""
- S:FUND="0151A7" PROG=9999 S:FUND="0151A1" PROG=9999 S:FUND="0151A7" OBJC=21 S:FUND="0151A1" OBJC=26
- S:OCP=971 PROG="MOD"
- S A=STATION_"~"_BFY_"~"_FUND_"~"_AO_"~"_PROG_"~"_OCP_"~"_OBJC_"~"_JOB
- S B=$$FIRST^PRC0B1("^PRCD(420.141,""B"","""_A_""",",0)
- I 'B S B=-1 QUIT B
- S B=+$P(^PRCD(420.141,B,0),"^",2),B=$P($G(^PRC(420,STATION,1,B,0)),"^")
- QUIT B
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCSREC2 2594 printed Feb 18, 2025@23:44:44 Page 2
- PRCSREC2 ;WISC/KMB/DL-UPDATE 420 BALANCES FOR ISSUE BOOK,CONVERSION ;1/28/98 1400
- +1 ;;5.1;IFCAP;**55,155,213**;4/21/95;Build 19
- +2 ;;Per VA Directive 6402, this routine should not be modified.
- +3 ;
- +4 ;PRC*5.1*213 Modify FCP Cost Center verification to
- +5 ; use ^TMP workfile to handle FCP's with
- +6 ; large number of attached cost centers
- +7 ;
- ISSUES(STATION,FY,CP,QUARTER,AMOUNT) ;
- +1 NEW A
- +2 SET A=+STATION_"^"_(+CP)_"^"_FY_"^"_QUARTER_"^"_AMOUNT
- +3 DO EBAL^PRCSEZ(A,"O")
- +4 QUIT
- COST(STATION,CP) ;
- +1 ;return FCP cost centers ;PRC*5.1*213
- +2 KILL ^TMP($JOB,"PRCCC")
- +3 NEW CC
- +4 IF '$DATA(^PRC(420,STATION,1,+CP,2))
- QUIT
- +5 SET CC=0
- FOR
- SET CC=$ORDER(^PRC(420,STATION,1,+CP,2,CC))
- if 'CC
- QUIT
- IF $DATA(^PRCD(420.1,CC,0))
- IF '$PIECE(^PRCD(420.1,CC,0),U,2)
- SET ^TMP($JOB,"PRCCC",CC)=""
- +6 QUIT
- +7 ;
- CONV(STRING,AMOUNT,COMMENT) ;
- +1 ;after V5 installation, reconcile CP with adjustment trans.
- +2 NEW A,CPNAME,IT,PRC,T,X,X1,Z
- +3 if '$DATA(STRING)
- QUIT
- +4 SET PRC("SITE")=$PIECE(STRING,"-")
- SET PRC("FY")=$PIECE(STRING,"-",2)
- SET PRC("QTR")=$PIECE(STRING,"-",3)
- SET PRC("CP")=$PIECE(STRING,"-",4)
- +5 SET T(2)="A"
- if '$DATA(DT)
- DO DT^DICRW
- +6 SET PRC("BBFY")=+$$YEAR^PRC0C(PRC("FY"))
- +7 SET X=PRC("SITE")_"-"_PRC("FY")_"-"_PRC("CP")
- SET Z=STRING
- +8 DO EN1^PRCSUT3
- if '$DATA(X)
- QUIT
- +9 SET X1=X
- DO EN2^PRCSUT3
- if '$DATA(X1)
- QUIT
- +10 LOCK +^PRCS(410,DA):15
- if '$TEST
- QUIT
- +11 SET $PIECE(^PRCS(410,DA,5),"^")=AMOUNT
- SET $PIECE(^(5),"^",2)=DT
- SET $PIECE(^(4),"^",2)=DT
- +12 FOR IT=1,4
- SET $PIECE(^PRCS(410,DA,IT),"^",4)=DT
- SET $PIECE(^(1),"^",IT)=DT
- +13 FOR IT=1,3,8
- SET $PIECE(^PRCS(410,DA,4),"^",IT)=AMOUNT
- +14 SET CPNAME=$PIECE(^PRC(420,PRC("SITE"),1,+PRC("CP"),0),"^")
- SET CPNAME=$EXTRACT(CPNAME,1,30)
- +15 SET $PIECE(^PRCS(410,DA,3),"^")=CPNAME
- +16 SET $PIECE(^PRCS(410,DA,0),"^",2)="A"
- SET $PIECE(^PRCS(410,DA,0),"^",4)=2
- SET $PIECE(^PRCS(410,DA,1),"^",3)="ST"
- +17 SET DA(1)=DA
- SET DIC("P")=$PIECE(^DD(410,60,0),"^",2)
- SET DIC="^PRCS(410,DA(1),""CO"","
- +18 SET DLAYGO=410
- SET DIC(0)="LX"
- SET X=COMMENT
- DO ^DIC
- +19 LOCK -^PRCS(410,DA)
- +20 ;update 420 balance here
- +21 SET A=PRC("SITE")_"^"_+PRC("CP")_"^"_PRC("FY")_"^"_PRC("QTR")_"^"_AMOUNT
- +22 DO EBAL^PRCSEZ(A,"O")
- DO EBAL^PRCSEZ(A,"C")
- +23 KILL DIC,DLAYGO,DA
- QUIT
- CREATE(STRING) ;create CP for user, return -1 if none created
- +1 if '$DATA(STRING)
- QUIT
- +2 NEW STATION,FUND,AO,OCP,OBJC,BFY,JOB,PROG,A,B,X,Y
- +3 SET X=$PIECE(STRING,"-",2)
- KILL %DT
- DO ^%DT
- +4 SET STATION=$PIECE(STRING,"-")
- SET BFY=$EXTRACT(Y,1,3)+1700
- SET FUND=$PIECE(STRING,"-",3)
- SET AO=$PIECE(STRING,"-",4)
- SET OCP=$PIECE(STRING,"-",5)
- SET PROG=$EXTRACT(OCP,1,4)
- +5 SET (OBJC,JOB)=""
- +6 if FUND="0151A7"
- SET PROG=9999
- if FUND="0151A1"
- SET PROG=9999
- if FUND="0151A7"
- SET OBJC=21
- if FUND="0151A1"
- SET OBJC=26
- +7 if OCP=971
- SET PROG="MOD"
- +8 SET A=STATION_"~"_BFY_"~"_FUND_"~"_AO_"~"_PROG_"~"_OCP_"~"_OBJC_"~"_JOB
- +9 SET B=$$FIRST^PRC0B1("^PRCD(420.141,""B"","""_A_""",",0)
- +10 IF 'B
- SET B=-1
- QUIT B
- +11 SET B=+$PIECE(^PRCD(420.141,B,0),"^",2)
- SET B=$PIECE($GET(^PRC(420,STATION,1,B,0)),"^")
- +12 QUIT B