Routine: IBOVOP

IBOVOP	;ALB/RLW - Report of Visits for NSC Outpatients ; 12-JUN-92

	;;Version 2.0 ; INTEGRATED BILLING ;; 21-MAR-94

INIT	;

	;***

	;S XRTL=$ZU(0),XRTN="IBOVOP-1" D T0^%ZOSV ;start rt clock

	D DT^DICRW,HOME^%ZIS S IBQUIT=0

	N IBJ,IBAMT,IBAIEN,IBPAGE,IBLINE,IBACT,IBDATA,IBTITLE,IBDATE,IBADFN,IBEL,IBIEN,IBCL,IBCKIN,IBSDATA,IBSTART,IBPRNT,IBAPPT,IBSTAT,IBFLD1,IBFLD2,IBFLD3,IBFLD4,IBFLD5,IBFLD6,IBSEQ

	S DIR(0)="DA^2901001:NOW:EX",DIR("A")="Start with DATE: " D ^DIR K DIR G:$D(DIRUT) END S IBBDT=+Y

	S DIR(0)="DA^"_+Y_":NOW:EX",DIR("A")="Go to DATE: " D ^DIR K DIR G:$D(DIRUT) END S IBEDT=+Y

	S %ZIS="QM" D ^%ZIS G:POP END

	I $D(IO("Q")) D  G END

	.S ZTRTN="QUE^IBOVOP",ZTDESC="CATEGORY C OUTPATIENT/REGISTRATION EVENTS",ZTSAVE("IB*")=""

	.D ^%ZTLOAD W !!,$S($D(ZTSK):"This job has been queued.  The task number is "_ZTSK_".",1:"Unable to queue this job.")

	.K ZTSK,IO("Q") D HOME^%ZIS

	U IO

	;***

	;I $D(XRT0) S:'$D(XRTN) XRTN="IBOVOP" D T1^%ZOSV ;stop rt clock

	D QUE

END	K IBBDT,IBEDT,IBQUIT

	;***

	;I $D(XRT0) S:'$D(XRTN) XRTN="IBOVOP" D T1^%ZOSV ;stop rt clock

QUE	;entry point if queued

	;***

	;S XRTL=$ZU(0),XRTN="IBOVOP-2" D T0^%ZOSV ;start rt clock

	S IBPAGE=0

	S IBDATE=IBBDT D MAIN^IBOVOP1 Q:IBQUIT

	F  S X1=IBDATE,X2=1 D C^%DTC Q:X>IBEDT  S IBDATE=X K ^TMP("IBOVOP",$J) D MAIN^IBOVOP1 Q:IBQUIT

	;***

	;I $D(XRT0) S:'$D(XRTN) XRTN="IBOVOP" D T1^%ZOSV ;stop rt clock

	I $D(ZTQUEUED) S ZTREQ="@" Q

	D ^%ZISC

CPMVST	; Find scheduled appointments for Category C veterans

	D BDT^IBOUTL I (IBBDT="")!(IBEDT="") G END2

	S DFN=0 F  S DFN=$O(^DPT("ACS",6,DFN)) Q:'DFN  S IBFLAG=0,IBDATE=IBBDT F  S IBDATE=$O(^DPT(DFN,"S",IBDATE)) Q:'IBDATE!(IBDATE>(IBEDT+.9999))  D PRINT

END2	K IBBDT,IBEDT,IBDATE,DFN,IBFLAG

PRINT	; write visit output

	I 'IBFLAG W !!,$P(^DPT(DFN,0),"^") S IBFLAG=1

	W !,$$DAT2^IBOUTL(IBDATE)

	W ?21,"STATUS: ",$P(^DPT(DFN,"S",IBDATE,0),"^",2)

IBOVOP    ;ALB/RLW - Report of Visits for NSC Outpatients ; 12-JUN-92

 +1       ;;Version 2.0 ; INTEGRATED BILLING ;; 21-MAR-94

INIT      ;

 +1       ;***

 +2       ;S XRTL=$ZU(0),XRTN="IBOVOP-1" D T0^%ZOSV ;start rt clock

 +3       ;

 +4        DO DT^DICRW

           DO HOME^%ZIS

           SET IBQUIT=0

 +5        NEW IBJ,IBAMT,IBAIEN,IBPAGE,IBLINE,IBACT,IBDATA,IBTITLE,IBDATE,IBADFN,IBEL,IBIEN,IBCL,IBCKIN,IBSDATA,IBSTART,IBPRNT,IBAPPT,IBSTAT,IBFLD1,IBFLD2,IBFLD3,IBFLD4,IBFLD5,IBFLD6,IBSEQ

 +6        SET DIR(0)="DA^2901001:NOW:EX"

           SET DIR("A")="Start with DATE: "

           DO ^DIR

           KILL DIR

           IF $DATA(DIRUT)

               GOTO END

           SET IBBDT=+Y

 +7        SET DIR(0)="DA^"_+Y_":NOW:EX"

           SET DIR("A")="Go to DATE: "

           DO ^DIR

           KILL DIR

           IF $DATA(DIRUT)

               GOTO END

           SET IBEDT=+Y

 +8        SET %ZIS="QM"

           DO ^%ZIS

           IF POP

               GOTO END

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

               Begin DoDot:1

 +10               SET ZTRTN="QUE^IBOVOP"

                   SET ZTDESC="CATEGORY C OUTPATIENT/REGISTRATION EVENTS"

                   SET ZTSAVE("IB*")=""

 +11               DO ^%ZTLOAD

                   WRITE !!,$SELECT($DATA(ZTSK):"This job has been queued.  The task number is "_ZTSK_".",1:"Unable to queue this job.")

 +12               KILL ZTSK,IO("Q")

                   DO HOME^%ZIS

               End DoDot:1

               GOTO END

 +13       USE IO

 +14      ;

 +15      ;***

 +16      ;I $D(XRT0) S:'$D(XRTN) XRTN="IBOVOP" D T1^%ZOSV ;stop rt clock

 +17      ;

 +18       DO QUE

END        KILL IBBDT,IBEDT,IBQUIT

 +1       ;

 +2       ;***

 +3       ;I $D(XRT0) S:'$D(XRTN) XRTN="IBOVOP" D T1^%ZOSV ;stop rt clock

 +4       ;

 +5        QUIT

 +6       ;

QUE       ;entry point if queued

 +1       ;***

 +2       ;S XRTL=$ZU(0),XRTN="IBOVOP-2" D T0^%ZOSV ;start rt clock

 +3       ;

 +4        SET IBPAGE=0

 +5        SET IBDATE=IBBDT

           DO MAIN^IBOVOP1

           IF IBQUIT

               QUIT

 +6        FOR

               SET X1=IBDATE

               SET X2=1

               DO C^%DTC

               IF X>IBEDT

                   QUIT

               SET IBDATE=X

               KILL ^TMP("IBOVOP",$JOB)

               DO MAIN^IBOVOP1

               IF IBQUIT

                   QUIT

 +7       ;

 +8       ;***

 +9       ;I $D(XRT0) S:'$D(XRTN) XRTN="IBOVOP" D T1^%ZOSV ;stop rt clock

 +10      ;

 +11       IF $DATA(ZTQUEUED)

               SET ZTREQ="@"

               QUIT

 +12       DO ^%ZISC

 +13       QUIT

 +14      ;

CPMVST    ; Find scheduled appointments for Category C veterans

 +1        DO BDT^IBOUTL

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

               GOTO END2

 +2        SET DFN=0

FOR

               SET DFN=$ORDER(^DPT("ACS",6,DFN))

               IF 'DFN

                   QUIT

               SET IBFLAG=0

               SET IBDATE=IBBDT

FOR

                   SET IBDATE=$ORDER(^DPT(DFN,"S",IBDATE))

                   IF 'IBDATE!(IBDATE>(IBEDT+.9999))

                       QUIT

                   DO PRINT

END2       KILL IBBDT,IBEDT,IBDATE,DFN,IBFLAG

 +1        QUIT

PRINT     ; write visit output

 +1        IF 'IBFLAG

               WRITE !!,$PIECE(^DPT(DFN,0),"^")

               SET IBFLAG=1

 +2        WRITE !,$$DAT2^IBOUTL(IBDATE)

 +3        WRITE ?21,"STATUS: ",$PIECE(^DPT(DFN,"S",IBDATE,0),"^",2)

 +4        QUIT

IBOVOP.m