source: FOIAVistA/tag/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCFFU14.m@ 1415

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

initial load of FOIAVistA 6/30/08 version
File size: 4.3 KB
Line 
1PRCFFU14 ;WISC/SJG-1358 OBLIGATION UTILITY ;8/18/94 17:03
2V ;;5.1;IFCAP;;Oct 20, 2000
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4 ;
5EN(IEN) ; Called from 1358 obligation processing
6 ; IEN - Internal entry number from 410
7 W !,"Editing Auto Accrual information...",!
8 S (ACCEDIT,AUTOACC,EXIT)=0
9 D GENDIQ^PRCFFU7(410,IEN,"1;11;13;21;52","IEN","")
10 I $G(PRCTMP(410,IEN,21,"I"))="",$G(PRCTMP(410,IEN,1,"I"))="O" D Q
11 .S FLDCHK=1
12 .K MSG W !!
13 .S MSG(1)="The DATE COMMITTED is missing - cannot process in Fiscal!!"
14 .S MSG(2)="Please return this 1358 to the Service!!"
15 .D EN^DDIOL(.MSG) W ! K MSG H 3
16 .Q
17 D GENDIQ^PRCFFU7(410,IEN,"1;3;17.5;20","IEN","")
18 N PRCCOMCT,PRCBOCCT
19 S PRCCOMCT=$G(PRCTMP(410,IEN,20,"I")),PRCBOCCT=$G(PRCTMP(410,IEN,17.5,"I"))
20 I $G(PRCTMP(410,IEN,1,"I"))="O",$G(PRCTMP(410,IEN,3,"I"))=1,$J(PRCCOMCT,0,2)'=$J(PRCBOCCT,0,2) D Q
21 . S FLDCHK=1
22 . K MSG W !!
23 . S MSG(1)="The COMMITTED COST does not equal BOC $ AMOUNT!"
24 . S MSG(2)="Please return this 1358 to the Service!!"
25 . D EN^DDIOL(.MSG) W ! K MSG H 3
26 . Q
27 S POIEN=$G(PRCTMP(410,IEN,52,"I")) I POIEN]"" D
28 .D GENDIQ^PRCFFU7(442,POIEN,".8;29;30","IEN","")
29 .N FISCSTAT S FISCSTAT=$G(PRCTMP(442,POIEN,.8,"I")) I FISCSTAT=45 K PRCTMP(410,IEN,52),PRCTMP(442,POIEN)
30 .Q
31 I $G(PRCTMP(410,IEN,52,"I"))="" I '$D(NEWDATE) D DATE,FLAG,PROMPT I 'Y!($D(DIRUT)) D:EXIT MSG5 G:EXIT EN2
32 I $G(PRCTMP(410,IEN,52,"I"))="" I $D(NEWDATE) D DATE,FLAG S OB=IEN D MSG1(NEWDATE,NEWACC),CHK1(NEWDATE),PROMPT1 I Y!($D(DIRUT)) D:EXIT MSG5 G:EXIT EN2
33 I $G(PRCTMP(410,IEN,52,"I"))'="" D G:EXIT EN2
34 .S OB=IEN
35 .S NEWDATE=$G(PRCTMP(442,POIEN,29,"E")) I $D(TMP("NEWDATE")) S NEWDATE=$P(TMP("NEWDATE"),U,2)
36 .S NEWACC=$G(PRCTMP(442,POIEN,30,"E")) I $D(TMP("NEWACC")) S NEWACC=$P(TMP("NEWACC"),U,2)
37 .D MSG1(NEWDATE,NEWACC),CHK1(NEWDATE),PROMPT1 I Y!($D(DIRUT)) D:EXIT MSG5 Q
38 .Q
39EN1 W ! D DATE,MSG3(NEWDATE),CHK1(NEWDATE),FLAG,MSG4(NEWACC)
40 I EXIT D MSG5 G EN2
41 W ! D CHK
42 I (NEWDATE="")&(NEWACC="YES") D
43 .K MSG W !!
44 .S MSG(1)="This 1358 Obligation does not have an Ending Date, but the"
45 .S MSG(2)="Auto Accrual flag is set to 'YES'.",MSG(3)=" "
46 .S MSG(4)="The Auto Accural flag will be corrected and set to 'NO'."
47 .D EN^DDIOL(.MSG) W ! K MSG H 3
48 .Q
49EN2 S TMP("NEWACC")=NEWACC,$P(TMP("NEWACC"),U,2)=$S(NEWACC=0:"NO",NEWACC=1:"YES",1:"YES")
50 S TMP("NEWDATE")=NEWDATE S Y=NEWDATE D DD^%DT S $P(TMP("NEWDATE"),U,2)=Y
51 KILL AUTOACC,OLDACC,OLDDATE
52 QUIT
53 ;
54PROMPT ; Prompt user
55 S EXIT=0
56 D EN^DDIOL("This 1358 Obligation appears to be for services.")
57 S DIR(0)="Y",DIR("A")="Will this 1358 Obligation need to be accrued in FMS",DIR("B")="YES"
58 S DIR("?")=" '^' to exit this option."
59 S DIR("?",1)="Enter one of the following:"
60 S DIR("?",2)=" 'NO' or 'N' if no accrual is needed OR it is for one month."
61 S DIR("?",3)=" 'YES' or 'Y' if the 1358 covers more than one month AND accrual is needed."
62 S DIR("?",4)=" 'RETURN' for YES."
63 S DIR("??")="^D MSG2^PRCFFU15"
64 D ^DIR K DIR W !
65 I 'Y!($D(DIRUT)) D MSG5 Q
66 S NEWDATE="",NEWACC=Y(0)
67 Q
68MSG1(DATE,FLAG) ; Display current auto accrual information
69 K MSG W !
70 S MSG(1)="CURRENT VALUES FOR AUTO ACCRUAL FOR 1358: "
71 S MSG(2)=" ENDING DATE FOR SERVICE: "_DATE
72 S MSG(3)=" AUTO ACCRUAL FLAG: "_FLAG
73 D EN^DDIOL(.MSG) K MSG
74 Q
75PROMPT1 ; Prompt for correct values
76 S EXIT=0
77 S DIR(0)="Y",DIR("A")="Are these Auto Accrual values correct",DIR("B")="YES",DIR("??")="^D MSG2^PRCFFU15"
78 W ! D ^DIR K DIR W !
79 I Y S EXIT=1
80 Q
81DATE ; Determine ending date
82 D DATE^PRCFFU17
83 Q
84MSG3(DATE) ; Prompt for ending date
85MSG31 S EXIT=0,DIR(0)="D",DIR("A")="END DATE FOR 1358"
86 D ^DIR K DIR
87 I $D(DIRUT) S EXIT=1 Q
88 I Y S NEWDATE=Y
89 S X1=NEWDATE,X2=$G(PRCTMP(410,IEN,21,"I")) D ^%DTC I X<0 W ! D EN^DDIOL("The Ending Date cannot come before the Committed Date - "_$G(PRCTMP(410,IEN,21,"E"))) W ! G MSG31
90 Q
91FLAG ; Determine prompt for Auto Accrual
92 D FLAG^PRCFFU17
93 Q
94MSG4(FLAG) ; Prompt for auto accrual
95 Q:EXIT
96 S DIR(0)="Y",DIR("A")="AUTO ACCRUAL FLAG"
97 D ^DIR K DIR
98 I $D(DIRUT) S EXIT=1 Q
99 S NEWACC=$S($E(Y,1)="Y":1,$E(Y,1)="N":0,$G(DIRUT)=1:0,'Y:0,Y:1,1:1)
100 Q
101MSG5 ; Exit message
102 D MSG5^PRCFFU15
103 Q
104CHK ; Check for changes
105 D CHK^PRCFFU17
106 Q
107CHK1(DATE) ;Check for Ending Date crossover to next FY
108 S X="0930"_PRC("FY") D ^%DT
109 S X2=Y ; end of FY for 1358
110 S X=DATE D ^%DT
111 S X1=Y D ^%DTC
112 I X>0 W ! D EN^DDIOL("NOTE: The Ending Date for Service exceeds the End of the Fiscal Year!!")
113 W !
114 Q
Note: See TracBrowser for help on using the repository browser.