IBXEX1.m

IBXEX1 ; ;11/29/04

 S X=DG(DQ),DIC=DIE

 S ^IBA(354.1,"AA",$E(X,1,30),DA)=""

 S X=DG(DQ),DIC=DIE

 N IBX S IBX=^IBA(354.1,DA,0) I +X,$P(IBX,U,2),$P(IBX,U,3),$P(IBX,U,4)'="" S ^IBA(354.1,"AIVDT",+$P(IBX,U,3),+$P(IBX,U,2),-($P(IBX,U)),DA)=""

 S X=DG(DQ),DIC=DIE

 I X,+$P(^IBA(354.1,DA,0),U,2),+$P(^(0),U,3),+^(0) S ^IBA(354.1,"ACY",+$P(^(0),U,3),+$P(^(0),U,2),+$E($P(^(0),U),1,3),DA)=""

IBXEX1    ; ;11/29/04

 +1        SET X=DG(DQ)

           SET DIC=DIE

 +2        SET ^IBA(354.1,"AA",$EXTRACT(X,1,30),DA)=""

 +3        SET X=DG(DQ)

           SET DIC=DIE

 +4        NEW IBX

           SET IBX=^IBA(354.1,DA,0)

           IF +X

               IF $PIECE(IBX,U,2)

                   IF $PIECE(IBX,U,3)

                       IF $PIECE(IBX,U,4)'=""

                           SET ^IBA(354.1,"AIVDT",+$PIECE(IBX,U,3),+$PIECE(IBX,U,2),-($PIECE(IBX,U)),DA)=""

 +5        SET X=DG(DQ)

           SET DIC=DIE

 +6        IF X

               IF +$PIECE(^IBA(354.1,DA,0),U,2)

                   IF +$PIECE(^(0),U,3)

                       IF +^(0)

                           SET ^IBA(354.1,"ACY",+$PIECE(^(0),U,3),+$PIECE(^(0),U,2),+$EXTRACT($PIECE(^(0),U),1,3),DA)=""