- 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 Jan 18, 2025@03:15:08 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