source: WorldVistAEHR/trunk/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCFFU17.m@ 1582

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

initial load of WorldVistAEHR

File size: 1.8 KB
Line 
1PRCFFU17 ;WISC/SJG-1358 OBLIGATION UTILITY ;6/29/00 12:15
2V ;;5.1;IFCAP;;Oct 20, 2000
3 ;Per VHA Directive 10-93-142, this routine should not be modified.
4 ;
5 QUIT
6 ; No top level entry
7 ;
8DATE ; Determine ending date
9 I $D(TMP("NEWDATE")) S (NEWDATE,DIR("B"))=$P(TMP("NEWDATE"),U,2) Q
10 I $G(PRCTMP(442,+POIEN,29,"E"))]"" S (NEWDATE,DIR("B"))=$G(PRCTMP(442,+POIEN,29,"E"))
11 I $G(PRCTMP(442,+POIEN,29,"E"))="" D
12 .I $G(PRCTMP(410,IEN,11,"E"))]"" D
13 ..I $G(PRCTMP(410,IEN,13,"I"))]"" D
14 ...S VENID=$G(PRCTMP(410,IEN,12,"I")) Q:VENID=""
15 ...S VENCONT=$G(PRCTMP(410,IEN,13,"I")) Q:VENCONT=""
16 ...S DIC="^PRC(440,"_VENID_",4,",DIC(0)="MNZ",X=VENCONT D ^DIC K DIC
17 ...I Y<0 D:$G(PRCTMP(410,IEN,13,"E"))]"" EOM Q
18 ...I Y>0 D Q
19 ....N DA S CONTIEN=+Y
20 ....S DIC=440,DR=6,DA=+VENID,DIQ="PRCTMP(",DIQ(0)="IEN",DR(440.03)=".5;1",DA(440.03)=CONTIEN D EN^DIQ1 K DIC,DIQ,DR
21 ....S CONTEND=$G(PRCTMP(440.03,CONTIEN,1,"E"))
22 ....I CONTEND]"" S (NEWDATE,DIR("B"))=CONTEND
23 ....Q
24 ...Q
25 ..Q
26 .I $G(PRCTMP(410,IEN,13,"E"))="" D EOM
27 .I $D(NEWDATE) S DIR("B")=NEWDATE
28 Q
29 ;
30FLAG ; Determine prompt for Auto Accrual
31 I $D(TMP("NEWACC")) S (NEWACC,DIR("B"))=$P(TMP("NEWACC"),U,2) Q
32 I $G(PRCTMP(442,+POIEN,30,"E"))]"" S (NEWACC,DIR("B"))=$G(PRCTMP(442,+POIEN,30,"E"))
33 I $G(PRCTMP(442,+POIEN,30,"E"))="" D
34 .S (NEWACC,DIR("B"))="YES"
35 .S X1=NEWDATE,X2=$G(PRCTMP(410,IEN,21,"I")) D ^%DTC I X<31 S (NEWACC,DIR("B"))="NO"
36 I $G(PRCTMP(442,+POIEN,30,"E"))]"" S (NEWACC,DIR("B"))=$G(PRCTMP(442,+POIEN,30,"E"))
37 Q
38 ;
39EOM ; Determine last date of month
40 N COM
41 S COM=$G(PRCTMP(410,IEN,21,"I")),Y=$P($$EOM^PRCFFU16(COM),U,2)
42 D DD^%DT S (NEWDATE,DIR("B"))=Y
43 Q
44CHK ; Check for changes
45 S OLDDATE=$G(PRCTMP(442,+POIEN,29,"I"))
46 S OLDACC=$G(PRCTMP(442,+POIEN,30,"I"))
47 I OLDDATE=NEWDATE&(OLDACC=NEWACC) Q
48 I OLDDATE'=NEWDATE S (PRCFA("ACCEDIT"),ACCEDIT)=1
49 I OLDACC'=NEWACC S (PRCFA("ACCEDIT"),ACCEDIT)=1
50 Q
Note: See TracBrowser for help on using the repository browser.