IBCNEDE1 ;DAOU/DAC - eIV INSURANCE BUFFER EXTRACT ;04-JUN-2002
;;2.0;INTEGRATED BILLING;**184,271,416,438,435,467,497,528,549,601,664,668**;21-MAR-94;Build 28
;;Per VA Directive 6402, this routine should not be modified.
;
;**Program Description**
; This routine loops through the insurance buffer and
; creates eIV transaction queue entries when appropriate.
; Periodically check for stop request for background task
;
;/vd-IB*2*668 - Removed the SSVI logic introduced with IB*2*528 in its entirety within VistA.
;
Q ; no direct calls allowed
;
EN ; Loop through designated cross-references for updates
; Insurance Buffer Extract
;
;/vd-IB*2*664 - Added the variable EHRSRC
N TODAYSDT,FRESHDAY,LOOPDT,IEN,OVRFRESH,FRESHDT
N DFN,PDOD,SRVICEDT,VERIFDDT,PAYERSTR,PAYERID,SYMBOL,PAYRNAME
N PIEN,PNIEN,TQIEN,TRIEN,TRSRVCDT,TQCRTDT,TRANSNO,DISYS
N ORIGINSR,ORGRPSTR,ORGRPNUM,ORGRPNAM,ORGSUBCR
N MAXCNT,CNT,ISYMBOLM,DATA1,DATA2,ORIG,SETSTR,ISYMBOL,IBCNETOT
N SIDDATA,SID,SIDACT,BSID,FDA,PASSBUF,SIDCNT,SIDARRAY
N TQDT,TQIENS,TQOK,STATIEN,PATID,MCAREFLG,INSNAME,PREL,EHRSRC,SOURCE,AMCMS
;
S SETSTR=$$SETTINGS^IBCNEDE7(1) ; Returns buffer extract settings
I 'SETSTR Q ; Quit if extract is not active
S MAXCNT=$P(SETSTR,U,4) ; Max # TQ entries that may be created
S:MAXCNT="" MAXCNT=9999999999
;
S EHRSRC=$O(^IBE(355.12,"C","ELECTRONIC HEALTH RECORD","")) ;vd/IB*2*664 - Used to identify EHR buffer entries.
S AMCMS=$O(^IBE(355.12,"C","ADV MED COST MGMT SOLUTION","")) ;IB*668/DW - AMCMS entries.
;
S FRESHDAY=$P($G(^IBE(350.9,1,51)),U,1) ; System freshness days
;
S CNT=0 ; Initialize count of TQ entries created
S IBCNETOT=0 ; Initialize count for periodic TaskMan check
;
S LOOPDT="" ; Date used to loop through the IB global
F S LOOPDT=$O(^IBA(355.33,"AEST","E",LOOPDT)) Q:LOOPDT=""!(CNT=MAXCNT) D Q:$G(ZTSTOP)
. S IEN=""
. F S IEN=$O(^IBA(355.33,"AEST","E",LOOPDT,IEN)) Q:IEN=""!(CNT=MAXCNT) D Q:$G(ZTSTOP)
.. ;
.. S SOURCE=$$GET1^DIQ(355.33,IEN_",",.03,"I") ;IB*668/DW set variable SOURCE
.. I (SOURCE=EHRSRC)!(SOURCE=AMCMS) Q ;IB*664/VD & IB*668/DW - Skip buffer entry
.. ;
.. ; Update count for periodic check
.. S IBCNETOT=IBCNETOT+1
.. ; Check for request to stop background job, periodically
.. I $D(ZTQUEUED),IBCNETOT#100=0,$$S^%ZTLOAD() S ZTSTOP=1 Q
.. ;
.. ; Get symbol, if symbol'=" " OR "!" then quit
.. S ISYMBOL=$$SYMBOL^IBCNBLL(IEN) ; Insurance buffer symbol
.. I (ISYMBOL'=" ")&(ISYMBOL'="!") Q
.. ; Don't extract ePharmacy buffer entries - IB*2*435
.. I +$P($G(^IBA(355.33,IEN,0)),U,17) Q
.. ;
.. ; Get the eIV STATUS IEN and quit for response related errors
.. S STATIEN=+$P($G(^IBA(355.33,IEN,0)),U,12)
.. I ",11,12,15,"[(","_STATIEN_",") Q ; Prevent update for response errors
.. ;
.. S OVRFRESH=$P($G(^IBA(355.33,IEN,0)),U,13) ; Freshness OvrRd flag
.. S DFN=$P($G(^IBA(355.33,IEN,60)),U,1) ; Patient DFN
.. Q:DFN=""
.. I $P($G(^DPT(DFN,0)),U,21) Q ; Exclude if test patient
.. ;
.. S PDOD=$P($G(^DPT(DFN,.35)),U,1)\1 ; Patient's date of death
.. S SRVICEDT=+$P($G(^IBA(355.33,IEN,0)),U,18)
.. S:'SRVICEDT SRVICEDT=DT ; Service Date
.. ;
.. ; IB*2.0*549 Removed following line
.. ;I PDOD,PDOD<SRVICEDT S SRVICEDT=PDOD
.. S FRESHDT=$$FMADD^XLFDT(SRVICEDT,-FRESHDAY)
.. S PAYERSTR=$$INSERROR^IBCNEUT3("B",IEN) ; Payer String
.. S PAYERID=$P(PAYERSTR,U,3),PIEN=$P(PAYERSTR,U,2) ; Payer ID
.. S SYMBOL=+PAYERSTR ; Payer Symbol
.. I '$$PYRACTV^IBCNEDE7(PIEN) Q ; Payer is not nationally active
.. ;
.. ; If payer symbol is returned set symbol in Ins. Buffer and quit
.. I SYMBOL D BUFF^IBCNEUT2(IEN,SYMBOL) Q
.. ;
.. D CLEAR^IBCNEUT4(IEN) ; remove any existing symbol
.. ;
.. ; If no payer ID or no payer IEN is returned quit
.. I (PAYERID="")!('PIEN) Q
.. ;
.. ; Update service date and freshness date based on payer's allowed
.. ; date range
.. D UPDDTS^IBCNEDE6(PIEN,.SRVICEDT,.FRESHDT)
.. ;
.. ; Update service dates for inquiries to be transmitted
.. D TQUPDSV^IBCNEUT5(DFN,PIEN,SRVICEDT)
.. ;
.. ; allow only one MEDICARE transmission per patient
.. S INSNAME=$P($G(^IBA(355.33,IEN,20)),U)
.. I INSNAME["MEDICARE",$G(MCAREFLG(DFN)) Q
.. ;
.. ; set pat. relationship to "self" if it's blank
.. D SETREL(IEN)
.. ;
.. ; make sure that service type codes are set
.. I '+$G(^IBA(355.33,IEN,80)) D SETSTC^IBCNERTQ(IEN)
.. ;
.. ; If freshness override flag is set, file to TQ and quit
.. I OVRFRESH=1 D Q
... NEW DIE,X,Y,DISYS
... S FDA(355.33,IEN_",",.13)="" D FILE^DIE("","FDA") K FDA
... S:INSNAME["MEDICARE" MCAREFLG(DFN)=1 D TQ
.. ; Check the existing TQ entries to confirm that this buffer IEN is
.. ; not included
.. S (TQDT,TQIENS)="",TQOK=1
.. F S TQDT=$O(^IBCN(365.1,"AD",DFN,PIEN,TQDT)) Q:'TQDT!'TQOK D
... F S TQIENS=$O(^IBCN(365.1,"AD",DFN,PIEN,TQDT,TQIENS)) Q:'TQIENS!'TQOK D
.... I $P($G(^IBCN(365.1,TQIENS,0)),U,5)=IEN S TQOK=0 Q
.. I TQOK S:INSNAME["MEDICARE" MCAREFLG(DFN)=1 D TQ
Q
TQ ; Determine how many entries to create in the TQ file and set entries
;
K SIDARRAY
S BSID=$P($G(^IBA(355.33,IEN,90)),U,3) ; Subscriber ID from buffer (IB*2.0*497 - vd)
S PATID=$P($G(^IBA(355.33,IEN,62)),U) ; Patient ID from buffer
S PREL=$P($G(^IBA(355.33,IEN,60)),U,14) ; Pat. relationship from buffer
S SIDDATA=$$SIDCHK^IBCNEDE5(PIEN,DFN,BSID,.SIDARRAY,FRESHDT) ;determine rules to follow
S SIDACT=$P(SIDDATA,U,1)
S SIDCNT=$P(SIDDATA,U,2) ;Pull cnt of SIDs - shd be 1
;
I SIDACT=3 D BUFF^IBCNEUT2(IEN,18) Q ; update buffer w/ bang & quit - no subscriber id
I PREL'=18 D Q
.I PATID="" D BUFF^IBCNEUT2(IEN,23) Q ; update buffer w/ bang & quit - no patient id
.D SET(IEN,OVRFRESH,1,"") ; set TQ entry
.Q
I CNT+SIDCNT>MAXCNT Q
S SID=""
F S SID=$O(SIDARRAY(SID)) Q:SID="" D:$P(SID,"_")'="" SET(IEN,OVRFRESH,1,$P(SID,"_")) ; set TQ w/ 'Pass Buffer' flag
I SIDACT=4 D SET(IEN,OVRFRESH,1,"") ; set TQ w/ 'Pass Buffer' flag w/ blank subscriber ID
Q
;
RET ; Record Retrieval - Insurance Buffer
;
S ORIGINSR=$P($G(^IBA(355.33,IEN,20)),U,1) ;Original ins. co.
S ORGRPSTR=$G(^IBA(355.33,IEN,90)) ; Original group string (IB*2.0*497 - vd)
S ORGRPNUM=$P(ORGRPSTR,U,2) ;Original group number (IB*2.0*497 - vd)
S ORGRPNAM=$P(ORGRPSTR,U,1) ;Original group name (IB*2.0*497 - vd)
S ORGSUBCR=$P(ORGRPSTR,U,3) ; Original subscriber (IB*2.0*497 - vd)
;
Q
;
SET(BUFFIEN,OVRFRESH,PASSBUF,SID1) ; Set data and check if set already
N DATA5
D RET
;
; The hard coded '1' in the 3rd piece of DATA1 sets the Transmission
; status of file 365.1 to "Ready to Transmit"
S DATA1=DFN_U_PIEN_U_1_U_$G(BUFFIEN)_U_SID1_U_FRESHDT_U_PASSBUF ; SETTQ parameter 1
S $P(DATA1,U,8)=PATID ; IB*2*416
;
;The hardcoded '1' in the 1st piece of DATA2 is the value to tell
; the file 365.1 that it is the buffer extract.
S DATA2=1_U_"V"_U_SRVICEDT_U_"" ; SETTQ parameter 2
;
S ORIG=ORIGINSR_U_ORGRPNUM_U_ORGRPNAM_U_ORGSUBCR ; SETTQ parameter 3
;
S DATA5=$$GET1^DIQ(355.33,BUFFIEN_",",.03,"I") ; IB*2*601/DM copy SOI IEN to TQ
S TQIEN=$$SETTQ^IBCNEDE7(DATA1,DATA2,ORIG,$G(OVRFRESH),DATA5) ; File TQ entry
I TQIEN'="" S CNT=CNT+1 ; If filed increment count
;
Q
;
SETREL(IEN) ; set pat. relationship to "self"
N DA,DIE,DR,X,Y
I $P($G(^IBA(355.33,IEN,60)),U,14)="" S DIE="^IBA(355.33,",DA=IEN,DR="60.14///SELF" D ^DIE
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCNEDE1 7616 printed Apr 09, 2024@21:30:50 Page 2
IBCNEDE1 ;DAOU/DAC - eIV INSURANCE BUFFER EXTRACT ;04-JUN-2002
+1 ;;2.0;INTEGRATED BILLING;**184,271,416,438,435,467,497,528,549,601,664,668**;21-MAR-94;Build 28
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;
+4 ;**Program Description**
+5 ; This routine loops through the insurance buffer and
+6 ; creates eIV transaction queue entries when appropriate.
+7 ; Periodically check for stop request for background task
+8 ;
+9 ;/vd-IB*2*668 - Removed the SSVI logic introduced with IB*2*528 in its entirety within VistA.
+10 ;
+11 ; no direct calls allowed
QUIT
+12 ;
EN ; Loop through designated cross-references for updates
+1 ; Insurance Buffer Extract
+2 ;
+3 ;/vd-IB*2*664 - Added the variable EHRSRC
+4 NEW TODAYSDT,FRESHDAY,LOOPDT,IEN,OVRFRESH,FRESHDT
+5 NEW DFN,PDOD,SRVICEDT,VERIFDDT,PAYERSTR,PAYERID,SYMBOL,PAYRNAME
+6 NEW PIEN,PNIEN,TQIEN,TRIEN,TRSRVCDT,TQCRTDT,TRANSNO,DISYS
+7 NEW ORIGINSR,ORGRPSTR,ORGRPNUM,ORGRPNAM,ORGSUBCR
+8 NEW MAXCNT,CNT,ISYMBOLM,DATA1,DATA2,ORIG,SETSTR,ISYMBOL,IBCNETOT
+9 NEW SIDDATA,SID,SIDACT,BSID,FDA,PASSBUF,SIDCNT,SIDARRAY
+10 NEW TQDT,TQIENS,TQOK,STATIEN,PATID,MCAREFLG,INSNAME,PREL,EHRSRC,SOURCE,AMCMS
+11 ;
+12 ; Returns buffer extract settings
SET SETSTR=$$SETTINGS^IBCNEDE7(1)
+13 ; Quit if extract is not active
IF 'SETSTR
QUIT
+14 ; Max # TQ entries that may be created
SET MAXCNT=$PIECE(SETSTR,U,4)
+15 if MAXCNT=""
SET MAXCNT=9999999999
+16 ;
+17 ;vd/IB*2*664 - Used to identify EHR buffer entries.
SET EHRSRC=$ORDER(^IBE(355.12,"C","ELECTRONIC HEALTH RECORD",""))
+18 ;IB*668/DW - AMCMS entries.
SET AMCMS=$ORDER(^IBE(355.12,"C","ADV MED COST MGMT SOLUTION",""))
+19 ;
+20 ; System freshness days
SET FRESHDAY=$PIECE($GET(^IBE(350.9,1,51)),U,1)
+21 ;
+22 ; Initialize count of TQ entries created
SET CNT=0
+23 ; Initialize count for periodic TaskMan check
SET IBCNETOT=0
+24 ;
+25 ; Date used to loop through the IB global
SET LOOPDT=""
+26 FOR
SET LOOPDT=$ORDER(^IBA(355.33,"AEST","E",LOOPDT))
if LOOPDT=""!(CNT=MAXCNT)
QUIT
Begin DoDot:1
+27 SET IEN=""
+28 FOR
SET IEN=$ORDER(^IBA(355.33,"AEST","E",LOOPDT,IEN))
if IEN=""!(CNT=MAXCNT)
QUIT
Begin DoDot:2
+29 ;
+30 ;IB*668/DW set variable SOURCE
SET SOURCE=$$GET1^DIQ(355.33,IEN_",",.03,"I")
+31 ;IB*664/VD & IB*668/DW - Skip buffer entry
IF (SOURCE=EHRSRC)!(SOURCE=AMCMS)
QUIT
+32 ;
+33 ; Update count for periodic check
+34 SET IBCNETOT=IBCNETOT+1
+35 ; Check for request to stop background job, periodically
+36 IF $DATA(ZTQUEUED)
IF IBCNETOT#100=0
IF $$S^%ZTLOAD()
SET ZTSTOP=1
QUIT
+37 ;
+38 ; Get symbol, if symbol'=" " OR "!" then quit
+39 ; Insurance buffer symbol
SET ISYMBOL=$$SYMBOL^IBCNBLL(IEN)
+40 IF (ISYMBOL'=" ")&(ISYMBOL'="!")
QUIT
+41 ; Don't extract ePharmacy buffer entries - IB*2*435
+42 IF +$PIECE($GET(^IBA(355.33,IEN,0)),U,17)
QUIT
+43 ;
+44 ; Get the eIV STATUS IEN and quit for response related errors
+45 SET STATIEN=+$PIECE($GET(^IBA(355.33,IEN,0)),U,12)
+46 ; Prevent update for response errors
IF ",11,12,15,"[(","_STATIEN_",")
QUIT
+47 ;
+48 ; Freshness OvrRd flag
SET OVRFRESH=$PIECE($GET(^IBA(355.33,IEN,0)),U,13)
+49 ; Patient DFN
SET DFN=$PIECE($GET(^IBA(355.33,IEN,60)),U,1)
+50 if DFN=""
QUIT
+51 ; Exclude if test patient
IF $PIECE($GET(^DPT(DFN,0)),U,21)
QUIT
+52 ;
+53 ; Patient's date of death
SET PDOD=$PIECE($GET(^DPT(DFN,.35)),U,1)\1
+54 SET SRVICEDT=+$PIECE($GET(^IBA(355.33,IEN,0)),U,18)
+55 ; Service Date
if 'SRVICEDT
SET SRVICEDT=DT
+56 ;
+57 ; IB*2.0*549 Removed following line
+58 ;I PDOD,PDOD<SRVICEDT S SRVICEDT=PDOD
+59 SET FRESHDT=$$FMADD^XLFDT(SRVICEDT,-FRESHDAY)
+60 ; Payer String
SET PAYERSTR=$$INSERROR^IBCNEUT3("B",IEN)
+61 ; Payer ID
SET PAYERID=$PIECE(PAYERSTR,U,3)
SET PIEN=$PIECE(PAYERSTR,U,2)
+62 ; Payer Symbol
SET SYMBOL=+PAYERSTR
+63 ; Payer is not nationally active
IF '$$PYRACTV^IBCNEDE7(PIEN)
QUIT
+64 ;
+65 ; If payer symbol is returned set symbol in Ins. Buffer and quit
+66 IF SYMBOL
DO BUFF^IBCNEUT2(IEN,SYMBOL)
QUIT
+67 ;
+68 ; remove any existing symbol
DO CLEAR^IBCNEUT4(IEN)
+69 ;
+70 ; If no payer ID or no payer IEN is returned quit
+71 IF (PAYERID="")!('PIEN)
QUIT
+72 ;
+73 ; Update service date and freshness date based on payer's allowed
+74 ; date range
+75 DO UPDDTS^IBCNEDE6(PIEN,.SRVICEDT,.FRESHDT)
+76 ;
+77 ; Update service dates for inquiries to be transmitted
+78 DO TQUPDSV^IBCNEUT5(DFN,PIEN,SRVICEDT)
+79 ;
+80 ; allow only one MEDICARE transmission per patient
+81 SET INSNAME=$PIECE($GET(^IBA(355.33,IEN,20)),U)
+82 IF INSNAME["MEDICARE"
IF $GET(MCAREFLG(DFN))
QUIT
+83 ;
+84 ; set pat. relationship to "self" if it's blank
+85 DO SETREL(IEN)
+86 ;
+87 ; make sure that service type codes are set
+88 IF '+$GET(^IBA(355.33,IEN,80))
DO SETSTC^IBCNERTQ(IEN)
+89 ;
+90 ; If freshness override flag is set, file to TQ and quit
+91 IF OVRFRESH=1
Begin DoDot:3
+92 NEW DIE,X,Y,DISYS
+93 SET FDA(355.33,IEN_",",.13)=""
DO FILE^DIE("","FDA")
KILL FDA
+94 if INSNAME["MEDICARE"
SET MCAREFLG(DFN)=1
DO TQ
End DoDot:3
QUIT
+95 ; Check the existing TQ entries to confirm that this buffer IEN is
+96 ; not included
+97 SET (TQDT,TQIENS)=""
SET TQOK=1
+98 FOR
SET TQDT=$ORDER(^IBCN(365.1,"AD",DFN,PIEN,TQDT))
if 'TQDT!'TQOK
QUIT
Begin DoDot:3
+99 FOR
SET TQIENS=$ORDER(^IBCN(365.1,"AD",DFN,PIEN,TQDT,TQIENS))
if 'TQIENS!'TQOK
QUIT
Begin DoDot:4
+100 IF $PIECE($GET(^IBCN(365.1,TQIENS,0)),U,5)=IEN
SET TQOK=0
QUIT
End DoDot:4
End DoDot:3
+101 IF TQOK
if INSNAME["MEDICARE"
SET MCAREFLG(DFN)=1
DO TQ
End DoDot:2
if $GET(ZTSTOP)
QUIT
End DoDot:1
if $GET(ZTSTOP)
QUIT
+102 QUIT
TQ ; Determine how many entries to create in the TQ file and set entries
+1 ;
+2 KILL SIDARRAY
+3 ; Subscriber ID from buffer (IB*2.0*497 - vd)
SET BSID=$PIECE($GET(^IBA(355.33,IEN,90)),U,3)
+4 ; Patient ID from buffer
SET PATID=$PIECE($GET(^IBA(355.33,IEN,62)),U)
+5 ; Pat. relationship from buffer
SET PREL=$PIECE($GET(^IBA(355.33,IEN,60)),U,14)
+6 ;determine rules to follow
SET SIDDATA=$$SIDCHK^IBCNEDE5(PIEN,DFN,BSID,.SIDARRAY,FRESHDT)
+7 SET SIDACT=$PIECE(SIDDATA,U,1)
+8 ;Pull cnt of SIDs - shd be 1
SET SIDCNT=$PIECE(SIDDATA,U,2)
+9 ;
+10 ; update buffer w/ bang & quit - no subscriber id
IF SIDACT=3
DO BUFF^IBCNEUT2(IEN,18)
QUIT
+11 IF PREL'=18
Begin DoDot:1
+12 ; update buffer w/ bang & quit - no patient id
IF PATID=""
DO BUFF^IBCNEUT2(IEN,23)
QUIT
+13 ; set TQ entry
DO SET(IEN,OVRFRESH,1,"")
+14 QUIT
End DoDot:1
QUIT
+15 IF CNT+SIDCNT>MAXCNT
QUIT
+16 SET SID=""
+17 ; set TQ w/ 'Pass Buffer' flag
FOR
SET SID=$ORDER(SIDARRAY(SID))
if SID=""
QUIT
if $PIECE(SID,"_")'=""
DO SET(IEN,OVRFRESH,1,$PIECE(SID,"_"))
+18 ; set TQ w/ 'Pass Buffer' flag w/ blank subscriber ID
IF SIDACT=4
DO SET(IEN,OVRFRESH,1,"")
+19 QUIT
+20 ;
RET ; Record Retrieval - Insurance Buffer
+1 ;
+2 ;Original ins. co.
SET ORIGINSR=$PIECE($GET(^IBA(355.33,IEN,20)),U,1)
+3 ; Original group string (IB*2.0*497 - vd)
SET ORGRPSTR=$GET(^IBA(355.33,IEN,90))
+4 ;Original group number (IB*2.0*497 - vd)
SET ORGRPNUM=$PIECE(ORGRPSTR,U,2)
+5 ;Original group name (IB*2.0*497 - vd)
SET ORGRPNAM=$PIECE(ORGRPSTR,U,1)
+6 ; Original subscriber (IB*2.0*497 - vd)
SET ORGSUBCR=$PIECE(ORGRPSTR,U,3)
+7 ;
+8 QUIT
+9 ;
SET(BUFFIEN,OVRFRESH,PASSBUF,SID1) ; Set data and check if set already
+1 NEW DATA5
+2 DO RET
+3 ;
+4 ; The hard coded '1' in the 3rd piece of DATA1 sets the Transmission
+5 ; status of file 365.1 to "Ready to Transmit"
+6 ; SETTQ parameter 1
SET DATA1=DFN_U_PIEN_U_1_U_$GET(BUFFIEN)_U_SID1_U_FRESHDT_U_PASSBUF
+7 ; IB*2*416
SET $PIECE(DATA1,U,8)=PATID
+8 ;
+9 ;The hardcoded '1' in the 1st piece of DATA2 is the value to tell
+10 ; the file 365.1 that it is the buffer extract.
+11 ; SETTQ parameter 2
SET DATA2=1_U_"V"_U_SRVICEDT_U_""
+12 ;
+13 ; SETTQ parameter 3
SET ORIG=ORIGINSR_U_ORGRPNUM_U_ORGRPNAM_U_ORGSUBCR
+14 ;
+15 ; IB*2*601/DM copy SOI IEN to TQ
SET DATA5=$$GET1^DIQ(355.33,BUFFIEN_",",.03,"I")
+16 ; File TQ entry
SET TQIEN=$$SETTQ^IBCNEDE7(DATA1,DATA2,ORIG,$GET(OVRFRESH),DATA5)
+17 ; If filed increment count
IF TQIEN'=""
SET CNT=CNT+1
+18 ;
+19 QUIT
+20 ;
SETREL(IEN) ; set pat. relationship to "self"
+1 NEW DA,DIE,DR,X,Y
+2 IF $PIECE($GET(^IBA(355.33,IEN,60)),U,14)=""
SET DIE="^IBA(355.33,"
SET DA=IEN
SET DR="60.14///SELF"
DO ^DIE
+3 QUIT
