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 ---[H[J[2J[HIBOTRR 3436 printed Nov 22, 2024@17:36:18 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)
