IBBAACCT ;OAK/ELZ - PFSS ACCOUNT API ;15-MAR-2005
;;2.0;INTEGRATED BILLING;**286**;21-MAR-94
;;Per VHA Directive 10-93-142, this routine should not be modified.
;
GET(IBBDFN,IBBARFN,IBBEVENT,IBBAPLR,IBBPV1,IBBPV2,IBBPR1,IBBDG1,IBBZCL,IBBDIV,IBBRAIEN,IBBSURG) ;
;
N IBB,IBBIEN,IBBIENS,IBBERR,IBBVERR,IBBSUBTY,IBBVDEF,FDA,OUT,J,J1,X,Y,X1,X2,X3
I '$G(IBBDFN)!($G(IBBEVENT)="") Q 0
I $D(IBBPV1)<10 Q 0
;
;update account record
S OUT=0
I IBBARFN'="" D
.S IBBIEN=IBBARFN
.I IBBDFN'=$P($G(^IBBAA(375,IBBIEN,0)),U,3) S OUT=1 Q
.;visit data
.I $D(IBBPV1)>1 D
..I $G(IBBPV1(44))="" S IBBPV1(44)=$G(IBBPV2(8))
..I $P($G(^IBBAA(375,IBBIEN,"PV1")),U,44),$G(IBBPV1(44))'=$P($G(^IBBAA(375,IBBIEN,"PV1")),U,44),$P(^IBBAA(375,IBBIEN,0),U,2) D KAC144^IBBAADD(IBBIEN)
..S J=0 F S J=$O(IBBPV1(J)) Q:'J S $P(^IBBAA(375,IBBIEN,"PV1"),U,J)=IBBPV1(J)
..I $G(IBBPV1(50)) S $P(^IBBAA(375,IBBIEN,"PV1"),U,50)=IBBPV1(50)_";;;;OPP"
.I $D(IBBPV2)>1 D
..S J=0 F S J=$O(IBBPV2(J)) Q:'J S $P(^IBBAA(375,IBBIEN,"PV2"),U,J)=IBBPV2(J)
.;procedure
.I $D(IBBPR1)>1 D
..S J=0,X="" F S J=$O(IBBPR1(J)) Q:'J I J'=4 S $P(X,U,J)=IBBPR1(J)
..S ^IBBAA(375,IBBIEN,"PR1")=X
..I $G(IBBPR1(4))'="" S ^IBBAA(375,IBBIEN,11)=IBBPR1(4)
.;diagnosis
.;if any dx sent, remove existing dx
.I $D(IBBDG1)>1,$G(IBBDG1(1,3))=+$G(IBBDG1(1,3)) K ^IBBAA(375,IBBIEN,"DG1") D DX^IBBAACCT(.IBBDG1,IBBIEN)
.I $G(IBBDG1(1,4)) S ^IBBAA(375,IBBIEN,12)=IBBDG1(1,4)
.;classification
.;if any classification sent, remove existing classification
.I $D(IBBZCL)>1 D
..K ^IBBAA(375,IBBIEN,"ZCL")
..S (J,J1)=0 F S J=$O(IBBZCL(J)) Q:'J S J1=J1+1,X=J1_U_IBBZCL(J,2)_U_IBBZCL(J,3),^IBBAA(375,IBBIEN,"ZCL",J1,0)=X
..S ^IBBAA(375,IBBIEN,"ZCL",0)="^375.05A^"_J1_U_J1
.;miscellaneous
.I $G(IBBDIV) S ^IBBAA(375,IBBIEN,13)=IBBDIV
.I $D(IBBSURG)>1 S ^IBBAA(375,IBBIEN,14)=$G(IBBSURG(1))_U_$G(IBBSURG(2))
.I $G(IBBRAIEN) S ^IBBAA(375,IBBIEN,15)=$G(IBBRAIEN)
.I $G(IBBSURG(1)) S $P(^IBBAA(375,IBBIEN,"PV1"),U,50)=IBBSURG(1)_";;;;SUR"
I OUT Q 0
;
;request account reference number
I IBBARFN="" D
.I $G(IBBAPLR)'="" D
..S IBBAPLR=$E($TR(IBBAPLR,U,";"),1,25)
..I IBBAPLR'[";" S IBBAPLR=";"_IBBAPLR
.L +^IBBAA(375,0):5
.Q:'$T
.S IBBIEN=$P(^IBBAA(375,0),U,3)+1,$P(^IBBAA(375,0),U,3)=IBBIEN
.L -^IBBAA(375,0)
.S ^IBBAA(375,IBBIEN,0)=IBBIEN
.S IBBIENS=IBBIEN_","
.S IBBERR="IBB(""DIERR"")"
.S FDA(375,IBBIENS,.02)="G"
.S FDA(375,IBBIENS,.03)=IBBDFN
.S FDA(375,IBBIENS,.04)=$G(IBBAPLR)
.D FILE^DIE("","FDA",IBBERR)
.Q:$D(IBB("DIERR"))
.S IBBARFN=IBBIEN
.;visit data
.I $D(IBBPV1)>1 D
..I $G(IBBPV1(44))="" S IBBPV1(44)=$G(IBBPV2(8))
..S J=0,X="" F S J=$O(IBBPV1(J)) Q:'J S $P(X,U,J)=IBBPV1(J)
..S ^IBBAA(375,IBBIEN,"PV1")=X
..I $G(IBBPV1(50)) S $P(^IBBAA(375,IBBIEN,"PV1"),U,50)=IBBPV1(50)_";;;;OPP"
..I $G(IBBPV1(3))="FEE BASIS" D
...S IBBPV1(44)=$P($G(IBBPV1(44)),".",1)
...S $P(^IBBAA(375,IBBIEN,"PV1"),U,3)="",$P(^("PV1"),U,44)=IBBPV1(44)
...S ^IBBAA(375,IBBIEN,16)=IBBPV1(3)
.I $D(IBBPV2)>1 D
..S J=0,X="" F S J=$O(IBBPV2(J)) Q:'J S $P(X,U,J)=IBBPV2(J)
..S ^IBBAA(375,IBBIEN,"PV2")=X
.;procedure
.I $D(IBBPR1)>1 D
..I $D(IBBPR1(4)) S ^IBBAA(375,IBBIEN,11)=IBBPR1(4)
..S J=0,X="" F S J=$O(IBBPR1(J)) Q:'J I J'=4 S $P(X,U,J)=IBBPR1(J)
..S ^IBBAA(375,IBBIEN,"PR1")=X
.;diagnosis
.I $D(IBBDG1)>1 D
..I $D(IBBDG1(1,4)) S ^IBBAA(375,IBBIEN,12)=IBBDG1(1,4)
..I $G(IBBDG1(1,3))=+$G(IBBDG1(1,3)) D DX^IBBAACCT(.IBBDG1,IBBIEN)
.;classification
.I $D(IBBZCL)>1 D
..S (J,J1)=0 F S J=$O(IBBZCL(J)) Q:'J S J1=J1+1,X=J1_U_IBBZCL(J,2)_U_IBBZCL(J,3),^IBBAA(375,IBBIEN,"ZCL",J1,0)=X
..S ^IBBAA(375,IBBIEN,"ZCL",0)="^375.05A^"_J1_U_J1
.;miscellaneous
.I $G(IBBDIV) S ^IBBAA(375,IBBIEN,13)=IBBDIV
.I $D(IBBSURG)>1 S ^IBBAA(375,IBBIEN,14)=$G(IBBSURG(1))_U_$G(IBBSURG(2))
.I $G(IBBRAIEN) S ^IBBAA(375,IBBIEN,15)=$G(IBBRAIEN)
.I $G(IBBSURG(1)) S $P(^IBBAA(375,IBBIEN,"PV1"),U,50)=IBBSURG(1)_";;;;SUR"
;
;exit here if lock failed or FM error (??)
I 'IBBARFN Q +IBBARFN
;
;update event history
I $L(IBBEVENT)=3 D EVENT^IBBAACCT(IBBARFN,IBBEVENT,"R")
;
;set xref
S X1=IBBDFN,X2=$G(IBBPV1(3)),X3=$G(IBBPV1(44)) I X3 D
.I X2'=+X2 S ^IBBAA(375,"AF",X1,X3,X2,IBBARFN)=""
.I X2=+X2 S ^IBBAA(375,"AC",X1,X3,X2,IBBARFN)=""
;
;quit if test patient
I $$TESTPAT^VADPT(IBBDFN) S $P(^IBBAA(375,IBBIEN,0),U,20)=1 Q IBBARFN
;
;call VDEF
S IBBVDEF=0,X=IBBEVENT
S IBBSUBTY=$S(X="A01":"PFAN",X="A03":"PFDE",X="A04":"PFOA",X="A05":"PFPA",X="A08":"PFUPI",X="A11":"PFCAN",X="A13":"PFCDE",X="A38":"PFCPA",1:"")
I IBBSUBTY'="" S X=$T(QUEUE^VDEFQM) I X'="" S IBBVDEF=$$QUEUE^VDEFQM("ADT^"_IBBEVENT,"SUBTYPE="_IBBSUBTY_"^IEN="_IBBARFN,.IBBVERR,"PFSS OUTBOUND")
;
Q +IBBARFN
;
DX(DG1,IEN) ;file diagnosis on subfile #375.04
N J,IBB,IBBIEN,IBBIENS,IBBERR,FDA
S J=0 F S J=$O(DG1(J)) Q:'J Q:(DG1(J,3)'=+DG1(J,3)) D
.S IBBIEN(1)=J
.S IBBIENS="+1,"_IEN_","
.S IBBERR="IBB(""DIERR"")"
.S FDA(375.04,IBBIENS,.01)=J
.S FDA(375.04,IBBIENS,.03)=DG1(J,3)
.S FDA(375.04,IBBIENS,.06)=$G(DG1(J,6))
.D UPDATE^DIE("","FDA","IBBIEN",IBBERR)
Q
;
EVENT(IBBARFN,IBBEVENT,IBBREAS,IBBHLMSG) ;update the event history subfile #375.099
;
;update event history
N IBB,IBBIEN,IBBIENS,IBBERR,FDA
Q:'$G(IBBARFN) Q:$G(IBBEVENT)=""
S IBBIEN(1)=""
S IBBIENS="+1,"_IBBARFN_","
S IBBERR="IBB(""DIERR"")"
S FDA(375.099,IBBIENS,.01)=$$NOW^XLFDT()
S FDA(375.099,IBBIENS,.02)=IBBEVENT
S FDA(375.099,IBBIENS,.03)=$G(IBBREAS)
S FDA(375.099,IBBIENS,.04)=$G(IBBHLMSG)
D UPDATE^DIE("","FDA","IBBIEN",IBBERR)
Q
;
EXTNUM(IBBDFN,IBBARFN) ;find external visit number
N IBBIEN,IBBEXVN,IBBARRY,IBBERR
S IBBEXVN="",IBBIEN=IBBARFN
D GETS^DIQ(375,IBBIEN_",",".02;.03","I","IBBARRY","IBBERR")
I $D(IBBERR("DIERR")) Q IBBEXVN
I IBBARRY(375,IBBIEN_",",.03,"I")=IBBDFN S IBBEXVN=IBBARRY(375,IBBIEN_",",.02,"I")
Q IBBEXVN
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBBAACCT 5936 printed Oct 16, 2024@18:08:58 Page 2
IBBAACCT ;OAK/ELZ - PFSS ACCOUNT API ;15-MAR-2005
+1 ;;2.0;INTEGRATED BILLING;**286**;21-MAR-94
+2 ;;Per VHA Directive 10-93-142, this routine should not be modified.
+3 ;
GET(IBBDFN,IBBARFN,IBBEVENT,IBBAPLR,IBBPV1,IBBPV2,IBBPR1,IBBDG1,IBBZCL,IBBDIV,IBBRAIEN,IBBSURG) ;
+1 ;
+2 NEW IBB,IBBIEN,IBBIENS,IBBERR,IBBVERR,IBBSUBTY,IBBVDEF,FDA,OUT,J,J1,X,Y,X1,X2,X3
+3 IF '$GET(IBBDFN)!($GET(IBBEVENT)="")
QUIT 0
+4 IF $DATA(IBBPV1)<10
QUIT 0
+5 ;
+6 ;update account record
+7 SET OUT=0
+8 IF IBBARFN'=""
Begin DoDot:1
+9 SET IBBIEN=IBBARFN
+10 IF IBBDFN'=$PIECE($GET(^IBBAA(375,IBBIEN,0)),U,3)
SET OUT=1
QUIT
+11 ;visit data
+12 IF $DATA(IBBPV1)>1
Begin DoDot:2
+13 IF $GET(IBBPV1(44))=""
SET IBBPV1(44)=$GET(IBBPV2(8))
+14 IF $PIECE($GET(^IBBAA(375,IBBIEN,"PV1")),U,44)
IF $GET(IBBPV1(44))'=$PIECE($GET(^IBBAA(375,IBBIEN,"PV1")),U,44)
IF $PIECE(^IBBAA(375,IBBIEN,0),U,2)
DO KAC144^IBBAADD(IBBIEN)
+15 SET J=0
FOR
SET J=$ORDER(IBBPV1(J))
if 'J
QUIT
SET $PIECE(^IBBAA(375,IBBIEN,"PV1"),U,J)=IBBPV1(J)
+16 IF $GET(IBBPV1(50))
SET $PIECE(^IBBAA(375,IBBIEN,"PV1"),U,50)=IBBPV1(50)_";;;;OPP"
End DoDot:2
+17 IF $DATA(IBBPV2)>1
Begin DoDot:2
+18 SET J=0
FOR
SET J=$ORDER(IBBPV2(J))
if 'J
QUIT
SET $PIECE(^IBBAA(375,IBBIEN,"PV2"),U,J)=IBBPV2(J)
End DoDot:2
+19 ;procedure
+20 IF $DATA(IBBPR1)>1
Begin DoDot:2
+21 SET J=0
SET X=""
FOR
SET J=$ORDER(IBBPR1(J))
if 'J
QUIT
IF J'=4
SET $PIECE(X,U,J)=IBBPR1(J)
+22 SET ^IBBAA(375,IBBIEN,"PR1")=X
+23 IF $GET(IBBPR1(4))'=""
SET ^IBBAA(375,IBBIEN,11)=IBBPR1(4)
End DoDot:2
+24 ;diagnosis
+25 ;if any dx sent, remove existing dx
+26 IF $DATA(IBBDG1)>1
IF $GET(IBBDG1(1,3))=+$GET(IBBDG1(1,3))
KILL ^IBBAA(375,IBBIEN,"DG1")
DO DX^IBBAACCT(.IBBDG1,IBBIEN)
+27 IF $GET(IBBDG1(1,4))
SET ^IBBAA(375,IBBIEN,12)=IBBDG1(1,4)
+28 ;classification
+29 ;if any classification sent, remove existing classification
+30 IF $DATA(IBBZCL)>1
Begin DoDot:2
+31 KILL ^IBBAA(375,IBBIEN,"ZCL")
+32 SET (J,J1)=0
FOR
SET J=$ORDER(IBBZCL(J))
if 'J
QUIT
SET J1=J1+1
SET X=J1_U_IBBZCL(J,2)_U_IBBZCL(J,3)
SET ^IBBAA(375,IBBIEN,"ZCL",J1,0)=X
+33 SET ^IBBAA(375,IBBIEN,"ZCL",0)="^375.05A^"_J1_U_J1
End DoDot:2
+34 ;miscellaneous
+35 IF $GET(IBBDIV)
SET ^IBBAA(375,IBBIEN,13)=IBBDIV
+36 IF $DATA(IBBSURG)>1
SET ^IBBAA(375,IBBIEN,14)=$GET(IBBSURG(1))_U_$GET(IBBSURG(2))
+37 IF $GET(IBBRAIEN)
SET ^IBBAA(375,IBBIEN,15)=$GET(IBBRAIEN)
+38 IF $GET(IBBSURG(1))
SET $PIECE(^IBBAA(375,IBBIEN,"PV1"),U,50)=IBBSURG(1)_";;;;SUR"
End DoDot:1
+39 IF OUT
QUIT 0
+40 ;
+41 ;request account reference number
+42 IF IBBARFN=""
Begin DoDot:1
+43 IF $GET(IBBAPLR)'=""
Begin DoDot:2
+44 SET IBBAPLR=$EXTRACT($TRANSLATE(IBBAPLR,U,";"),1,25)
+45 IF IBBAPLR'[";"
SET IBBAPLR=";"_IBBAPLR
End DoDot:2
+46 LOCK +^IBBAA(375,0):5
+47 if '$TEST
QUIT
+48 SET IBBIEN=$PIECE(^IBBAA(375,0),U,3)+1
SET $PIECE(^IBBAA(375,0),U,3)=IBBIEN
+49 LOCK -^IBBAA(375,0)
+50 SET ^IBBAA(375,IBBIEN,0)=IBBIEN
+51 SET IBBIENS=IBBIEN_","
+52 SET IBBERR="IBB(""DIERR"")"
+53 SET FDA(375,IBBIENS,.02)="G"
+54 SET FDA(375,IBBIENS,.03)=IBBDFN
+55 SET FDA(375,IBBIENS,.04)=$GET(IBBAPLR)
+56 DO FILE^DIE("","FDA",IBBERR)
+57 if $DATA(IBB("DIERR"))
QUIT
+58 SET IBBARFN=IBBIEN
+59 ;visit data
+60 IF $DATA(IBBPV1)>1
Begin DoDot:2
+61 IF $GET(IBBPV1(44))=""
SET IBBPV1(44)=$GET(IBBPV2(8))
+62 SET J=0
SET X=""
FOR
SET J=$ORDER(IBBPV1(J))
if 'J
QUIT
SET $PIECE(X,U,J)=IBBPV1(J)
+63 SET ^IBBAA(375,IBBIEN,"PV1")=X
+64 IF $GET(IBBPV1(50))
SET $PIECE(^IBBAA(375,IBBIEN,"PV1"),U,50)=IBBPV1(50)_";;;;OPP"
+65 IF $GET(IBBPV1(3))="FEE BASIS"
Begin DoDot:3
+66 SET IBBPV1(44)=$PIECE($GET(IBBPV1(44)),".",1)
+67 SET $PIECE(^IBBAA(375,IBBIEN,"PV1"),U,3)=""
SET $PIECE(^("PV1"),U,44)=IBBPV1(44)
+68 SET ^IBBAA(375,IBBIEN,16)=IBBPV1(3)
End DoDot:3
End DoDot:2
+69 IF $DATA(IBBPV2)>1
Begin DoDot:2
+70 SET J=0
SET X=""
FOR
SET J=$ORDER(IBBPV2(J))
if 'J
QUIT
SET $PIECE(X,U,J)=IBBPV2(J)
+71 SET ^IBBAA(375,IBBIEN,"PV2")=X
End DoDot:2
+72 ;procedure
+73 IF $DATA(IBBPR1)>1
Begin DoDot:2
+74 IF $DATA(IBBPR1(4))
SET ^IBBAA(375,IBBIEN,11)=IBBPR1(4)
+75 SET J=0
SET X=""
FOR
SET J=$ORDER(IBBPR1(J))
if 'J
QUIT
IF J'=4
SET $PIECE(X,U,J)=IBBPR1(J)
+76 SET ^IBBAA(375,IBBIEN,"PR1")=X
End DoDot:2
+77 ;diagnosis
+78 IF $DATA(IBBDG1)>1
Begin DoDot:2
+79 IF $DATA(IBBDG1(1,4))
SET ^IBBAA(375,IBBIEN,12)=IBBDG1(1,4)
+80 IF $GET(IBBDG1(1,3))=+$GET(IBBDG1(1,3))
DO DX^IBBAACCT(.IBBDG1,IBBIEN)
End DoDot:2
+81 ;classification
+82 IF $DATA(IBBZCL)>1
Begin DoDot:2
+83 SET (J,J1)=0
FOR
SET J=$ORDER(IBBZCL(J))
if 'J
QUIT
SET J1=J1+1
SET X=J1_U_IBBZCL(J,2)_U_IBBZCL(J,3)
SET ^IBBAA(375,IBBIEN,"ZCL",J1,0)=X
+84 SET ^IBBAA(375,IBBIEN,"ZCL",0)="^375.05A^"_J1_U_J1
End DoDot:2
+85 ;miscellaneous
+86 IF $GET(IBBDIV)
SET ^IBBAA(375,IBBIEN,13)=IBBDIV
+87 IF $DATA(IBBSURG)>1
SET ^IBBAA(375,IBBIEN,14)=$GET(IBBSURG(1))_U_$GET(IBBSURG(2))
+88 IF $GET(IBBRAIEN)
SET ^IBBAA(375,IBBIEN,15)=$GET(IBBRAIEN)
+89 IF $GET(IBBSURG(1))
SET $PIECE(^IBBAA(375,IBBIEN,"PV1"),U,50)=IBBSURG(1)_";;;;SUR"
End DoDot:1
+90 ;
+91 ;exit here if lock failed or FM error (??)
+92 IF 'IBBARFN
QUIT +IBBARFN
+93 ;
+94 ;update event history
+95 IF $LENGTH(IBBEVENT)=3
DO EVENT^IBBAACCT(IBBARFN,IBBEVENT,"R")
+96 ;
+97 ;set xref
+98 SET X1=IBBDFN
SET X2=$GET(IBBPV1(3))
SET X3=$GET(IBBPV1(44))
IF X3
Begin DoDot:1
+99 IF X2'=+X2
SET ^IBBAA(375,"AF",X1,X3,X2,IBBARFN)=""
+100 IF X2=+X2
SET ^IBBAA(375,"AC",X1,X3,X2,IBBARFN)=""
End DoDot:1
+101 ;
+102 ;quit if test patient
+103 IF $$TESTPAT^VADPT(IBBDFN)
SET $PIECE(^IBBAA(375,IBBIEN,0),U,20)=1
QUIT IBBARFN
+104 ;
+105 ;call VDEF
+106 SET IBBVDEF=0
SET X=IBBEVENT
+107 SET IBBSUBTY=$SELECT(X="A01":"PFAN",X="A03":"PFDE",X="A04":"PFOA",X="A05":"PFPA",X="A08":"PFUPI",X="A11":"PFCAN",X="A13":"PFCDE",X="A38":"PFCPA",1:"")
+108 IF IBBSUBTY'=""
SET X=$TEXT(QUEUE^VDEFQM)
IF X'=""
SET IBBVDEF=$$QUEUE^VDEFQM("ADT^"_IBBEVENT,"SUBTYPE="_IBBSUBTY_"^IEN="_IBBARFN,.IBBVERR,"PFSS OUTBOUND")
+109 ;
+110 QUIT +IBBARFN
+111 ;
DX(DG1,IEN) ;file diagnosis on subfile #375.04
+1 NEW J,IBB,IBBIEN,IBBIENS,IBBERR,FDA
+2 SET J=0
FOR
SET J=$ORDER(DG1(J))
if 'J
QUIT
if (DG1(J,3)'=+DG1(J,3))
QUIT
Begin DoDot:1
+3 SET IBBIEN(1)=J
+4 SET IBBIENS="+1,"_IEN_","
+5 SET IBBERR="IBB(""DIERR"")"
+6 SET FDA(375.04,IBBIENS,.01)=J
+7 SET FDA(375.04,IBBIENS,.03)=DG1(J,3)
+8 SET FDA(375.04,IBBIENS,.06)=$GET(DG1(J,6))
+9 DO UPDATE^DIE("","FDA","IBBIEN",IBBERR)
End DoDot:1
+10 QUIT
+11 ;
EVENT(IBBARFN,IBBEVENT,IBBREAS,IBBHLMSG) ;update the event history subfile #375.099
+1 ;
+2 ;update event history
+3 NEW IBB,IBBIEN,IBBIENS,IBBERR,FDA
+4 if '$GET(IBBARFN)
QUIT
if $GET(IBBEVENT)=""
QUIT
+5 SET IBBIEN(1)=""
+6 SET IBBIENS="+1,"_IBBARFN_","
+7 SET IBBERR="IBB(""DIERR"")"
+8 SET FDA(375.099,IBBIENS,.01)=$$NOW^XLFDT()
+9 SET FDA(375.099,IBBIENS,.02)=IBBEVENT
+10 SET FDA(375.099,IBBIENS,.03)=$GET(IBBREAS)
+11 SET FDA(375.099,IBBIENS,.04)=$GET(IBBHLMSG)
+12 DO UPDATE^DIE("","FDA","IBBIEN",IBBERR)
+13 QUIT
+14 ;
EXTNUM(IBBDFN,IBBARFN) ;find external visit number
+1 NEW IBBIEN,IBBEXVN,IBBARRY,IBBERR
+2 SET IBBEXVN=""
SET IBBIEN=IBBARFN
+3 DO GETS^DIQ(375,IBBIEN_",",".02;.03","I","IBBARRY","IBBERR")
+4 IF $DATA(IBBERR("DIERR"))
QUIT IBBEXVN
+5 IF IBBARRY(375,IBBIEN_",",.03,"I")=IBBDFN
SET IBBEXVN=IBBARRY(375,IBBIEN_",",.02,"I")
+6 QUIT IBBEXVN
