source: FOIAVistA/tag/r/IFCAP-PRC-PRX--PRCA--PRCN/PRCFFU17.m@ 1251

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