IBCNBED.m

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 ---IBCNBED   1223     printed  Apr 09, 2024@21:32:39                                                                                                                                                                                                     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