51 lines
1.8 KiB
Mathematica
51 lines
1.8 KiB
Mathematica
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
|