- 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 Apr 23, 2025@18:32:08 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
