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

IBARXMN.m

Go to the documentation of this file.
  1. IBARXMN ;LL/ELZ-PHARMCAY COPAY CAP RX PROCESSING ; 15 Jun 2021 11:46 AM
  1. ;;2.0;INTEGRATED BILLING;**150,158,156,186,308,563,676**;21-MAR-94;Build 34
  1. ;;Per VA Directive 6402, this routine should not be modified.
  1. ;
  1. TRACK(DFN) ; checks out patient if tracked already
  1. ;
  1. I '$D(^IBAM(354.7,DFN,0)) D QUERY(DFN,$E(DT,1,5)_"00")
  1. Q
  1. ;
  1. QUERY(DFN,IBDT) ; if there are treating facilities, perform query
  1. N IBT,IBX,IBS,IBD,IBB,DIE,DA,DR,X,IBA,IBP,IBZ,IBY,IBFD,IBTD
  1. S IBB=0,IBP=$$PRIORITY^IBARXMU(DFN)
  1. ;
  1. D ADD^IBARXMU(DFN) Q:'IBP
  1. S IBT=$$TFL^IBARXMU(DFN,.IBT,2) Q:'IBT
  1. D CAP^IBARXMC(IBDT,IBP,.IBZ,.IBY,.IBFD,.IBTD) I 'IBY,'IBZ Q
  1. I 'IBFD!('IBTD) Q
  1. W !!,"This patient has never had billing information tracked before",!,"Now querying other facilities..."
  1. S IBX=0 F S IBX=$O(IBT(IBX)) Q:IBX<1 W !,"Now sending query to ",$P(IBT(IBX),"^",2)," ..." D
  1. . ;
  1. . ;676;BL; Need to check for Cerner, if found send to IBARXCQR and quit
  1. . I $P(IBT(IBX),"^",1)["200CRNR" D Q
  1. . . D EN^IBARXCQR(DFN,$E(IBDT,1,5)_"00")
  1. . ;
  1. . ; need to query every month in the cap billing period
  1. . S IBDT=IBFD D F S IBDT=$$NEXTMO^IBARXMC(IBDT) Q:IBDT>IBTD D
  1. .. D UQUERY^IBARXMU(DFN,$E(IBDT,1,5)_"00",IBX,.IBD)
  1. .. ;
  1. .. ; error returned
  1. .. I -1=+$G(IBD,"-1") Q
  1. .. ;
  1. .. ; loop through query and file data
  1. .. S X=0 F S X=$O(IBD(X)) Q:X<1 S:$E(IBD(X),1,4)=(+IBT(IBX)_"-") IBA=$$ADD(DFN,IBD(X)),IBB=IBB+$P(IBD(X),"^",11)
  1. .. K IBD
  1. ;
  1. Q
  1. ;
  1. ACCT(DFN,IBB,IBU,IBDT,IBS) ; - update amount in patient account
  1. ; IBB = amount to be added to pt account (billed)
  1. ; IBU = amount to be added to pt account (not billable)
  1. ; IBDT = effective date for amount
  1. ; IBS = flag, if passed the amounts are totals not to be added to what is already there
  1. ;
  1. N DIE,DR,DO,DIC,DA,Y,IBA
  1. ;
  1. S DA(1)=DFN,IBDT=$E(IBDT,1,5)_"00"
  1. ;
  1. ; check to see if there is already that mo/year there and add if not
  1. S DA=$O(^IBAM(354.7,DFN,1,"B",IBDT,0))
  1. I 'DA S DIC="^IBAM(354.7,"_DFN_",1,",DIC(0)="",X=IBDT D FILE^DICN S DA=+Y
  1. ;
  1. ; now edit and add the new amount
  1. S IBA=^IBAM(354.7,DFN,1,DA,0)
  1. S:'$D(IBS) IBB=IBB+$P(IBA,"^",2),IBU=IBU+$P(IBA,"^",4)
  1. L +^IBAM(354.7,DFN):10 I '$T Q
  1. S DIE="^IBAM(354.7,"_DFN_",1,",DR=".02///^S X=IBB;.04///^S X=IBU"
  1. D ^DIE L -^IBAM(354.7,DFN)
  1. ;
  1. D FLAG^IBARXMC(DFN,IBDT)
  1. ;
  1. Q
  1. ;
  1. UPCHG(IBX,IBU,IBC) ; update a charge (from one that is on hold only)
  1. ; IBX = ien in 354.71
  1. ; IBU = updated # of units
  1. ; IBC = updated charge amount
  1. N IBO,IBY,DIE,DA,DR
  1. W !,"Updating copay cap account records..."
  1. S IBO=^IBAM(354.71,IBX,0)
  1. ;
  1. ; first update 354.71 entry
  1. S DIE="^IBAM(354.71,",DA=IBX,DR=".07///^S X=IBU;.08///^S X=IBC;.11///^S X=IBC;.05///P"
  1. L +^IBAM(354.71,DA):10 I '$T W !!,"Unable to update records, entry locked!!" Q
  1. D ^DIE L -^IBAM(354.71,DA)
  1. ;
  1. ; now update account
  1. D ACCT($P(IBO,"^",2),IBC-$P(IBO,"^",11),0,$P(IBO,"^",3))
  1. ;
  1. ; finally clean transmission record
  1. D CLEAN(IBX)
  1. ;
  1. Q
  1. CLEAN(IBX) ; clean out transmission record
  1. N IBA,DA,DIK,X,Y
  1. S IBA=0 F S IBA=$O(^IBAM(354.71,IBX,1,IBA)) Q:IBA<1 S DA=IBA,DA(1)=IBX,DIK="^IBAM(354.71,"_IBX_",1," D ^DIK
  1. Q
  1. ;
  1. CANCEL(DFN,IBX,IBY,IBR) ; cancel a transaction (flags old one and creates a new one)
  1. ; IBX is the ien from 354.71, IBY is the error flag (y) passed by ref
  1. ; IBR is optional, it is the reason to cancel
  1. ;
  1. N IBN,IBD,DIE,DA,DR,X,Y
  1. ;
  1. ; is IBX there or is this an old transaction
  1. S IBD=$G(^IBAM(354.71,+IBX,0)) I 'IBD S IBN=0 G CANQ
  1. S IBAMP=$P($G(^IBAM(354.71,+$P(IBD,"^",10),0)),"^")
  1. ;
  1. ; set flag for at or above cap
  1. S:'$D(IBCAP) IBCAP=+$P($G(^IBAM(354.7,DFN,1,+$O(^IBAM(354.7,DFN,1,"B",$E($P(IBD,"^",3),1,5)_"00",0)),0)),"^",3)
  1. ;
  1. ; flag old one as canceled, and clean out transmission record.
  1. S DIE="^IBAM(354.71,",DA=IBX,DR=".05///Y;.16///"_DUZ_";.17///"_$$NOW^XLFDT_";.19///"_$S($D(IBR):IBR,1:16)
  1. L +^IBAM(354.71,IBX):5 I '$T S IBY="-1^IB318",IBN=0 G CANQ
  1. D ^DIE L -^IBAM(354.71,IBX)
  1. D CLEAN(IBX)
  1. ;
  1. ; now create new transaction to adjust amounts
  1. ; first set up parent, clear out .01, set facility, - dollar amt, status
  1. S $P(IBD,"^",10)=$P(IBD,"^"),$P(IBD,"^")="",$P(IBD,"^",13)=+$P($$FAC^IBARXMU(+$$SITE^IBARXMU),"^",2),$P(IBD,"^",11)=-$P(IBD,"^",11),$P(IBD,"^",12)=-$P(IBD,"^",12),$P(IBD,"^",5)="P"
  1. S IBN=$$ADD(DFN,$P(IBD,"^",1,13)_"^^^^^^^"_$P(IBD,"^",20)) I IBN<1 S IBY="-1^IB316"
  1. ;
  1. ; set up variable to check for cap and re-bill if necessary
  1. S IBCAP($E($P(IBD,"^",3),1,5)_"00")=""
  1. ;
  1. ; now check to see if the patient has previously reached cap and has some unbilled (only if not updating, check for flag)
  1. ;I '$G(IBUPDATE) D CANCEL^IBARXMC(DFN,$P(IBD,"^",3))
  1. ;D CANCEL^IBARXMC(DFN,$P(IBD,"^",3))
  1. ;
  1. CANQ Q IBN
  1. ;
  1. ADD(DFN,IBD,IBT,IBPFSS) ; adds a transaction to 354.71
  1. ; IBD = data in 354.71 format, if $p(IBD,"^")="" create new number
  1. ; IBT = action type pointer (optional, but needed for local site)
  1. ; returns ien in 354.71
  1. ; IBPFSS optional to indicate came from PFSS system
  1. ;
  1. N IBA,DIC,X,IBS,IBN,NEW
  1. S NEW=0
  1. Q:'$G(DFN)
  1. D ADD^IBARXMU(DFN)
  1. I $P(IBD,"^") S IBA=$O(^IBAM(354.71,"B",$P(IBD,"^"),0)) D Q IBA
  1. . ;I IBA D TRANF(DFN,IBA,IBD,$G(IBT)) Q
  1. . I 'IBA S DIC="^IBAM(354.71,",DIC(0)="",X=$P(IBD,"^") D FILE^DICN S IBA=+Y,NEW=1
  1. . I IBA>0 D TRANF(DFN,IBA,IBD,$G(IBT)) I NEW D ACCT(DFN,$P(IBD,"^",11),$P(IBD,"^",12),$P(IBD,"^",3))
  1. K DO S DIC="^IBAM(354.71,",DIC(0)="",IBS=+$P($$SITE^IBARXMU,"^",3)
  1. ;
  1. ; get next number and file
  1. F L +^IBAM(354.71,0):20 I $T S IBN=$P(^IBAM(354.71,0),"^",3) S:'IBN IBN=0 Q
  1. I +$G(^IBAM(354.71,+IBN,0))'=IBS,IBN F S IBN=$O(^IBAM(354.71,IBN),-1) Q:IBS=+$G(^IBAM(354.71,IBN,0))!('IBN)
  1. S IBN=$P($P($G(^IBAM(354.71,+IBN,0)),"^"),"-",2)+1 F IBN=IBN:1 S X=IBS_"-"_IBN I '$D(^IBAM(354.71,"B",X)) L +^IBAM(354.71,"B",X):10 I $T D FILE^DICN L -^IBAM(354.71,"B",X) I Y>0 S IBA=+Y Q
  1. L -^IBAM(354.71,0)
  1. ;
  1. D TRANF(DFN,IBA,IBD,$G(IBT),$G(IBPFSS)),ACCT(DFN,$P(IBD,"^",11),$P(IBD,"^",12),$P(IBD,"^",3))
  1. ;I '$G(IBUPDATE) D CANCEL^IBARXMC(DFN,$P(IBD,"^",3))
  1. ;
  1. Q IBA
  1. ;
  1. TRANF(DFN,IBA,IBD,IBT,IBPFSS) ; file transaction data in 354.71
  1. ; DFN = patient's dfn
  1. ; IBA = ien from file 354.71
  1. ; IBD = data in global file format for file 354.71
  1. ; piece 2 will be changed to dfn
  1. ; pieces 10 and 13 will be resolved
  1. ; pieces 14,15 will be created new if they don't exist
  1. ; pieces 16,17 will be created new
  1. ; piece 18 will be filled if not $g(IBT)=""
  1. ;
  1. N X,Y,IBZ,IBN,D,IBU,DIC,IBPAR,DA,DIK Q:'$D(^IBAM(354.71,IBA,0))
  1. ;
  1. X $S($P(IBD,"^")=$P(IBD,"^",10):"S $P(IBD,""^"",10)=IBA",1:"S X=$P(IBD,""^"",10),D=""B"",DIC=""^IBAM(354.71,"",DIC(0)=""OX"" D IX^DIC S $P(IBD,""^"",10)=$S(Y>0:+Y,1:"""")")
  1. S IBPAR=$$PARENT^IBARXMC(+$P(IBD,"^",10)) S:IBPAR $P(IBD,"^",10)=IBPAR
  1. S DIC="^DIC(4,",DIC(0)="O",X=$P(IBD,"^",13),D="D" D IX^DIC
  1. S IBS=$S(Y>0:+Y,1:"")
  1. S IBN=$$NOW^XLFDT,IBU=$P(^IBAM(354.71,IBA,0),"^",14,15)
  1. ;
  1. S $P(^IBAM(354.71,IBA,0),"^",2,18)=DFN_"^"_$P(IBD,"^",3,12)_"^"_IBS_"^"_$S(+IBU:+IBU,$D(IBDUZ):IBDUZ,1:DUZ)_"^"_$S($P(IBU,"^",2):$P(IBU,"^",2),1:IBN)_"^"_$S($D(IBDUZ):IBDUZ,1:DUZ)_"^"_IBN_$S($G(IBT):"^"_IBT,1:"")
  1. S:$P(IBD,"^",20) $P(^IBAM(354.71,IBA,0),"^",20)=$P(IBD,"^",20)
  1. S DA=IBA,DIK="^IBAM(354.71," D IX^DIK
  1. Q