PRCF58A1 ;WISC@ALTOONA/CTB-1358 ADJUSTMENT CONT ;4/30/93 3:02 PM
V ;;5.1;IFCAP;;Oct 20, 2000
;Per VHA Directive 10-93-142, this routine should not be modified.
D SCREEN S %A="Ok to continue",%B="",%=1 D ^PRCFYN I %'=1 G OUT
S AMT=$P(TRNODE(4),"^",8)
;PRELOAD CODE SHEET
S (OLDTT,X)=$E(^PRC(442,PRCFA("PODA"),10,1,0),1,6)
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:'% KILL D NEWCS^PRCFAC G:'$D(DA) KILL
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
X ;UPDATE AMOUNTS IN 442
S $P(PO(0),"^",15)=$P(PO(0),"^",15)+AMT,$P(PO(0),"^",11)=AMT
F I=7,9 S $P(PO(0),"^",I)=$P(PO(0),"^",I)+$P(TRNODE(3),"^",I)
F I=0 S ^PRC(442,PRCFA("PODA"),I)=PO(I)
K PO S X=100,DA=PRCFA("PODA") D ENF^PRCHSTAT
;UPDATE ENTRY IN 410
S DA=PRCFA("TRDA")
D NOW^PRCFQ S TIME=X K %,%X
S $P(^PRCS(410,PRCFA("TRDA"),10),"^",3,4)=PRCFA("PODA")_"^"
S X=^PRCS(410,DA,4)
S $P(X,"^",3,5)=AMT_"^"_TIME_"^"_$P($P(^PRC(442,PRCFA("PODA"),0),"^"),"-",2)
S $P(X,"^",8)=AMT
S ^PRCS(410,DA,4)=X
S MESSAGE=""
D ENCODE^PRCSC2(DA,DUZ,.MESSAGE)
K MESSAGE
S X=AMT
S PRCHOBL="" D TRANK^PRCSES,TRANS^PRCSES K PRCHOBL D TRANS1^PRCSES K TIME
;POST ENTRY IN 424
Z S PO(0)=^PRC(442,PRCFA("PODA"),0),(X,Z)=$P(PO(0),"^"),%=1 D EN1^PRCSUT3 S DIC="^PRC(424,",DIC(0)="L",DLAYGO=424 D FILE^DICN K DLAYGO I Y<0 W !,"ERROR IN CREATING 424 RECORD",$C(7),!! Q
S PRCFA("424DA")=+Y D NOW^PRCFQ S DA=PRCFA("424DA"),X=PRCFA("PODA")_"^"_PRCFA("TRDA")_"^O^"_$P(TRNODE(4),"^",8)_"^"_%_"^OBLIGATION^^^^^^^ADJUSTMENT OBLIGATION"
S $P(^PRC(424,DA,0),"^",2,14)=X,DIK="^PRC(424," D IX1^DIK K DIK
S X=" ----DONE----*" D MSG^PRCFQ G OUT
W Q
SCREEN ;COMPARISON SCREEN
D HILO^PRCFQ S CEILING=$P(PO(0),"^",15) W @IOF,IOINLOW,"Adjustment Transaction # ",IOINHI,$P(TRNODE(0),"^"),IOINLOW," 1358 # ",IOINHI,$P(PO(0),"^")
W !!,IOINLOW,"Current amount obligated on 1358: ",IOINHI," $ ",$J(CEILING,0,2)
S TBAL=$P(PO(8),"^"),TAUTH=CEILING-TBAL W !!,IOINLOW," Total Authorizations: ",IOINHI," $ ",$J(TAUTH,10,2)
S LBAL=$P(PO(8),"^",2),LAUTH=CEILING-LBAL W ?40,IOINLOW," Total Liquidations: ",IOINHI," $ ",$J(LAUTH,10,2)
W !,IOINLOW,"Authorization Balance: ",IOINHI," $ ",$J(TBAL,10,2),?40,IOINLOW,"Liquidation Balance: ",IOINHI," $ ",$J(LBAL,10,2),!!
W IOINLOW,"Amount of Adjustment: ",IOINHI,$J($P(TRNODE(4),"^",8),0,2),!!,IOINORM K IOINHI,IOINLOW,IOINORM,LAUTH,TAUTH,TBAL,LBAL
Q
KILL Q
OUT K %,A,AMT,C,CS,CEILING,DA,DEL,DIK,DIC,DLAYGO,I,J,N1,N2,OLDTT,PO,PRCF,PRCFA,IOINORM,IOINHI,IOINLOW,TMP,TRNODE,X,X1,Y,Z Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCF58A1 3290 printed Dec 13, 2024@02:01:41 Page 2
PRCF58A1 ;WISC@ALTOONA/CTB-1358 ADJUSTMENT CONT ;4/30/93 3:02 PM
V ;;5.1;IFCAP;;Oct 20, 2000
+1 ;Per VHA Directive 10-93-142, this routine should not be modified.
+2 DO SCREEN
SET %A="Ok to continue"
SET %B=""
SET %=1
DO ^PRCFYN
IF %'=1
GOTO OUT
+3 SET AMT=$PIECE(TRNODE(4),"^",8)
+4 ;PRELOAD CODE SHEET
+5 SET (OLDTT,X)=$EXTRACT(^PRC(442,PRCFA("PODA"),10,1,0),1,6)
+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 KILL
DO NEWCS^PRCFAC
if '$DATA(DA)
GOTO KILL
+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
X ;UPDATE AMOUNTS IN 442
+1 SET $PIECE(PO(0),"^",15)=$PIECE(PO(0),"^",15)+AMT
SET $PIECE(PO(0),"^",11)=AMT
+2 FOR I=7,9
SET $PIECE(PO(0),"^",I)=$PIECE(PO(0),"^",I)+$PIECE(TRNODE(3),"^",I)
+3 FOR I=0
SET ^PRC(442,PRCFA("PODA"),I)=PO(I)
+4 KILL PO
SET X=100
SET DA=PRCFA("PODA")
DO ENF^PRCHSTAT
+5 ;UPDATE ENTRY IN 410
+6 SET DA=PRCFA("TRDA")
+7 DO NOW^PRCFQ
SET TIME=X
KILL %,%X
+8 SET $PIECE(^PRCS(410,PRCFA("TRDA"),10),"^",3,4)=PRCFA("PODA")_"^"
+9 SET X=^PRCS(410,DA,4)
+10 SET $PIECE(X,"^",3,5)=AMT_"^"_TIME_"^"_$PIECE($PIECE(^PRC(442,PRCFA("PODA"),0),"^"),"-",2)
+11 SET $PIECE(X,"^",8)=AMT
+12 SET ^PRCS(410,DA,4)=X
+13 SET MESSAGE=""
+14 DO ENCODE^PRCSC2(DA,DUZ,.MESSAGE)
+15 KILL MESSAGE
+16 SET X=AMT
+17 SET PRCHOBL=""
DO TRANK^PRCSES
DO TRANS^PRCSES
KILL PRCHOBL
DO TRANS1^PRCSES
KILL TIME
+18 ;POST ENTRY IN 424
Z SET PO(0)=^PRC(442,PRCFA("PODA"),0)
SET (X,Z)=$PIECE(PO(0),"^")
SET %=1
DO EN1^PRCSUT3
SET DIC="^PRC(424,"
SET DIC(0)="L"
SET DLAYGO=424
DO FILE^DICN
KILL DLAYGO
IF Y<0
WRITE !,"ERROR IN CREATING 424 RECORD",$CHAR(7),!!
QUIT
+1 SET PRCFA("424DA")=+Y
DO NOW^PRCFQ
SET DA=PRCFA("424DA")
SET X=PRCFA("PODA")_"^"_PRCFA("TRDA")_"^O^"_$PIECE(TRNODE(4),"^",8)_"^"_%_"^OBLIGATION^^^^^^^ADJUSTMENT OBLIGATION"
+2 SET $PIECE(^PRC(424,DA,0),"^",2,14)=X
SET DIK="^PRC(424,"
DO IX1^DIK
KILL DIK
+3 SET X=" ----DONE----*"
DO MSG^PRCFQ
GOTO OUT
+4 WRITE Q
SCREEN ;COMPARISON SCREEN
+1 DO HILO^PRCFQ
SET CEILING=$PIECE(PO(0),"^",15)
WRITE @IOF,IOINLOW,"Adjustment Transaction # ",IOINHI,$PIECE(TRNODE(0),"^"),IOINLOW," 1358 # ",IOINHI,$PIECE(PO(0),"^")
+2 WRITE !!,IOINLOW,"Current amount obligated on 1358: ",IOINHI," $ ",$JUSTIFY(CEILING,0,2)
+3 SET TBAL=$PIECE(PO(8),"^")
SET TAUTH=CEILING-TBAL
WRITE !!,IOINLOW," Total Authorizations: ",IOINHI," $ ",$JUSTIFY(TAUTH,10,2)
+4 SET LBAL=$PIECE(PO(8),"^",2)
SET LAUTH=CEILING-LBAL
WRITE ?40,IOINLOW," Total Liquidations: ",IOINHI," $ ",$JUSTIFY(LAUTH,10,2)
+5 WRITE !,IOINLOW,"Authorization Balance: ",IOINHI," $ ",$JUSTIFY(TBAL,10,2),?40,IOINLOW,"Liquidation Balance: ",IOINHI," $ ",$JUSTIFY(LBAL,10,2),!!
+6 WRITE IOINLOW,"Amount of Adjustment: ",IOINHI,$JUSTIFY($PIECE(TRNODE(4),"^",8),0,2),!!,IOINORM
KILL IOINHI,IOINLOW,IOINORM,LAUTH,TAUTH,TBAL,LBAL
+7 QUIT
KILL QUIT
OUT KILL %,A,AMT,C,CS,CEILING,DA,DEL,DIK,DIC,DLAYGO,I,J,N1,N2,OLDTT,PO,PRCF,PRCFA,IOINORM,IOINHI,IOINLOW,TMP,TRNODE,X,X1,Y,Z
QUIT
