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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCFFU17 1927 printed Apr 09, 2024@21:18:42 Page 2
PRCFFU17 ;WISC/SJG-1358 OBLIGATION UTILITY ;6/29/00 12:15
V ;;5.1;IFCAP;;Oct 20, 2000
+1 ;Per VHA Directive 10-93-142, this routine should not be modified.
+2 ;
+3 QUIT
+4 ; No top level entry
+5 ;
DATE ; Determine ending date
+1 IF $DATA(TMP("NEWDATE"))
SET (NEWDATE,DIR("B"))=$PIECE(TMP("NEWDATE"),U,2)
QUIT
+2 IF $GET(PRCTMP(442,+POIEN,29,"E"))]""
SET (NEWDATE,DIR("B"))=$GET(PRCTMP(442,+POIEN,29,"E"))
+3 IF $GET(PRCTMP(442,+POIEN,29,"E"))=""
Begin DoDot:1
+4 IF $GET(PRCTMP(410,IEN,11,"E"))]""
Begin DoDot:2
+5 IF $GET(PRCTMP(410,IEN,13,"I"))]""
Begin DoDot:3
+6 SET VENID=$GET(PRCTMP(410,IEN,12,"I"))
if VENID=""
QUIT
+7 SET VENCONT=$GET(PRCTMP(410,IEN,13,"I"))
if VENCONT=""
QUIT
+8 SET DIC="^PRC(440,"_VENID_",4,"
SET DIC(0)="MNZ"
SET X=VENCONT
DO ^DIC
KILL DIC
+9 IF Y<0
if $GET(PRCTMP(410,IEN,13,"E"))]""
DO EOM
QUIT
+10 IF Y>0
Begin DoDot:4
+11 NEW DA
SET CONTIEN=+Y
+12 SET DIC=440
SET DR=6
SET DA=+VENID
SET DIQ="PRCTMP("
SET DIQ(0)="IEN"
SET DR(440.03)=".5;1"
SET DA(440.03)=CONTIEN
DO EN^DIQ1
KILL DIC,DIQ,DR
+13 SET CONTEND=$GET(PRCTMP(440.03,CONTIEN,1,"E"))
+14 IF CONTEND]""
SET (NEWDATE,DIR("B"))=CONTEND
+15 QUIT
End DoDot:4
QUIT
+16 QUIT
End DoDot:3
+17 QUIT
End DoDot:2
+18 IF $GET(PRCTMP(410,IEN,13,"E"))=""
DO EOM
+19 IF $DATA(NEWDATE)
SET DIR("B")=NEWDATE
End DoDot:1
+20 QUIT
+21 ;
FLAG ; Determine prompt for Auto Accrual
+1 IF $DATA(TMP("NEWACC"))
SET (NEWACC,DIR("B"))=$PIECE(TMP("NEWACC"),U,2)
QUIT
+2 IF $GET(PRCTMP(442,+POIEN,30,"E"))]""
SET (NEWACC,DIR("B"))=$GET(PRCTMP(442,+POIEN,30,"E"))
+3 IF $GET(PRCTMP(442,+POIEN,30,"E"))=""
Begin DoDot:1
+4 SET (NEWACC,DIR("B"))="YES"
+5 SET X1=NEWDATE
SET X2=$GET(PRCTMP(410,IEN,21,"I"))
DO ^%DTC
IF X<31
SET (NEWACC,DIR("B"))="NO"
End DoDot:1
+6 IF $GET(PRCTMP(442,+POIEN,30,"E"))]""
SET (NEWACC,DIR("B"))=$GET(PRCTMP(442,+POIEN,30,"E"))
+7 QUIT
+8 ;
EOM ; Determine last date of month
+1 NEW COM
+2 SET COM=$GET(PRCTMP(410,IEN,21,"I"))
SET Y=$PIECE($$EOM^PRCFFU16(COM),U,2)
+3 DO DD^%DT
SET (NEWDATE,DIR("B"))=Y
+4 QUIT
CHK ; Check for changes
+1 SET OLDDATE=$GET(PRCTMP(442,+POIEN,29,"I"))
+2 SET OLDACC=$GET(PRCTMP(442,+POIEN,30,"I"))
+3 IF OLDDATE=NEWDATE&(OLDACC=NEWACC)
QUIT
+4 IF OLDDATE'=NEWDATE
SET (PRCFA("ACCEDIT"),ACCEDIT)=1
+5 IF OLDACC'=NEWACC
SET (PRCFA("ACCEDIT"),ACCEDIT)=1
+6 QUIT
