Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: IBARXMB

IBARXMB.m

Go to the documentation of this file.
  1. 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
  1. ;;Per VA Directive 6402, this routine should not be modified.
  1. ;
  1. 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
  1. ; IBX = the parent transaction number to bill, IBB = the amount to bill
  1. ;
  1. N IBY,IBZ,IB350,IBUPDATE,IBER,Y,IBL,IBN,ZVZTQ
  1. ;
  1. ; find bill number
  1. S IBY=+$O(^IBAM(354.71,"B",IBX,0)) Q:'IBY
  1. ;
  1. ; find last 354.71 entry for IBX
  1. S IBL=$O(^IBAM(354.71,"AF",IBY,":"),-1) I IBL S IBY=+IBL
  1. ;
  1. ; get info
  1. S IBZ=^IBAM(354.71,IBY,0),IB350=$G(^IB(+$P(IBZ,"^",4),0))
  1. ;
  1. ; is this already totally billed?
  1. Q:$P($$NET^IBARXMC(IBY),"^",2)'>0
  1. ;
  1. ; cancel old 354.71 entry
  1. S IBUPDATE=1 S IBN=$$CANCEL^IBARXMN(DFN,IBY,.IBER)
  1. ;
  1. ;676;BL; Send negative transaction immediately
  1. I IBN>0 D
  1. . S IBER=1
  1. . S:'$D(ZTQUEUED) ZVZTQ=1,ZTQUEUED=1
  1. . D FOUND^IBARXMA(.IBER,IBN)
  1. . K:$G(ZVZTQ) ZTQUEUED
  1. ;
  1. ; cancel old 350 entry
  1. D:IB350 CAN(DFN,+$P(IBZ,"^",4))
  1. ;
  1. ; create updated one
  1. D ADDUP(IBY,IBB)
  1. ;
  1. Q
  1. 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
  1. ; IBX = the parent transaction number to bill, IBB = the amount to bill
  1. ; ia #3144
  1. 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
  1. D
  1. . S IBICN=$$ICN^IBARXMU(DFN) Q:'IBICN
  1. . D DIRECT^XWB2HL7(.IBD,+IBX,"IBARXM TRANS BILL","",IBICN,IBX,IBB)
  1. Q
  1. CAN(DFN,IBX,IBCRES) ; cancels charge to be updated
  1. ; IBX = ien from 350, IBCRES = charge cancel reason (optional)
  1. ;
  1. N IBZ,IBSERV,IBDUZ,IBSITE,IBFAC,IBLAST,IBPARNT,IBTYP,IBSEQNO,IBIL,IBLASTZ,IBUNIT,IBCHRG,IBNOS,IBTOTL,IBN,IBND,IBEFDT
  1. ;
  1. S (IBND,IBZ)=$G(^IB(IBX,0)) Q:'IBZ
  1. ;
  1. S IBSERV=$$SERVICE(IBZ)
  1. D ARPARM^IBAUTL
  1. S:'$D(IBCRES) IBCRES=16
  1. ;
  1. 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
  1. ;
  1. ; cancel a charge with a status of HOLD
  1. I $P(IBZ,"^",5)=8 N DIE,DA,DR S DIE="^IB(",DA=IBX,DR=".05///10;.1///"_IBCRES D ^DIE Q
  1. ;
  1. S IBDUZ=DUZ
  1. S IBPARNT=$P(IBZ,"^",9) Q:'$D(^IB(IBPARNT,0))
  1. S IBATYP=$P(^IBE(350.1,$P(IBZ,"^",3),0),"^",6) ;cancellation action type
  1. S IBSEQNO=$P($G(^IBE(350.1,+IBATYP,0)),"^",5) Q:'IBSEQNO
  1. S IBIL=$P(IBZ,"^",11) Q:'IBIL ; no bill exists
  1. S IBLASTZ=$G(^IB(+IBLAST,0))
  1. S IBUNIT=$S($P(IBLASTZ,"^",6):$P(IBLASTZ,"^",6),1:$P(IBZ,"^",6))
  1. S IBCHRG=$S($P(IBLASTZ,"^",7):$P(IBLASTZ,"^",7),1:$P(IBZ,"^",7))
  1. S IBEFDT=$S($P(IBZ,"^",14):$P(IBZ,"^",14),1:$P($G(^IB(IBX,1)),"^",2))
  1. S IBTOTL=IBCHRG,IBWHER=2
  1. D ADD^IBAUTL I +Y<1 Q
  1. ;
  1. 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)
  1. K ^IB("AC",1,IBN)
  1. D INDEX^IBARX1
  1. S IBNOS=IBN
  1. D ^IBAFIL
  1. Q
  1. ;
  1. ADDUP(IBX,IBB) ; add updated transaction, assumes DFN
  1. ; IBX = example ien from 354.71 to bill, IBB = amount to bill
  1. ;
  1. N IBZ,IBSEQNO,IBDESC,IBCHRG,IBNOCH,IBAM,IBATYP,IBPARNT,IBN,IBDUZ,IBFAC,IBNOS,Y
  1. ;
  1. S IBZ=^IBAM(354.71,IBX,0),IBDUZ=$P(IBZ,"^",14)
  1. D ARPARM^IBAUTL
  1. ;
  1. ; check exemption status
  1. I +$$RXEXMT^IBARXEU0(DFN,$P(IBZ,"^",3)) Q
  1. ;
  1. S IBATYP=$P(IBZ,"^",18),IBATYP=$P($G(^IBE(350.1,+IBATYP,0)),"^",7)
  1. S IBSEQNO=$P($G(^IBE(350.1,+IBATYP,0)),"^",5) Q:'IBSEQNO
  1. S IBDESC=$P(IBZ,"^",9)
  1. ;
  1. S IBCHRG=IBB+$P(IBZ,"^",11),IBNOCH=$P(IBZ,"^",8)-IBCHRG
  1. ;
  1. 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
  1. ;
  1. D ADD^IBAUTL
  1. S IBPARNT=$S($P(IBZ,"^",4):$P(IBZ,"^",4),1:IBN)
  1. 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)
  1. K IBPARNT,^IB("AC",1,IBN)
  1. D INDEX^IBARX1
  1. S IBNOS=IBN_"^"_$G(IBNOS)
  1. D ^IBAFIL
  1. ;
  1. ; call pso to let them know I have billed
  1. ; check for pso part not installed
  1. ; ia #3462
  1. 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
  1. ;
  1. ;
  1. Q
  1. ;
  1. SERVICE(IBZ) ; returns service pointer
  1. ; IBZ = zero node from 350
  1. Q $P($G(^IBE(350.1,+$P(IBZ,"^",3),0)),"^",4)
  1. ;