source: WorldVistAEHR/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCEADJ1.m@ 1608

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

initial load of WorldVistAEHR
File size: 4.3 KB
RevLine 
[613]1PRCEADJ1 ;WISC/CLH/LDB/SJG-FISCAL 1358 ADJUSTMENTS ; 04/21/93 4:20 PM
2V ;;5.1;IFCAP;**23**;Oct 20, 2000
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4 ; Adjustment processing FISCAL
5 N PRC410,PRC442,DA,I,PO,PRC,PRCB,PRCF,PRCFA,DIC,TRNODE,X,Y,FSO,PX,TRDA,X1,PODA,NOGO
6V1 D OUT S PRCF("X")="AB" D ^PRCFSITE Q:'%
7 D LU^PRCS58OB(.Y,.PRC,.PRCF) G:Y<0 OUT
8 S PRCFA("RETRAN")=0
9RETRAN ; Entry point for rebuild/transmit
10 W !,"...retrieving 1358 information...",! D WAIT^DICD
11 S (DA,TRDA)=+Y
12 D NODE^PRCS58OB(DA,.TRNODE)
13 S (X,X1)=$P(TRNODE(4),U,5) D VER^PRCH58OB(.PRC,.X)
14 I X="" W !!,"Unable to Process due to lack of Obligation Number." G OUT
15 S PODA=X,PRC410=TRDA,PRC442=X,NOGO="" D OB1^PRCS58OB(TRDA,X)
16 D PO^PRCH58OB(PODA,.PO) S PO=PODA
17 D HILO^PRCFQ
18FMSCHK ;
19 ; Patch 23, disable obligation process for SO with "Q" & "T" status
20 I $D(PRCFA("RETRAN")),PRCFA("RETRAN")=0 D FMSTAT I $D(SOSTAT),("^Q^T^R^E^")[$E(SOSTAT,1),SOSTAT'="CALM" D G V1
21 .W !! K MSG S MSG(1)=" One of the previous documents has not been accepted in FMS."
22 .S MSG(2)=" The adjustment to this 1358 cannot be obligated at this time."
23 .S MSG(3)=" In order for the obligation of this adjustment to proceed, the"
24 .S MSG(4)=" previous document cannot have a status of 'REJECTED', 'ERROR"
25 .S MSG(5)=" IN TRANSMISSION', 'QUEUED FOR TRANSMISSION', or 'TRANSMITTED'.",MSG(6)=" "
26 .S MSG(7)=" FMS Document: "_SODOC,MSG(8)=" Status: "_SOSTAT,MSG(9)=" "
27 .S MSG(10)=" No further action is being taken on this obligation."
28 .D EN^DDIOL(.MSG) K MSG W !
29 .Q
30SC W:$D(IOF) @IOF W "PROCESS 1358 ADJUSTMENT",?40,"Obligation #: ",IOINHI,$P(PO(0),"^")
31 W !!,IOINLOW," Service Balance: $ ",IOINHI,$FN(+PO(8)-$P(PO(8),"^",3),"P,",2)
32 W !,IOINLOW," Fiscal Balance: $ ",IOINHI,$FN(+PO(8)-$P(PO(8),"^",2),"P,",2)
33 W !,IOINLOW,"Amount of Adjustment: $ ",IOINHI,$FN($P(TRNODE(4),"^",8),",P",2)
34 W !!,IOINLOW,?20,"ORIGINAL",?45,"ADJUSTMENT"
35 W !!,IOINLOW," COST CENTER: ",?21,IOINHI,+$P(PO(0),"^",5),?48,+$P(TRNODE(3),"^",3) I +$P(PO(0),"^",5)'=+$P(TRNODE(3),"^",3) S NOGO=NOGO_3 W $C(7),?60,"*****"
36 W !!,IOINLOW,?10,"BOC #1:",?22,IOINHI,$P($P(PO(0),"^",6)," "),?49,$P($P(TRNODE(3),"^",6)," ") I +$P(PO(0),"^",6)'=+$P(TRNODE(3),"^",6) W $C(7),?60,"*****" S NOGO=NOGO_2
37 I +$P(PO(0),"^",8)>0!(+$P(TRNODE(3),"^",8)>0) W !,IOINLOW,?10,"BOC #2:",?22,IOINHI,$P($P(PO(0),"^",8)," "),?49,$P($P(TRNODE(3),"^",8)," ") I +$P(PO(0),"^",8)'=+$P(TRNODE(3),"^",8) W $C(7),?60,"*****" S NOGO=NOGO_2
38 W IOINORM
39 I NOGO[2 D SUB G OUT ;G:'Y V D SAEDIT^PRCS58OB(.PO,TRDA) S I=4
40 I NOGO[3 D CC G OUT
41CHECK ; Check adjustment amount with obligation/liquidation/authorization amounts
42 I PRC442,+$G(PRCFA("RETRAN"))=0,$$EN1^PRCE0A(PRC410,PRC442,1) W !,$C(7),"Send 1358 adjustment back to service.",! G OUT
43 S PRCFA("MOD")="M^1^Modification Entry"
44 W ! D VENCONM^PRCFFU15(+PO)
45 D EN^PRCFFU14(TRDA) I ACCEDIT G SC
46 D AUTACC^PRCFFU6 S PRCFA("ACCEDIT")=1
47 N Y S PRCFA("IDES")="1358 Obligation Adjustment" W ! D OKAY^PRCFFU
48 ; Patch 23, fix Y undef error
49 ;I Y K DIR,Y D ^PRCESOM I $D(PRCFA("RETRAN")),PRCFA("RETRAN")=0 G V1
50 I Y K DIR,Y D ^PRCESOM G:'$G(PRCFA("RETRAN")) V1 S Y=0 ; patch 23
51 I 'Y!($D(DIRUT)) W ! D EN^DDIOL("No further processing is being taken on this adjustment.")
52OUT K DTOUT,DIR,DUOUT,DIRUT,DIROUT
53OUT1 K DA,D0,ACCEDIT,BBFY,BEGDATE,CONT,CONTEND,CONTIEN,ENDDATE,ESIGMSG,EXIT
54 K FMSMOD,FMSVENID,GECSFMS,I,NEWACC,NEWDATE,NOGO
55 K NUMB,OB,PARAM1,PO,PODA,PODATE,POIEN,PRC410,PRC442,PRCCC,PRCCCC,PRCCSCC
56 K PRCCP,PRCFA,PRCFMO,PRCREQST,PRCSTA,PRCSTR,PRCTMP,SODOC,SOSTAT
57 K STR2,TMP410,TMP442,TRDA,TRNODE,VENCONT,X,X1
58 Q
59FMSTAT ; Check status of prior FMS Documments
60 D FMSTAT^PRCEADJ(+PO,.SODOC,.SOSTAT)
61 Q
62SUB ; Check BOCs (subaccounts)
63 K MSG W !!
64 S MSG(1)=" BOCs on the adjustment are not the same as on the original obligation."
65 S MSG(2)=" Processing cannot continue - please return to the Service for correction.",MSG(3)=" "
66 S MSG(4)=" No further processing is being taken on this adjustment."
67 D MSG(.MSG)
68 Q
69CC ; Check Cost Centers
70 K MSG W !!
71 S MSG(1)=" Cost Center on the adjustment is not the same as on the original"
72 S MSG(2)=" obligation. Processing cannot continue - please return to the"
73 S MSG(3)=" Service for correction.",MSG(4)=" "
74 S MSG(5)=" No further processing is being taken on this adjustment."
75 D MSG(.MSG)
76 Q
77MSG(X) ; Display message
78 Q:'$D(MSG)
79 D EN^DDIOL(.MSG),ENCON^PRCFQ
80 Q
Note: See TracBrowser for help on using the repository browser.