IBPU2.m

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

 ;;Version 2.0 ; INTEGRATED BILLING ;**48**; 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 CTARNB ;     adds a Reason Not Billable (.19) to 356:  PURGED

 D CLBCOM ;     deletes Rec from file 362.1

 D CLPSTE ;     deletes Rec from file 362.3,362.4,362.5

 D CLCTRK ;     deletes ptr from file 356  field .11

 D CLCTBI ;     deletes Rec from file 356.399

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

 D IBCYTO ;     checks the ptr in fld .15

 Q

 ;

CTARNB ; add a RNB (356,.19) for every episode found on the bill, if none exists (non-cancelled bills)

 N ARRAY,IBA,IBX,DIE,DIC,DA,DR,IBRNB K ARRAY S IBRNB=$O(^IBE(356.8,"B","BILL PURGED",0)) Q:'IBRNB

 D IFNTRN^IBCU83(IBN,.ARRAY) S IBA=0 F  S IBA=$O(ARRAY(IBA)) Q:'IBA  I +ARRAY(IBA)'=5 S ^TMP($J,"IBPPTRN",IBA)=""

 I $P($G(^DGCR(399,+IBN,0)),U,13)'=7 S IBA=0 F  S IBA=$O(ARRAY(IBA)) Q:'IBA  S IBX=$G(^IBT(356,+IBA,0)) D

 . I +IBX,'$P(IBX,U,19),+ARRAY(IBA)'=5 S DIE="^IBT(356,",DA=IBA,DR=".19////"_IBRNB D ^DIE

 Q

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

 Q

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

 Q

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  D

 . S IBB=$P($G(^IBT(356.399,IBA,0)),U,1) I +IBB S ^TMP($J,"IBPPTRN",+IBB)=""

 . S DIK="^IBT(356.399,",DA=IBA D ^DIK

 Q

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 ^TMP($J,"IBPPTRN",+IBA)="",DIE="^IBT(356,",DA=IBA,DR=".11///@" D ^DIE

 Q

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

 Q

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///@"

 Q

 ;

 ;

PTCH48 ; CODE FOR PATCH IB*2*48 TO ADD NEW REASON NOT BILLABLE

 N IBI,DINUM,DIC,Y

 I $D(^IBE(356.8,"B","BILL PURGED")) W !!,"*** REASON NOT BILLABLE of 'BILL PURGED' already exists in FILE #356.8, new entry NOT added.",!! Q

 W !!,">>> Adding new REASON NOT BILLABLE of 'BILL PURGED' to FILE #356.8"

 F IBI=19:1:999 I '$D(^IBE(356.8,IBI,0)) D  Q

 . S DINUM=IBI I '$D(^IBE(356.8,DINUM,0)) K DD,DO S DIC="^IBE(356.8,",DIC(0)="L",X="BILL PURGED" D FILE^DICN

 I $G(Y)<1 W !!,"**** Unable to add new entry to FILE #356.8, contact Field Support ****",!!

 I $G(Y)>0 W !,"Done.",!!

 K DIC,DINUM,Y,DD,DO

 Q

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---IBPU2   3367     printed  Mar 13, 2025@21:31:38                                                                                                                                                                                                       Page 2

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

 +1       ;;Version 2.0 ; INTEGRATED BILLING ;**48**; 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      ;     adds a Reason Not Billable (.19) to 356:  PURGED

           DO CTARNB

 +13      ;     deletes Rec from file 362.1

           DO CLBCOM

 +14      ;     deletes Rec from file 362.3,362.4,362.5

           DO CLPSTE

 +15      ;     deletes ptr from file 356  field .11

           DO CLCTRK

 +16      ;     deletes Rec from file 356.399

           DO CLCTBI

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

           DO IBPBIL

 +18      ;     checks the ptr in fld .15

           DO IBCYTO

 +19       QUIT 

 +20      ;

CTARNB    ; add a RNB (356,.19) for every episode found on the bill, if none exists (non-cancelled bills)

 +1        NEW ARRAY,IBA,IBX,DIE,DIC,DA,DR,IBRNB

           KILL ARRAY

           SET IBRNB=$ORDER(^IBE(356.8,"B","BILL PURGED",0))

           if 'IBRNB

               QUIT 

 +2        DO IFNTRN^IBCU83(IBN,.ARRAY)

           SET IBA=0

           FOR 

               SET IBA=$ORDER(ARRAY(IBA))

               if 'IBA

                   QUIT 

               IF +ARRAY(IBA)'=5

                   SET ^TMP($JOB,"IBPPTRN",IBA)=""

 +3        IF $PIECE($GET(^DGCR(399,+IBN,0)),U,13)'=7

               SET IBA=0

               FOR 

                   SET IBA=$ORDER(ARRAY(IBA))

                   if 'IBA

                       QUIT 

                   SET IBX=$GET(^IBT(356,+IBA,0))

                   Begin DoDot:1

 +4                    IF +IBX

                           IF '$PIECE(IBX,U,19)

                               IF +ARRAY(IBA)'=5

                                   SET DIE="^IBT(356,"

                                   SET DA=IBA

                                   SET DR=".19////"_IBRNB

                                   DO ^DIE

                   End DoDot:1

 +5        QUIT 

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 

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 

               Begin DoDot:1

 +3                SET IBB=$PIECE($GET(^IBT(356.399,IBA,0)),U,1)

                   IF +IBB

                       SET ^TMP($JOB,"IBPPTRN",+IBB)=""

 +4                SET DIK="^IBT(356.399,"

                   SET DA=IBA

                   DO ^DIK

               End DoDot:1

 +5        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 ^TMP($JOB,"IBPPTRN",+IBA)=""

               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 

 +5       ;

 +6       ;

PTCH48    ; CODE FOR PATCH IB*2*48 TO ADD NEW REASON NOT BILLABLE

 +1        NEW IBI,DINUM,DIC,Y

 +2        IF $DATA(^IBE(356.8,"B","BILL PURGED"))

               WRITE !!,"*** REASON NOT BILLABLE of 'BILL PURGED' already exists in FILE #356.8, new entry NOT added.",!!

               QUIT 

 +3        WRITE !!,">>> Adding new REASON NOT BILLABLE of 'BILL PURGED' to FILE #356.8"

 +4        FOR IBI=19:1:999

               IF '$DATA(^IBE(356.8,IBI,0))

                   Begin DoDot:1

 +5                    SET DINUM=IBI

                       IF '$DATA(^IBE(356.8,DINUM,0))

                           KILL DD,DO

                           SET DIC="^IBE(356.8,"

                           SET DIC(0)="L"

                           SET X="BILL PURGED"

                           DO FILE^DICN

                   End DoDot:1

                   QUIT 

 +6        IF $GET(Y)<1

               WRITE !!,"**** Unable to add new entry to FILE #356.8, contact Field Support ****",!!

 +7        IF $GET(Y)>0

               WRITE !,"Done.",!!

 +8        KILL DIC,DINUM,Y,DD,DO

 +9        QUIT