- 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 Feb 18, 2025@23:28:05 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
