IBCNBED ;ALB/ARH-Ins Buffer: delete existing entries in buffer ;1 Jun 97
;;2.0;INTEGRATED BILLING;**82**;21-MAR-94
;;Per VHA Directive 10-93-142, this routine should not be modified.
;
DELDATA(IBBUFDA) ; delete all insurance/group/policy data from buffer file entry, leaving stub entry
; deletes all data with field numbers 1 or greater and blank nodes
;
Q:'$G(^IBA(355.33,+$G(IBBUFDA),0))
N DR,DA,DIE,DIC,X,Y,IBFLDS,IBIFN,IBFLD,IBCNT,IBI,IBX S IBIFN=IBBUFDA_",",DR="",IBCNT=1
;
D GETS^DIQ(355.33,IBIFN,"1:999","IN","IBFLDS") ; returns all non-blank fields
;
S IBFLD=0 F S IBFLD=$O(IBFLDS(355.33,IBIFN,IBFLD)) Q:'IBFLD D ; set up DR string
. I $L(DR)>200 S DR(1,355.33,IBCNT)=DR,DR="",IBCNT=IBCNT+1
. S DR=DR_IBFLD_"///@;"
;
I DR'="" D ; delete data then nodes
. S DIE="^IBA(355.33,",DA=IBBUFDA D ^DIE K DA,DIC,DIE,DR
. ;
. ; if Status is Entered, change it to Rejected, there should be no entry with a status of Entered without data
. I $P(^IBA(355.33,IBBUFDA,0),U,4)="E" D STATUS^IBCNBEE(IBBUFDA,"R")
;
; kill blank nodes since DIE doesn't
S IBI=0 F S IBI=$O(^IBA(355.33,IBBUFDA,IBI)) Q:'IBI S IBX=$G(^IBA(355.33,IBBUFDA,IBI)) I IBX?."^" K ^IBA(355.33,IBBUFDA,IBI)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCNBED 1223 printed Dec 13, 2024@02:13:55 Page 2
IBCNBED ;ALB/ARH-Ins Buffer: delete existing entries in buffer ;1 Jun 97
+1 ;;2.0;INTEGRATED BILLING;**82**;21-MAR-94
+2 ;;Per VHA Directive 10-93-142, this routine should not be modified.
+3 ;
DELDATA(IBBUFDA) ; delete all insurance/group/policy data from buffer file entry, leaving stub entry
+1 ; deletes all data with field numbers 1 or greater and blank nodes
+2 ;
+3 if '$GET(^IBA(355.33,+$GET(IBBUFDA),0))
QUIT
+4 NEW DR,DA,DIE,DIC,X,Y,IBFLDS,IBIFN,IBFLD,IBCNT,IBI,IBX
SET IBIFN=IBBUFDA_","
SET DR=""
SET IBCNT=1
+5 ;
+6 ; returns all non-blank fields
DO GETS^DIQ(355.33,IBIFN,"1:999","IN","IBFLDS")
+7 ;
+8 ; set up DR string
SET IBFLD=0
FOR
SET IBFLD=$ORDER(IBFLDS(355.33,IBIFN,IBFLD))
if 'IBFLD
QUIT
Begin DoDot:1
+9 IF $LENGTH(DR)>200
SET DR(1,355.33,IBCNT)=DR
SET DR=""
SET IBCNT=IBCNT+1
+10 SET DR=DR_IBFLD_"///@;"
End DoDot:1
+11 ;
+12 ; delete data then nodes
IF DR'=""
Begin DoDot:1
+13 SET DIE="^IBA(355.33,"
SET DA=IBBUFDA
DO ^DIE
KILL DA,DIC,DIE,DR
+14 ;
+15 ; if Status is Entered, change it to Rejected, there should be no entry with a status of Entered without data
+16 IF $PIECE(^IBA(355.33,IBBUFDA,0),U,4)="E"
DO STATUS^IBCNBEE(IBBUFDA,"R")
End DoDot:1
+17 ;
+18 ; kill blank nodes since DIE doesn't
+19 SET IBI=0
FOR
SET IBI=$ORDER(^IBA(355.33,IBBUFDA,IBI))
if 'IBI
QUIT
SET IBX=$GET(^IBA(355.33,IBBUFDA,IBI))
IF IBX?."^"
KILL ^IBA(355.33,IBBUFDA,IBI)
+20 QUIT
