| [613] | 1 | PRCSED1 ;SF-ISC/LJP/DXH - CONTROL POINT ACTIVITY EDITS CON'T ;7.26.99
|
|---|
| 2 | V ;;5.1;IFCAP;;Oct 20, 2000
|
|---|
| 3 | ;Per VHA Directive 10-93-142, this routine should not be modified.
|
|---|
| 4 | ENT ;ADJUST SUB-CONTROL POINT AMOUNTS FOR NON-CEILING TRANSACTIONS
|
|---|
| 5 | D EN3F^PRCSUT(1) G W2^PRCSED:'$D(PRC("SITE")),EXIT^PRCSED:Y<0
|
|---|
| 6 | 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)))"
|
|---|
| 7 | 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
|
|---|
| 8 | S DR="[PRCSENE]",DIE=DIC D ^DIE L -^PRCS(410,DA) W ! G ENT
|
|---|
| 9 | ENA ;CREATE 1358 ADJUSTMENT
|
|---|
| 10 | D ENF^PRCSUT(1) S X(1)=X,X(2)=Z
|
|---|
| 11 | G W2^PRCSED:'$D(PRC("SITE")) G EXIT^PRCSED:'$D(PRC("QTR"))!(Y<0)
|
|---|
| 12 | 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
|
|---|
| 13 | K DIC("A"),DIC("S") I $D(DTOUT)!$D(DUOUT) G EXIT^PRCSED
|
|---|
| 14 | I Y<0 W $C(7),!!,"Obligation number is required." G ENA1
|
|---|
| 15 | 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
|
|---|
| 16 | S X=X(1),Z=X(2)
|
|---|
| 17 | 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
|
|---|
| 18 | S DIC(0)="AEMQ",DIE=DIC,DR="3///1"_$S($D(PRCSIP):";4////"_PRCSIP,1:""),X4=1 D ^DIE
|
|---|
| 19 | S $P(^PRCS(410,DA,0),U,2)="A",$P(^(0),U,4)=1
|
|---|
| 20 | S $P(^PRCS(410,DA,4),U,5)=$P(^PRCS(410,+Y410,4),U,5),^PRCS(410,"D",X,DA)=""
|
|---|
| 21 | D OBL^PRCSES2
|
|---|
| 22 | ENA2 S DIC(0)="AEMQ",DIE="^PRCS(410,",DR="[PRCSEN1358A]" D ^DIE
|
|---|
| 23 | I $D(^PRC(420,PRC("SITE"),1,+PRC("CP"),0)),$P(^(0),U,12)>0 G ENA3
|
|---|
| 24 | 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
|
|---|
| 25 | ENA3 D:$O(^PRCS(410,DA,12,0)) SCPC0^PRCSED D W1^PRCSEB I $D(PRCS2),+^PRCS(410,DA,0) D W6^PRCSEB
|
|---|
| 26 | L -^PRCS(410,DA) D W3^PRCSED G EXIT^PRCSED:%'=1 W !! K PRCS2 G ENA
|
|---|
| 27 | Q
|
|---|
