- 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 Jan 18, 2025@03:08:08 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