IBARXMC ;LL/ELZ-PHARMACY COPAY CAP FUNCTIONS ; 03 Mar 2021
;;2.0;INTEGRATED BILLING;**156,186,237,552,563,676**;21-MAR-94;Build 34
;;Per VA Directive 6402, this routine should not be modified.
;
NEW(IBQ,IBC,IBD,IBB,IBN) ; used to compute new bills amount above cap
; DFN is assumed
; IBQ = quantity
; IBC = charge per item
; IBD = effective date
; Return:
; IBB = Amount to bill
; IBN = Amount NOT to bill
;
N IBA,IBA,IBZ,IBP,IBE,IBY,IBFD,IBTD
;
S IBP=$$PRIORITY^IBARXMU(DFN)
; - if the patient has no Priority Group (not enrolled), assume the highest PG
I 'IBP S IBP=8
D CAP(IBD,IBP,.IBZ,.IBY,.IBFD,.IBTD)
S IBA=$$BILLED(DFN,IBD,IBFD,IBTD),IBE=$P(IBA,"^",2)
S IBB=IBQ*IBC
S IBB=$S('IBZ:IBB,IBB+IBA>IBZ:$S(IBZ-IBA>0:IBZ-IBA,1:0),1:IBB) ; monthly
I IBB,IBY S IBB=$S(IBB+IBE>IBY:$S(IBY-IBE>0:IBY-IBE,1:0),1:IBB) ; yearly
S IBN=$S(IBQ*IBC=IBB:0,1:IBQ*IBC-IBB)
;
Q
;
BILLED(DFN,IBD,IBFD,IBTD) ; returns about billed, format: month^year
; IBD = transaction date, IBFD = from date, IBTD = to date
N IBFY,IBX,IBM,IBY,IBZ
F IBX="IBD","IBFD","IBTD" S @IBX=$E(@IBX,1,5)_"00"
S IBX=+$O(^IBAM(354.7,DFN,1,"B",IBD,0))
S IBM=+$P($G(^IBAM(354.7,DFN,1,IBX,0)),"^",2)
S IBY=0,IBZ=IBFD-1 F S IBZ=$O(^IBAM(354.7,DFN,1,"B",IBZ)) Q:IBZ<1!(IBZ>IBTD) S IBX=$O(^IBAM(354.7,DFN,1,"B",IBZ,0)) I IBX S IBY=IBY+$P($G(^IBAM(354.7,DFN,1,IBX,0)),"^",2)
Q IBM_"^"_IBY
;
CAP(IBD,IBP,IBM,IBY,IBF,IBT) ; returns the cap amount and dates
; IBD = date of transaction
; IBP = priority level of patient
; return (by reference):
; IBM = monthly cap amount
; IBY = yearly cap amount
; IBF = from date for yearly cap determination
; IBT = to date for yearly cap determination
N IBX,IBDT
I $D(^IBAM(354.75,"AC",IBP,IBD)) S IBX=+$O(^(IBD,0)) G CAPC
S IBDT=+$O(^IBAM(354.75,"AC",IBP,IBD),-1),IBX=+$O(^(IBDT,0))
CAPC ;
S IBX=$G(^IBAM(354.75,IBX,0))
I 'IBX!($P(IBX,"^",5)&(IBD>$P(IBX,"^",5))) S (IBM,IBY,IBF,IBT)=0 Q
S IBM=$P(IBX,"^",3),IBY=$P(IBX,"^",4)
S IBDT=$P($$FYCY^IBCU8(IBD),"^",$S($P(IBX,"^",6)="C":1,1:3),$S($P(IBX,"^",6)="C":2,1:4))
S IBF=$S($P(IBDT,"^")>IBX:$P(IBDT,"^"),1:+IBX)
S IBT=$S('$P(IBX,"^",5):$P(IBDT,"^",2),$P(IBDT,"^",2)<$P(IBX,"^",5):$P(IBDT,"^",2),1:$P(IBX,"^",5))
;
Q
;
FLAG(DFN,IBD) ; flag account if at or above cap
; IBD = date of transaction (mo/year fm format)
; flag in account is set to: 2 = cap exceeded, some copays not billed
; 1 = cap reached
; 0 = below cap
;
N IBC,IBB,IBZ,IBF,IBX,DIE,DR,DA,X,Y,IBFD,IBTD,IBY
S IBX=+$O(^IBAM(354.7,DFN,1,"B",IBD,0)) Q:'IBX
S IBZ=$G(^IBAM(354.7,DFN,1,IBX,0))
D CAP(IBD+1,+$$PRIORITY^IBARXMU(DFN),.IBC,.IBY,.IBFD,.IBTD)
S IBB=$$BILLED(DFN,IBD,IBFD,IBTD)
S IBF=$S('IBC&('IBY):0,$P(IBZ,"^",4):2,IBC=+IBB:1,IBY=$P(IBB,"^",2):1,1:0)
I IBF'=$P(IBZ,"^",3) S DIE="^IBAM(354.7,"_DFN_",1,",DA=IBX,DR=".03///^S X=IBF",DA(1)=DFN L +^IBAM(354.7,DFN):10 I $T D ^DIE L -^IBAM(354.7,DFN)
Q
;
PARENT(X) ; returns the parent entry in 354.71 for a transaction
Q +$P($G(^IBAM(354.71,X,0)),"^",10)
;
NET(X) ; returns net amount billed for a parent and its children
; X = ien from 354.71 (parent or child) output: billed ^ un-billed
;
N Y,Z,B,N,P S P=$$PARENT(X),(Y,B,N)=0 F S Y=$O(^IBAM(354.71,"AF",P,Y)) Q:Y<1 S Z=^IBAM(354.71,Y,0),B=B+$P(Z,"^",11),N=N+$P(Z,"^",12)
Q B_"^"_N
;
CANCEL(DFN,IBDT) ; receives notification of a cancellation and determines
; if more need to be billed. IBDT should be in fm format date to check
;
N IBT,IBTFL,IBX,IBD,IBFD,IBTD,IBDTQ,IBBIL,IBS,IBS1,IBS2
;
C1 ; get starting values
S IBS=+$P($$SITE^IBARXMU,"^",3) ;676;Need to use Site ID not IEN
S IBP=+$$PRIORITY^IBARXMU(DFN)
D CAP(IBDT+1,IBP,.IBZ,.IBY,.IBFD,.IBTD)
I ('IBY&('IBZ))!('IBFD)!('IBTD) Q
S IBA=$$BILLED(DFN,IBDT+1,IBFD,IBTD),IBE=$P(IBA,"^",2)
;
; query (if any) other facilities to see what is there.
C2 S IBT=$$TFL^IBARXMU(DFN,.IBTFL,2)
I IBT W:'$D(ZTQUEUED) !,"This patient is being seen at other VA treating facilities. I need to make",!,"sure there are no Rx fills that have not been billed elsewhere." S IBX=0 F S IBX=$O(IBTFL(IBX)) Q:IBX<1 D
. I '$D(ZTQUEUED) U IO W !,"Now sending queries to ",$P(IBTFL(IBX),"^",2)," ..."
. ;676;BL; Send request to Cerner Separate response message returns transactions
. I $P(IBTFL(IBX),"^",1)["200CRNR" D Q
. . D EN^IBARXCQR(DFN,$E(IBFD,1,5)_"00")
. S IBDTQ=IBFD F D S IBDTQ=$$NEXTMO(IBDTQ) Q:IBDTQ>IBTD
.. D UQUERY^IBARXMU(DFN,$E(IBDTQ,1,5)_"00",+IBTFL(IBX),.IBD)
.. I $P(IBD(0),"^")=-1!(-1=+IBD) K IBD Q
.. S X=1 F S X=$O(IBD(X)) Q:X<1 S IBD=$$ADD^IBARXMN(DFN,IBD(X))
.. K IBD
I '$D(ZTQUEUED) U IO
;
C3 K ^TMP("IBD",$J)
; now lets see if there are some unbilled that can be billed.
S IBDTQ=IBFD F D S IBDTQ=$$NEXTMO(IBDTQ) Q:IBDTQ>IBTD
. S IBX=0 F S IBX=$O(^IBAM(354.71,"AD",DFN,$E(IBDTQ,1,5)_"00",IBX)) Q:IBX<1 D
.. N IBZ S IBZ=^IBAM(354.71,IBX,0)
.. ;
.. ; check, am I the parent and still have some unbilled
.. I $P(IBZ,"^",10)'=IBX!('$P($$NET(IBX),"^",2)) Q
.. ;
.. ; ^TMP("IBD",$J format(date of transaction,date/time entry added,ien)
.. S ^TMP("IBD",$J,$P(IBZ,"^",3),$P(IBZ,"^",15),IBX)=IBZ
;
I '$D(^TMP("IBD",$J)) W:'$D(ZTQUEUED) !,"No un-billed transactions exist" Q
;
; how much more can we bill
C4 S IBB=$S('IBZ&('IBY):9999999,IBZ&((IBZ-IBA)<(IBY-IBE)):IBZ-IBA,1:IBY-IBE)
;
; we now have to bill some of the unbilled ones
S IBS1=0 F S IBS1=$O(^TMP("IBD",$J,IBS1)) Q:IBS1<1 S IBS2=0 F S IBS2=$O(^TMP("IBD",$J,IBS1,IBS2)) Q:IBS2<1 S IBX=0 F S IBX=$O(^TMP("IBD",$J,IBS1,IBS2,IBX)) Q:IBX<1 D
. S IBZ=^TMP("IBD",$J,IBS1,IBS2,IBX)
. ;
C5 . ; determine how much to bill (if any)
. S IBA=$$NET(IBX)
. S IBBIL=$S(IBB>$P(IBA,"^",2):$P(IBA,"^",2),1:IBB)
. I 'IBBIL S IBS1=9999999999 Q
. S IBB=IBB-IBBIL
. ;quit if IBBIL is less than zero IB*552 ticket 956230
. Q:IBBIL<0
. ;676;If Cerner send HL7
. I +$P(IBZ,"^",1)=200 D EN^IBARXCBK(IBX,IBBIL) Q
. ;
. D @($S(IBS=+IBZ:"BILL",1:"SEND")_"^IBARXMB($P(IBZ,""^""),IBBIL)")
K ^TMP("IBD",$J)
Q
;
NEXTMO(DATE) ; returns first date of next month
N X S X="",DATE=$G(DATE)\1 I DATE'?7N G NEXTMOQ
S X=$S($E(DATE,4,5)<12:$E(DATE,1,5)+1_"01",1:$E(DATE,1,3)+1_"0101")
NEXTMOQ Q X
;
QCAN(DFN,IBCAP,IBSAVXMC) ; queue off job to look for back billing in the background
N ZTRTN,ZTDTH,ZTIO,ZTDESC,ZTSK,ZTSAVE,Y,IBTAG
;
S ZTRTN="DQCAN^IBARXMC",ZTDESC="IB Back Billing of Rx Copay Charges"
S ZTDTH=$$FMTH^XLFDT($$FMADD^XLFDT($$NOW^XLFDT,"","",10))
S (ZTSAVE("DFN"),ZTSAVE("IBCAP("),ZTSAVE("IBSAVXMC("),ZTIO)="" D ^%ZTLOAD
;
I ZTSK<1 S IBTAG=3,Y="^^Error when trying to queue back billing job." D BULL^IBAERR
;
Q
;
DQCAN ; entry point for queued back billing job
N IBD,IBL,IBPAT,IBREF,IBSSN,IBTAG,Y
;
; try to get a lock
S IBL=0 F X=1:1:10 L +^IBAM(354.7,"APAT",DFN):10 H:'$T 600 I $T S IBL=1 Q
I 'IBL D Q
.S IBTAG=3
.S IBPAT=$P($G(^DPT(DFN,0)),"^",1) I IBPAT="" S IBPAT=DFN
.S IBSSN=$P($G(^DPT(DFN,0)),"^",9) I IBSSN="" S IBSSN="????"
.S (X,IBREF)=""
.F S X=$O(IBSAVXMC(X)) Q:X="" D
..I IBREF'="" S IBREF=IBREF_", "_$P(IBSAVXMC(X),"^",1)
..I IBREF="" S IBREF=$P(IBSAVXMC(X),"^",1)
.S Y="^^Unable to lock the IB PATIENT COPAY ACCOUNT (#354.7) file for back billing job related to "_IBPAT_" ("_IBSSN_") and IB reference number(s): "_IBREF_"."
.D ^IBAERR Q
;
; do query/back billing
S IBD=0 F S IBD=$O(IBCAP(IBD)) Q:IBD<1 D CANCEL(DFN,IBD) H 120 ;Delay between backbilling months
;
; remove lock
L -^IBAM(354.7,"APAT",DFN)
;
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBARXMC 7628 printed Sep 23, 2025@19:43:46 Page 2
IBARXMC ;LL/ELZ-PHARMACY COPAY CAP FUNCTIONS ; 03 Mar 2021
+1 ;;2.0;INTEGRATED BILLING;**156,186,237,552,563,676**;21-MAR-94;Build 34
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;
NEW(IBQ,IBC,IBD,IBB,IBN) ; used to compute new bills amount above cap
+1 ; DFN is assumed
+2 ; IBQ = quantity
+3 ; IBC = charge per item
+4 ; IBD = effective date
+5 ; Return:
+6 ; IBB = Amount to bill
+7 ; IBN = Amount NOT to bill
+8 ;
+9 NEW IBA,IBA,IBZ,IBP,IBE,IBY,IBFD,IBTD
+10 ;
+11 SET IBP=$$PRIORITY^IBARXMU(DFN)
+12 ; - if the patient has no Priority Group (not enrolled), assume the highest PG
+13 IF 'IBP
SET IBP=8
+14 DO CAP(IBD,IBP,.IBZ,.IBY,.IBFD,.IBTD)
+15 SET IBA=$$BILLED(DFN,IBD,IBFD,IBTD)
SET IBE=$PIECE(IBA,"^",2)
+16 SET IBB=IBQ*IBC
+17 ; monthly
SET IBB=$SELECT('IBZ:IBB,IBB+IBA>IBZ:$SELECT(IBZ-IBA>0:IBZ-IBA,1:0),1:IBB)
+18 ; yearly
IF IBB
IF IBY
SET IBB=$SELECT(IBB+IBE>IBY:$SELECT(IBY-IBE>0:IBY-IBE,1:0),1:IBB)
+19 SET IBN=$SELECT(IBQ*IBC=IBB:0,1:IBQ*IBC-IBB)
+20 ;
+21 QUIT
+22 ;
BILLED(DFN,IBD,IBFD,IBTD) ; returns about billed, format: month^year
+1 ; IBD = transaction date, IBFD = from date, IBTD = to date
+2 NEW IBFY,IBX,IBM,IBY,IBZ
+3 FOR IBX="IBD","IBFD","IBTD"
SET @IBX=$EXTRACT(@IBX,1,5)_"00"
+4 SET IBX=+$ORDER(^IBAM(354.7,DFN,1,"B",IBD,0))
+5 SET IBM=+$PIECE($GET(^IBAM(354.7,DFN,1,IBX,0)),"^",2)
+6 SET IBY=0
SET IBZ=IBFD-1
FOR
SET IBZ=$ORDER(^IBAM(354.7,DFN,1,"B",IBZ))
if IBZ<1!(IBZ>IBTD)
QUIT
SET IBX=$ORDER(^IBAM(354.7,DFN,1,"B",IBZ,0))
IF IBX
SET IBY=IBY+$PIECE($GET(^IBAM(354.7,DFN,1,IBX,0)),"^",2)
+7 QUIT IBM_"^"_IBY
+8 ;
CAP(IBD,IBP,IBM,IBY,IBF,IBT) ; returns the cap amount and dates
+1 ; IBD = date of transaction
+2 ; IBP = priority level of patient
+3 ; return (by reference):
+4 ; IBM = monthly cap amount
+5 ; IBY = yearly cap amount
+6 ; IBF = from date for yearly cap determination
+7 ; IBT = to date for yearly cap determination
+8 NEW IBX,IBDT
+9 IF $DATA(^IBAM(354.75,"AC",IBP,IBD))
SET IBX=+$ORDER(^(IBD,0))
GOTO CAPC
+10 SET IBDT=+$ORDER(^IBAM(354.75,"AC",IBP,IBD),-1)
SET IBX=+$ORDER(^(IBDT,0))
CAPC ;
+1 SET IBX=$GET(^IBAM(354.75,IBX,0))
+2 IF 'IBX!($PIECE(IBX,"^",5)&(IBD>$PIECE(IBX,"^",5)))
SET (IBM,IBY,IBF,IBT)=0
QUIT
+3 SET IBM=$PIECE(IBX,"^",3)
SET IBY=$PIECE(IBX,"^",4)
+4 SET IBDT=$PIECE($$FYCY^IBCU8(IBD),"^",$SELECT($PIECE(IBX,"^",6)="C":1,1:3),$SELECT($PIECE(IBX,"^",6)="C":2,1:4))
+5 SET IBF=$SELECT($PIECE(IBDT,"^")>IBX:$PIECE(IBDT,"^"),1:+IBX)
+6 SET IBT=$SELECT('$PIECE(IBX,"^",5):$PIECE(IBDT,"^",2),$PIECE(IBDT,"^",2)<$PIECE(IBX,"^",5):$PIECE(IBDT,"^",2),1:$PIECE(IBX,"^",5))
+7 ;
+8 QUIT
+9 ;
FLAG(DFN,IBD) ; flag account if at or above cap
+1 ; IBD = date of transaction (mo/year fm format)
+2 ; flag in account is set to: 2 = cap exceeded, some copays not billed
+3 ; 1 = cap reached
+4 ; 0 = below cap
+5 ;
+6 NEW IBC,IBB,IBZ,IBF,IBX,DIE,DR,DA,X,Y,IBFD,IBTD,IBY
+7 SET IBX=+$ORDER(^IBAM(354.7,DFN,1,"B",IBD,0))
if 'IBX
QUIT
+8 SET IBZ=$GET(^IBAM(354.7,DFN,1,IBX,0))
+9 DO CAP(IBD+1,+$$PRIORITY^IBARXMU(DFN),.IBC,.IBY,.IBFD,.IBTD)
+10 SET IBB=$$BILLED(DFN,IBD,IBFD,IBTD)
+11 SET IBF=$SELECT('IBC&('IBY):0,$PIECE(IBZ,"^",4):2,IBC=+IBB:1,IBY=$PIECE(IBB,"^",2):1,1:0)
+12 IF IBF'=$PIECE(IBZ,"^",3)
SET DIE="^IBAM(354.7,"_DFN_",1,"
SET DA=IBX
SET DR=".03///^S X=IBF"
SET DA(1)=DFN
LOCK +^IBAM(354.7,DFN):10
IF $TEST
DO ^DIE
LOCK -^IBAM(354.7,DFN)
+13 QUIT
+14 ;
PARENT(X) ; returns the parent entry in 354.71 for a transaction
+1 QUIT +$PIECE($GET(^IBAM(354.71,X,0)),"^",10)
+2 ;
NET(X) ; returns net amount billed for a parent and its children
+1 ; X = ien from 354.71 (parent or child) output: billed ^ un-billed
+2 ;
+3 NEW Y,Z,B,N,P
SET P=$$PARENT(X)
SET (Y,B,N)=0
FOR
SET Y=$ORDER(^IBAM(354.71,"AF",P,Y))
if Y<1
QUIT
SET Z=^IBAM(354.71,Y,0)
SET B=B+$PIECE(Z,"^",11)
SET N=N+$PIECE(Z,"^",12)
+4 QUIT B_"^"_N
+5 ;
CANCEL(DFN,IBDT) ; receives notification of a cancellation and determines
+1 ; if more need to be billed. IBDT should be in fm format date to check
+2 ;
+3 NEW IBT,IBTFL,IBX,IBD,IBFD,IBTD,IBDTQ,IBBIL,IBS,IBS1,IBS2
+4 ;
C1 ; get starting values
+1 ;676;Need to use Site ID not IEN
SET IBS=+$PIECE($$SITE^IBARXMU,"^",3)
+2 SET IBP=+$$PRIORITY^IBARXMU(DFN)
+3 DO CAP(IBDT+1,IBP,.IBZ,.IBY,.IBFD,.IBTD)
+4 IF ('IBY&('IBZ))!('IBFD)!('IBTD)
QUIT
+5 SET IBA=$$BILLED(DFN,IBDT+1,IBFD,IBTD)
SET IBE=$PIECE(IBA,"^",2)
+6 ;
+7 ; query (if any) other facilities to see what is there.
C2 SET IBT=$$TFL^IBARXMU(DFN,.IBTFL,2)
+1 IF IBT
if '$DATA(ZTQUEUED)
WRITE !,"This patient is being seen at other VA treating facilities. I need to make",!,"sure there are no Rx fills that have not been billed elsewhere."
SET IBX=0
FOR
SET IBX=$ORDER(IBTFL(IBX))
if IBX<1
QUIT
Begin DoDot:1
+2 IF '$DATA(ZTQUEUED)
USE IO
WRITE !,"Now sending queries to ",$PIECE(IBTFL(IBX),"^",2)," ..."
+3 ;676;BL; Send request to Cerner Separate response message returns transactions
+4 IF $PIECE(IBTFL(IBX),"^",1)["200CRNR"
Begin DoDot:2
+5 DO EN^IBARXCQR(DFN,$EXTRACT(IBFD,1,5)_"00")
End DoDot:2
QUIT
+6 SET IBDTQ=IBFD
FOR
Begin DoDot:2
+7 DO UQUERY^IBARXMU(DFN,$EXTRACT(IBDTQ,1,5)_"00",+IBTFL(IBX),.IBD)
+8 IF $PIECE(IBD(0),"^")=-1!(-1=+IBD)
KILL IBD
QUIT
+9 SET X=1
FOR
SET X=$ORDER(IBD(X))
if X<1
QUIT
SET IBD=$$ADD^IBARXMN(DFN,IBD(X))
+10 KILL IBD
End DoDot:2
SET IBDTQ=$$NEXTMO(IBDTQ)
if IBDTQ>IBTD
QUIT
End DoDot:1
+11 IF '$DATA(ZTQUEUED)
USE IO
+12 ;
C3 KILL ^TMP("IBD",$JOB)
+1 ; now lets see if there are some unbilled that can be billed.
+2 SET IBDTQ=IBFD
FOR
Begin DoDot:1
+3 SET IBX=0
FOR
SET IBX=$ORDER(^IBAM(354.71,"AD",DFN,$EXTRACT(IBDTQ,1,5)_"00",IBX))
if IBX<1
QUIT
Begin DoDot:2
+4 NEW IBZ
SET IBZ=^IBAM(354.71,IBX,0)
+5 ;
+6 ; check, am I the parent and still have some unbilled
+7 IF $PIECE(IBZ,"^",10)'=IBX!('$PIECE($$NET(IBX),"^",2))
QUIT
+8 ;
+9 ; ^TMP("IBD",$J format(date of transaction,date/time entry added,ien)
+10 SET ^TMP("IBD",$JOB,$PIECE(IBZ,"^",3),$PIECE(IBZ,"^",15),IBX)=IBZ
End DoDot:2
End DoDot:1
SET IBDTQ=$$NEXTMO(IBDTQ)
if IBDTQ>IBTD
QUIT
+11 ;
+12 IF '$DATA(^TMP("IBD",$JOB))
if '$DATA(ZTQUEUED)
WRITE !,"No un-billed transactions exist"
QUIT
+13 ;
+14 ; how much more can we bill
C4 SET IBB=$SELECT('IBZ&('IBY):9999999,IBZ&((IBZ-IBA)<(IBY-IBE)):IBZ-IBA,1:IBY-IBE)
+1 ;
+2 ; we now have to bill some of the unbilled ones
+3 SET IBS1=0
FOR
SET IBS1=$ORDER(^TMP("IBD",$JOB,IBS1))
if IBS1<1
QUIT
SET IBS2=0
FOR
SET IBS2=$ORDER(^TMP("IBD",$JOB,IBS1,IBS2))
if IBS2<1
QUIT
SET IBX=0
FOR
SET IBX=$ORDER(^TMP("IBD",$JOB,IBS1,IBS2,IBX))
if IBX<1
QUIT
Begin DoDot:1
+4 SET IBZ=^TMP("IBD",$JOB,IBS1,IBS2,IBX)
+5 ;
C5 ; determine how much to bill (if any)
+1 SET IBA=$$NET(IBX)
+2 SET IBBIL=$SELECT(IBB>$PIECE(IBA,"^",2):$PIECE(IBA,"^",2),1:IBB)
+3 IF 'IBBIL
SET IBS1=9999999999
QUIT
+4 SET IBB=IBB-IBBIL
+5 ;quit if IBBIL is less than zero IB*552 ticket 956230
+6 if IBBIL<0
QUIT
+7 ;676;If Cerner send HL7
+8 IF +$PIECE(IBZ,"^",1)=200
DO EN^IBARXCBK(IBX,IBBIL)
QUIT
+9 ;
+10 DO @($SELECT(IBS=+IBZ:"BILL",1:"SEND")_"^IBARXMB($P(IBZ,""^""),IBBIL)")
End DoDot:1
+11 KILL ^TMP("IBD",$JOB)
+12 QUIT
+13 ;
NEXTMO(DATE) ; returns first date of next month
+1 NEW X
SET X=""
SET DATE=$GET(DATE)\1
IF DATE'?7N
GOTO NEXTMOQ
+2 SET X=$SELECT($EXTRACT(DATE,4,5)<12:$EXTRACT(DATE,1,5)+1_"01",1:$EXTRACT(DATE,1,3)+1_"0101")
NEXTMOQ QUIT X
+1 ;
QCAN(DFN,IBCAP,IBSAVXMC) ; queue off job to look for back billing in the background
+1 NEW ZTRTN,ZTDTH,ZTIO,ZTDESC,ZTSK,ZTSAVE,Y,IBTAG
+2 ;
+3 SET ZTRTN="DQCAN^IBARXMC"
SET ZTDESC="IB Back Billing of Rx Copay Charges"
+4 SET ZTDTH=$$FMTH^XLFDT($$FMADD^XLFDT($$NOW^XLFDT,"","",10))
+5 SET (ZTSAVE("DFN"),ZTSAVE("IBCAP("),ZTSAVE("IBSAVXMC("),ZTIO)=""
DO ^%ZTLOAD
+6 ;
+7 IF ZTSK<1
SET IBTAG=3
SET Y="^^Error when trying to queue back billing job."
DO BULL^IBAERR
+8 ;
+9 QUIT
+10 ;
DQCAN ; entry point for queued back billing job
+1 NEW IBD,IBL,IBPAT,IBREF,IBSSN,IBTAG,Y
+2 ;
+3 ; try to get a lock
+4 SET IBL=0
FOR X=1:1:10
LOCK +^IBAM(354.7,"APAT",DFN):10
if '$TEST
HANG 600
IF $TEST
SET IBL=1
QUIT
+5 IF 'IBL
Begin DoDot:1
+6 SET IBTAG=3
+7 SET IBPAT=$PIECE($GET(^DPT(DFN,0)),"^",1)
IF IBPAT=""
SET IBPAT=DFN
+8 SET IBSSN=$PIECE($GET(^DPT(DFN,0)),"^",9)
IF IBSSN=""
SET IBSSN="????"
+9 SET (X,IBREF)=""
+10 FOR
SET X=$ORDER(IBSAVXMC(X))
if X=""
QUIT
Begin DoDot:2
+11 IF IBREF'=""
SET IBREF=IBREF_", "_$PIECE(IBSAVXMC(X),"^",1)
+12 IF IBREF=""
SET IBREF=$PIECE(IBSAVXMC(X),"^",1)
End DoDot:2
+13 SET Y="^^Unable to lock the IB PATIENT COPAY ACCOUNT (#354.7) file for back billing job related to "_IBPAT_" ("_IBSSN_") and IB reference number(s): "_IBREF_"."
+14 DO ^IBAERR
QUIT
End DoDot:1
QUIT
+15 ;
+16 ; do query/back billing
+17 ;Delay between backbilling months
SET IBD=0
FOR
SET IBD=$ORDER(IBCAP(IBD))
if IBD<1
QUIT
DO CANCEL(DFN,IBD)
HANG 120
+18 ;
+19 ; remove lock
+20 LOCK -^IBAM(354.7,"APAT",DFN)
+21 ;
+22 QUIT
