IBARXMB ;LL/ELZ - PHARMCAY COPAY CAP BILLING FUNCTIONS ; 08 Jul 2021 10:46 AM
;;2.0;INTEGRATED BILLING;**156,563,676**;21-MAR-94;Build 34
;;Per VA Directive 6402, this routine should not be modified.
;
BILL(IBX,IBB) ; receives information to bill for amounts not previously billed
; to create bills for them on the local system, DFN is assumed
; IBX = the parent transaction number to bill, IBB = the amount to bill
;
N IBY,IBZ,IB350,IBUPDATE,IBER,Y,IBL,IBN,ZVZTQ
;
; find bill number
S IBY=+$O(^IBAM(354.71,"B",IBX,0)) Q:'IBY
;
; find last 354.71 entry for IBX
S IBL=$O(^IBAM(354.71,"AF",IBY,":"),-1) I IBL S IBY=+IBL
;
; get info
S IBZ=^IBAM(354.71,IBY,0),IB350=$G(^IB(+$P(IBZ,"^",4),0))
;
; is this already totally billed?
Q:$P($$NET^IBARXMC(IBY),"^",2)'>0
;
; cancel old 354.71 entry
S IBUPDATE=1 S IBN=$$CANCEL^IBARXMN(DFN,IBY,.IBER)
;
;676;BL; Send negative transaction immediately
I IBN>0 D
. S IBER=1
. S:'$D(ZTQUEUED) ZVZTQ=1,ZTQUEUED=1
. D FOUND^IBARXMA(.IBER,IBN)
. K:$G(ZVZTQ) ZTQUEUED
;
; cancel old 350 entry
D:IB350 CAN(DFN,+$P(IBZ,"^",4))
;
; create updated one
D ADDUP(IBY,IBB)
;
Q
SEND(IBX,IBB) ; receives information to bill remotely for amounts not already
; billed. Makes a call to the remote system to tell them to bill
; IBX = the parent transaction number to bill, IBB = the amount to bill
; ia #3144
N IBICN,Y,DA,HLDOM,HLECH,HLFS,HLINSTN,HLNEXT,HLNODE,HLPARAM,HLQ,HLQUIT,PHONE,RPCIEN,IO,IOBS,IOCPU,IOF,IOHG,IOM,ION,IOPAR,IOUPAR,IOS,IOSL,IOST,IOT,IOXY,POP,IBD
D
. S IBICN=$$ICN^IBARXMU(DFN) Q:'IBICN
. D DIRECT^XWB2HL7(.IBD,+IBX,"IBARXM TRANS BILL","",IBICN,IBX,IBB)
Q
CAN(DFN,IBX,IBCRES) ; cancels charge to be updated
; IBX = ien from 350, IBCRES = charge cancel reason (optional)
;
N IBZ,IBSERV,IBDUZ,IBSITE,IBFAC,IBLAST,IBPARNT,IBTYP,IBSEQNO,IBIL,IBLASTZ,IBUNIT,IBCHRG,IBNOS,IBTOTL,IBN,IBND,IBEFDT
;
S (IBND,IBZ)=$G(^IB(IBX,0)) Q:'IBZ
;
S IBSERV=$$SERVICE(IBZ)
D ARPARM^IBAUTL
S:'$D(IBCRES) IBCRES=16
;
D LAST^IBARX1 I IBLAST'=IBPARNT,$D(^IB(IBLAST,0)),$P(^IBE(350.1,$P(^IB(IBLAST,0),"^",3),0),"^",5)=2 Q ; already cancelled
;
; cancel a charge with a status of HOLD
I $P(IBZ,"^",5)=8 N DIE,DA,DR S DIE="^IB(",DA=IBX,DR=".05///10;.1///"_IBCRES D ^DIE Q
;
S IBDUZ=DUZ
S IBPARNT=$P(IBZ,"^",9) Q:'$D(^IB(IBPARNT,0))
S IBATYP=$P(^IBE(350.1,$P(IBZ,"^",3),0),"^",6) ;cancellation action type
S IBSEQNO=$P($G(^IBE(350.1,+IBATYP,0)),"^",5) Q:'IBSEQNO
S IBIL=$P(IBZ,"^",11) Q:'IBIL ; no bill exists
S IBLASTZ=$G(^IB(+IBLAST,0))
S IBUNIT=$S($P(IBLASTZ,"^",6):$P(IBLASTZ,"^",6),1:$P(IBZ,"^",6))
S IBCHRG=$S($P(IBLASTZ,"^",7):$P(IBLASTZ,"^",7),1:$P(IBZ,"^",7))
S IBEFDT=$S($P(IBZ,"^",14):$P(IBZ,"^",14),1:$P($G(^IB(IBX,1)),"^",2))
S IBTOTL=IBCHRG,IBWHER=2
D ADD^IBAUTL I +Y<1 Q
;
S $P(^IB(IBN,1),"^",1)=IBDUZ,$P(^IB(IBN,0),"^",2,15)=DFN_"^"_IBATYP_"^"_$P(IBND,"^",4)_"^2^"_IBUNIT_"^"_IBCHRG_"^"_$P(IBND,"^",8)_"^"_IBPARNT_"^"_IBCRES_"^"_IBIL_"^^"_IBFAC_"^"_IBEFDT_"^"_IBEFDT,$P(^(0),"^",22)=$P(IBZ,"^",22)
K ^IB("AC",1,IBN)
D INDEX^IBARX1
S IBNOS=IBN
D ^IBAFIL
Q
;
ADDUP(IBX,IBB) ; add updated transaction, assumes DFN
; IBX = example ien from 354.71 to bill, IBB = amount to bill
;
N IBZ,IBSEQNO,IBDESC,IBCHRG,IBNOCH,IBAM,IBATYP,IBPARNT,IBN,IBDUZ,IBFAC,IBNOS,Y
;
S IBZ=^IBAM(354.71,IBX,0),IBDUZ=$P(IBZ,"^",14)
D ARPARM^IBAUTL
;
; check exemption status
I +$$RXEXMT^IBARXEU0(DFN,$P(IBZ,"^",3)) Q
;
S IBATYP=$P(IBZ,"^",18),IBATYP=$P($G(^IBE(350.1,+IBATYP,0)),"^",7)
S IBSEQNO=$P($G(^IBE(350.1,+IBATYP,0)),"^",5) Q:'IBSEQNO
S IBDESC=$P(IBZ,"^",9)
;
S IBCHRG=IBB+$P(IBZ,"^",11),IBNOCH=$P(IBZ,"^",8)-IBCHRG
;
S IBAM=$$ADD^IBARXMN(DFN,"^^"_$P(IBZ,"^",3)_"^^P^"_$P(IBZ,"^",6,9)_"^"_$P(IBZ,"^")_"^"_IBCHRG_"^"_IBNOCH_"^"_(+$P($$SITE^IBARXMU,"^",3))_"^^^^^^^^^"_$P(IBZ,"^",22),IBATYP) I IBAM<1 Q
;
D ADD^IBAUTL
S IBPARNT=$S($P(IBZ,"^",4):$P(IBZ,"^",4),1:IBN)
S $P(^IB(IBN,1),"^")=IBDUZ,$P(^IB(IBN,0),"^",2,15)=DFN_"^"_IBATYP_"^"_$P(IBZ,"^",6)_"^2^"_$P(IBZ,"^",7)_"^"_IBCHRG_"^"_IBDESC_"^"_IBPARNT_"^^^^"_IBFAC_"^"_$P(IBZ,"^",3)_"^"_$P(IBZ,"^",3),$P(^(0),"^",19,22)=IBAM_"^^^"_$P(IBZ,"^",22)
K IBPARNT,^IB("AC",1,IBN)
D INDEX^IBARX1
S IBNOS=IBN_"^"_$G(IBNOS)
D ^IBAFIL
;
; call pso to let them know I have billed
; check for pso part not installed
; ia #3462
I $L($T(^PSOCPIB)) S Y(1)=$$NOW^XLFDT_"^"_DUZ_"^"_(+$P($P(IBZ,"^",6),":",2))_"^"_(+$P($P(IBZ,"^",6),":",3))_"^"_$S(IBNOCH:"P",1:"F")_"^"_IBN D ^PSOCPIB
;
;
Q
;
SERVICE(IBZ) ; returns service pointer
; IBZ = zero node from 350
Q $P($G(^IBE(350.1,+$P(IBZ,"^",3),0)),"^",4)
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBARXMB 4681 printed Dec 13, 2024@02:07:31 Page 2
IBARXMB ;LL/ELZ - PHARMCAY COPAY CAP BILLING FUNCTIONS ; 08 Jul 2021 10:46 AM
+1 ;;2.0;INTEGRATED BILLING;**156,563,676**;21-MAR-94;Build 34
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;
BILL(IBX,IBB) ; receives information to bill for amounts not previously billed
+1 ; to create bills for them on the local system, DFN is assumed
+2 ; IBX = the parent transaction number to bill, IBB = the amount to bill
+3 ;
+4 NEW IBY,IBZ,IB350,IBUPDATE,IBER,Y,IBL,IBN,ZVZTQ
+5 ;
+6 ; find bill number
+7 SET IBY=+$ORDER(^IBAM(354.71,"B",IBX,0))
if 'IBY
QUIT
+8 ;
+9 ; find last 354.71 entry for IBX
+10 SET IBL=$ORDER(^IBAM(354.71,"AF",IBY,":"),-1)
IF IBL
SET IBY=+IBL
+11 ;
+12 ; get info
+13 SET IBZ=^IBAM(354.71,IBY,0)
SET IB350=$GET(^IB(+$PIECE(IBZ,"^",4),0))
+14 ;
+15 ; is this already totally billed?
+16 if $PIECE($$NET^IBARXMC(IBY),"^",2)'>0
QUIT
+17 ;
+18 ; cancel old 354.71 entry
+19 SET IBUPDATE=1
SET IBN=$$CANCEL^IBARXMN(DFN,IBY,.IBER)
+20 ;
+21 ;676;BL; Send negative transaction immediately
+22 IF IBN>0
Begin DoDot:1
+23 SET IBER=1
+24 if '$DATA(ZTQUEUED)
SET ZVZTQ=1
SET ZTQUEUED=1
+25 DO FOUND^IBARXMA(.IBER,IBN)
+26 if $GET(ZVZTQ)
KILL ZTQUEUED
End DoDot:1
+27 ;
+28 ; cancel old 350 entry
+29 if IB350
DO CAN(DFN,+$PIECE(IBZ,"^",4))
+30 ;
+31 ; create updated one
+32 DO ADDUP(IBY,IBB)
+33 ;
+34 QUIT
SEND(IBX,IBB) ; receives information to bill remotely for amounts not already
+1 ; billed. Makes a call to the remote system to tell them to bill
+2 ; IBX = the parent transaction number to bill, IBB = the amount to bill
+3 ; ia #3144
+4 NEW IBICN,Y,DA,HLDOM,HLECH,HLFS,HLINSTN,HLNEXT,HLNODE,HLPARAM,HLQ,HLQUIT,PHONE,RPCIEN,IO,IOBS,IOCPU,IOF,IOHG,IOM,ION,IOPAR,IOUPAR,IOS,IOSL,IOST,IOT,IOXY,POP,IBD
+5 Begin DoDot:1
+6 SET IBICN=$$ICN^IBARXMU(DFN)
if 'IBICN
QUIT
+7 DO DIRECT^XWB2HL7(.IBD,+IBX,"IBARXM TRANS BILL","",IBICN,IBX,IBB)
End DoDot:1
+8 QUIT
CAN(DFN,IBX,IBCRES) ; cancels charge to be updated
+1 ; IBX = ien from 350, IBCRES = charge cancel reason (optional)
+2 ;
+3 NEW IBZ,IBSERV,IBDUZ,IBSITE,IBFAC,IBLAST,IBPARNT,IBTYP,IBSEQNO,IBIL,IBLASTZ,IBUNIT,IBCHRG,IBNOS,IBTOTL,IBN,IBND,IBEFDT
+4 ;
+5 SET (IBND,IBZ)=$GET(^IB(IBX,0))
if 'IBZ
QUIT
+6 ;
+7 SET IBSERV=$$SERVICE(IBZ)
+8 DO ARPARM^IBAUTL
+9 if '$DATA(IBCRES)
SET IBCRES=16
+10 ;
+11 ; already cancelled
DO LAST^IBARX1
IF IBLAST'=IBPARNT
IF $DATA(^IB(IBLAST,0))
IF $PIECE(^IBE(350.1,$PIECE(^IB(IBLAST,0),"^",3),0),"^",5)=2
QUIT
+12 ;
+13 ; cancel a charge with a status of HOLD
+14 IF $PIECE(IBZ,"^",5)=8
NEW DIE,DA,DR
SET DIE="^IB("
SET DA=IBX
SET DR=".05///10;.1///"_IBCRES
DO ^DIE
QUIT
+15 ;
+16 SET IBDUZ=DUZ
+17 SET IBPARNT=$PIECE(IBZ,"^",9)
if '$DATA(^IB(IBPARNT,0))
QUIT
+18 ;cancellation action type
SET IBATYP=$PIECE(^IBE(350.1,$PIECE(IBZ,"^",3),0),"^",6)
+19 SET IBSEQNO=$PIECE($GET(^IBE(350.1,+IBATYP,0)),"^",5)
if 'IBSEQNO
QUIT
+20 ; no bill exists
SET IBIL=$PIECE(IBZ,"^",11)
if 'IBIL
QUIT
+21 SET IBLASTZ=$GET(^IB(+IBLAST,0))
+22 SET IBUNIT=$SELECT($PIECE(IBLASTZ,"^",6):$PIECE(IBLASTZ,"^",6),1:$PIECE(IBZ,"^",6))
+23 SET IBCHRG=$SELECT($PIECE(IBLASTZ,"^",7):$PIECE(IBLASTZ,"^",7),1:$PIECE(IBZ,"^",7))
+24 SET IBEFDT=$SELECT($PIECE(IBZ,"^",14):$PIECE(IBZ,"^",14),1:$PIECE($GET(^IB(IBX,1)),"^",2))
+25 SET IBTOTL=IBCHRG
SET IBWHER=2
+26 DO ADD^IBAUTL
IF +Y<1
QUIT
+27 ;
+28 SET $PIECE(^IB(IBN,1),"^",1)=IBDUZ
SET $PIECE(^IB(IBN,0),"^",2,15)=DFN_"^"_IBATYP_"^"_$PIECE(IBND,"^",4)_"^2^"_IBUNIT_"^"_IBCHRG_"^"_$PIECE(IBND,"^",8)_"^"_IBPARNT_"^"_IBCRES_"^"_IBIL_"^^"_IBFAC_"^"_IBEFDT_"^"_IBEFDT
SET $PIECE(^(0),"^",22)=$PIECE(IBZ,"^",22)
+29 KILL ^IB("AC",1,IBN)
+30 DO INDEX^IBARX1
+31 SET IBNOS=IBN
+32 DO ^IBAFIL
+33 QUIT
+34 ;
ADDUP(IBX,IBB) ; add updated transaction, assumes DFN
+1 ; IBX = example ien from 354.71 to bill, IBB = amount to bill
+2 ;
+3 NEW IBZ,IBSEQNO,IBDESC,IBCHRG,IBNOCH,IBAM,IBATYP,IBPARNT,IBN,IBDUZ,IBFAC,IBNOS,Y
+4 ;
+5 SET IBZ=^IBAM(354.71,IBX,0)
SET IBDUZ=$PIECE(IBZ,"^",14)
+6 DO ARPARM^IBAUTL
+7 ;
+8 ; check exemption status
+9 IF +$$RXEXMT^IBARXEU0(DFN,$PIECE(IBZ,"^",3))
QUIT
+10 ;
+11 SET IBATYP=$PIECE(IBZ,"^",18)
SET IBATYP=$PIECE($GET(^IBE(350.1,+IBATYP,0)),"^",7)
+12 SET IBSEQNO=$PIECE($GET(^IBE(350.1,+IBATYP,0)),"^",5)
if 'IBSEQNO
QUIT
+13 SET IBDESC=$PIECE(IBZ,"^",9)
+14 ;
+15 SET IBCHRG=IBB+$PIECE(IBZ,"^",11)
SET IBNOCH=$PIECE(IBZ,"^",8)-IBCHRG
+16 ;
+17 SET IBAM=$$ADD^IBARXMN(DFN,"^^"_$PIECE(IBZ,"^",3)_"^^P^"_$PIECE(IBZ,"^",6,9)_"^"_$PIECE(IBZ,"^")_"^"_IBCHRG_"^"_IBNOCH_"^"_(+$PIECE($$SITE^IBARXMU,"^",3))_"^^^^^^^^^"_$PIECE(IBZ,"^",22),IBATYP)
IF IBAM<1
QUIT
+18 ;
+19 DO ADD^IBAUTL
+20 SET IBPARNT=$SELECT($PIECE(IBZ,"^",4):$PIECE(IBZ,"^",4),1:IBN)
+21 SET $PIECE(^IB(IBN,1),"^")=IBDUZ
SET $PIECE(^IB(IBN,0),"^",2,15)=DFN_"^"_IBATYP_"^"_$PIECE(IBZ,"^",6)_"^2^"_$PIECE(IBZ,"^",7)_"^"_IBCHRG_"^"_IBDESC_"^"_IBPARNT_"^^^^"_IBFAC_"^"_$PIECE(IBZ,"^",3)_"^"_$PIECE(IBZ,"^",3)
SET $PIECE(^(0),"^",19,22)=IBAM_"^^^"_$PIECE(IBZ,"^",22)
+22 KILL IBPARNT,^IB("AC",1,IBN)
+23 DO INDEX^IBARX1
+24 SET IBNOS=IBN_"^"_$GET(IBNOS)
+25 DO ^IBAFIL
+26 ;
+27 ; call pso to let them know I have billed
+28 ; check for pso part not installed
+29 ; ia #3462
+30 IF $LENGTH($TEXT(^PSOCPIB))
SET Y(1)=$$NOW^XLFDT_"^"_DUZ_"^"_(+$PIECE($PIECE(IBZ,"^",6),":",2))_"^"_(+$PIECE($PIECE(IBZ,"^",6),":",3))_"^"_$SELECT(IBNOCH:"P",1:"F")_"^"_IBN
DO ^PSOCPIB
+31 ;
+32 ;
+33 QUIT
+34 ;
SERVICE(IBZ) ; returns service pointer
+1 ; IBZ = zero node from 350
+2 QUIT $PIECE($GET(^IBE(350.1,+$PIECE(IBZ,"^",3),0)),"^",4)
+3 ;
