PRCFFU17 ;WISC/SJG-1358 OBLIGATION UTILITY ;6/29/00 12:15 V ;;5.1;IFCAP;;Oct 20, 2000 ;Per VHA Directive 10-93-142, this routine should not be modified. ; QUIT ; No top level entry ; DATE ; Determine ending date I $D(TMP("NEWDATE")) S (NEWDATE,DIR("B"))=$P(TMP("NEWDATE"),U,2) Q I $G(PRCTMP(442,+POIEN,29,"E"))]"" S (NEWDATE,DIR("B"))=$G(PRCTMP(442,+POIEN,29,"E")) I $G(PRCTMP(442,+POIEN,29,"E"))="" D .I $G(PRCTMP(410,IEN,11,"E"))]"" D ..I $G(PRCTMP(410,IEN,13,"I"))]"" D ...S VENID=$G(PRCTMP(410,IEN,12,"I")) Q:VENID="" ...S VENCONT=$G(PRCTMP(410,IEN,13,"I")) Q:VENCONT="" ...S DIC="^PRC(440,"_VENID_",4,",DIC(0)="MNZ",X=VENCONT D ^DIC K DIC ...I Y<0 D:$G(PRCTMP(410,IEN,13,"E"))]"" EOM Q ...I Y>0 D Q ....N DA S CONTIEN=+Y ....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 ....S CONTEND=$G(PRCTMP(440.03,CONTIEN,1,"E")) ....I CONTEND]"" S (NEWDATE,DIR("B"))=CONTEND ....Q ...Q ..Q .I $G(PRCTMP(410,IEN,13,"E"))="" D EOM .I $D(NEWDATE) S DIR("B")=NEWDATE Q ; FLAG ; Determine prompt for Auto Accrual I $D(TMP("NEWACC")) S (NEWACC,DIR("B"))=$P(TMP("NEWACC"),U,2) Q I $G(PRCTMP(442,+POIEN,30,"E"))]"" S (NEWACC,DIR("B"))=$G(PRCTMP(442,+POIEN,30,"E")) I $G(PRCTMP(442,+POIEN,30,"E"))="" D .S (NEWACC,DIR("B"))="YES" .S X1=NEWDATE,X2=$G(PRCTMP(410,IEN,21,"I")) D ^%DTC I X<31 S (NEWACC,DIR("B"))="NO" I $G(PRCTMP(442,+POIEN,30,"E"))]"" S (NEWACC,DIR("B"))=$G(PRCTMP(442,+POIEN,30,"E")) Q ; EOM ; Determine last date of month N COM S COM=$G(PRCTMP(410,IEN,21,"I")),Y=$P($$EOM^PRCFFU16(COM),U,2) D DD^%DT S (NEWDATE,DIR("B"))=Y Q CHK ; Check for changes S OLDDATE=$G(PRCTMP(442,+POIEN,29,"I")) S OLDACC=$G(PRCTMP(442,+POIEN,30,"I")) I OLDDATE=NEWDATE&(OLDACC=NEWACC) Q I OLDDATE'=NEWDATE S (PRCFA("ACCEDIT"),ACCEDIT)=1 I OLDACC'=NEWACC S (PRCFA("ACCEDIT"),ACCEDIT)=1 Q