IBOTRR.m

IBOTRR ;ALB/ARH - ROI EXPIRING REPORT ; 08-JAN-2013

 ;;2.0;INTEGRATED BILLING;**458**;21-MAR-94;Build 4

 ;;Per VHA Directive 2004-038, this routine should not be modified.

 ;

EN ;get parameters then run the report

 D HOME^%ZIS N DIR,DIRUT,DUOUT,X,Y,IBBDT,IBEDT,IBEXCEL

 W !!,"ROI Special Consent Report - Find ROIs about to expire",!

 ;

 D DATE^IBOUTL I IBBDT=""!(IBEDT="") Q

 ;

 W !!,"ROI's that expire between "_$$FMTE^XLFDT(IBBDT,2)_" and "_$$FMTE^XLFDT(IBEDT,2)_" will be included on the report.",!

 ;

 ; Determine whether to gather data for Excel report

 S DIR("?")="Enter Yes to capture the report on the screen for transfer to Excel."

 S DIR(0)="Y",DIR("B")="NO",DIR("A")="Do you want to capture report data for an Excel document" D ^DIR K DIR I $D(DIRUT) G EXIT

 S IBEXCEL=0 I Y=1 S IBEXCEL=1 W !,"Enter '0;80;999' at the 'DEVICE:' prompt.",!

 ;

DEV ;get the device

 S %ZIS="QM",%ZIS("A")="OUTPUT DEVICE: " D ^%ZIS G:POP EXIT

 I $D(IO("Q")) S ZTRTN="RPT^IBOTRR",ZTSAVE("IB*")="",ZTDESC="IB ROI Expires" D ^%ZTLOAD K IO("Q") G EXIT

 U IO

 ;

RPT ;find, save, and print the data that satisfies the search parameters

 ;entry point for tasked jobs

 ;

 K ^TMP($J,"IBOTRR")

 ;

 D SORT,PRINT

 ;

EXIT ;clean up and quit

 K ^TMP($J,"IBOTRR") Q:$D(ZTQUEUED)

 D ^%ZISC

 Q

 ;

SORT ; sort report - get all ROIs that will expire in Patient and Effective Date order

 N DFN,IBRFN,IBR0,IBPAT,IBB,IBE K ^TMP($J,"IBOTRR")

 ;

 S DFN=0 F  S DFN=$O(^IBT(356.26,"C",DFN)) Q:'DFN  D

 .S IBRFN=0 F  S IBRFN=$O(^IBT(356.26,"C",DFN,IBRFN)) Q:'IBRFN  D

 .. S IBR0=$G(^IBT(356.26,IBRFN,0))

 .. S IBB=+$P(IBR0,U,4),IBE=+$P(IBR0,U,5),IBPAT=$P($G(^DPT(+$P(IBR0,U,2),0)),U,1)

 .. ;

 .. I IBE'<IBBDT,IBE'>IBEDT S ^TMP($J,"IBOTRR",IBPAT,$P(IBR0,U,4),IBRFN)=""

 ;

 Q

 ;

PRINT ;print the report from the temp sort file to the appropriate device

 N IBPGN,IBLN,IBQUIT,IBPAT,IBB,IBRFN,IBR0

 S IBPGN=0,IBQUIT=0 D HDR Q:IBQUIT

 ;

 S IBPAT="" F  S IBPAT=$O(^TMP($J,"IBOTRR",IBPAT)) Q:IBPAT=""  D  Q:IBQUIT

 . S IBB="" F  S IBB=$O(^TMP($J,"IBOTRR",IBPAT,IBB)) Q:IBB=""  D  Q:IBQUIT

 .. S IBRFN=0 F  S IBRFN=$O(^TMP($J,"IBOTRR",IBPAT,IBB,IBRFN)) Q:'IBRFN  D  Q:$$LNCHK(2)

 ... S IBR0=$G(^IBT(356.26,IBRFN,0))

 ... I +$G(IBEXCEL) W !,IBPAT,U,$$FMTE^XLFDT($P(IBR0,U,4)),U,$$FMTE^XLFDT($P(IBR0,U,5)) S IBLN=1 Q

 ... W !,IBPAT,?36,$$FMTE^XLFDT($P(IBR0,U,4)),?53,$$FMTE^XLFDT($P(IBR0,U,5)) S IBLN=IBLN+1

 ;

 I 'IBQUIT D PAUSE

 Q

LNCHK(LNS) ; check if new page is needed

 I 'IBQUIT,IBLN>(IOSL-LNS) D PAUSE I 'IBQUIT D HDR

 Q IBQUIT

 ;

HDR ;print the report header

 N IBNOW,IBI

 I +$G(IBEXCEL) W !,"Patient^Effective^Expires" S IBLN=1 Q

 ;

 S IBQUIT=$$STOP Q:IBQUIT  S IBPGN=IBPGN+1,IBLN=7

 S IBNOW=$$FMTE^XLFDT($$NOW^XLFDT,2),IBNOW=$P(IBNOW,"@",1)_"  "_$P($P(IBNOW,"@",2),":",1,2)

 I IBPGN>1!($E(IOST,1,2)["C-") W @IOF

 ;

 W !,"ROI Special Consent To Expire ",$$FMTE^XLFDT(IBBDT)," - ",$$FMTE^XLFDT(IBEDT),?(IOM-30),IBNOW,?(IOM-8),"PAGE ",IBPGN,!

 W !,"Patient",?36,"Effective",?53,"Expires",!

 S IBI="",$P(IBI,"-",IOM+1)="" W IBI

 Q

 ;

PAUSE ;pause at end of screen if beeing displayed on a terminal

 Q:$E(IOST,1,2)'["C-"  N DIR,DUOUT,DTOUT,DIRUT W !

 S DIR(0)="E" D ^DIR K DIR

 I $D(DUOUT)!($D(DIRUT)) S IBQUIT=1

 Q

 ;

STOP() ;determine if user has requested the queued report to stop

 I $D(ZTQUEUED),$$S^%ZTLOAD S ZTSTOP=1 K ZTREQ I +$G(IBPGN) W !,"***TASK STOPPED BY USER***"

 Q +$G(ZTSTOP)

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---IBOTRR   3436     printed  Mar 13, 2025@21:31:15                                                                                                                                                                                                      Page 2

IBOTRR    ;ALB/ARH - ROI EXPIRING REPORT ; 08-JAN-2013

 +1       ;;2.0;INTEGRATED BILLING;**458**;21-MAR-94;Build 4

 +2       ;;Per VHA Directive 2004-038, this routine should not be modified.

 +3       ;

EN        ;get parameters then run the report

 +1        DO HOME^%ZIS

           NEW DIR,DIRUT,DUOUT,X,Y,IBBDT,IBEDT,IBEXCEL

 +2        WRITE !!,"ROI Special Consent Report - Find ROIs about to expire",!

 +3       ;

 +4        DO DATE^IBOUTL

           IF IBBDT=""!(IBEDT="")

               QUIT 

 +5       ;

 +6        WRITE !!,"ROI's that expire between "_$$FMTE^XLFDT(IBBDT,2)_" and "_$$FMTE^XLFDT(IBEDT,2)_" will be included on the report.",!

 +7       ;

 +8       ; Determine whether to gather data for Excel report

 +9        SET DIR("?")="Enter Yes to capture the report on the screen for transfer to Excel."

 +10       SET DIR(0)="Y"

           SET DIR("B")="NO"

           SET DIR("A")="Do you want to capture report data for an Excel document"

           DO ^DIR

           KILL DIR

           IF $DATA(DIRUT)

               GOTO EXIT

 +11       SET IBEXCEL=0

           IF Y=1

               SET IBEXCEL=1

               WRITE !,"Enter '0;80;999' at the 'DEVICE:' prompt.",!

 +12      ;

DEV       ;get the device

 +1        SET %ZIS="QM"

           SET %ZIS("A")="OUTPUT DEVICE: "

           DO ^%ZIS

           if POP

               GOTO EXIT

 +2        IF $DATA(IO("Q"))

               SET ZTRTN="RPT^IBOTRR"

               SET ZTSAVE("IB*")=""

               SET ZTDESC="IB ROI Expires"

               DO ^%ZTLOAD

               KILL IO("Q")

               GOTO EXIT

 +3        USE IO

 +4       ;

RPT       ;find, save, and print the data that satisfies the search parameters

 +1       ;entry point for tasked jobs

 +2       ;

 +3        KILL ^TMP($JOB,"IBOTRR")

 +4       ;

 +5        DO SORT

           DO PRINT

 +6       ;

EXIT      ;clean up and quit

 +1        KILL ^TMP($JOB,"IBOTRR")

           if $DATA(ZTQUEUED)

               QUIT 

 +2        DO ^%ZISC

 +3        QUIT 

 +4       ;

SORT      ; sort report - get all ROIs that will expire in Patient and Effective Date order

 +1        NEW DFN,IBRFN,IBR0,IBPAT,IBB,IBE

           KILL ^TMP($JOB,"IBOTRR")

 +2       ;

 +3        SET DFN=0

           FOR 

               SET DFN=$ORDER(^IBT(356.26,"C",DFN))

               if 'DFN

                   QUIT 

               Begin DoDot:1

 +4                SET IBRFN=0

                   FOR 

                       SET IBRFN=$ORDER(^IBT(356.26,"C",DFN,IBRFN))

                       if 'IBRFN

                           QUIT 

                       Begin DoDot:2

 +5                        SET IBR0=$GET(^IBT(356.26,IBRFN,0))

 +6                        SET IBB=+$PIECE(IBR0,U,4)

                           SET IBE=+$PIECE(IBR0,U,5)

                           SET IBPAT=$PIECE($GET(^DPT(+$PIECE(IBR0,U,2),0)),U,1)

 +7       ;

 +8                        IF IBE'<IBBDT

                               IF IBE'>IBEDT

                                   SET ^TMP($JOB,"IBOTRR",IBPAT,$PIECE(IBR0,U,4),IBRFN)=""

                       End DoDot:2

               End DoDot:1

 +9       ;

 +10       QUIT 

 +11      ;

PRINT     ;print the report from the temp sort file to the appropriate device

 +1        NEW IBPGN,IBLN,IBQUIT,IBPAT,IBB,IBRFN,IBR0

 +2        SET IBPGN=0

           SET IBQUIT=0

           DO HDR

           if IBQUIT

               QUIT 

 +3       ;

 +4        SET IBPAT=""

           FOR 

               SET IBPAT=$ORDER(^TMP($JOB,"IBOTRR",IBPAT))

               if IBPAT=""

                   QUIT 

               Begin DoDot:1

 +5                SET IBB=""

                   FOR 

                       SET IBB=$ORDER(^TMP($JOB,"IBOTRR",IBPAT,IBB))

                       if IBB=""

                           QUIT 

                       Begin DoDot:2

 +6                        SET IBRFN=0

                           FOR 

                               SET IBRFN=$ORDER(^TMP($JOB,"IBOTRR",IBPAT,IBB,IBRFN))

                               if 'IBRFN

                                   QUIT 

                               Begin DoDot:3

 +7                                SET IBR0=$GET(^IBT(356.26,IBRFN,0))

 +8                                IF +$GET(IBEXCEL)

                                       WRITE !,IBPAT,U,$$FMTE^XLFDT($PIECE(IBR0,U,4)),U,$$FMTE^XLFDT($PIECE(IBR0,U,5))

                                       SET IBLN=1

                                       QUIT 

 +9                                WRITE !,IBPAT,?36,$$FMTE^XLFDT($PIECE(IBR0,U,4)),?53,$$FMTE^XLFDT($PIECE(IBR0,U,5))

                                   SET IBLN=IBLN+1

                               End DoDot:3

                               if $$LNCHK(2)

                                   QUIT 

                       End DoDot:2

                       if IBQUIT

                           QUIT 

               End DoDot:1

               if IBQUIT

                   QUIT 

 +10      ;

 +11       IF 'IBQUIT

               DO PAUSE

 +12       QUIT 

LNCHK(LNS) ; check if new page is needed

 +1        IF 'IBQUIT

               IF IBLN>(IOSL-LNS)

                   DO PAUSE

                   IF 'IBQUIT

                       DO HDR

 +2        QUIT IBQUIT

 +3       ;

HDR       ;print the report header

 +1        NEW IBNOW,IBI

 +2        IF +$GET(IBEXCEL)

               WRITE !,"Patient^Effective^Expires"

               SET IBLN=1

               QUIT 

 +3       ;

 +4        SET IBQUIT=$$STOP

           if IBQUIT

               QUIT 

           SET IBPGN=IBPGN+1

           SET IBLN=7

 +5        SET IBNOW=$$FMTE^XLFDT($$NOW^XLFDT,2)

           SET IBNOW=$PIECE(IBNOW,"@",1)_"  "_$PIECE($PIECE(IBNOW,"@",2),":",1,2)

 +6        IF IBPGN>1!($EXTRACT(IOST,1,2)["C-")

               WRITE @IOF

 +7       ;

 +8        WRITE !,"ROI Special Consent To Expire ",$$FMTE^XLFDT(IBBDT)," - ",$$FMTE^XLFDT(IBEDT),?(IOM-30),IBNOW,?(IOM-8),"PAGE ",IBPGN,!

 +9        WRITE !,"Patient",?36,"Effective",?53,"Expires",!

 +10       SET IBI=""

           SET $PIECE(IBI,"-",IOM+1)=""

           WRITE IBI

 +11       QUIT 

 +12      ;

PAUSE     ;pause at end of screen if beeing displayed on a terminal

 +1        if $EXTRACT(IOST,1,2)'["C-"

               QUIT 

           NEW DIR,DUOUT,DTOUT,DIRUT

           WRITE !

 +2        SET DIR(0)="E"

           DO ^DIR

           KILL DIR

 +3        IF $DATA(DUOUT)!($DATA(DIRUT))

               SET IBQUIT=1

 +4        QUIT 

 +5       ;

STOP()    ;determine if user has requested the queued report to stop

 +1        IF $DATA(ZTQUEUED)

               IF $$S^%ZTLOAD

                   SET ZTSTOP=1

                   KILL ZTREQ

                   IF +$GET(IBPGN)

                       WRITE !,"***TASK STOPPED BY USER***"

 +2        QUIT +$GET(ZTSTOP)