IBARX.m

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