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

IBARX.m

Go to the documentation of this file.
  1. IBARX ;ALB/AAS - INTEGRATED BILLING, PHARMACY COPAY INTERFACE;8/30/17 3:42pm
  1. ;;2.0;INTEGRATED BILLING;**101,150,156,168,186,237,308,563,604,645,676**;21-MAR-94;Build 34
  1. ;;Per VA Directive 6402, this routine should not be modified.
  1. ;
  1. XTYPE ; - tag XTYPE - returns array of billable action types for service
  1. ; - see IBARXDOC for documentation
  1. ;
  1. X1 K Y D INSTAL I '$T S Y=-1 Q
  1. N I,J,X1,X2,DA,DFN,IBCAP S Y=1,IBSAVX=X,IBTAG=1,IBWHER=5
  1. ;
  1. D CHKX^IBAUTL G:+Y<1 XTYPEQ
  1. ;
  1. I '$D(^IBE(350.1,"ANEW",IBSERV,1,1)) D S Y=-1 G XTYPEQ
  1. .I '$D(ZTQUEUED) W !!,*7,"WARNING: Pharmacy Copay not working,",!," Check IB SERVICE/SECTION in Pharmacy Site File.",!!
  1. .D E3^IBAERR
  1. ;
  1. N X D ELIG^VADPT,INP^VADPT,DOM S Y=1
  1. ;IB*2.0*645 - Modified copay check to include Community Care Action Types with Fee Basis.
  1. F I=0:0 S I=$O(^IBE(350.1,"ANEW",IBSERV,1,I)) Q:'I I $D(^IBE(350.1,I,40)),$$NFEECCRX($P(^IBE(350.1,I,0),U,1)) S DA=I X ^IBE(350.1,DA,40) S Y(DA,X)=I_"^"_X1_"^"_X2 S:'$G(IBCAP) IBCAP=X
  1. ;
  1. ;I $G(IBCAP),$G(DFN) D NEW^IBARXPFS(DFN) ;IB*2.0*676 DISABLED PROCESSED THOUGH TRACK^IBARXMN RXCOPAY
  1. ;
  1. XTYPEQ K X1,X2,IBSERV,VAEL,VA,VAERR,IBDOM,VAIN,IBSAVX,IBTAG,IBWHER
  1. ;
  1. Q
  1. ;
  1. DOM S IBDOM=0 I $D(VAIN(4)),$D(^DIC(42,+VAIN(4),0)),$P(^(0),"^",3)="D" S IBDOM=1
  1. Q
  1. NEW ; - process new/renew/refill rx for charges
  1. ; - see IBARXDOC for documentation
  1. ;
  1. N1 K Y,IBSAVX D INSTAL I '$T S Y=-1 Q
  1. N I,J,X1,X2,DA,DFN,IBEXMP,IBEFDT
  1. S IBWHER=1,IBSAVX=X,Y=1,IBTAG=2 D CHKX^IBAUTL I +Y<1 G NEWQ
  1. I $D(X)<11 S Y="-1^IB010" G NEWQ
  1. S J="" F S J=$O(X(J)) Q:J="" S IBSAVX(J)=X(J)
  1. D ARPARM^IBAUTL I +Y<1 G NEWQ
  1. ;
  1. ; -- check rx exemption in case refill is exempt
  1. ; -- if exempt set amount to each rx and total to zero
  1. ; 1= exempt, 0= non-exempt, -1=copay off (manila)
  1. S IBEXMP=+$$RXEXMT^IBARXEU0(DFN,DT)
  1. I IBEXMP'=0 D S Y="1^0" G NEWQ
  1. .S IBJ=""
  1. .; changed return value 6th piece is the exempt flag
  1. .F S IBJ=$O(IBSAVX(IBJ)) Q:IBJ="" S $P(Y(IBJ),"^",6)=IBEXMP
  1. .Q
  1. ;
  1. ; check to see if billing has been tracked across facilities before,
  1. ; if not, start now.
  1. D TRACK^IBARXMN(DFN) I +Y<1 G NEWQ
  1. ;
  1. S IBTOTL=0
  1. D BILLNO^IBAUTL I +Y<1 G NEWQ
  1. ;
  1. S IBTOTL=0,IBJ="",IBSEQNO=$P(^IBE(350.1,IBATYP,0),"^",5) I 'IBSEQNO S Y="-1^IB023" G NEWQ
  1. F S IBJ=$O(IBSAVX(IBJ)) Q:IBJ="" S IBX=IBSAVX(IBJ) D RX^IBARX1
  1. I +Y<1 G NEWQ
  1. ;
  1. ; changed to only do if charge exists
  1. D:IBTOTL ^IBAFIL
  1. ;
  1. S IBJ="" F S IBJ=$O(IBSAVY(IBJ)) Q:IBJ="" S Y(IBJ)=IBSAVY(IBJ)
  1. S:+Y>0 Y="1^"_IBTOTL S X=IBSAVX
  1. ;
  1. NEWQ D:+Y<1 ^IBAERR
  1. D END
  1. Q
  1. ;
  1. INSTAL I $S($D(^IBE(350.9,1,0)):1,$D(^IB(0)):1,1:0)
  1. Q
  1. ;
  1. CANCEL ; - cancel charges for a rx
  1. ; - see IBARXDOC for documentation
  1. ;
  1. C1 K Y,IBSAVX N I,J,X1,X2,DA,DFN I '$G(IBUPDATE) N IBCAP,IBAMP,IBSAVXMC
  1. S IBWHER=1,IBSAVX=X,Y=1,IBTAG=3 D CHKX^IBAUTL I +Y<1 G CANQ
  1. I $D(X)<11 S Y="-1^IB010" G CANQ
  1. S J="" F S J=$O(X(J)) Q:J="" S IBSAVX(J)=X(J)
  1. D ARPARM^IBAUTL I +Y<1 G CANQ
  1. ;
  1. S IBJ="",IBTOTL=0
  1. F S IBJ=$O(IBSAVX(IBJ)) Q:IBJ="" S IBX=IBSAVX(IBJ) D CANRX^IBARX1 I +IBY(IBJ)'<1 D ^IBAFIL:$P(IBND,"^",5)'=8 I +Y<1 S IBY(IBJ)=Y
  1. I +Y<1 S IBT="",IBY=Y,IBM="" F S IBM=$O(IBY(IBM)) Q:IBM="" I +IBY(IBM)<1 S Y=IBY(IBM) D ^IBAERR S Y(IBM)=IBY(IBM),Y=IBY
  1. CANQ D:+Y<1 ^IBAERR:('$D(IBT))
  1. S X=IBSAVX
  1. M IBSAVXMC=Y
  1. D END
  1. ;
  1. ; now that I have cancelled lets see if there are some to be billed
  1. I '$G(IBUPDATE),$D(IBCAP)>10 D QCAN^IBARXMC(DFN,.IBCAP,.IBSAVXMC)
  1. ;S IBD=0 F S IBD=$O(IBCAP(IBD)) Q:IBD<1 D CANCEL^IBARXMC(DFN,IBD)
  1. Q
  1. ;
  1. UPDATE ; - will cancel current open charge and create updated entry
  1. ; - see IBARXDOC for documentation
  1. ;
  1. U1 K Y,IBSAVX N I,J,X1,X2,DA,DFN,IBEXMP,IBUPDATE,IBCAP,IBEFDT,IBAMP,IBSAVXMC
  1. S IBUPDATE=1 ; new flag so we know we are updating
  1. S IBWHER=1,IBSAVX=X,Y=1,IBTAG=4 D CHKX^IBAUTL I +Y<1 G UPDQ
  1. S IBSAVXU=IBSAVX
  1. I $D(X)<11 S Y="-1^IB010" G UPDQ
  1. S J="" F S J=$O(X(J)) Q:J="" S IBSAVXU(J)=X(J),X(J)=$P(X(J),"^",3,4) D EFDT^IBARXMU($P(X(J),"^"),.IBEFDT)
  1. ;
  1. D CANCEL
  1. U2 K X
  1. S X=IBSAVXU S J="" F S J=$O(IBSAVXU(J)) Q:J="" S X(J)=$P(IBSAVXU(J),"^",1,3)
  1. S IBSAVX=X,Y=1,IBTAG=4 D CHKX^IBAUTL I +Y<1 G UPDQ
  1. D ARPARM^IBAUTL I +Y<1 G UPDQ
  1. ;
  1. ; -- check rx exemption in case refill is exempt
  1. ; -- if exempt set amount to each rx and total to zero
  1. S IBEXMP=+$$RXEXMT^IBARXEU0(DFN,DT)
  1. I IBEXMP'=0 D S Y="1^0" G UPDQ
  1. .; changed return value 6th piece is the exempt flag
  1. .S IBJ="" F S IBJ=$O(IBSAVXU(IBJ)) Q:IBJ="" S $P(Y(IBJ),"^",6)=IBEXMP
  1. .Q
  1. ;
  1. S IBATYP=$P(^IBE(350.1,+IBATYP,0),"^",7) I '$D(^IBE(350.1,+IBATYP,0)) S Y="-1^IB008" G UPDQ ;update type action
  1. ;
  1. D BILLNO^IBAUTL G:+Y<1 UPDQ
  1. S IBTOTL=0,IBNOS="",IBSEQNO=$P(^IBE(350.1,IBATYP,0),"^",5) I 'IBSEQNO S Y="-1^IB023" G UPDQ
  1. S IBJ="" F S IBJ=$O(IBSAVXU(IBJ)) Q:IBJ="" S IBX=IBSAVXU(IBJ) S:$D(IBEFDT(+$P(IBX,"^",3))) IBEFDT=IBEFDT(+$P(IBX,"^",3)) D UCHPAR,RX^IBARX1:'$D(IBSAVY(IBJ)) S IBEFDT=0
  1. D ^IBAFIL
  1. ;
  1. S IBJ="" F S IBJ=$O(IBSAVY(IBJ)) Q:IBJ="" S Y(IBJ)=IBSAVY(IBJ),$P(Y(IBJ),"^",6)=+$G(IBEXMP) S:+Y(IBJ)<1 Y=Y(IBJ)
  1. S:+Y>0 Y="1^"_IBTOTL S X=IBSAVXU
  1. ;
  1. ; now that I have the update done lets see if there are some to be billed
  1. I $D(IBCAP)>10 D QCAN^IBARXMC(DFN,.IBCAP,.IBSAVXMC)
  1. ;S IBD=0 F S IBD=$O(IBCAP(IBD)) Q:IBD<1 D CANCEL^IBARXMC(DFN,IBD)
  1. ;
  1. UPDQ D:+Y<1 ^IBAERR
  1. K IBSAVXU
  1. END K %,%H,%I,K,X1,X2,X3,IBSERV,IBATYP,IBAFY,IBDUZ,IBNOW,IBSAVX,IBTOTL,IBX,IBT,IBCHRG,IBDESC,IBFAC,IBIL,IBN,IBNOS,IBSEQNO,IBSITE,IBTAG,IBTRAN,IBCRES,IBJ,IBLAST,IBND,IBY,IBPARNT,IBUNIT,IBJ,IBARTYP,IBI,IBSAVY,IBWHER,IBTIER
  1. Q
  1. UCHPAR ; Check that IB action and its parent exist.
  1. S IBPARNT=$P(IBX,"^",3)
  1. I '$D(^IB(+IBPARNT,0)) S IBSAVY(IBJ)="-1^IB021" G UCHPARQ
  1. S IBPARNT=$P(^IB(+IBPARNT,0),"^",9)
  1. I '$D(^IB(+IBPARNT,0)) S IBSAVY(IBJ)="-1^IB027"
  1. UCHPARQ Q
  1. ;
  1. STATUS(X) ; returns the status of a transaction in 350
  1. ; - see IBARXDOC for documentation
  1. ;
  1. N Y S Y=$G(^IB(X,0))
  1. Q +$S($P(Y,"^",5)=10:2,1:$P($G(^IBE(350.1,+$P(Y,"^",3),0)),"^",5))
  1. ;
  1. CANIBAM ; used by pso to cancel a 354.71 transaction
  1. ; - see IBARXDOC for documentation
  1. N IBZ,IBXX,IBYY,IBCAP
  1. M IBXX=X
  1. S IBXX=0 F S IBXX=$O(IBXX(IBXX)) Q:IBXX="" D
  1. . N IBY
  1. . S IBZ=$G(^IBAM(354.71,+IBXX(IBXX),0))
  1. . I $P(IBZ,"^",4) S IBYY(IBXX)="-1^Transaction has been billed" Q
  1. . I $P(IBZ,"^",5)="Y"!($P(IBZ,"^",5)="X") S IBYY(IBXX)="-1^Transaction already cancelled" Q
  1. . S IBZ=$$CANCEL^IBARXMN($P(IBZ,"^",2),+IBXX(IBXX),.IBY,$P(IBXX(IBXX),"^",2))
  1. . S IBYY(IBXX)=$S($P($G(IBY),"^")=-1:IBY,1:IBZ)
  1. K Y M Y=IBYY
  1. Q
  1. ;
  1. UPIBAM ; - will cancel current potential charge and create updated entry
  1. ; - see IBARXDOC for documentation
  1. ;
  1. N IBXX,IBYY,IBWHER,IBTAG,IBZ,IBX,IBY,IBSAVX,IBA,IBAM,IBATYP,IBCAP,IBDESC,IBDUZ,IBSERV,IBTCH
  1. M IBXX=X
  1. S IBA=$O(X("")) I IBA="" S (Y)="-1^Invalid Subscript in X" Q
  1. S IBWHER=1,Y=1,IBTAG=4,IBSAVX=X D CHKX^IBAUTL I +Y<1 S Y(IBA)=Y Q
  1. S IBZ=$G(^IBAM(354.71,+$P($G(IBXX(IBA)),"^",3),0))
  1. ;
  1. ; check out the transaction sent
  1. I 'IBZ S (Y,Y(IBA))="-1^Not a valid transaction number" Q
  1. I $P(IBZ,"^",4) S (Y,Y(IBA))="-1^Transaction has been billed" Q
  1. I $P(IBZ,"^",5)="Y"!($P(IBZ,"^",5)="X") S (Y,Y(IBA))="-1^Transaction already cancelled" Q
  1. ;
  1. ; cancel that transaction
  1. S IBX=$$CANCEL^IBARXMN($P(IBZ,"^",2),$P($G(IBXX(IBA)),"^",3),.Y,$P(IBXX(IBA),"^",4)) I +Y<1 S Y(IBA)=Y Q
  1. ;
  1. ; create the new updated transaction
  1. S IBX=IBXX(IBA) D BDESC^IBARX1 S IBATYP=$P(^IBE(350.1,+IBATYP,0),"^",7),DA=IBATYP D COST^IBAUTL S IBTCH=$P(IBX,"^",2)*X1
  1. S IBAM=$$ADD^IBARXMN($P(IBZ,"^",2),"^^"_$P(IBZ,"^",3)_"^^P^"_$P(IBXX(IBA),"^")_"^"_$P(IBXX(IBA),"^",2)_"^"_IBTCH_"^"_IBDESC_"^"_$$PARENT^IBARXMC($P(IBXX(IBA),"^",3))_"^0^"_IBTCH_"^"_(+$P($$SITE^IBARXMU,"^",3)),IBATYP)
  1. I IBAM<1 S (Y,Y(IBA))="-1^IB316" Q
  1. ;
  1. S Y(IBA)=IBAM,Y=1
  1. ;
  1. Q
  1. ;
  1. ;IB*2.0*645 - added routine NFEECCRX
  1. NFEECCRX(IBACTNM) ;Determine if the Action Type is a Non-Fee RX Action type for the co-payment indicator
  1. ;
  1. ;Input: IBACTNM Name of the Action Type from File 350.1, field 1
  1. ;Output: 0 - Fee or Community Care RX copay or non RX
  1. ; 1 - Non Fee Basis or Community Care RX Copay
  1. N IBFLG
  1. S IBFLG=1
  1. I IBACTNM'["RX" Q 0 ;Non RX Copay
  1. I IBACTNM["FEE" Q 0 ;Fee Basis NSC RX Copay
  1. I IBACTNM["CHOICE" Q 0 ;Choice RX Copay
  1. I IBACTNM["CC" Q 0 ;CC, CCN, or CC MTF RX Copays
  1. Q IBFLG ;Copay is NSC or SC RX