IBARX ;ALB/AAS - INTEGRATED BILLING, PHARMACY COPAY INTERFACE ; 14-FEB-91
;;Version 2.0 ; INTEGRATED BILLING ;; 21-MAR-94
;;Per VHA Directive 10-93-142, 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 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
F I=0:0 S I=$O(^IBE(350.1,"ANEW",IBSERV,1,I)) Q:'I I $D(^IBE(350.1,I,40)) S DA=I X ^IBE(350.1,DA,40) S Y(DA,X)=I_"^"_X1_"^"_X2
;
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
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 incase refill is exempt
; -- if exempt set amount to each rx and total to zero
; 1= exempt, 0= non-exmept, -1=copay off (manilla)
I +$$RXEXMT^IBARXEU0(DFN,DT)'=0 D S Y="1^0" G NEWQ
.S IBJ=""
.F S IBJ=$O(IBSAVX(IBJ)) Q:IBJ="" S Y(IBJ)="^0^"
.Q
;
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
D ^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
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 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
D END
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
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 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 incase refill is exempt
; -- if exempt set amount to each rx and total to zero
I +$$RXEXMT^IBARXEU0(DFN,DT)'=0 D S Y="1^0" G UPDQ
.S IBJ=""
.F S IBJ=$O(IBSAVXU(IBJ)) Q:IBJ="" S Y(IBJ)="^0^"
.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) D UCHPAR,RX^IBARX1:'$D(IBSAVY(IBJ))
D ^IBAFIL
S IBJ="" F S IBJ=$O(IBSAVY(IBJ)) Q:IBJ="" S Y(IBJ)=IBSAVY(IBJ) S:+Y(IBJ)<1 Y=Y(IBJ)
S:+Y>0 Y="1^"_IBTOTL S X=IBSAVXU
;
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
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
IBARX ;ALB/AAS - INTEGRATED BILLING, PHARMACY COPAY INTERFACE ; 14-FEB-91
+1 ;;Version 2.0 ; INTEGRATED BILLING ;; 21-MAR-94
+2 ;;Per VHA Directive 10-93-142, 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
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 FOR I=0:0
SET I=$ORDER(^IBE(350.1,"ANEW",IBSERV,1,I))
IF 'I
QUIT
IF $DATA(^IBE(350.1,I,40))
SET DA=I
XECUTE ^IBE(350.1,DA,40)
SET Y(DA,X)=I_"^"_X1_"^"_X2
+11 ;
XTYPEQ KILL X1,X2,IBSERV,VAEL,VA,VAERR,IBDOM,VAIN,IBSAVX,IBTAG,IBWHER
+1 QUIT
+2 ;
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
+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 incase refill is exempt
+8 ; -- if exempt set amount to each rx and total to zero
+9 ; 1= exempt, 0= non-exmept, -1=copay off (manilla)
+10 IF +$$RXEXMT^IBARXEU0(DFN,DT)'=0
Begin DoDot:1
+11 SET IBJ=""
+12 FOR
SET IBJ=$ORDER(IBSAVX(IBJ))
IF IBJ=""
QUIT
SET Y(IBJ)="^0^"
+13 QUIT
End DoDot:1
SET Y="1^0"
GOTO NEWQ
+14 ;
+15 SET IBTOTL=0
+16 DO BILLNO^IBAUTL
IF +Y<1
GOTO NEWQ
+17 ;
+18 SET IBTOTL=0
SET IBJ=""
SET IBSEQNO=$PIECE(^IBE(350.1,IBATYP,0),"^",5)
IF 'IBSEQNO
SET Y="-1^IB023"
GOTO NEWQ
+19 FOR
SET IBJ=$ORDER(IBSAVX(IBJ))
IF IBJ=""
QUIT
SET IBX=IBSAVX(IBJ)
DO RX^IBARX1
+20 IF +Y<1
GOTO NEWQ
+21 DO ^IBAFIL
+22 SET IBJ=""
FOR
SET IBJ=$ORDER(IBSAVY(IBJ))
IF IBJ=""
QUIT
SET Y(IBJ)=IBSAVY(IBJ)
+23 IF +Y>0
SET Y="1^"_IBTOTL
SET X=IBSAVX
+24 ;
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
+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
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 DO END
+3 QUIT
+4 ;
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
+1 SET IBWHER=1
SET IBSAVX=X
SET Y=1
SET IBTAG=4
DO CHKX^IBAUTL
IF +Y<1
GOTO UPDQ
+2 SET IBSAVXU=IBSAVX
+3 IF $DATA(X)<11
SET Y="-1^IB010"
GOTO UPDQ
+4 SET J=""
FOR
SET J=$ORDER(X(J))
IF J=""
QUIT
SET IBSAVXU(J)=X(J)
SET X(J)=$PIECE(X(J),"^",3,4)
+5 ;
+6 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 incase refill is exempt
+6 ; -- if exempt set amount to each rx and total to zero
+7 IF +$$RXEXMT^IBARXEU0(DFN,DT)'=0
Begin DoDot:1
+8 SET IBJ=""
+9 FOR
SET IBJ=$ORDER(IBSAVXU(IBJ))
IF IBJ=""
QUIT
SET Y(IBJ)="^0^"
+10 QUIT
End DoDot:1
SET Y="1^0"
GOTO UPDQ
+11 ;
+12 ;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
+13 ;
+14 DO BILLNO^IBAUTL
IF +Y<1
GOTO UPDQ
+15 SET IBTOTL=0
SET IBNOS=""
SET IBSEQNO=$PIECE(^IBE(350.1,IBATYP,0),"^",5)
IF 'IBSEQNO
SET Y="-1^IB023"
GOTO UPDQ
+16 SET IBJ=""
FOR
SET IBJ=$ORDER(IBSAVXU(IBJ))
IF IBJ=""
QUIT
SET IBX=IBSAVXU(IBJ)
DO UCHPAR
IF '$DATA(IBSAVY(IBJ))
DO RX^IBARX1
+17 DO ^IBAFIL
+18 SET IBJ=""
FOR
SET IBJ=$ORDER(IBSAVY(IBJ))
IF IBJ=""
QUIT
SET Y(IBJ)=IBSAVY(IBJ)
IF +Y(IBJ)<1
SET Y=Y(IBJ)
+19 IF +Y>0
SET Y="1^"_IBTOTL
SET X=IBSAVXU
+20 ;
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
+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
