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 ---[H[J[2J[HIBPU2 3367 printed Dec 13, 2024@02:26:37 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
