source: WorldVistAEHR/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCEADJ2.m@ 1800

Last change on this file since 1800 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR

File size: 2.7 KB
RevLine 
[613]1PRCEADJ2 ;WISC/CLH/CTB-PRCEADJ1 CONT ; 21 Apr 93 8:32 AM
2V ;;5.1;IFCAP;;Oct 20, 2000
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4 N TI,PRCFASYS,IOINLOW,IOINHI,IOINORM,DIR,AMT,OLDTT,CS,HASH,DIE,DR,LAUTH,LBAL,TAUTH,TBAL,DLAYGO
5 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
6 S AMT=$P(TRNODE(4),U,8)
7 D OLDTT^PRCH58OB(PODA,.X) S OLDTT=X
8 K PRCFA("TT") I X="921.60" S PRCFA("TT")=$S(AMT<0:"921.33",1:"921.31") G K
9 I X="921.10" S PRCFA("TT")=$S(AMT<0:"921.32",1:"921.30") G K
10 I X="921.71" S PRCFA("TT")=$S(AMT<0:"921.73",1:"921.72")
11K S PRCFA("REF")=$P($P(PO(0),"^"),"-",2),PRCFA("SYS")="CLM" D TT^PRCFAC G:'% OUT D NEWCS^PRCFAC G:'$D(DA) OUT
12 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)_"^^"
13 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
14 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)
15 S ^PRCF(423,PRCFA("CSDA"),1)=CS
16Y 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
17 W !!,"Updating Obligation balances. Please hold...",!!
18X D POADJ^PRCH58OB(.PO,PODA,.TRNODE,AMT)
19 D POADJ^PRCS58OB(.PRC,PODA,TRDA,AMT)
20 D:AMT>0 BULC^PRCH58(PODA)
21Z 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
22 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"
23 D ^DIE S X=" ----Adjustment Completed ----*" D MSG^PRCFQ G OUT
24 Q
25SCREEN ;COMPARISON SCREEN
26 N CEILING,LAUTH,TAUTH,TBAL,LBAL,IOINHI,IOINLOW,IOINORM
27 D HILO^PRCFQ S CEILING=$P(PO(8),U) W @IOF,IOINLOW,"Adjustment Transaction # ",IOINHI,$P(TRNODE(0),"^"),IOINLOW," 1358 # ",IOINHI,$P(PO(0),"^")
28 W !!,IOINLOW,"Current amount obligated on 1358: ",IOINHI," $ ",$FN(CEILING,"P,",2)
29 S TBAL=$P(PO(8),U,3),TAUTH=CEILING-TBAL W !!,IOINLOW," Total Authorizations: ",IOINHI," $ ",$J($FN(TAUTH,"P,",2),12)
30 S LBAL=$P(PO(8),U,2),LAUTH=CEILING-LBAL W ?40,IOINLOW," Total Liquidations: ",IOINHI," $ ",$J($FN(LAUTH,",P",2),12)
31 W !,IOINLOW,"Authorization Balance: ",IOINHI," $ ",$J($FN(TBAL,"P,",2),12),?40,IOINLOW,"Liquidation Balance: ",IOINHI," $ ",$J($FN(LBAL,"P,",2),12),!!
32 W IOINLOW,"Amount of Adjustment: ",IOINHI,$J($P(TRNODE(4),"^",8),0,2),!!,IOINORM
33 Q
34OUT K DIRUT,DTOUT,DUOUT,DIROUT Q
Note: See TracBrowser for help on using the repository browser.