IBAUTL7.m

IBAUTL7	;AAS/ALB - RX EXEMPTION UTILITY ROUTINE (CONT.) ; 2-NOV-92

	;;Version 2.0 ; INTEGRATED BILLING ;; 21-MAR-94

	;;Per VHA Directive 10-93-142, this routine should not be modified.

	;

CURREX(IBSTAT,IBDT)	;update current status if current year

	;  input :    dfn  =  patient file pointer

	;            ibdt  =  internal form of effective date

	;          ibstat  =  status = 1 if exempt, 0 if not exempt

	;

	N X,Y,DIC,DIE,DR,DA

	I $S('$D(DFN):1,'$D(IBSTAT):1,IBSTAT=0:0,IBSTAT=1:0,1:1) G CURREXQ

	;

	; -- make sure ibdt > old current date

	S X=+$P($G(^IBA(354,DFN,0)),"^",3)

	I '$G(IBFORCE),$G(IBOLDAUT)'?7N,X>IBDT G CURREXQ ;only if most recent (I took this out for awhile but don't know why, its needed to keep from updating old over new)

	;

	; -- not greater than today

	;I IBDT>DT G CURREXQ

	;

	S DIE="^IBA(354,",DA=DFN,DR="[IB CURRENT STATUS]" D ^DIE ; set status in billing patient file

	I $D(Y) S IBEXERR=6,IBWHER=14

	;DR=".04////"_IBSTAT_";.03////"_IBDT_";.05////"_IBEXREA

	;

CURREXQ	Q

	;

INACT(IBDT)	; -- must inactivate active exemptions before creating new exemption

	;    should only be called from addex so event driver logic works

	;

	N IBX,X,Y,DA,DR,DIE,DIC

	S IBX=0 F  S IBX=$O(^IBA(354.1,"AIVDT",1,DFN,-IBDT,IBX)) Q:'IBX  D

	.S DA=IBX

	.I $P($G(^IBA(354.1,DA,0)),"^",10)'=1 Q

	.I '$D(ZTQUEUED),$D(IBTALK) W:IBTALK<2 !,"Deleting Active flag from current entry" S IBTALK=IBTALK+1

	.S DA=IBX,DIE="^IBA(354.1,",DR="[IB INACTIVATE EXEMPTION]" D ^DIE K DIC,DIE,DA,DR

	.I $D(Y) S IBEXERR=7,IBWHER=15

	.;S IBACTION="CHG"

	.Q

INACTQ	Q

	;

DUPL()	; -- see if entry is a duplicate

	N X,Y

	S X=0

	S Y=$$LST^IBARXEU0(DFN,IBDT)

	I IBDT=+Y,+IBEXREA=+$P(Y,"^",5),IBTYPE=$P(Y,"^",3) S X=1

	Q X

	;

	;

ALERT()	; -- use alerts or bulletins

	;    returns 1 = use alerts

	;            0 = use bulletins

	;

	Q $P($G(^IBE(350.9,1,0)),"^",14)

IBAUTL7   ;AAS/ALB - RX EXEMPTION UTILITY ROUTINE (CONT.) ; 2-NOV-92

 +1       ;;Version 2.0 ; INTEGRATED BILLING ;; 21-MAR-94

 +2       ;;Per VHA Directive 10-93-142, this routine should not be modified.

 +3       ;

CURREX(IBSTAT,IBDT) ;update current status if current year

 +1       ;  input :    dfn  =  patient file pointer

 +2       ;            ibdt  =  internal form of effective date

 +3       ;          ibstat  =  status = 1 if exempt, 0 if not exempt

 +4       ;

 +5        NEW X,Y,DIC,DIE,DR,DA

 +6        IF $SELECT('$DATA(DFN):1,'$DATA(IBSTAT):1,IBSTAT=0:0,IBSTAT=1:0,1:1)

               GOTO CURREXQ

 +7       ;

 +8       ; -- make sure ibdt > old current date

 +9        SET X=+$PIECE($GET(^IBA(354,DFN,0)),"^",3)

 +10      ;only if most recent (I took this out for awhile but don't know why, its needed to keep from updating old over new)

           IF '$GET(IBFORCE)

               IF $GET(IBOLDAUT)'?7N

                   IF X>IBDT

                       GOTO CURREXQ

 +11      ;

 +12      ; -- not greater than today

 +13      ;I IBDT>DT G CURREXQ

 +14      ;

 +15      ; set status in billing patient file

           SET DIE="^IBA(354,"

           SET DA=DFN

           SET DR="[IB CURRENT STATUS]"

           DO ^DIE

 +16       IF $DATA(Y)

               SET IBEXERR=6

               SET IBWHER=14

 +17      ;DR=".04////"_IBSTAT_";.03////"_IBDT_";.05////"_IBEXREA

 +18      ;

CURREXQ    QUIT 

 +1       ;

INACT(IBDT) ; -- must inactivate active exemptions before creating new exemption

 +1       ;    should only be called from addex so event driver logic works

 +2       ;

 +3        NEW IBX,X,Y,DA,DR,DIE,DIC

 +4        SET IBX=0

           FOR 

               SET IBX=$ORDER(^IBA(354.1,"AIVDT",1,DFN,-IBDT,IBX))

               IF 'IBX

                   QUIT 

               Begin DoDot:1

 +5                SET DA=IBX

 +6                IF $PIECE($GET(^IBA(354.1,DA,0)),"^",10)'=1

                       QUIT 

 +7                IF '$DATA(ZTQUEUED)

                       IF $DATA(IBTALK)

                           IF IBTALK<2

                               WRITE !,"Deleting Active flag from current entry"

                           SET IBTALK=IBTALK+1

 +8                SET DA=IBX

                   SET DIE="^IBA(354.1,"

                   SET DR="[IB INACTIVATE EXEMPTION]"

                   DO ^DIE

                   KILL DIC,DIE,DA,DR

 +9                IF $DATA(Y)

                       SET IBEXERR=7

                       SET IBWHER=15

 +10      ;S IBACTION="CHG"

 +11               QUIT 

               End DoDot:1

INACTQ     QUIT 

 +1       ;

DUPL()    ; -- see if entry is a duplicate

 +1        NEW X,Y

 +2        SET X=0

 +3        SET Y=$$LST^IBARXEU0(DFN,IBDT)

 +4        IF IBDT=+Y

               IF +IBEXREA=+$PIECE(Y,"^",5)

                   IF IBTYPE=$PIECE(Y,"^",3)

                       SET X=1

 +5        QUIT X

 +6       ;

 +7       ;

ALERT()   ; -- use alerts or bulletins

 +1       ;    returns 1 = use alerts

 +2       ;            0 = use bulletins

 +3       ;

 +4        QUIT $PIECE($GET(^IBE(350.9,1,0)),"^",14)