Routine: IBPU2

IBPU2	;ALB/BGA - IB PURGE FILE CLEAN UP ; 17-FEB-94

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

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

	; This routine requires IBN from routine IBPP

	; and deletes entries in FILE #399

	; The following procedures remove references which

	; point to the IBN about to be deleted. This routine is

	; invoked by IBPU.

	Q:'$G(IBN)

	D CLBCOM ;     deletes Rec from file 362.1

	D CLPSTE ;     deletes Rec from file 362.5

	D CLCTBI ;     deletes Rec from file 356.399

	D CLCTRK ;     deletes ptr from file 356  field .11

	D IBPBIL ;     sets the ptr in fld .17 to its self

	D IBCYTO ;     checks the ptr in fld .15

CLBCOM	; uses "D" xref to find all recs to be deleted

	N IBA,DIK,DA

	S IBA="" F  S IBA=$O(^IBA(362.1,"D",IBN,IBA)) Q:'IBA  S DIK="^IBA(362.1,",DA=IBA D ^DIK

CLPSTE	; uses "AIFN_IBN" to find all recs pointing to the rec to be deleted

	N IBA,IBB,REF,DIK,DA

	S REF="AIFN"_IBN

	F IBI=362.5,362.3,362.4 S (IBA,IBB)="" F  S IBA=$O(^IBA(IBI,REF,IBA)) Q:'IBA  F  S IBB=$O(^IBA(IBI,REF,IBA,IBB)) Q:'IBB  S DIK="^IBA("_IBI_",",DA=IBB D ^DIK

CLCTBI	; uses "C" xref to find all recs pointing to 399 then deletes

	N IBA,IBB,DIK,DA

	S IBA="" F  S IBA=$O(^IBT(356.399,"C",IBN,IBA)) Q:'IBA  S DIK="^IBT(356.399,",DA=IBA D ^DIK

CLCTRK	; uses "E" xref to find all recs ptr to 399 then sets them to null

	N IBA,DIE,DA,DR

	S IBA="" F  S IBA=$O(^IBT(356,"E",IBN,IBA)) Q:'IBA  S DIE="^IBT(356,",DA=IBA,DR=".11///@" D ^DIE

IBPBIL	; uses "AC" xref to find all recs ptr to 399 then sets to the bill #

	N IBA,DIE,DA,DR

	S IBA="" F  S IBA=$O(^DGCR(399,"AC",IBN,IBA)) Q:'IBA  I IBN'=IBA S DIE="^DGCR(399,",DA=IBA,DR=".17///"_IBA D ^DIE

IBCYTO	; uses "C" xref to find all recs ptr to 399 then sets the recs to null

	N IBA,IBB,DFN,DIE,DA,DR

	S (IBA,IBB)="",DFN=+$P($G(^DGCR(399,IBN,0)),U,2)

	F  S IBA=$O(^DGCR(399,"C",DFN,IBA)) Q:'IBA  I +$P($G(^DGCR(399,IBA,0)),U,15)=IBN S DIE="^DGCR(399,",DA=IBA,DR=".15///@"

IBPU2     ;ALB/BGA - IB PURGE FILE CLEAN UP ; 17-FEB-94

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

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

 +3       ;

 +4       ; This routine requires IBN from routine IBPP

 +5       ; and deletes entries in FILE #399

 +6       ;

 +7       ; The following procedures remove references which

 +8       ; point to the IBN about to be deleted. This routine is

 +9       ; invoked by IBPU.

 +10      ;

 +11       IF '$GET(IBN)

               QUIT

 +12      ;     deletes Rec from file 362.1

           DO CLBCOM

 +13      ;     deletes Rec from file 362.5

           DO CLPSTE

 +14      ;     deletes Rec from file 356.399

           DO CLCTBI

 +15      ;     deletes ptr from file 356  field .11

           DO CLCTRK

 +16      ;     sets the ptr in fld .17 to its self

           DO IBPBIL

 +17      ;     checks the ptr in fld .15

           DO IBCYTO

 +18       QUIT

 +19      ;

CLBCOM    ; uses "D" xref to find all recs to be deleted

 +1        NEW IBA,DIK,DA

 +2        SET IBA=""

FOR

               SET IBA=$ORDER(^IBA(362.1,"D",IBN,IBA))

               IF 'IBA

                   QUIT

               SET DIK="^IBA(362.1,"

               SET DA=IBA

               DO ^DIK

 +3        QUIT

 +4       ;

CLPSTE    ; uses "AIFN_IBN" to find all recs pointing to the rec to be deleted

 +1        NEW IBA,IBB,REF,DIK,DA

 +2        SET REF="AIFN"_IBN

 +3        FOR IBI=362.5,362.3,362.4

               SET (IBA,IBB)=""

FOR

                   SET IBA=$ORDER(^IBA(IBI,REF,IBA))

                   IF 'IBA

                       QUIT

FOR

                       SET IBB=$ORDER(^IBA(IBI,REF,IBA,IBB))

                       IF 'IBB

                           QUIT

                       SET DIK="^IBA("_IBI_","

                       SET DA=IBB

                       DO ^DIK

 +4        QUIT

CLCTBI    ; uses "C" xref to find all recs pointing to 399 then deletes

 +1        NEW IBA,IBB,DIK,DA

 +2        SET IBA=""

FOR

               SET IBA=$ORDER(^IBT(356.399,"C",IBN,IBA))

               IF 'IBA

                   QUIT

               SET DIK="^IBT(356.399,"

               SET DA=IBA

               DO ^DIK

 +3        QUIT

CLCTRK    ; uses "E" xref to find all recs ptr to 399 then sets them to null

 +1        NEW IBA,DIE,DA,DR

 +2        SET IBA=""

FOR

               SET IBA=$ORDER(^IBT(356,"E",IBN,IBA))

               IF 'IBA

                   QUIT

               SET DIE="^IBT(356,"

               SET DA=IBA

               SET DR=".11///@"

               DO ^DIE

 +3        QUIT

IBPBIL    ; uses "AC" xref to find all recs ptr to 399 then sets to the bill #

 +1        NEW IBA,DIE,DA,DR

 +2        SET IBA=""

FOR

               SET IBA=$ORDER(^DGCR(399,"AC",IBN,IBA))

               IF 'IBA

                   QUIT

               IF IBN'=IBA

                   SET DIE="^DGCR(399,"

                   SET DA=IBA

                   SET DR=".17///"_IBA

                   DO ^DIE

 +3        QUIT

IBCYTO    ; uses "C" xref to find all recs ptr to 399 then sets the recs to null

 +1        NEW IBA,IBB,DFN,DIE,DA,DR

 +2        SET (IBA,IBB)=""

           SET DFN=+$PIECE($GET(^DGCR(399,IBN,0)),U,2)

 +3        FOR

               SET IBA=$ORDER(^DGCR(399,"C",DFN,IBA))

               IF 'IBA

                   QUIT

               IF +$PIECE($GET(^DGCR(399,IBA,0)),U,15)=IBN

                   SET DIE="^DGCR(399,"

                   SET DA=IBA

                   SET DR=".15///@"

 +4        QUIT

IBPU2.m