- 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 Feb 18, 2025@23:29:18 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