- 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
- ;
- Q
- ;
- 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
- Q
- ;
- 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
- Q
- 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)
- Q
- 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
