source: WorldVistAEHR/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCEADJ.m@ 1093

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

initial load of WorldVistAEHR
File size: 4.5 KB
RevLine 
[613]1PRCEADJ ;WISC/CLH/LDB/PLT/SJG-CP 1358 ADJUSTMENTS ; 04/21/93 10:52 AM
2V ;;5.1;IFCAP;;Oct 20, 2000
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4 ;Create increase/decrease adjustment
5EN N PRC410,PRC442,PRCS,DIE,DR,PRC,PRCS2,DIC,X,X410,X442,X1,X2,X3,X4,PRCSIP,Y,Y410,DIR,TRNODE,Z,Z410,PRCSOBN
6EN1 ;
7 D EN^PRCSUT ; ask site, fiscal year, quarter, control point; set X & Z
8 I '$D(PRC("SITE")) W !,$C(7),"You are not an authorized control point user.",! G OUT
9 G OUT:'$D(PRC("QTR"))!(Y<0)
10 S X410=X ; station-FY-FCP
11 S Z410=Z ; station-FY-quarter-FCP
12ENA1 S DIC=410,Y=""
13 D OROBL^PRCS58OB(DIC,.PRC,.Y) ; get obligation # from old 1358
14 I $D(DTOUT)!$D(DUOUT) G OUT
15 I Y<0 W $C(7),!!," Obligation number is required. Use '^' to exit this option.",! G ENA1
16 S Y410=Y
17 S X442=X
18 D NODE^PRCS58OB(+Y,.TRNODE) ; set up TRNODE array from data in 410
19 S X="0101"_$P(TRNODE(0),"-",2),%DT="X" D ^%DT
20 S X2=$E(Y,1,3) ; FY of original 1358
21 S X="0101"_PRC("FY"),%DT="X" D ^%DT
22 S X3=$E(Y,1,3) ; adjustment FY
23 I X2_"-"_$P(TRNODE(0),"-",3)](X3_"-"_PRC("QTR")) D EN^DDIOL("Adjustments cannot be earlier than the original 1358's FY-QTR.") G ENA1
24 N POOBL S POOBL=$P($G(TRNODE(10)),U,3)
25 I POOBL="" D EN^DDIOL(" Obligation number is required.") W ! G ENA1
26 N OBLSTAT S OBLSTAT=$$NP^PRC0B("^PRC(442,"_POOBL_",",7,1)
27 I $G(OBLSTAT)=40 D EN^DDIOL(" Adjusting a closed 1358 request is not allowed.") W ! G ENA1
28ENA2 N EXIT S EXIT=0
29 D FMSTAT(POOBL,.FMSDOC,.STATUS)
30 I $D(STATUS),"AF"'[$E(STATUS,1) D I EXIT D MSG1,OUT G EN1
31 .Q:STATUS="CALM"
32 .; S TMP=Y,%X="Y",%Y="TMP(" D %XY^%RCR K %X,%Y ; PRC*5*231 - saves Y earlier
33 .K MSG W !
34 .S MSG(1)=" Note that one of the previous documents has not been processed in FMS."
35 .S MSG(2)=" The adjustment to this 1358 cannot be obligated until the previous"
36 .S MSG(3)=" document has been processed in FMS.",MSG(5)=" "
37 .S MSG(6)=" FMS Document: "_FMSDOC,MSG(7)=" Status: "_STATUS
38 .D EN^DDIOL(.MSG) K MSG
39 .W ! D PROMPT
40 .S:Y EXIT=0 I 'Y!($D(DIRUT)) S EXIT=1
41 .Q
42 ;The following lines commented out by PRC*5*231 - Y doesn't need to be restored
43 ; I $D(STATUS) S:"AF"[$E(STATUS,1)!(STATUS="CALM") EXIT=1
44ENA3 ; I $D(EXIT) I 'EXIT S Y=TMP,%X="TMP",%Y="Y(" D %XY^%RCR,MSG2 K TMP,%X,%Y
45 S PRC442=$P($G(TRNODE(10)),U,3)
46 S PRCSOBN=$$BAL^PRCH58(PRC442) ; get obligation# from file 442,node 8
47 I PRCSOBN'=-1 W !," Original Obligation Amount: $ ",$FN($P(PRCSOBN,U),",P",2)
48 I PRCSOBN'=-1 D
49 .W ?46,"Service Balance: $ ",$FN((+PRCSOBN-$P(PRCSOBN,U,3)),",P",2),!
50 .W ?4," Fiscal's 1358 Balance: $ ",$FN(+PRCSOBN-$P(PRCSOBN,U,2),",P",2),!
51 S Y=Y410,X=X410,X1=X,Z=Z410
52 D EN1^PRCSUT3 Q:'X S X1=X
53 D EN2^PRCSUT3 Q:'$D(X1) S X=X1 ; add data to record in 410
54 W !,"This transaction is assigned transaction number: ",X
55 L +^PRCS(410,DA):0 I $T=0 D EN^DDIOL("File in use.... Please try again later") D KILL G EN1
56 I $D(^PRC(420,PRC("SITE"),1,+PRC("CP"),0)) S:$P(^(0),U,11)="Y" PRCS2=1
57 S PRC410=DA
58 S PRCSIP=$S($D(PRCSIP):PRCSIP,1:"")
59 D ADJ^PRCS58OB(DIC,DA,PRCSIP,.X4)
60 K PRCSOBN
61 D ADJ1^PRCS58OB(DA,X,Y410)
62 D ADJ2^PRCS58OB(.PRC,X442,DA)
63 L -^PRCS(410,DA)
64 S DIR("A")="Enter another increase/decrease adjustment"
65 S DIR(0)="YO",DIR("B")="NO"
66 S DIR("?")="Yes to enter an adjustment, return or '^' to quit"
67 D ^DIR I Y D KILL G EN1
68OUT K DIRUT,DTOUT,DUOUT
69KILL K PRC410,PRC442,PRCS,DIE,DR,PRC,PRCSL,PRCS2,DIC,X,X410,X442,X1,X4,PRCSIP,Y,Y410,DIR,TRNODE,Z,Z410,PRCSOBN
70 K DA,FMSDOC,STATUS,TMP
71 QUIT
72 ;
73ASK ; entry point from other options
74 S DIR(0)="YO"
75 S DIR("A")="Do you want to enter an increase adjustment at this time"
76 S DIR("B")="NO"
77 S DIR("?")="Yes to enter an increase adjustment, return or '^' to quit"
78 D ^DIR I 'Y&'$D(DIRUT) W !!,"No action can be taken with this authorization amount now.",! K DIR Q
79 K DIR,DIC,X,Y I $D(DIRUT) Q
80 G EN
81 ;
82FMSTAT(POOBL,FMSDOC,STATUS) ; Check status of prior FMS Documents
83 N LOOP,NODE
84 S LOOP=0,(FMSDOC,STATUS)=""
85 F S LOOP=$O(^PRC(442,+POOBL,10,LOOP)) Q:LOOP'>0 D
86 .S NODE=^PRC(442,+POOBL,10,LOOP,0)
87 .I $E(NODE,1,2)="SO"!($E(NODE,1,2)="AR") D
88 ..S FMSDOC=$P($G(^PRC(442,+POOBL,10,LOOP,0)),U,4)
89 ..S STATUS=$$STATUS^GECSSGET(FMSDOC)
90 ..Q
91 .I $E(NODE,1,6)?3N1"."2N S STATUS="CALM"
92 Q
93PROMPT ;
94 S DIR(0)="Y"
95 S DIR("A")=" Do you wish to create the adjustment to this 1358"
96 S DIR("B")="YES"
97 S DIR("?")=" Enter 'YES' or 'Y' or 'RETURN' to create the adjustment."
98 S DIR("?",1)=" Enter 'NO' or 'N' or '^' to exit."
99 D ^DIR K DIR
100 Q
101 ;
102MSG1 W ! D EN^DDIOL(" No further action taken on this adjustment.") W ! Q
103MSG2 W ! D EN^DDIOL(" Returning to creating the 1358 adjustment...") W !! Q
Note: See TracBrowser for help on using the repository browser.