IBEMTO ;ALB/CPM-BILL MT CHARGES AWAITING NEW COPAY RATE ;02-AUG-93
;;2.0;INTEGRATED BILLING;**179,183,202**;21-MAR-94
;;Per VHA Directive 10-93-142, this routine should not be modified.
;
; Bill MT OPT charges on hold awaiting the new copay rate.
;
ENO ; Standalone option entry point
S IBOPT=1
;
ENR ; Enter/edit billing rates entry point
;
; - quit if job has been fired up from enter/edit rates already
I $G(IBRUN) G ENQ
;
; no longer used (at least for now)
W !!,"This option is no longer available.",! G ENQ
;
; - quit if there are no charges on hold awaiting the new rate
I '$D(^IB("AC",20)) W:$G(IBOPT) !!,"There are no charges on hold awaiting the entry of the new copay rate." G ENQ
;
; - quit if current rate is still too old
S IBDT=DT,IBX="O" D TYPE^IBAUTL2
I $$OLDRATE^IBAMTS1(IBRTED,DT) D:$G(IBOPT) G ENQ
.W !!,"The current copay rate (effective ",$$DAT1^IBOUTL(IBRTED),") is still too old to use. Please be"
.W !,"sure that you have entered the most current rate in your Billing Rates table."
;
; - if x-ref is locked, the job must be currently running
L +^IB("AC",20):5 E D:$G(IBOPT) G ENQ
.W !!,"The list of held charges cannot be accessed -- the job to bill these held"
.W !,"charges may currently be running."
;
; - queue the job to bill the held charges?
I '$G(IBOPT) D
.W !!?28,*7,*7,"*** PLEASE NOTE ***"
.W !?8,"The Means Test Outpatient Copayment rate has just been updated,"
.W !?8,"and there are charges 'on hold' awaiting the entry of this new rate!",!
;
I $G(IBOPT) D
.S IBN=0 F IBJ=0:1:21 S IBN=$O(^IB("AC",20,IBN)) Q:'IBN
.W !!,"There ",$S(IBJ=1:"is 1",1:"are "_$S(IBJ>20:"at least ",1:"")_IBJ)," charge",$E("s",IBJ>1)," on hold, awaiting the new copay rate."
S DIR(0)="Y",DIR("A")="Do you want to queue a job to automatically bill these held charges",DIR("?")="^D HQ^IBEMTO"
D ^DIR K DIR I 'Y!($D(DIRUT))!($D(DUOUT)) G ENQ
;
; - queue up job to bill held charges
S:'$G(IBOPT) ZTDTH=$H
S ZTRTN="DQ^IBEMTO",ZTIO="",ZTDESC="BILLING OF MT OPT CHARGES AWAITING NEW COPAY RATE"
S IBRUN=1 D ^%ZTLOAD W !!,$S($D(ZTSK):"This job has been queued. The task number is "_ZTSK_".",1:"Unable to queue this job!")
;
ENQ L -^IB("AC",20)
K:$G(IBOPT) IBRUN
K IBN,IBDT,IBATYP,IBDESC,IBJ,IBOPT,IBRTED,IBCHG,IBX,ZTSK
Q
;
HQ ; Help for prompt
W !!,"If you wish to queue off a job to bill the Means Test Outpatient"
W !,"copayment charges that are on hold awaiting entry of the updated"
W !,"billing rate, please enter 'Y' or 'YES'. The job will be tasked"
W !,"immediately. Otherwise, enter 'N' or 'NO' or '^' to quit."
Q
;
;
DQ ; Tasked job to bill all charges awaiting the new copay rate.
S IBJOB=8,IBDUZ=DUZ,IBSEQNO=1,IBCNT=0
;
; - record start time
D NOW^%DTC S IBSTART=$$DAT2^IBOUTL(%)
;
; - if can't lock x-ref, job must currently be running
L +^IB("AC",20):5
;
; - loop through all charges awaiting the new rate
I S IBREF=0 F S IBREF=$O(^IB("AC",20,IBREF)) Q:'IBREF D CHG
;
; - unlock x-ref, record end time, and post bulletin
L -^IB("AC",20)
D NOW^%DTC S IBEND=$$DAT2^IBOUTL(%)
D BULL^IBEMTO1
K IBT,IBSTART,IBEND,IBREF,IBND,IBDT,IBX,IBCHG,IBSEQNO,IBNOS,IBCNT,XMTEXT,XMSUB,XMZ,XMY,XMDUZ
Q
;
CHG ; Pass a single charge to Accounts Receivable.
S IBND=$G(^IB(IBREF,0)) I 'IBND K ^IB("AC",20,IBREF) G CHGQ
S IBDT=DT,IBX="O" D TYPE^IBAUTL2
I $$OLDRATE^IBAMTS1(IBRTED,$P(IBND,"^",14)) G CHGQ ; rate still old
S $P(^IB(IBREF,0),"^",7)=IBCHG,IBSEQNO=1,DFN=+$P(IBND,"^",2)
S IBNOS=IBREF D ^IBR S:Y>0 IBCNT=IBCNT+1
CHGQ Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBEMTO 3604 printed Oct 16, 2024@18:22:46 Page 2
IBEMTO ;ALB/CPM-BILL MT CHARGES AWAITING NEW COPAY RATE ;02-AUG-93
+1 ;;2.0;INTEGRATED BILLING;**179,183,202**;21-MAR-94
+2 ;;Per VHA Directive 10-93-142, this routine should not be modified.
+3 ;
+4 ; Bill MT OPT charges on hold awaiting the new copay rate.
+5 ;
ENO ; Standalone option entry point
+1 SET IBOPT=1
+2 ;
ENR ; Enter/edit billing rates entry point
+1 ;
+2 ; - quit if job has been fired up from enter/edit rates already
+3 IF $GET(IBRUN)
GOTO ENQ
+4 ;
+5 ; no longer used (at least for now)
+6 WRITE !!,"This option is no longer available.",!
GOTO ENQ
+7 ;
+8 ; - quit if there are no charges on hold awaiting the new rate
+9 IF '$DATA(^IB("AC",20))
if $GET(IBOPT)
WRITE !!,"There are no charges on hold awaiting the entry of the new copay rate."
GOTO ENQ
+10 ;
+11 ; - quit if current rate is still too old
+12 SET IBDT=DT
SET IBX="O"
DO TYPE^IBAUTL2
+13 IF $$OLDRATE^IBAMTS1(IBRTED,DT)
if $GET(IBOPT)
Begin DoDot:1
+14 WRITE !!,"The current copay rate (effective ",$$DAT1^IBOUTL(IBRTED),") is still too old to use. Please be"
+15 WRITE !,"sure that you have entered the most current rate in your Billing Rates table."
End DoDot:1
GOTO ENQ
+16 ;
+17 ; - if x-ref is locked, the job must be currently running
+18 LOCK +^IB("AC",20):5
IF '$TEST
if $GET(IBOPT)
Begin DoDot:1
+19 WRITE !!,"The list of held charges cannot be accessed -- the job to bill these held"
+20 WRITE !,"charges may currently be running."
End DoDot:1
GOTO ENQ
+21 ;
+22 ; - queue the job to bill the held charges?
+23 IF '$GET(IBOPT)
Begin DoDot:1
+24 WRITE !!?28,*7,*7,"*** PLEASE NOTE ***"
+25 WRITE !?8,"The Means Test Outpatient Copayment rate has just been updated,"
+26 WRITE !?8,"and there are charges 'on hold' awaiting the entry of this new rate!",!
End DoDot:1
+27 ;
+28 IF $GET(IBOPT)
Begin DoDot:1
+29 SET IBN=0
FOR IBJ=0:1:21
SET IBN=$ORDER(^IB("AC",20,IBN))
if 'IBN
QUIT
+30 WRITE !!,"There ",$SELECT(IBJ=1:"is 1",1:"are "_$SELECT(IBJ>20:"at least ",1:"")_IBJ)," charge",$EXTRACT("s",IBJ>1)," on hold, awaiting the new copay rate."
End DoDot:1
+31 SET DIR(0)="Y"
SET DIR("A")="Do you want to queue a job to automatically bill these held charges"
SET DIR("?")="^D HQ^IBEMTO"
+32 DO ^DIR
KILL DIR
IF 'Y!($DATA(DIRUT))!($DATA(DUOUT))
GOTO ENQ
+33 ;
+34 ; - queue up job to bill held charges
+35 if '$GET(IBOPT)
SET ZTDTH=$HOROLOG
+36 SET ZTRTN="DQ^IBEMTO"
SET ZTIO=""
SET ZTDESC="BILLING OF MT OPT CHARGES AWAITING NEW COPAY RATE"
+37 SET IBRUN=1
DO ^%ZTLOAD
WRITE !!,$SELECT($DATA(ZTSK):"This job has been queued. The task number is "_ZTSK_".",1:"Unable to queue this job!")
+38 ;
ENQ LOCK -^IB("AC",20)
+1 if $GET(IBOPT)
KILL IBRUN
+2 KILL IBN,IBDT,IBATYP,IBDESC,IBJ,IBOPT,IBRTED,IBCHG,IBX,ZTSK
+3 QUIT
+4 ;
HQ ; Help for prompt
+1 WRITE !!,"If you wish to queue off a job to bill the Means Test Outpatient"
+2 WRITE !,"copayment charges that are on hold awaiting entry of the updated"
+3 WRITE !,"billing rate, please enter 'Y' or 'YES'. The job will be tasked"
+4 WRITE !,"immediately. Otherwise, enter 'N' or 'NO' or '^' to quit."
+5 QUIT
+6 ;
+7 ;
DQ ; Tasked job to bill all charges awaiting the new copay rate.
+1 SET IBJOB=8
SET IBDUZ=DUZ
SET IBSEQNO=1
SET IBCNT=0
+2 ;
+3 ; - record start time
+4 DO NOW^%DTC
SET IBSTART=$$DAT2^IBOUTL(%)
+5 ;
+6 ; - if can't lock x-ref, job must currently be running
+7 LOCK +^IB("AC",20):5
+8 ;
+9 ; - loop through all charges awaiting the new rate
+10 IF $TEST
SET IBREF=0
FOR
SET IBREF=$ORDER(^IB("AC",20,IBREF))
if 'IBREF
QUIT
DO CHG
+11 ;
+12 ; - unlock x-ref, record end time, and post bulletin
+13 LOCK -^IB("AC",20)
+14 DO NOW^%DTC
SET IBEND=$$DAT2^IBOUTL(%)
+15 DO BULL^IBEMTO1
+16 KILL IBT,IBSTART,IBEND,IBREF,IBND,IBDT,IBX,IBCHG,IBSEQNO,IBNOS,IBCNT,XMTEXT,XMSUB,XMZ,XMY,XMDUZ
+17 QUIT
+18 ;
CHG ; Pass a single charge to Accounts Receivable.
+1 SET IBND=$GET(^IB(IBREF,0))
IF 'IBND
KILL ^IB("AC",20,IBREF)
GOTO CHGQ
+2 SET IBDT=DT
SET IBX="O"
DO TYPE^IBAUTL2
+3 ; rate still old
IF $$OLDRATE^IBAMTS1(IBRTED,$PIECE(IBND,"^",14))
GOTO CHGQ
+4 SET $PIECE(^IB(IBREF,0),"^",7)=IBCHG
SET IBSEQNO=1
SET DFN=+$PIECE(IBND,"^",2)
+5 SET IBNOS=IBREF
DO ^IBR
if Y>0
SET IBCNT=IBCNT+1
CHGQ QUIT
