PRCEADJ2 ;WISC/CLH/CTB-PRCEADJ1 CONT ; 21 Apr 93 8:32 AM
V ;;5.1;IFCAP;;Oct 20, 2000
;Per VHA Directive 10-93-142, this routine should not be modified.
N TI,PRCFASYS,IOINLOW,IOINHI,IOINORM,DIR,AMT,OLDTT,CS,HASH,DIE,DR,LAUTH,LBAL,TAUTH,TBAL,DLAYGO
D SCREEN S DIR("A")="Ok to continue",DIR("B")="Yes",DIR(0)="Y",DIR("?")="Press <RETURN> to continue processing" D ^DIR I 'Y G OUT
S AMT=$P(TRNODE(4),U,8)
D OLDTT^PRCH58OB(PODA,.X) S OLDTT=X
K PRCFA("TT") I X="921.60" S PRCFA("TT")=$S(AMT<0:"921.33",1:"921.31") G K
I X="921.10" S PRCFA("TT")=$S(AMT<0:"921.32",1:"921.30") G K
I X="921.71" S PRCFA("TT")=$S(AMT<0:"921.73",1:"921.72")
K S PRCFA("REF")=$P($P(PO(0),"^"),"-",2),PRCFA("SYS")="CLM" D TT^PRCFAC G:'% OUT D NEWCS^PRCFAC G:'$D(DA) OUT
S PRC("CP")=$P(TRNODE(0),"-",4),CS=$S($D(^PRCF(423,PRCFA("CSDA"),1)):^(1),1:""),$P(CS,"^")="..",$P(CS,"^",5,7)=PRC("CP")_"^"_+$P(PO(0),"^",5)_"^^"
F I=7,9 S AMT(I)=$P(TRNODE(3),"^",I) S:AMT(I)<0 AMT(I)=-AMT(I) S AMT(I)=AMT(I)*100
S $P(CS,"^",16)="$",$P(CS,"^",8,11)=+$P(TRNODE(3),"^",6)_"^"_AMT(7)_"^$^" I OLDTT'="921.60",+$P(TRNODE(3),"^",8)>0,AMT(9)>0 S $P(CS,"^",10,11)=$P(TRNODE(3),"^",8)_"^"_AMT(9)
S ^PRCF(423,PRCFA("CSDA"),1)=CS
Y D ^PRCFA921,^PRCFACXM I $D(PRCFDEL)!($D(PRCFA("CSHOLD"))) K PRCFDEL,PRCFA("CSHOLD") S X=" Code Sheet not Processed, No Further Action Taken.*" D MSG^PRCFQ G OUT
W !!,"Updating Obligation balances. Please hold...",!!
X D POADJ^PRCH58OB(.PO,PODA,.TRNODE,AMT)
D POADJ^PRCS58OB(.PRC,PODA,TRDA,AMT)
D:AMT>0 BULC^PRCH58(PODA)
Z S (X,Z)=$P(PO(0),U),%=1 D EN1^PRCSUT3 S DLAYGO=424,DIC="^PRC(424,",DIC(0)="L" D FILE^DICN I Y<0 W !,"ERROR IN CREATING 424 RECORD",$C(7),!! Q
S DIE="^PRC(424,",DA(1358)=+Y D NOW^%DTC S TI=%,DA=DA(1358),DR=".02///^S X=PODA;.03///^S X=""A"";.06///^S X=$P(TRNODE(4),U,8);.07///^S X=TI;.08////^S X=DUZ;1.1////^S X=""ADJUSTMENT OBLIGATION"";.15////^S X=TRDA"
D ^DIE S X=" ----Adjustment Completed ----*" D MSG^PRCFQ G OUT
Q
SCREEN ;COMPARISON SCREEN
N CEILING,LAUTH,TAUTH,TBAL,LBAL,IOINHI,IOINLOW,IOINORM
D HILO^PRCFQ S CEILING=$P(PO(8),U) W @IOF,IOINLOW,"Adjustment Transaction # ",IOINHI,$P(TRNODE(0),"^"),IOINLOW," 1358 # ",IOINHI,$P(PO(0),"^")
W !!,IOINLOW,"Current amount obligated on 1358: ",IOINHI," $ ",$FN(CEILING,"P,",2)
S TBAL=$P(PO(8),U,3),TAUTH=CEILING-TBAL W !!,IOINLOW," Total Authorizations: ",IOINHI," $ ",$J($FN(TAUTH,"P,",2),12)
S LBAL=$P(PO(8),U,2),LAUTH=CEILING-LBAL W ?40,IOINLOW," Total Liquidations: ",IOINHI," $ ",$J($FN(LAUTH,",P",2),12)
W !,IOINLOW,"Authorization Balance: ",IOINHI," $ ",$J($FN(TBAL,"P,",2),12),?40,IOINLOW,"Liquidation Balance: ",IOINHI," $ ",$J($FN(LBAL,"P,",2),12),!!
W IOINLOW,"Amount of Adjustment: ",IOINHI,$J($P(TRNODE(4),"^",8),0,2),!!,IOINORM
Q
OUT K DIRUT,DTOUT,DUOUT,DIROUT Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCEADJ2 2794 printed Nov 22, 2024@17:11:20 Page 2
PRCEADJ2 ;WISC/CLH/CTB-PRCEADJ1 CONT ; 21 Apr 93 8:32 AM
V ;;5.1;IFCAP;;Oct 20, 2000
+1 ;Per VHA Directive 10-93-142, this routine should not be modified.
+2 NEW TI,PRCFASYS,IOINLOW,IOINHI,IOINORM,DIR,AMT,OLDTT,CS,HASH,DIE,DR,LAUTH,LBAL,TAUTH,TBAL,DLAYGO
+3 DO SCREEN
SET DIR("A")="Ok to continue"
SET DIR("B")="Yes"
SET DIR(0)="Y"
SET DIR("?")="Press <RETURN> to continue processing"
DO ^DIR
IF 'Y
GOTO OUT
+4 SET AMT=$PIECE(TRNODE(4),U,8)
+5 DO OLDTT^PRCH58OB(PODA,.X)
SET OLDTT=X
+6 KILL PRCFA("TT")
IF X="921.60"
SET PRCFA("TT")=$SELECT(AMT<0:"921.33",1:"921.31")
GOTO K
+7 IF X="921.10"
SET PRCFA("TT")=$SELECT(AMT<0:"921.32",1:"921.30")
GOTO K
+8 IF X="921.71"
SET PRCFA("TT")=$SELECT(AMT<0:"921.73",1:"921.72")
K SET PRCFA("REF")=$PIECE($PIECE(PO(0),"^"),"-",2)
SET PRCFA("SYS")="CLM"
DO TT^PRCFAC
if '%
GOTO OUT
DO NEWCS^PRCFAC
if '$DATA(DA)
GOTO OUT
+1 SET PRC("CP")=$PIECE(TRNODE(0),"-",4)
SET CS=$SELECT($DATA(^PRCF(423,PRCFA("CSDA"),1)):^(1),1:"")
SET $PIECE(CS,"^")=".."
SET $PIECE(CS,"^",5,7)=PRC("CP")_"^"_+$PIECE(PO(0),"^",5)_"^^"
+2 FOR I=7,9
SET AMT(I)=$PIECE(TRNODE(3),"^",I)
if AMT(I)<0
SET AMT(I)=-AMT(I)
SET AMT(I)=AMT(I)*100
+3 SET $PIECE(CS,"^",16)="$"
SET $PIECE(CS,"^",8,11)=+$PIECE(TRNODE(3),"^",6)_"^"_AMT(7)_"^$^"
IF OLDTT'="921.60"
IF +$PIECE(TRNODE(3),"^",8)>0
IF AMT(9)>0
SET $PIECE(CS,"^",10,11)=$PIECE(TRNODE(3),"^",8)_"^"_AMT(9)
+4 SET ^PRCF(423,PRCFA("CSDA"),1)=CS
Y DO ^PRCFA921
DO ^PRCFACXM
IF $DATA(PRCFDEL)!($DATA(PRCFA("CSHOLD")))
KILL PRCFDEL,PRCFA("CSHOLD")
SET X=" Code Sheet not Processed, No Further Action Taken.*"
DO MSG^PRCFQ
GOTO OUT
+1 WRITE !!,"Updating Obligation balances. Please hold...",!!
X DO POADJ^PRCH58OB(.PO,PODA,.TRNODE,AMT)
+1 DO POADJ^PRCS58OB(.PRC,PODA,TRDA,AMT)
+2 if AMT>0
DO BULC^PRCH58(PODA)
Z SET (X,Z)=$PIECE(PO(0),U)
SET %=1
DO EN1^PRCSUT3
SET DLAYGO=424
SET DIC="^PRC(424,"
SET DIC(0)="L"
DO FILE^DICN
IF Y<0
WRITE !,"ERROR IN CREATING 424 RECORD",$CHAR(7),!!
QUIT
+1 SET DIE="^PRC(424,"
SET DA(1358)=+Y
DO NOW^%DTC
SET TI=%
SET DA=DA(1358)
SET DR=".02///^S X=PODA;.03///^S X=""A"";.06///^S X=$P(TRNODE(4),U,8);.07///^S X=TI;.08////^S X=DUZ;1.1////^S X=""ADJUSTMENT OBLIGATION"";.15////^S X=TRDA"
+2 DO ^DIE
SET X=" ----Adjustment Completed ----*"
DO MSG^PRCFQ
GOTO OUT
+3 QUIT
SCREEN ;COMPARISON SCREEN
+1 NEW CEILING,LAUTH,TAUTH,TBAL,LBAL,IOINHI,IOINLOW,IOINORM
+2 DO HILO^PRCFQ
SET CEILING=$PIECE(PO(8),U)
WRITE @IOF,IOINLOW,"Adjustment Transaction # ",IOINHI,$PIECE(TRNODE(0),"^"),IOINLOW," 1358 # ",IOINHI,$PIECE(PO(0),"^")
+3 WRITE !!,IOINLOW,"Current amount obligated on 1358: ",IOINHI," $ ",$FNUMBER(CEILING,"P,",2)
+4 SET TBAL=$PIECE(PO(8),U,3)
SET TAUTH=CEILING-TBAL
WRITE !!,IOINLOW," Total Authorizations: ",IOINHI," $ ",$JUSTIFY($FNUMBER(TAUTH,"P,",2),12)
+5 SET LBAL=$PIECE(PO(8),U,2)
SET LAUTH=CEILING-LBAL
WRITE ?40,IOINLOW," Total Liquidations: ",IOINHI," $ ",$JUSTIFY($FNUMBER(LAUTH,",P",2),12)
+6 WRITE !,IOINLOW,"Authorization Balance: ",IOINHI," $ ",$JUSTIFY($FNUMBER(TBAL,"P,",2),12),?40,IOINLOW,"Liquidation Balance: ",IOINHI," $ ",$JUSTIFY($FNUMBER(LBAL,"P,",2),12),!!
+7 WRITE IOINLOW,"Amount of Adjustment: ",IOINHI,$JUSTIFY($PIECE(TRNODE(4),"^",8),0,2),!!,IOINORM
+8 QUIT
OUT KILL DIRUT,DTOUT,DUOUT,DIROUT
QUIT
