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