IBRCON2 ;ALB/RJS - PASSING CHARGES TO A/R BY DATE - 4/28/92
;;Version 2.0 ; INTEGRATED BILLING ;; 21-MAR-94
;;Per VHA Directive 10-93-142, this routine should not be modified.
INIT ;
S (IBRCOUNT,IBRDONE)=0
S IBFEE="DG FEE SERVICE (OPT) NEW",IBFEE=$O(^IBE(350.1,"B",IBFEE,0))
S IBOPT="DG OPT COPAY NEW",IBOPT=$O(^IBE(350.1,"B",IBOPT,0))
I IBFEE=""!(IBOPT="") W !,"Error finding entries in file 350.1" G END
START ;
S %DT("A")="Enter beginning date: "
D PROMPT G:Y=-1 END
S IBBEG=Y
W !
S %DT("A")="Enter ending date: "
D PROMPT G:Y=-1 END
I (Y<IBBEG) W !,"Ending date must be > or = start date!",!
I G START
S IBENDING=Y
W !!
S SUBROUT="LOAD1" D LOOP,PROMPT2
G:IBRDONE=1 END
D QUEUED,HOME^%ZIS
END ;
I $D(ZTQUEUED) S ZTREQ="@" Q
K %DT,DFN,IBCUTOFF,IBDUZ,IBNOS,IBRRCNR,IBRXXX,IBSEQNO,Y,XMY
K IBEND,IBRCOUNT,IBRDONE,IBSTART,SUBROUT,XMDUZ,XMSUB,XMTEXT
K IBFEE,IBOPT,DIR,%,%ZIS,IBBEG,IBENDING
Q
NEXT ;
D NOW^%DTC S IBSTART=$$DAT2^IBOUTL(%)
S SUBROUT="LOAD2" D LOOP
D NOW^%DTC S IBEND=$$DAT2^IBOUTL(%)
D MAIL
Q
LOOP ;
S IBSEQNO=1,IBDUZ=DUZ
F IBRXXX=IBFEE,IBOPT D
.S IBRRCNR=0
.F S IBRRCNR=$O(^IB("AE",IBRXXX,IBRRCNR)) Q:IBRRCNR="" D @SUBROUT
Q
LOAD1 ;
Q:$P($G(^IB(IBRRCNR,0)),U,17)=""!($P($G(^(0)),U,17)>IBENDING)!($P($G(^(0)),U,17)<IBBEG)!($P($G(^(0)),U,5)'=99)
S IBRCOUNT=IBRCOUNT+1
W "."
Q
LOAD2 ;
Q:$P($G(^IB(IBRRCNR,0)),U,17)=""!($P($G(^(0)),U,17)>IBENDING)!($P($G(^(0)),U,17)<IBBEG)!($P($G(^(0)),U,5)'=99)
S IBNOS=IBRRCNR,DFN=$P(^IB(IBRRCNR,0),U,2)
D ^IBR,ERR:Y<1
Q
PROMPT ;
S %DT="AEX" D ^%DT
Q
ERR ;
W !,"Error encountered - a separate bulletin has been posted"
Q
PROMPT2 ;
I IBRCOUNT=0 W !," There are no outpatient or fee basis converted",!," charges in this date range" S IBRDONE=1 Q
W !!,"There are [ ",IBRCOUNT," ] charges to be passed to accounts receivable",!
S DIR(0)="YA"
S DIR("A")="Do you wish to pass these charges to accounts receivable (Y/N): "
D ^DIR
I Y'=1 S IBRDONE=1 Q
Q
QUEUED ;
S ZTIO="",ZTRTN="NEXT^IBRCON2",ZTDESC="IBRCON2 JOB TO PASS TO AR CONVERTED CHARGES",ZTSAVE("IB*")="" D ^%ZTLOAD W !!,$S($D(ZTSK):"Request Queued",1:"Request Cancelled")
Q
OPEN ;
S %ZIS="QM" D ^%ZIS
Q
MAIL ;
S XMSUB="PASSED CONVERTED CHARGES"
S XMDUZ="INTEGRATED BILLING PACKAGE"
S XMTEXT="IBT("
K IBT,XMY
S XMY(IBDUZ)=""
S IBT(1)="The job that passes converted charges to accounts receivable"
S IBT(2)="is complete."
S IBT(3)="[ "_IBRCOUNT_" ] charges have been passed to accounts receivable."
S IBT(4)=""
S IBT(5)="Job started on "_$P(IBSTART,"@",1)_" at "_$P(IBSTART,"@",2)
S IBT(6)="Job finished on "_$P(IBEND,"@",1)_" at "_$P(IBEND,"@",2)
D ^XMD
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBRCON2 2713 printed Nov 22, 2024@17:36:46 Page 2
IBRCON2 ;ALB/RJS - PASSING CHARGES TO A/R BY DATE - 4/28/92
+1 ;;Version 2.0 ; INTEGRATED BILLING ;; 21-MAR-94
+2 ;;Per VHA Directive 10-93-142, this routine should not be modified.
INIT ;
+1 SET (IBRCOUNT,IBRDONE)=0
+2 SET IBFEE="DG FEE SERVICE (OPT) NEW"
SET IBFEE=$ORDER(^IBE(350.1,"B",IBFEE,0))
+3 SET IBOPT="DG OPT COPAY NEW"
SET IBOPT=$ORDER(^IBE(350.1,"B",IBOPT,0))
+4 IF IBFEE=""!(IBOPT="")
WRITE !,"Error finding entries in file 350.1"
GOTO END
START ;
+1 SET %DT("A")="Enter beginning date: "
+2 DO PROMPT
if Y=-1
GOTO END
+3 SET IBBEG=Y
+4 WRITE !
+5 SET %DT("A")="Enter ending date: "
+6 DO PROMPT
if Y=-1
GOTO END
+7 IF (Y<IBBEG)
WRITE !,"Ending date must be > or = start date!",!
+8 IF $TEST
GOTO START
+9 SET IBENDING=Y
+10 WRITE !!
+11 SET SUBROUT="LOAD1"
DO LOOP
DO PROMPT2
+12 if IBRDONE=1
GOTO END
+13 DO QUEUED
DO HOME^%ZIS
END ;
+1 IF $DATA(ZTQUEUED)
SET ZTREQ="@"
QUIT
+2 KILL %DT,DFN,IBCUTOFF,IBDUZ,IBNOS,IBRRCNR,IBRXXX,IBSEQNO,Y,XMY
+3 KILL IBEND,IBRCOUNT,IBRDONE,IBSTART,SUBROUT,XMDUZ,XMSUB,XMTEXT
+4 KILL IBFEE,IBOPT,DIR,%,%ZIS,IBBEG,IBENDING
+5 QUIT
NEXT ;
+1 DO NOW^%DTC
SET IBSTART=$$DAT2^IBOUTL(%)
+2 SET SUBROUT="LOAD2"
DO LOOP
+3 DO NOW^%DTC
SET IBEND=$$DAT2^IBOUTL(%)
+4 DO MAIL
+5 QUIT
LOOP ;
+1 SET IBSEQNO=1
SET IBDUZ=DUZ
+2 FOR IBRXXX=IBFEE,IBOPT
Begin DoDot:1
+3 SET IBRRCNR=0
+4 FOR
SET IBRRCNR=$ORDER(^IB("AE",IBRXXX,IBRRCNR))
if IBRRCNR=""
QUIT
DO @SUBROUT
End DoDot:1
+5 QUIT
LOAD1 ;
+1 if $PIECE($GET(^IB(IBRRCNR,0)),U,17)=""!($PIECE($GET(^(0)),U,17)>IBENDING)!($PIECE($GET(^(0)),U,17)<IBBEG)!($PIECE($GET(^(0)),U,5)'=99)
QUIT
+2 SET IBRCOUNT=IBRCOUNT+1
+3 WRITE "."
+4 QUIT
LOAD2 ;
+1 if $PIECE($GET(^IB(IBRRCNR,0)),U,17)=""!($PIECE($GET(^(0)),U,17)>IBENDING)!($PIECE($GET(^(0)),U,17)<IBBEG)!($PIECE($GET(^(0)),U,5)'=99)
QUIT
+2 SET IBNOS=IBRRCNR
SET DFN=$PIECE(^IB(IBRRCNR,0),U,2)
+3 DO ^IBR
if Y<1
DO ERR
+4 QUIT
PROMPT ;
+1 SET %DT="AEX"
DO ^%DT
+2 QUIT
ERR ;
+1 WRITE !,"Error encountered - a separate bulletin has been posted"
+2 QUIT
PROMPT2 ;
+1 IF IBRCOUNT=0
WRITE !," There are no outpatient or fee basis converted",!," charges in this date range"
SET IBRDONE=1
QUIT
+2 WRITE !!,"There are [ ",IBRCOUNT," ] charges to be passed to accounts receivable",!
+3 SET DIR(0)="YA"
+4 SET DIR("A")="Do you wish to pass these charges to accounts receivable (Y/N): "
+5 DO ^DIR
+6 IF Y'=1
SET IBRDONE=1
QUIT
+7 QUIT
QUEUED ;
+1 SET ZTIO=""
SET ZTRTN="NEXT^IBRCON2"
SET ZTDESC="IBRCON2 JOB TO PASS TO AR CONVERTED CHARGES"
SET ZTSAVE("IB*")=""
DO ^%ZTLOAD
WRITE !!,$SELECT($DATA(ZTSK):"Request Queued",1:"Request Cancelled")
+2 QUIT
OPEN ;
+1 SET %ZIS="QM"
DO ^%ZIS
+2 QUIT
MAIL ;
+1 SET XMSUB="PASSED CONVERTED CHARGES"
+2 SET XMDUZ="INTEGRATED BILLING PACKAGE"
+3 SET XMTEXT="IBT("
+4 KILL IBT,XMY
+5 SET XMY(IBDUZ)=""
+6 SET IBT(1)="The job that passes converted charges to accounts receivable"
+7 SET IBT(2)="is complete."
+8 SET IBT(3)="[ "_IBRCOUNT_" ] charges have been passed to accounts receivable."
+9 SET IBT(4)=""
+10 SET IBT(5)="Job started on "_$PIECE(IBSTART,"@",1)_" at "_$PIECE(IBSTART,"@",2)
+11 SET IBT(6)="Job finished on "_$PIECE(IBEND,"@",1)_" at "_$PIECE(IBEND,"@",2)
+12 DO ^XMD
+13 QUIT
