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