IBCEP5C ;ALB/TMP - EDI UTILITIES for provider ID ;02-NOV-00
;;2.0;INTEGRATED BILLING;**137,239,232,320,348,349,592**;21-MAR-94;Build 58
;;Per VA Directive 6402, this routine should not be modified.
;
COMBOK(IBFILE,IBDAT,IBALL,IBF) ; Generic ask if conflict, should id rec still
; be added?
; IBFILE = 355.9 or 355.91 for the file being edited
; IBDAT = var ptr prov ien (355.9) ^ pc to check ^
; ins co ien or *ALL* ^ care unit or *N/A* ^
; form type code ^ care type code ^ prov id type ptr
; IBALL = flag:
; 0 = Individual entry selected - check for existing ALL entry
; 1 = 'ALL' selected - check for existing individual ones
; IBF = 1 if deleting from ins co-related options, ""
; from provider-related options
; Returns 1 if ok to continue, 0 if not
;
N X,Y,Q,DIR,Z,IBD,IBDD,IBOK,IBSPEC
S IBALL=$G(IBALL),IBOK=1
S IBD=+$P(IBDAT,U,2),IBDD=$S(IBD=4:5,1:4)
F Z=2:1:6 D
. I IBD'=Z,$P(IBDAT,U,Z+1)'="" S Z(Z)=$P(IBDAT,U,Z+1) Q
. I IBD=Z S IBD(Z)=$P(IBDAT,U,Z+1)
K IBSPEC
I IBALL D ; Check for specific
. N X0,X1
. S X1=0
. F S X1=$O(^IBA(IBFILE,"AC",$S(IBFILE=355.9:Z(6),1:Z(2)),$S(IBFILE=355.9:Z(2),1:Z(6)),$S(IBFILE=355.9:$P(IBDAT,U),1:Z(3)),X1)) Q:'X1 S X0=$G(^IBA(IBFILE,X1,0)) I $S(IBFILE=355.9:$P(X0,U,3)=Z(3),1:1) D
.. I $P(X0,U,IBD)'=IBD(IBD),"12"[$P(X0,U,IBD),($P(X0,U,IBDD)=Z(IBDD)!($P(X0,U,IBDD)=0)!(Z(IBDD)=0&(IBD(IBD)=0))) S X1($P(X0,U,IBD))=X1 Q
.. I IBD(IBD)=0,Z(IBDD)=0 S X1(0)=X1
. S X0=0 F S X0=$O(X1(X0)) Q:X0="" D
.. S IBSPEC=$S($G(IBSPEC)'="":IBSPEC_" ",1:"")_$P($S(IBD=4:"UB-04^CMS-1500",1:"INPT^OUTPT"),U,X0)_" ONLY"
. I $D(X1(0)) S IBSPEC=$S($G(IBSPEC)'="":IBSPEC_" ",1:"")_$S(IBD=4:"BOTH UB-04 and CMS-1500 form type AND BOTH INPT and OUTPT care type",1:"BOTH INPT and OUTPT care type AND BOTH UB-04 and CMS-1500 form type")
. ;
I 'IBALL D
. N X0,X1
. S X1=0
. F S X1=$O(^IBA(IBFILE,"AC",$S(IBFILE=355.9:Z(6),1:Z(2)),$S(IBFILE=355.9:Z(2),1:Z(6)),$S(IBFILE=355.9:$P(IBDAT,U),1:Z(3)),X1)) Q:'X1 D
.. S X0=$G(^IBA(IBFILE,X1,0))
.. I $S(IBFILE=355.9:$P(X0,U,16)=Z(3),1:1),$P(X0,U,IBD)=0,$S($P(X0,U,IBDD)=Z(IBDD):1,1:$P(X0,U,IBDD)=0) S IBSPEC=""
;
I $D(IBSPEC) D
. N X0,X1,TEXT,IBWHAT
. S IBWHAT=$S(IBFILE=355.9:$S($G(IBF):"INS CO AND PROVIDER",1:"PROVIDER"),1:"INSURANCE CO")
. S X0=$S($D(IBD(4)):"UB-04^CMS-1500",1:"INPT^OUTPT")
. S X1=$S($D(IBD(4)):"FORM TYPE",1:"CARE TYPE")
. S DIR(0)="YA"
. S TEXT(1)="WARNING ... POTENTIAL CONFLICT DETECTED!!"
. S TEXT(2)=" YOUR NEW COMBINATION APPLIES TO "_$S(IBALL:"BOTH "_$S(IBD=4:"FORM ",1:"INPT AND OUTPT CARE ")_"TYPES",1:"ONLY "_$P(X0,U,IBD(IBD))_" "_X1)
. S TEXT(3)=" THIS SAME COMBINATION ALREADY EXISTS FOR THE "_IBWHAT_" & "_$S('IBALL:"ALL "_X1_"S",1:"SPECIFIC "_X1_"(S):")
. S:IBSPEC'="" TEXT(4)=$J("",4)_IBSPEC
. S TEXT($S($D(TEXT(4)):5,1:4))=" "
. S DIR("A")="ARE YOU SURE YOU STILL WANT TO ADD THIS RECORD?: "
. S DIR("?",1)=" "
. S DIR("?",2)="This combination appears to be conflicting with one(s) already on file."
. S DIR("?",3)="It has already been defined for the "_$$LOW^XLFSTR(IBWHAT)_" for "_$S(IBALL:"at least 1 specific ",1:"ALL ")_$S(IBD=4:"form",1:"care")_" type"_$S(IBALL:".",1:"s.")
. S DIR("?")="Respond NO to reject this conflicting record or YES to continue on to add it in spite of the apparent conflict.",DIR("B")="NO"
. W !! F Q=1:1 Q:'$D(TEXT(Q)) W TEXT(Q),!
. D ^DIR K DIR W !
. S IBOK=(Y=1)
Q IBOK
;
CAREUN ;Called from NEWID^IBCEP5B to check for existing record combination
N DIR
I IBFILE'=355.9 D
. S IB35591(.03)=IB3559(.03)
. I "0"[IB35591(.03) S IB35591(.03)="*N/A*"
. I IB35591(.03)'="*N/A*" S IB35591(.03)=$O(^IBA(355.96,"AUNIQ",IBINS,IB3559(.03),IB3559(.04),IB3559(.05),IBPTYP,"")) I 'IB35591(.03) D
.. S IB35591(.03)=$O(^IBA(355.96,"AUNIQ",IBINS,IB3559(.03),IB3559(.04),0,IBPTYP,"")) I 'IB35591(.03) D
... S IB35591(.03)=$O(^IBA(355.96,"AUNIQ",IBINS,IB3559(.03),0,IB3559(.05),IBPTYP,"")) I 'IB35591(.03) D
.... S IB35591(.03)=$O(^IBA(355.96,"AUNIQ",IBINS,IB3559(.03),0,0,IBPTYP,""))
. I $D(^IBA(355.91,"AUNIQ",IBINS,IB35591(.03),IB3559(.04),IB3559(.05),IBPTYP)) D Q
.. S DIR(0)="EA",DIR("A",1)="This record already exists - NOT ADDED",DIR("A")="PRESS the ENTER key to continue" W ! D ^DIR K DIR,IB3559,IB35591 W !
I IBFILE=355.9 D
. S IB35591(.03)=IB3559(.03)
. I "0"[IB35591(.03) S IB35591(.03)="*N/A*"
. I IB35591(.03)'="*N/A*" S IB35591(.03)=$O(^IBA(355.96,"AUNIQ",IBINS,IB3559(.03),IB3559(.04),IB3559(.05),IBPTYP,"")) I 'IB35591(.03) D
.. S IB35591(.03)=$O(^IBA(355.96,"AUNIQ",IBINS,IB3559(.03),IB3559(.04),0,IBPTYP,"")) I 'IB35591(.03) D
... S IB35591(.03)=$O(^IBA(355.96,"AUNIQ",IBINS,IB3559(.03),0,IB3559(.05),IBPTYP,"")) I 'IB35591(.03) D
.... S IB35591(.03)=$O(^IBA(355.96,"AUNIQ",IBINS,IB3559(.03),0,0,IBPTYP,""))
. I $D(^IBA(355.9,"AUNIQ",IBPRV,IBINS,IB35591(.03),IB3559(.04),IB3559(.05),IBPTYP)) D Q
.. S DIR(0)="EA",DIR("A",1)="This record already exists - NOT ADDED",DIR("A")="PRESS the ENTER key to continue" W ! D ^DIR K DIR,IB3559,IB35591 W !
Q
;
DEL(IBFILE,IBDA,IBF) ; Delete prov specific ID's
; IBFILE = 355.9 or 355.91 for the file
; IBDA = ien of entry in file IBFILE
; IBF = 1 if deleting from ins co-related options, ""
; from prov-related options
N IB0,IBLAST,IBX,DIK,DA,DIR,X,Y,Z
F Z=1:1:3 L +^IBA(IBFILE,IBDA):5 Q:$T
I '$T D G DELQ
. W !,"RECORD IS LOCKED BY ANOTHER USER - TRY AGAIN LATER"
. D ENTER^IBCEP5B(.DIR)
. W ! D ^DIR K DIR W !
S IB0=$G(^IBA(IBFILE,IBDA,0))
S IBX=0
S IBX=IBX+1,DIR("A",IBX)=" PROVIDER: "_$S(IBFILE=355.9:$$EXPAND^IBTRE(355.9,.01,$P(IB0,U)),1:"*ALL*")
D DISP^IBCEP4("DIR(""A"")",$P(IB0,U,$S(IBFILE=355.9:2,1:1)),$P(IB0,U,6),$P(IB0,U,4),$P(IB0,U,5),IBX+1,.IBLAST)
I $P(IB0,U,3)'="" S DIR("A",IBLAST+1)="CARE UNIT: "_$$EXPAND^IBTRE(355.91,.03,$P(IB0,U,3))
S DIR("A",IBLAST+2)=" PROV ID: "_$P(IB0,U,7),DIR("A",IBLAST+3)=" "
S DIR("A")="OK TO DELETE THIS "_$S($G(IBF):"INSURANCE COMPANY ",1:"")_"PROVIDER ID RECORD?: ",DIR("B")="NO"
S DIR(0)="YA"
W ! D ^DIR K DIR W !
I Y'=1 G DELQ
I IBDA>0 D
. I IBFILE=355.91!(IBFILE=355.9&($P($G(^IBA(IBFILE,IBDA,0)),U)["VA(200,")) D
.. N NEXTONE S NEXTONE=$$NEXTONE^IBCEP5A()
.. S ^TMP("IB_EDITED_IDS",$J,NEXTONE)=IBDA_U_"DEL"_U_IBFILE_U_IBDA
.. S ^TMP("IB_EDITED_IDS",$J,NEXTONE,0)=$G(^IBA(IBFILE,IBDA,0))
. S DA=IBDA,DIK="^IBA("_IBFILE_"," D ^DIK
DELQ L -^IBA(IBFILE,IBDA)
Q
;
CUCHK(IBDA,IB0) ;Called from CHG^IBCEP5B to check for existing combination
; during edit
; IBDA = the ien of the record being edited
; IB0 = Proposed changed 0 node of the entry in the file
; FUNCTION RETURNS 0 if no duplicate found, 1 if record already exists
N Z,IBCUCHK,DIR,X,Y
S IBCUCHK=0
I IBFILE=355.91 S Z=+$O(^IBA(355.91,"AUNIQ",$P(IB0,U,1),$S($P(IB0,U,3)="@":"*N/A*",$P(IB0,U,3):$P(IB0,U,3),1:$P(IB0,U,10)),$P(IB0,U,4),$P(IB0,U,5),$P(IB0,U,6),0)) I Z,Z'=IBDA S IBCUCHK=1
I IBFILE=355.9 D
. N X,X1
. S X=$S($P(IB0,U,2):$P(IB0,U,2),1:$P(IB0,U,15)) S:X="" X="*ALL*"
. S X1=$S($P(IB0,U,3):$P(IB0,U,3),$P(IB0,U,3)="@":"",1:$P(IB0,U,16)) S:X1="" X1="*N/A*"
. S Z=+$O(^IBA(355.9,"AUNIQ",$P(IB0,U,1),X,X1,$P(IB0,U,4),$P(IB0,U,5),$P(IB0,U,6),0)) I Z,Z'=IBDA S IBCUCHK=1
I IBCUCHK D
. S DIR(0)="EA",DIR("A",1)="This combination already exists - RECORD NOT CHANGED",DIR("A")="PRESS the ENTER key to continue" W ! D ^DIR K DIR W !
Q IBCUCHK
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCEP5C 7426 printed Dec 13, 2024@02:11:40 Page 2
IBCEP5C ;ALB/TMP - EDI UTILITIES for provider ID ;02-NOV-00
+1 ;;2.0;INTEGRATED BILLING;**137,239,232,320,348,349,592**;21-MAR-94;Build 58
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;
COMBOK(IBFILE,IBDAT,IBALL,IBF) ; Generic ask if conflict, should id rec still
+1 ; be added?
+2 ; IBFILE = 355.9 or 355.91 for the file being edited
+3 ; IBDAT = var ptr prov ien (355.9) ^ pc to check ^
+4 ; ins co ien or *ALL* ^ care unit or *N/A* ^
+5 ; form type code ^ care type code ^ prov id type ptr
+6 ; IBALL = flag:
+7 ; 0 = Individual entry selected - check for existing ALL entry
+8 ; 1 = 'ALL' selected - check for existing individual ones
+9 ; IBF = 1 if deleting from ins co-related options, ""
+10 ; from provider-related options
+11 ; Returns 1 if ok to continue, 0 if not
+12 ;
+13 NEW X,Y,Q,DIR,Z,IBD,IBDD,IBOK,IBSPEC
+14 SET IBALL=$GET(IBALL)
SET IBOK=1
+15 SET IBD=+$PIECE(IBDAT,U,2)
SET IBDD=$SELECT(IBD=4:5,1:4)
+16 FOR Z=2:1:6
Begin DoDot:1
+17 IF IBD'=Z
IF $PIECE(IBDAT,U,Z+1)'=""
SET Z(Z)=$PIECE(IBDAT,U,Z+1)
QUIT
+18 IF IBD=Z
SET IBD(Z)=$PIECE(IBDAT,U,Z+1)
End DoDot:1
+19 KILL IBSPEC
+20 ; Check for specific
IF IBALL
Begin DoDot:1
+21 NEW X0,X1
+22 SET X1=0
+23 FOR
SET X1=$ORDER(^IBA(IBFILE,"AC",$SELECT(IBFILE=355.9:Z(6),1:Z(2)),$SELECT(IBFILE=355.9:Z(2),1:Z(6)),$SELECT(IBFILE=355.9:$PIECE(IBDAT,U),1:Z(3)),X1))
if 'X1
QUIT
SET X0=$GET(^IBA(IBFILE,X1,0))
IF $SELECT(IBFILE=355.9:$PIECE(X0,U,3)=Z(3),1:1)
Begin DoDot:2
+24 IF $PIECE(X0,U,IBD)'=IBD(IBD)
IF "12"[$PIECE(X0,U,IBD)
IF ($PIECE(X0,U,IBDD)=Z(IBDD)!($PIECE(X0,U,IBDD)=0)!(Z(IBDD)=0&(IBD(IBD)=0)))
SET X1($PIECE(X0,U,IBD))=X1
QUIT
+25 IF IBD(IBD)=0
IF Z(IBDD)=0
SET X1(0)=X1
End DoDot:2
+26 SET X0=0
FOR
SET X0=$ORDER(X1(X0))
if X0=""
QUIT
Begin DoDot:2
+27 SET IBSPEC=$SELECT($GET(IBSPEC)'="":IBSPEC_" ",1:"")_$PIECE($SELECT(IBD=4:"UB-04^CMS-1500",1:"INPT^OUTPT"),U,X0)_" ONLY"
End DoDot:2
+28 IF $DATA(X1(0))
SET IBSPEC=$SELECT($GET(IBSPEC)'="":IBSPEC_" ",1:"")_$SELECT(IBD=4:"BOTH UB-04 and CMS-1500 form type AND BOTH INPT and OUTPT care type",1:"BOTH INPT and OUTPT care type AND BOTH UB-04 and CMS-1500 form type")
+29 ;
End DoDot:1
+30 IF 'IBALL
Begin DoDot:1
+31 NEW X0,X1
+32 SET X1=0
+33 FOR
SET X1=$ORDER(^IBA(IBFILE,"AC",$SELECT(IBFILE=355.9:Z(6),1:Z(2)),$SELECT(IBFILE=355.9:Z(2),1:Z(6)),$SELECT(IBFILE=355.9:$PIECE(IBDAT,U),1:Z(3)),X1))
if 'X1
QUIT
Begin DoDot:2
+34 SET X0=$GET(^IBA(IBFILE,X1,0))
+35 IF $SELECT(IBFILE=355.9:$PIECE(X0,U,16)=Z(3),1:1)
IF $PIECE(X0,U,IBD)=0
IF $SELECT($PIECE(X0,U,IBDD)=Z(IBDD):1,1:$PIECE(X0,U,IBDD)=0)
SET IBSPEC=""
End DoDot:2
End DoDot:1
+36 ;
+37 IF $DATA(IBSPEC)
Begin DoDot:1
+38 NEW X0,X1,TEXT,IBWHAT
+39 SET IBWHAT=$SELECT(IBFILE=355.9:$SELECT($GET(IBF):"INS CO AND PROVIDER",1:"PROVIDER"),1:"INSURANCE CO")
+40 SET X0=$SELECT($DATA(IBD(4)):"UB-04^CMS-1500",1:"INPT^OUTPT")
+41 SET X1=$SELECT($DATA(IBD(4)):"FORM TYPE",1:"CARE TYPE")
+42 SET DIR(0)="YA"
+43 SET TEXT(1)="WARNING ... POTENTIAL CONFLICT DETECTED!!"
+44 SET TEXT(2)=" YOUR NEW COMBINATION APPLIES TO "_$SELECT(IBALL:"BOTH "_$SELECT(IBD=4:"FORM ",1:"INPT AND OUTPT CARE ")_"TYPES",1:"ONLY "_$PIECE(X0,U,IBD(IBD))_" "_X1)
+45 SET TEXT(3)=" THIS SAME COMBINATION ALREADY EXISTS FOR THE "_IBWHAT_" & "_$SELECT('IBALL:"ALL "_X1_"S",1:"SPECIFIC "_X1_"(S):")
+46 if IBSPEC'=""
SET TEXT(4)=$JUSTIFY("",4)_IBSPEC
+47 SET TEXT($SELECT($DATA(TEXT(4)):5,1:4))=" "
+48 SET DIR("A")="ARE YOU SURE YOU STILL WANT TO ADD THIS RECORD?: "
+49 SET DIR("?",1)=" "
+50 SET DIR("?",2)="This combination appears to be conflicting with one(s) already on file."
+51 SET DIR("?",3)="It has already been defined for the "_$$LOW^XLFSTR(IBWHAT)_" for "_$SELECT(IBALL:"at least 1 specific ",1:"ALL ")_$SELECT(IBD=4:"form",1:"care")_" type"_$SELECT(IBALL:".",1:"s.")
+52 SET DIR("?")="Respond NO to reject this conflicting record or YES to continue on to add it in spite of the apparent conflict."
SET DIR("B")="NO"
+53 WRITE !!
FOR Q=1:1
if '$DATA(TEXT(Q))
QUIT
WRITE TEXT(Q),!
+54 DO ^DIR
KILL DIR
WRITE !
+55 SET IBOK=(Y=1)
End DoDot:1
+56 QUIT IBOK
+57 ;
CAREUN ;Called from NEWID^IBCEP5B to check for existing record combination
+1 NEW DIR
+2 IF IBFILE'=355.9
Begin DoDot:1
+3 SET IB35591(.03)=IB3559(.03)
+4 IF "0"[IB35591(.03)
SET IB35591(.03)="*N/A*"
+5 IF IB35591(.03)'="*N/A*"
SET IB35591(.03)=$ORDER(^IBA(355.96,"AUNIQ",IBINS,IB3559(.03),IB3559(.04),IB3559(.05),IBPTYP,""))
IF 'IB35591(.03)
Begin DoDot:2
+6 SET IB35591(.03)=$ORDER(^IBA(355.96,"AUNIQ",IBINS,IB3559(.03),IB3559(.04),0,IBPTYP,""))
IF 'IB35591(.03)
Begin DoDot:3
+7 SET IB35591(.03)=$ORDER(^IBA(355.96,"AUNIQ",IBINS,IB3559(.03),0,IB3559(.05),IBPTYP,""))
IF 'IB35591(.03)
Begin DoDot:4
+8 SET IB35591(.03)=$ORDER(^IBA(355.96,"AUNIQ",IBINS,IB3559(.03),0,0,IBPTYP,""))
End DoDot:4
End DoDot:3
End DoDot:2
+9 IF $DATA(^IBA(355.91,"AUNIQ",IBINS,IB35591(.03),IB3559(.04),IB3559(.05),IBPTYP))
Begin DoDot:2
+10 SET DIR(0)="EA"
SET DIR("A",1)="This record already exists - NOT ADDED"
SET DIR("A")="PRESS the ENTER key to continue"
WRITE !
DO ^DIR
KILL DIR,IB3559,IB35591
WRITE !
End DoDot:2
QUIT
End DoDot:1
+11 IF IBFILE=355.9
Begin DoDot:1
+12 SET IB35591(.03)=IB3559(.03)
+13 IF "0"[IB35591(.03)
SET IB35591(.03)="*N/A*"
+14 IF IB35591(.03)'="*N/A*"
SET IB35591(.03)=$ORDER(^IBA(355.96,"AUNIQ",IBINS,IB3559(.03),IB3559(.04),IB3559(.05),IBPTYP,""))
IF 'IB35591(.03)
Begin DoDot:2
+15 SET IB35591(.03)=$ORDER(^IBA(355.96,"AUNIQ",IBINS,IB3559(.03),IB3559(.04),0,IBPTYP,""))
IF 'IB35591(.03)
Begin DoDot:3
+16 SET IB35591(.03)=$ORDER(^IBA(355.96,"AUNIQ",IBINS,IB3559(.03),0,IB3559(.05),IBPTYP,""))
IF 'IB35591(.03)
Begin DoDot:4
+17 SET IB35591(.03)=$ORDER(^IBA(355.96,"AUNIQ",IBINS,IB3559(.03),0,0,IBPTYP,""))
End DoDot:4
End DoDot:3
End DoDot:2
+18 IF $DATA(^IBA(355.9,"AUNIQ",IBPRV,IBINS,IB35591(.03),IB3559(.04),IB3559(.05),IBPTYP))
Begin DoDot:2
+19 SET DIR(0)="EA"
SET DIR("A",1)="This record already exists - NOT ADDED"
SET DIR("A")="PRESS the ENTER key to continue"
WRITE !
DO ^DIR
KILL DIR,IB3559,IB35591
WRITE !
End DoDot:2
QUIT
End DoDot:1
+20 QUIT
+21 ;
DEL(IBFILE,IBDA,IBF) ; Delete prov specific ID's
+1 ; IBFILE = 355.9 or 355.91 for the file
+2 ; IBDA = ien of entry in file IBFILE
+3 ; IBF = 1 if deleting from ins co-related options, ""
+4 ; from prov-related options
+5 NEW IB0,IBLAST,IBX,DIK,DA,DIR,X,Y,Z
+6 FOR Z=1:1:3
LOCK +^IBA(IBFILE,IBDA):5
if $TEST
QUIT
+7 IF '$TEST
Begin DoDot:1
+8 WRITE !,"RECORD IS LOCKED BY ANOTHER USER - TRY AGAIN LATER"
+9 DO ENTER^IBCEP5B(.DIR)
+10 WRITE !
DO ^DIR
KILL DIR
WRITE !
End DoDot:1
GOTO DELQ
+11 SET IB0=$GET(^IBA(IBFILE,IBDA,0))
+12 SET IBX=0
+13 SET IBX=IBX+1
SET DIR("A",IBX)=" PROVIDER: "_$SELECT(IBFILE=355.9:$$EXPAND^IBTRE(355.9,.01,$PIECE(IB0,U)),1:"*ALL*")
+14 DO DISP^IBCEP4("DIR(""A"")",$PIECE(IB0,U,$SELECT(IBFILE=355.9:2,1:1)),$PIECE(IB0,U,6),$PIECE(IB0,U,4),$PIECE(IB0,U,5),IBX+1,.IBLAST)
+15 IF $PIECE(IB0,U,3)'=""
SET DIR("A",IBLAST+1)="CARE UNIT: "_$$EXPAND^IBTRE(355.91,.03,$PIECE(IB0,U,3))
+16 SET DIR("A",IBLAST+2)=" PROV ID: "_$PIECE(IB0,U,7)
SET DIR("A",IBLAST+3)=" "
+17 SET DIR("A")="OK TO DELETE THIS "_$SELECT($GET(IBF):"INSURANCE COMPANY ",1:"")_"PROVIDER ID RECORD?: "
SET DIR("B")="NO"
+18 SET DIR(0)="YA"
+19 WRITE !
DO ^DIR
KILL DIR
WRITE !
+20 IF Y'=1
GOTO DELQ
+21 IF IBDA>0
Begin DoDot:1
+22 IF IBFILE=355.91!(IBFILE=355.9&($PIECE($GET(^IBA(IBFILE,IBDA,0)),U)["VA(200,"))
Begin DoDot:2
+23 NEW NEXTONE
SET NEXTONE=$$NEXTONE^IBCEP5A()
+24 SET ^TMP("IB_EDITED_IDS",$JOB,NEXTONE)=IBDA_U_"DEL"_U_IBFILE_U_IBDA
+25 SET ^TMP("IB_EDITED_IDS",$JOB,NEXTONE,0)=$GET(^IBA(IBFILE,IBDA,0))
End DoDot:2
+26 SET DA=IBDA
SET DIK="^IBA("_IBFILE_","
DO ^DIK
End DoDot:1
DELQ LOCK -^IBA(IBFILE,IBDA)
+1 QUIT
+2 ;
CUCHK(IBDA,IB0) ;Called from CHG^IBCEP5B to check for existing combination
+1 ; during edit
+2 ; IBDA = the ien of the record being edited
+3 ; IB0 = Proposed changed 0 node of the entry in the file
+4 ; FUNCTION RETURNS 0 if no duplicate found, 1 if record already exists
+5 NEW Z,IBCUCHK,DIR,X,Y
+6 SET IBCUCHK=0
+7 IF IBFILE=355.91
SET Z=+$ORDER(^IBA(355.91,"AUNIQ",$PIECE(IB0,U,1),$SELECT($PIECE(IB0,U,3)="@":"*N/A*",$PIECE(IB0,U,3):$PIECE(IB0,U,3),1:$PIECE(IB0,U,10)),$PIECE(IB0,U,4),$PIECE(IB0,U,5),$PIECE(IB0,U,6),0))
IF Z
IF Z'=IBDA
SET IBCUCHK=1
+8 IF IBFILE=355.9
Begin DoDot:1
+9 NEW X,X1
+10 SET X=$SELECT($PIECE(IB0,U,2):$PIECE(IB0,U,2),1:$PIECE(IB0,U,15))
if X=""
SET X="*ALL*"
+11 SET X1=$SELECT($PIECE(IB0,U,3):$PIECE(IB0,U,3),$PIECE(IB0,U,3)="@":"",1:$PIECE(IB0,U,16))
if X1=""
SET X1="*N/A*"
+12 SET Z=+$ORDER(^IBA(355.9,"AUNIQ",$PIECE(IB0,U,1),X,X1,$PIECE(IB0,U,4),$PIECE(IB0,U,5),$PIECE(IB0,U,6),0))
IF Z
IF Z'=IBDA
SET IBCUCHK=1
End DoDot:1
+13 IF IBCUCHK
Begin DoDot:1
+14 SET DIR(0)="EA"
SET DIR("A",1)="This combination already exists - RECORD NOT CHANGED"
SET DIR("A")="PRESS the ENTER key to continue"
WRITE !
DO ^DIR
KILL DIR
WRITE !
End DoDot:1
+15 QUIT IBCUCHK
+16 ;
