- 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 Mar 13, 2025@21:08:29 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
