- 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 Feb 18, 2025@23:33:57 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
