PRCSED1 ;SF-ISC/LJP/DXH - CONTROL POINT ACTIVITY EDITS CON'T ;7.26.99
V ;;5.1;IFCAP;;Oct 20, 2000
;Per VHA Directive 10-93-142, this routine should not be modified.
ENT ;ADJUST SUB-CONTROL POINT AMOUNTS FOR NON-CEILING TRANSACTIONS
D EN3F^PRCSUT(1) G W2^PRCSED:'$D(PRC("SITE")),EXIT^PRCSED:Y<0
S DIC="^PRCS(410,",DIE=DIC,DIC(0)="AEQM",DIC("S")="I $D(^(3)),+^(3)=+PRC(""CP""),$P(^(0),U,5)=PRC(""SITE""),$P(^(0),U,2)'=""C"" I $D(^PRC(420,""A"",DUZ,PRC(""SITE""),+PRC(""CP""),1))!($D(^(2)))"
ASK S DIC("A")="Select TRANSACTION NUMBER: " D ^PRCSDIC G EXIT^PRCSED:Y<0 K DIC("S"),DIC("A") S DA=+Y L +^PRCS(410,DA):15 G ASK:$T=0
S DR="[PRCSENE]",DIE=DIC D ^DIE L -^PRCS(410,DA) W ! G ENT
ENA ;CREATE 1358 ADJUSTMENT
D ENF^PRCSUT(1) S X(1)=X,X(2)=Z
G W2^PRCSED:'$D(PRC("SITE")) G EXIT^PRCSED:'$D(PRC("QTR"))!(Y<0)
ENA1 S DIC=410,DIC("A")="Select OBLIGATION NUMBER: ",DIC(0)="AEQZ",D="D",DIC("S")="I $P(^(0),U,2)=""O"",$P(^(0),U,4)=1,PRC(""SITE"")=+^(0),+PRC(""CP"")=+$P($P(^(0),U),""-"",4)" D IX^DIC
K DIC("A"),DIC("S") I $D(DTOUT)!$D(DUOUT) G EXIT^PRCSED
I Y<0 W $C(7),!!,"Obligation number is required." G ENA1
S Y410=+Y,PRCSOBN=$S($D(^PRCS(410,+Y,10)):$P(^(10),U,3),1:"") W:$D(^PRC(442,+PRCSOBN,8)) !," Fiscal's 1358 Balance: $ ",$J($P(^(8),U,2),9,2),! K PRCSOBN
S X=X(1),Z=X(2)
S (DIC,DLAYGO)=410.1 D EN1^PRCSUT3 Q:'X S X1=X D EN2^PRCSUT3 Q:'$D(X1) S X=X1 D W^PRCSED L +^PRCS(410,DA):15 G ENA:$T=0 I $D(^PRC(420,PRC("SITE"),1,+PRC("CP"),0)) S:$P(^(0),U,11)="Y" PRCS2=1
S DIC(0)="AEMQ",DIE=DIC,DR="3///1"_$S($D(PRCSIP):";4////"_PRCSIP,1:""),X4=1 D ^DIE
S $P(^PRCS(410,DA,0),U,2)="A",$P(^(0),U,4)=1
S $P(^PRCS(410,DA,4),U,5)=$P(^PRCS(410,+Y410,4),U,5),^PRCS(410,"D",X,DA)=""
D OBL^PRCSES2
ENA2 S DIC(0)="AEMQ",DIE="^PRCS(410,",DR="[PRCSEN1358A]" D ^DIE
I $D(^PRC(420,PRC("SITE"),1,+PRC("CP"),0)),$P(^(0),U,12)>0 G ENA3
I $D(^PRCS(410,DA,4)) S X=$P(^(4),U,6),X2=^(3),X1=$P(X2,U,7)+$P(X2,U,9) I $J(X,0,2)'=$J(X1,0,2)!('X)!('X1) W $C(7),!,"Adjustment $ Amount does not equal the BOC $ Amount.",!,"Please correct the error.",! G ENA2
ENA3 D:$O(^PRCS(410,DA,12,0)) SCPC0^PRCSED D W1^PRCSEB I $D(PRCS2),+^PRCS(410,DA,0) D W6^PRCSEB
L -^PRCS(410,DA) D W3^PRCSED G EXIT^PRCSED:%'=1 W !! K PRCS2 G ENA
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCSED1 2239 printed Nov 22, 2024@17:27:42 Page 2
PRCSED1 ;SF-ISC/LJP/DXH - CONTROL POINT ACTIVITY EDITS CON'T ;7.26.99
V ;;5.1;IFCAP;;Oct 20, 2000
+1 ;Per VHA Directive 10-93-142, this routine should not be modified.
ENT ;ADJUST SUB-CONTROL POINT AMOUNTS FOR NON-CEILING TRANSACTIONS
+1 DO EN3F^PRCSUT(1)
if '$DATA(PRC("SITE"))
GOTO W2^PRCSED
if Y<0
GOTO EXIT^PRCSED
+2 SET DIC="^PRCS(410,"
SET DIE=DIC
SET DIC(0)="AEQM"
SET DIC("S")="I $D(^(3)),+^(3)=+PRC(""CP""),$P(^(0),U,5)=PRC(""SITE""),$P(^(0),U,2)'=""C"" I $D(^PRC(420,""A"",DUZ,PRC(""SITE""),+PRC(""CP""),1))!($D(^(2)))"
ASK SET DIC("A")="Select TRANSACTION NUMBER: "
DO ^PRCSDIC
if Y<0
GOTO EXIT^PRCSED
KILL DIC("S"),DIC("A")
SET DA=+Y
LOCK +^PRCS(410,DA):15
if $TEST=0
GOTO ASK
+1 SET DR="[PRCSENE]"
SET DIE=DIC
DO ^DIE
LOCK -^PRCS(410,DA)
WRITE !
GOTO ENT
ENA ;CREATE 1358 ADJUSTMENT
+1 DO ENF^PRCSUT(1)
SET X(1)=X
SET X(2)=Z
+2 if '$DATA(PRC("SITE"))
GOTO W2^PRCSED
if '$DATA(PRC("QTR"))!(Y<0)
GOTO EXIT^PRCSED
ENA1 SET DIC=410
SET DIC("A")="Select OBLIGATION NUMBER: "
SET DIC(0)="AEQZ"
SET D="D"
SET DIC("S")="I $P(^(0),U,2)=""O"",$P(^(0),U,4)=1,PRC(""SITE"")=+^(0),+PRC(""CP"")=+$P($P(^(0),U),""-"",4)"
DO IX^DIC
+1 KILL DIC("A"),DIC("S")
IF $DATA(DTOUT)!$DATA(DUOUT)
GOTO EXIT^PRCSED
+2 IF Y<0
WRITE $CHAR(7),!!,"Obligation number is required."
GOTO ENA1
+3 SET Y410=+Y
SET PRCSOBN=$SELECT($DATA(^PRCS(410,+Y,10)):$PIECE(^(10),U,3),1:"")
if $DATA(^PRC(442,+PRCSOBN,8))
WRITE !," Fiscal's 1358 Balance: $ ",$JUSTIFY($PIECE(^(8),U,2),9,2),!
KILL PRCSOBN
+4 SET X=X(1)
SET Z=X(2)
+5 SET (DIC,DLAYGO)=410.1
DO EN1^PRCSUT3
if 'X
QUIT
SET X1=X
DO EN2^PRCSUT3
if '$DATA(X1)
QUIT
SET X=X1
DO W^PRCSED
LOCK +^PRCS(410,DA):15
if $TEST=0
GOTO ENA
IF $DATA(^PRC(420,PRC("SITE"),1,+PRC("CP"),0))
if $PIECE(^(0),U,11)="Y"
SET PRCS2=1
+6 SET DIC(0)="AEMQ"
SET DIE=DIC
SET DR="3///1"_$SELECT($DATA(PRCSIP):";4////"_PRCSIP,1:"")
SET X4=1
DO ^DIE
+7 SET $PIECE(^PRCS(410,DA,0),U,2)="A"
SET $PIECE(^(0),U,4)=1
+8 SET $PIECE(^PRCS(410,DA,4),U,5)=$PIECE(^PRCS(410,+Y410,4),U,5)
SET ^PRCS(410,"D",X,DA)=""
+9 DO OBL^PRCSES2
ENA2 SET DIC(0)="AEMQ"
SET DIE="^PRCS(410,"
SET DR="[PRCSEN1358A]"
DO ^DIE
+1 IF $DATA(^PRC(420,PRC("SITE"),1,+PRC("CP"),0))
IF $PIECE(^(0),U,12)>0
GOTO ENA3
+2 IF $DATA(^PRCS(410,DA,4))
SET X=$PIECE(^(4),U,6)
SET X2=^(3)
SET X1=$PIECE(X2,U,7)+$PIECE(X2,U,9)
IF $JUSTIFY(X,0,2)'=$JUSTIFY(X1,0,2)!('X)!('X1)
WRITE $CHAR(7),!,"Adjustment $ Amount does not equal the BOC $ Amount.",!,"Please correct the error.",!
GOTO ENA2
ENA3 if $ORDER(^PRCS(410,DA,12,0))
DO SCPC0^PRCSED
DO W1^PRCSEB
IF $DATA(PRCS2)
IF +^PRCS(410,DA,0)
DO W6^PRCSEB
+1 LOCK -^PRCS(410,DA)
DO W3^PRCSED
if %'=1
GOTO EXIT^PRCSED
WRITE !!
KILL PRCS2
GOTO ENA
+2 QUIT
