PRCFDCIP ;WISC@ALTOONA/CLH-VARIOUS PRINT ROUTINES FOR CI ; 1/23/97 1:55 PM
V ;;5.1;IFCAP;;Oct 20, 2000
;Per VHA Directive 10-93-142, this routine should not be modified.
FIS ;PRINT OF INVOICES DUE IN FISCAL ON "T" TO "T+1"
S DIC="^PRCF(421.5,",BY="[PRCF CI OUT SORT]",TO="TODAY",FR="1901"
N PRCFDHIT S DIOBEG="S PRCFDHIT=0",DHIT="S PRCFDHIT=PRCFDHIT+1"
S DIOEND="I 'PRCFDHIT W ""CERTIFIED INVOICE DUE IN FISCAL LIST"",!!,""NO INVOICES DUE IN FISCAL FOUND"",!!,""[End of Report]"""
S FLDS="[PRCFD DUE IN FISCAL PRINT]" D EN1^DIP K DIC,BY,TO,FR,FLDS Q
QUE ;C.I.'S DUE FOR PAYMENT
I $D(ZTQUEUED) G PD
S ZTRTN="PD^PRCFDCIP",ZTDESC="PRINT CERT. INV. DUE FOR PAYMENT" D ^PRCFQ
K DIC,TO,FR,BY,FLDS Q
PD ;QUE'D ENTRY POINT
D:$D(ZTQUEUED) KILL^%ZTLOAD
I '$D(PRIOP) S PRIOP=$S($D(ION):ION,1:IO)
S IOP=PRIOP,DIC="^PRCF(421.5,",BY="[PRCF CI DISCOUNT DUE SORT]"
S TO="TODAY+15",FR="T-180",FLDS="[PRCF CI DISCOUNT DUE PRINT]"
N PRCFDHIT S DIOBEG="S PRCFDHIT=0",DHIT="S PRCFDHIT=PRCFDHIT+1"
S DIOEND="I 'PRCFDHIT W ""CERTIFIED INVOICE DISCOUNT DUE LIST"",!!,""NO DISCOUNT DUE INVOICES FOUND"",!!,""[End of Report]"""
D EN1^DIP
S IOP=PRIOP,DIC="^PRCF(421.5,",BY="[PRCF CI NET DUE DATE SORT]"
S TO="TODAY+15",FR="T-180",FLDS="[PRCF CI NET DUE DATE PRINT]"
N PRCFDHIT S DIOBEG="S PRCFDHIT=0",DHIT="S PRCFDHIT=PRCFDHIT+1"
S DIOEND="I 'PRCFDHIT W ""CERTIFIED INVOICE NET DUE LIST"",!!,""NO NET DUE INVOICES FOUND"",!!,""[End of Report]"""
D EN1^DIP
K DIC,TO,FR,BY,FLDS,PRIOP Q
ENTER ; Set Payment Dates for Single Entry at same time as PPay terms
N DISC,INVDT,J,NDISC,NET,NODE0,NODE6,PRCFINV,SVCDT,X,X1,X2
Q:'$D(^PRCF(421.5,PRCF("CIDA"),6)) ; Quit if no prompt pay terms
S NODE0=$G(^PRCF(421.5,PRCF("CIDA"),0))
S INVDT=$P(NODE0,U,5),SVCDT=$P(NODE0,U,21)
S J=0,(NET,DISC)=-1 F S J=$O(^PRCF(421.5,PRCF("CIDA"),6,J)) Q:+J'>0 D
. S NODE6=$G(^PRCF(421.5,PRCF("CIDA"),6,J,0)) Q:NODE6=""
. I $P(NODE6,U,3)="NET",$P(NODE6,U,5)>0 S NET=$P(NODE6,U,5)
. I "NET"'[$P(NODE6,U,3),$P(NODE6,U,5)>0 D
. . S NDISC=$P(NODE6,U,5) I DISC=-1 S DISC=NDISC
. . I NDISC<DISC S DISC=NDISC
. . Q
. Q
I $G(DISC)>0 S X1=INVDT,X2=DISC D C^%DTC S $P(^PRCF(421.5,PRCF("CIDA"),2),U,6)=X
I $G(NET)]"" D
. I INVDT>SVCDT S X1=INVDT
. I INVDT'>SVCDT S X1=SVCDT
. S X2=NET D C^%DTC S $P(^PRCF(421.5,PRCF("CIDA"),2),U,7)=X
. Q
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCFDCIP 2360 printed Dec 13, 2024@02:02:54 Page 2
PRCFDCIP ;WISC@ALTOONA/CLH-VARIOUS PRINT ROUTINES FOR CI ; 1/23/97 1:55 PM
V ;;5.1;IFCAP;;Oct 20, 2000
+1 ;Per VHA Directive 10-93-142, this routine should not be modified.
FIS ;PRINT OF INVOICES DUE IN FISCAL ON "T" TO "T+1"
+1 SET DIC="^PRCF(421.5,"
SET BY="[PRCF CI OUT SORT]"
SET TO="TODAY"
SET FR="1901"
+2 NEW PRCFDHIT
SET DIOBEG="S PRCFDHIT=0"
SET DHIT="S PRCFDHIT=PRCFDHIT+1"
+3 SET DIOEND="I 'PRCFDHIT W ""CERTIFIED INVOICE DUE IN FISCAL LIST"",!!,""NO INVOICES DUE IN FISCAL FOUND"",!!,""[End of Report]"""
+4 SET FLDS="[PRCFD DUE IN FISCAL PRINT]"
DO EN1^DIP
KILL DIC,BY,TO,FR,FLDS
QUIT
QUE ;C.I.'S DUE FOR PAYMENT
+1 IF $DATA(ZTQUEUED)
GOTO PD
+2 SET ZTRTN="PD^PRCFDCIP"
SET ZTDESC="PRINT CERT. INV. DUE FOR PAYMENT"
DO ^PRCFQ
+3 KILL DIC,TO,FR,BY,FLDS
QUIT
PD ;QUE'D ENTRY POINT
+1 if $DATA(ZTQUEUED)
DO KILL^%ZTLOAD
+2 IF '$DATA(PRIOP)
SET PRIOP=$SELECT($DATA(ION):ION,1:IO)
+3 SET IOP=PRIOP
SET DIC="^PRCF(421.5,"
SET BY="[PRCF CI DISCOUNT DUE SORT]"
+4 SET TO="TODAY+15"
SET FR="T-180"
SET FLDS="[PRCF CI DISCOUNT DUE PRINT]"
+5 NEW PRCFDHIT
SET DIOBEG="S PRCFDHIT=0"
SET DHIT="S PRCFDHIT=PRCFDHIT+1"
+6 SET DIOEND="I 'PRCFDHIT W ""CERTIFIED INVOICE DISCOUNT DUE LIST"",!!,""NO DISCOUNT DUE INVOICES FOUND"",!!,""[End of Report]"""
+7 DO EN1^DIP
+8 SET IOP=PRIOP
SET DIC="^PRCF(421.5,"
SET BY="[PRCF CI NET DUE DATE SORT]"
+9 SET TO="TODAY+15"
SET FR="T-180"
SET FLDS="[PRCF CI NET DUE DATE PRINT]"
+10 NEW PRCFDHIT
SET DIOBEG="S PRCFDHIT=0"
SET DHIT="S PRCFDHIT=PRCFDHIT+1"
+11 SET DIOEND="I 'PRCFDHIT W ""CERTIFIED INVOICE NET DUE LIST"",!!,""NO NET DUE INVOICES FOUND"",!!,""[End of Report]"""
+12 DO EN1^DIP
+13 KILL DIC,TO,FR,BY,FLDS,PRIOP
QUIT
ENTER ; Set Payment Dates for Single Entry at same time as PPay terms
+1 NEW DISC,INVDT,J,NDISC,NET,NODE0,NODE6,PRCFINV,SVCDT,X,X1,X2
+2 ; Quit if no prompt pay terms
if '$DATA(^PRCF(421.5,PRCF("CIDA"),6))
QUIT
+3 SET NODE0=$GET(^PRCF(421.5,PRCF("CIDA"),0))
+4 SET INVDT=$PIECE(NODE0,U,5)
SET SVCDT=$PIECE(NODE0,U,21)
+5 SET J=0
SET (NET,DISC)=-1
FOR
SET J=$ORDER(^PRCF(421.5,PRCF("CIDA"),6,J))
if +J'>0
QUIT
Begin DoDot:1
+6 SET NODE6=$GET(^PRCF(421.5,PRCF("CIDA"),6,J,0))
if NODE6=""
QUIT
+7 IF $PIECE(NODE6,U,3)="NET"
IF $PIECE(NODE6,U,5)>0
SET NET=$PIECE(NODE6,U,5)
+8 IF "NET"'[$PIECE(NODE6,U,3)
IF $PIECE(NODE6,U,5)>0
Begin DoDot:2
+9 SET NDISC=$PIECE(NODE6,U,5)
IF DISC=-1
SET DISC=NDISC
+10 IF NDISC<DISC
SET DISC=NDISC
+11 QUIT
End DoDot:2
+12 QUIT
End DoDot:1
+13 IF $GET(DISC)>0
SET X1=INVDT
SET X2=DISC
DO C^%DTC
SET $PIECE(^PRCF(421.5,PRCF("CIDA"),2),U,6)=X
+14 IF $GET(NET)]""
Begin DoDot:1
+15 IF INVDT>SVCDT
SET X1=INVDT
+16 IF INVDT'>SVCDT
SET X1=SVCDT
+17 SET X2=NET
DO C^%DTC
SET $PIECE(^PRCF(421.5,PRCF("CIDA"),2),U,7)=X
+18 QUIT
End DoDot:1
+19 QUIT
