PRCB1E2.m

PRCB1E2 ;WISC/PLT-PRCB1E continue ;3/4/97  15:59

V ;;5.1;IFCAP;;Oct 20, 2000

 ;Per VHA Directive 10-93-142, this routine should not be modified.

 QUIT  ;invalid entry

 ;

 ;prcduz - user id #

 ;prcopt data ^1=option #, ^2=yyyy-q, ^3=station #, ^4=cp ri

 ;prcdes = description

 ;

 ;prca = prcopt, prcb=fund control point ri

CPBAL(PRCA,PRCB) ;carry forward cp ballance

 N PRC,PRCRI,PRCC,PRCD,PRCCOM

 N A,B,C,X,Y,Z,DA

 S PRC("SITE")=$P(PRCA,"^",3),PRCRI(420)=+PRC("SITE"),PRCRI(420.01)=+PRCB

 S PRC("CP")=$P($G(^PRC(420,PRCRI(420),1,PRCRI(420.01),0)),"^")

 S PRCC=$$QTRDT^PRC0G(PRCRI(420)_"^"_PRCRI(420.01)_"^"_+$P(PRCA,"^",2)_"^"_"F")

 QUIT:$P(PRCA,"^",5)'<$P(PRCC,"^",2)  ;last qtr always open

 S A=$P(PRCOPT,"^",2),PRC("FY")=$E(A,3,4),PRC("QTR")=$P(A,"-",2)

 L +^PRC(420,PRCRI(420),1,PRCRI(420.01),4,PRC("FY"),0):5

 E  S PRC("MSG")="Note: Carry forward from "_$P(PRC("CP")," ")_" failed. File locked by another user." D EN^DDIOL(PRC("MSG")) QUIT

 S A=$G(^PRC(420,PRCRI(420),1,PRCRI(420.01),4,PRC("FY"),0))

 L -^PRC(420,PRCRI(420),1,PRCRI(420.01),4,PRC("FY"),0)

 QUIT:A=""

 S PRCCOM=$P(A,"^",1+PRC("QTR"))

 I +PRCCOM=0 S PRC("MSG")=PRC("CP")_" Qtr "_$E($P(PRCOPT,"^",2),3,999)_" adjusted with $"_$J(PRCCOM,0,2)_"."

 ;zero out from CP quarter balances

 S A=$$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 S PRC("TXNTO")=X D EN2^PRCSUT3 S PRCRI(410)=DA

 I 'PRCRI(410) S PRC("MSG")="Note: CP balance adjust 'to' fails for "_$P(PRC("CP")," ")_"   $"_$J(PRCCOM,10,2) D EN^DDIOL(PRC("MSG")) G MM

 S A="1///A;40////"_DUZ_";449////"_$P(PRCA,"^",5)_";450////O;25.5////Y;24////QTRADJ;26///T"

 D EDIT^PRC0B(.X,"410;^PRCS(410,;"_PRCRI(410),A)

 D EDIT^PRC0B(.X,"410;^PRCS(410,;"_PRCRI(410),"25////"_PRCCOM)

 ;adjust new CP quarter balance

 S PRCCOM=-PRCCOM

 S A=$P(PRCOPT,"^",7),PRC("FY")=$E(A,3,4),PRC("QTR")=$P(A,"-",2)

 S A=$$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 S PRC("TXNFR")=X D EN2^PRCSUT3 S PRCRI(410)=DA

 I 'PRCRI(410) S PRC("MSG")="Note: CP balance adjust 'from' fails for "_$P(PRC("CP")," ")_"   $"_$J(PRCCOM,10,2) D EN^DDIOL(PRC("MSG")) G MM

 S A="1///A;40////"_DUZ_";449////"_$P(PRCA,"^",6)_";450////O;25.5////Y;24////QTRADJ;26///T"

 D EDIT^PRC0B(.X,"410;^PRCS(410,;"_PRCRI(410),A)

 D EDIT^PRC0B(.X,"410;^PRCS(410,;"_PRCRI(410),"25////"_PRCCOM)

 S PRC("MSG")=PRC("CP")_" Qtr "_$E($P(PRCOPT,"^",2),3,999)_" adjusted with $"_$J(PRCCOM,0,2)_"."

MM D EN^DDIOL($J($P(PRC("CP")," "),8)_"  "_$E($P(PRC("CP")," ",2,999)_$J("",40),1,40)_"  (ADJ) $"_$J(PRCCOM,0,2)) D:+PRCCOM'=0

 . N A,B,X,Y,XMY

 . D NAMES^PRCBBUL

 . S X(1)=PRC("MSG")

 . D:$O(XMY("")) MM^PRC0B2(PRCDES,"X(",.XMY)

 . QUIT

 QUIT

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---PRCB1E2   2919     printed  Mar 13, 2025@21:05:09                                                                                                                                                                                                     Page 2

PRCB1E2   ;WISC/PLT-PRCB1E continue ;3/4/97  15:59

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       ;prcduz - user id #

 +5       ;prcopt data ^1=option #, ^2=yyyy-q, ^3=station #, ^4=cp ri

 +6       ;prcdes = description

 +7       ;

 +8       ;prca = prcopt, prcb=fund control point ri

CPBAL(PRCA,PRCB) ;carry forward cp ballance

 +1        NEW PRC,PRCRI,PRCC,PRCD,PRCCOM

 +2        NEW A,B,C,X,Y,Z,DA

 +3        SET PRC("SITE")=$PIECE(PRCA,"^",3)

           SET PRCRI(420)=+PRC("SITE")

           SET PRCRI(420.01)=+PRCB

 +4        SET PRC("CP")=$PIECE($GET(^PRC(420,PRCRI(420),1,PRCRI(420.01),0)),"^")

 +5        SET PRCC=$$QTRDT^PRC0G(PRCRI(420)_"^"_PRCRI(420.01)_"^"_+$PIECE(PRCA,"^",2)_"^"_"F")

 +6       ;last qtr always open

           if $PIECE(PRCA,"^",5)'<$PIECE(PRCC,"^",2)

               QUIT 

 +7        SET A=$PIECE(PRCOPT,"^",2)

           SET PRC("FY")=$EXTRACT(A,3,4)

           SET PRC("QTR")=$PIECE(A,"-",2)

 +8        LOCK +^PRC(420,PRCRI(420),1,PRCRI(420.01),4,PRC("FY"),0):5

 +9       IF '$TEST

               SET PRC("MSG")="Note: Carry forward from "_$PIECE(PRC("CP")," ")_" failed. File locked by another user."

               DO EN^DDIOL(PRC("MSG"))

               QUIT 

 +10       SET A=$GET(^PRC(420,PRCRI(420),1,PRCRI(420.01),4,PRC("FY"),0))

 +11       LOCK -^PRC(420,PRCRI(420),1,PRCRI(420.01),4,PRC("FY"),0)

 +12       if A=""

               QUIT 

 +13       SET PRCCOM=$PIECE(A,"^",1+PRC("QTR"))

 +14       IF +PRCCOM=0

               SET PRC("MSG")=PRC("CP")_" Qtr "_$EXTRACT($PIECE(PRCOPT,"^",2),3,999)_" adjusted with $"_$JUSTIFY(PRCCOM,0,2)_"."

 +15      ;zero out from CP quarter balances

 +16       SET A=$$BBFY^PRCSUT(PRC("SITE"),PRC("FY"),PRC("CP"),1)

 +17       SET X=PRC("SITE")_"-"_PRC("FY")_"-"_$PIECE(PRC("CP")," ")

 +18       SET Z=PRC("SITE")_"-"_PRC("FY")_"-"_PRC("QTR")_"-"_$PIECE(PRC("CP")," ")

 +19       DO EN1^PRCSUT3

           SET PRC("TXNTO")=X

           DO EN2^PRCSUT3

           SET PRCRI(410)=DA

 +20       IF 'PRCRI(410)

               SET PRC("MSG")="Note: CP balance adjust 'to' fails for "_$PIECE(PRC("CP")," ")_"   $"_$JUSTIFY(PRCCOM,10,2)

               DO EN^DDIOL(PRC("MSG"))

               GOTO MM

 +21       SET A="1///A;40////"_DUZ_";449////"_$PIECE(PRCA,"^",5)_";450////O;25.5////Y;24////QTRADJ;26///T"

 +22       DO EDIT^PRC0B(.X,"410;^PRCS(410,;"_PRCRI(410),A)

 +23       DO EDIT^PRC0B(.X,"410;^PRCS(410,;"_PRCRI(410),"25////"_PRCCOM)

 +24      ;adjust new CP quarter balance

 +25       SET PRCCOM=-PRCCOM

 +26       SET A=$PIECE(PRCOPT,"^",7)

           SET PRC("FY")=$EXTRACT(A,3,4)

           SET PRC("QTR")=$PIECE(A,"-",2)

 +27       SET A=$$BBFY^PRCSUT(PRC("SITE"),PRC("FY"),PRC("CP"),1)

 +28       SET X=PRC("SITE")_"-"_PRC("FY")_"-"_$PIECE(PRC("CP")," ")

 +29       SET Z=PRC("SITE")_"-"_PRC("FY")_"-"_PRC("QTR")_"-"_$PIECE(PRC("CP")," ")

 +30       DO EN1^PRCSUT3

           SET PRC("TXNFR")=X

           DO EN2^PRCSUT3

           SET PRCRI(410)=DA

 +31       IF 'PRCRI(410)

               SET PRC("MSG")="Note: CP balance adjust 'from' fails for "_$PIECE(PRC("CP")," ")_"   $"_$JUSTIFY(PRCCOM,10,2)

               DO EN^DDIOL(PRC("MSG"))

               GOTO MM

 +32       SET A="1///A;40////"_DUZ_";449////"_$PIECE(PRCA,"^",6)_";450////O;25.5////Y;24////QTRADJ;26///T"

 +33       DO EDIT^PRC0B(.X,"410;^PRCS(410,;"_PRCRI(410),A)

 +34       DO EDIT^PRC0B(.X,"410;^PRCS(410,;"_PRCRI(410),"25////"_PRCCOM)

 +35       SET PRC("MSG")=PRC("CP")_" Qtr "_$EXTRACT($PIECE(PRCOPT,"^",2),3,999)_" adjusted with $"_$JUSTIFY(PRCCOM,0,2)_"."

MM         DO EN^DDIOL($JUSTIFY($PIECE(PRC("CP")," "),8)_"  "_$EXTRACT($PIECE(PRC("CP")," ",2,999)_$JUSTIFY("",40),1,40)_"  (ADJ) $"_$JUSTIFY(PRCCOM,0,2))

           if +PRCCOM'=0

               Begin DoDot:1

 +1                NEW A,B,X,Y,XMY

 +2                DO NAMES^PRCBBUL

 +3                SET X(1)=PRC("MSG")

 +4                if $ORDER(XMY(""))

                       DO MM^PRC0B2(PRCDES,"X(",.XMY)

 +5                QUIT 

               End DoDot:1

 +6        QUIT