IBCNSC1 ;ALB/NLR - IBCNS INSURANCE COMPANY ;23-MAR-93
;;2.0;INTEGRATED BILLING;**62,137,232,291,320,348,349,371,400,519,516,547,592**;21-MAR-94;Build 58
;;Per VA Directive 6402, this routine should not be modified.
;
% G EN^IBCNSC
;
AI ; -- (In)Activate Company
D FULL^VALM1 W !!
I '$D(^XUSEC("IB INSURANCE SUPERVISOR",DUZ)) D SORRY G EXIT
D ^IBCNSC2
G EXIT
CC ; -- Change Insurance Company
D FULL^VALM1 W !!
S IBCNS1=IBCNS K IBCNS D INSCO^IBCNSC
I '$D(IBCNS) S IBCNS=IBCNS1
K IBCNS1,VALMQUIT
G EXIT
EA ; -- Billing,Claims,Appeals,Inquiry,Telephone,Main,Remarks,Synonyms
D FULL^VALM1
;
; IB*2*320 - check key for associate company action
I $G(IBY)=",13,",'$$KCHK^XUSRB("IB EDI INSURANCE EDIT") D G EXIT
. W !!?5,"You must hold the IB EDI INSURANCE EDIT key to access this option."
. D PAUSE^VALM1
. Q
;
W !!
D MAIN
;
; -- was company deleted
I '$D(^DIC(36,IBCNS)) W !!,"<DELETED>",!! S VALMQUIT="" Q
;
EXIT ;
D HDR^IBCNSC,BLD^IBCNSC
S VALMBCK="R"
Q
MAIN ; -- Call edit template
N IBEDIKEY,Z
L +^DIC(36,+IBCNS):5 I '$T D LOCKED^IBTRCD1 G MAINQ
I $G(IBY)=",12," D FACID
;JWS;IB*2.0*592;add field .15 (piece 15) Dental EDI Payer ID
;IA# 5292
F Z=1,2,4,9,13,14,15 S IBEDIKEY(Z)=$P($G(^DIC(36,+IBCNS,3)),U,Z) ; save EDI data fields
F Z=1:1:8 S IBEDIKEY(Z,6)=$P($G(^DIC(36,+IBCNS,6)),U,Z) ; save EDI data fields
I $G(IBY)'=",12," N DIE,DA,DR S DIE="^DIC(36,",(DA,Y)=IBCNS,DR="[IBEDIT INS CO1]" D ^DIE K DIE S:$D(Y) IB("^")=1 D:$TR($P($G(^DIC(36,IBCNS,6)),U,1,8),U)]"" CUIDS(IBCNS)
I $G(IBY)=",12," D EDITID^IBCEP(+IBCNS)
I $F(",6,1,",$G(IBY)) D CLEANIDS^IBCNSC(+IBCNS) ;clean up any errant nodes on alternate payert IDS
I $F(",6,13,",$G(IBY)) D PARENT^IBCNSC02(+IBCNS) ; parent/child management
L -^DIC(36,+IBCNS)
; IB*2.0*519: If field 3.02 or 3.04 has changed, trigger HL7 to update the NIF
I (IBEDIKEY(2)'=$P($G(^DIC(36,+IBCNS,3)),U,2))!(IBEDIKEY(4)'=$P($G(^DIC(36,+IBCNS,3)),U,4)) D EXR^IBCNHUT1(IBCNS),SEND^IBCNHHLO(IBCNS)
MAINQ Q
;
FACID ; -- Edit facility ids
D FACID^IBCEP2B(+IBCNS,"E")
Q
;
SORRY ; -- can't inactivate, don't have key
W !!,"You do not have access to Inactivate entries. See your application coordinator.",! D PAUSE^VALM1
Q
PRESCR ;
N OFFSET,START,IBCNS18,IBADD
;
;WCJ;IB*2.0*547;Call New API
;S IBCNS18=$$ADDRESS^IBCNSC0(IBCNS,.18,11)
S IBCNS18=$$ADD2^IBCNSC0(IBCNS,.18,11)
;
;WCJ;IB*2.0*547
;S START=41,OFFSET=2
S START=42+(2*$G(IBACMAX)),OFFSET=2
PRESCRAD ; KDM US2487 IB*2.0*592 call in tag from IBCNSI
D SET^IBCNSP(START,OFFSET+19," Prescription Claims Office Information ",IORVON,IORVOFF)
D SET^IBCNSP(START+1,OFFSET," Company Name: "_$P($G(^DIC(36,+$P(IBCNS18,"^",7),0)),"^",1))
D SET^IBCNSP(START+2,OFFSET," Street: "_$P(IBCNS18,"^",1))
D SET^IBCNSP(START+3,OFFSET," Street 2: "_$P(IBCNS18,"^",2))
; D SET^IBCNSP(START+4,OFFSET,"Claim Off. ID: "_$P(IBCNS18,"^",11))
S OFFSET=45
D SET^IBCNSP(START+1,OFFSET," Street 3: "_$P(IBCNS18,"^",3)) S IBADD=1
D SET^IBCNSP(START+1+IBADD,OFFSET," City/State: "_$E($P(IBCNS18,"^",4),1,15)_$S($P(IBCNS18,"^",4)="":"",1:", ")_$P($G(^DIC(5,+$P(IBCNS18,"^",5),0)),"^",2)_" "_$E($P(IBCNS18,"^",6),1,5))
D SET^IBCNSP(START+2+IBADD,OFFSET," Phone: "_$P(IBCNS18,"^",8))
D SET^IBCNSP(START+3+IBADD,OFFSET," Fax: "_$P(IBCNS18,"^",9))
Q
;
PROVID N OFFSET,START,IBCNS4,IBCNS3,IBDISP,Z,LINE
S START=$O(^TMP("IBCNSC",$J,""),-1)+1
S (IB1ST("PROVID"),LINE)=START
S OFFSET=2,IBCNS4=$G(^DIC(36,IBCNS,4)),IBCNS3=$G(^(3))
;
D SET^IBCNSP(LINE,OFFSET+25,"Provider IDs",IORVON,IORVOFF)
S LINE=LINE+1,OFFSET=1
D SET^IBCNSP(LINE,OFFSET,"Billing Provider Secondary ID")
;
N Z,Z0,Z1,IBS,I,DIV,FT,CU,CUF,DIVISION,FORMTYPE,PIDT
S Z=0 F S Z=$O(^IBA(355.92,"B",+IBCNS,Z)) Q:'Z D
. S Z0=$G(^IBA(355.92,Z,0))
. Q:'$P(Z0,U,6)!($P(Z0,U,7)="") ; Quit if no provider id or id type
. Q:'($P(Z0,U,8)="E")
. S IBS(+$P(Z0,U,5),+$P(Z0,U,3),+$P(Z0,U,4))=$P(Z0,U,6)_U_$P(Z0,U,7)
;
S DIV="" F S DIV=$O(IBS(DIV)) Q:DIV="" D
. S DIVISION=$$DIV^IBCEP7(DIV)
. S CU="",CUF=0 F S CU=$O(IBS(DIV,CU)) Q:CU="" D
.. S FT="" F S FT=$O(IBS(DIV,CU,FT)) Q:FT="" D
... S FORMTYPE=$S(FT=1:"UB-04",FT=2:"1500",1:"UNKNOWN")
... S LINE=LINE+1
... I 'CUF,+CU S CUF=1 S TEXT=$P(DIVISION,"/")_" Care Units :",OFFSET=5 D SET^IBCNSP(LINE,OFFSET,TEXT) S LINE=LINE+1
... I CU=0 S TEXT=DIVISION_"/"_FORMTYPE_": "_$$GET1^DIQ(355.97,$P(IBS(DIV,CU,FT),U),.03,"E")_" "_$P(IBS(DIV,CU,FT),U,2),OFFSET=2
... I +CU S TEXT=$$EXPAND^IBTRE(355.92,.03,CU)_"/"_FORMTYPE_": "_$$GET1^DIQ(355.97,$P(IBS(DIV,CU,FT),U),.03,"E")_" "_$P(IBS(DIV,CU,FT),U,2),OFFSET=5
... D SET^IBCNSP(LINE,OFFSET,TEXT)
;
S LINE=LINE+1 D SET^IBCNSP(LINE,2," ")
;
K IBS
S OFFSET=1,LINE=LINE+1
D SET^IBCNSP(LINE,OFFSET,"Additional Billing Provider Secondary IDs")
S Z=0 F S Z=$O(^IBA(355.92,"B",+IBCNS,Z)) Q:'Z D
. S Z0=$G(^IBA(355.92,Z,0))
. Q:'$P(Z0,U,6)!($P(Z0,U,7)="") ; Quit if no provider id or id type
. Q:'($P(Z0,U,8)="A")
. ; IBS(DIVISION,FORMTYPE,IDTYPE)=ID
. S IBS(+$P(Z0,U,5),+$P(Z0,U,4),+$P(Z0,U,6))=$P(Z0,U,7)
;
S DIVISION=$$DIV^IBCEP7(0)
S DIV="" F S DIV=$O(IBS(DIV)) Q:DIV="" D
. S FT="" F S FT=$O(IBS(DIV,FT)) Q:FT="" D
.. S FORMTYPE=$S(FT=1:"UB-04",FT=2:"1500",1:"UNKNOWN")
.. S TEXT=DIVISION_"/"_FORMTYPE_": "
.. S LINE=LINE+1,OFFSET=2
.. D SET^IBCNSP(LINE,OFFSET,TEXT)
.. S PIDT="" F S PIDT=$O(IBS(DIV,FT,PIDT)) Q:PIDT="" D
... S LINE=LINE+1
... S TEXT=$$GET1^DIQ(355.97,PIDT,.03,"E")_" "_IBS(DIV,FT,PIDT),OFFSET=5
... D SET^IBCNSP(LINE,OFFSET,TEXT)
;
S LINE=LINE+1 D SET^IBCNSP(LINE,2," ")
;
K IBS
S OFFSET=1,LINE=LINE+1
D SET^IBCNSP(LINE,OFFSET,"VA-Laboratory or Facility Secondary IDs")
S Z=0 F S Z=$O(^IBA(355.92,"B",+IBCNS,Z)) Q:'Z D
. S Z0=$G(^IBA(355.92,Z,0))
. Q:'$P(Z0,U,6)!($P(Z0,U,7)="") ; Quit if no provider id or id type
. Q:'($P(Z0,U,8)="LF")
. ; IBS(DIVISION,FORMTYPE,IDTYPE)=ID
. S IBS(+$P(Z0,U,5),+$P(Z0,U,4),+$P(Z0,U,6))=$P(Z0,U,7)
;
S DIVISION=$$DIV^IBCEP7(0)
S DIV="" F S DIV=$O(IBS(DIV)) Q:DIV="" D
. S FT="" F S FT=$O(IBS(DIV,FT)) Q:FT="" D
.. S FORMTYPE=$S(FT=1:"UB-04",FT=2:"1500",1:"UNKNOWN")
.. S TEXT=DIVISION_"/"_FORMTYPE_": "
.. S LINE=LINE+1,OFFSET=2
.. D SET^IBCNSP(LINE,OFFSET,TEXT)
.. S PIDT="" F S PIDT=$O(IBS(DIV,FT,PIDT)) Q:PIDT="" D
... S LINE=LINE+1
... ;S TEXT=$$EXPAND^IBTRE(355.92,.06,PIDT)_" "_IBS(DIV,FT,PIDT),OFFSET=5
... S TEXT=$$GET1^DIQ(355.97,PIDT,.03,"E")_" "_IBS(DIV,FT,PIDT),OFFSET=5
... D SET^IBCNSP(LINE,OFFSET,TEXT)
;
S LINE=LINE+1 D SET^IBCNSP(LINE,2," ")
S LINE=LINE+1 D SET^IBCNSP(LINE,2," ")
S OFFSET=2
S LINE=LINE+1 D SET^IBCNSP(LINE,OFFSET+25,"ID Parameters",IORVON,IORVOFF)
;
S IBCNS4=$G(^DIC(36,IBCNS,4)),IBCNS3=$G(^(3)),OFFSET=1
S TEXT="Attending/Rendering Provider Secondary ID Qualifier (1500): "_$$EXPAND^IBTRE(36,4.01,+$P(IBCNS4,U))
S LINE=LINE+1
D SET^IBCNSP(LINE,OFFSET,TEXT)
;
S TEXT="Attending/Rendering Provider Secondary ID Qualifier (UB-04): "_$$EXPAND^IBTRE(36,4.02,+$P(IBCNS4,U,2))
S LINE=LINE+1
D SET^IBCNSP(LINE,OFFSET,TEXT)
;
S TEXT="Attending/Rendering Secondary ID Requirement: "_$$EXPAND^IBTRE(36,4.03,+$P(IBCNS4,U,3))
S LINE=LINE+1
D SET^IBCNSP(LINE,OFFSET,TEXT)
;
S TEXT="Referring Provider Secondary ID Qualifier (1500): "_$$EXPAND^IBTRE(36,4.04,+$P(IBCNS4,U,4))
S LINE=LINE+1
D SET^IBCNSP(LINE,OFFSET,TEXT)
;
S TEXT="Referring Provider Secondary ID Requirement: "_$$EXPAND^IBTRE(36,4.05,+$P(IBCNS4,U,5))
S LINE=LINE+1
D SET^IBCNSP(LINE,OFFSET,TEXT)
;
S TEXT="Use Att/Rend ID as Billing Provider Sec. ID (1500): "_$$EXPAND^IBTRE(36,4.06,+$P(IBCNS4,U,6))
S LINE=LINE+1
D SET^IBCNSP(LINE,OFFSET,TEXT)
;
S TEXT="Use Att/Rend ID as Billing Provider Sec. ID (UB-04): "_$$EXPAND^IBTRE(36,4.08,+$P(IBCNS4,U,8))
S LINE=LINE+1
D SET^IBCNSP(LINE,OFFSET,TEXT)
;
; MRD;IB*2.0*516 - Marked fields 4.07, 4.11, 4.12 and 4.13 for
; deletion and removed all references to them.
;S TEXT="Always use main VAMC as Billing Provider (1500)?: "_$$EXPAND^IBTRE(36,4.11,+$P(IBCNS4,U,11))
;S LINE=LINE+1
;D SET^IBCNSP(LINE,OFFSET,TEXT)
;
;S TEXT="Always use main VAMC as Billing Provider (UB-04)?: "_$$EXPAND^IBTRE(36,4.12,+$P(IBCNS4,U,12))
;S LINE=LINE+1
;D SET^IBCNSP(LINE,OFFSET,TEXT)
;
;I $P(IBCNS4,U,11)!($P(IBCNS4,U,12)) D
;.S TEXT="Send VA Lab/Facility IDs or Facility Data for VAMC?: "_$$EXPAND^IBTRE(36,4.07,+$P(IBCNS4,U,7))
;.S LINE=LINE+1
;.D SET^IBCNSP(LINE,OFFSET,TEXT)
;.;
;.S TEXT="Use the Billing Provider (VAMC) Name and Street Address?: "_$$EXPAND^IBTRE(36,4.13,+$P(IBCNS4,U,13))
;.S LINE=LINE+1
;.D SET^IBCNSP(LINE,OFFSET,TEXT)
;.Q
;
S TEXT="Transmit no Billing Provider Sec. ID for the Electronic Plan Types: "
S LINE=LINE+1
D SET^IBCNSP(LINE,OFFSET,TEXT)
;
N TAR,ERR,IBCT
D LIST^DIC(36.013,","_IBCNS_",",".01",,10,,,,,,"TAR","ERR")
F IBCT=1:1:+$G(TAR("DILIST",0)) D
. S TEXT=TAR("DILIST",1,IBCT)
. S LINE=LINE+1
. D SET^IBCNSP(LINE,OFFSET,TEXT)
;
S LINE=LINE+1 D SET^IBCNSP(LINE,2," ")
S LINE=LINE+1 D SET^IBCNSP(LINE,2," ")
Q
;
INSDEF(IBINS,IBPTYP) ; Returns the default id # for an ins co, if possible
N X
S X=""
I IBINS,IBPTYP S X=$P($G(^IBA(355.91,+$O(^IBA(355.91,"AC",IBINS,IBPTYP,"*N/A*","")),0)),U,7)
Q X
;
CUIDS(IBCNS) ;
N DIE,DA,DR,PIECE,DAT6,Y
S DAT6=$P(^DIC(36,IBCNS,6),U,1,8) ; get the Payer IDs
;
; Make sure each qualifier has an ID and vice versa
F PIECE=1,3,5,7 D
. I $TR($P(DAT6,U,PIECE,PIECE+1),U)="" Q ; both blank
. I $P(DAT6,U,PIECE)]"",$P(DAT6,U,PIECE+1)]"" Q ; both have data
. S DIE="^DIC(36,",(DA,Y)=IBCNS,DR="6.0"_$S($P(DAT6,U,PIECE)]"":PIECE,1:PIECE+1)_"////@"
. D ^DIE K DIE
;
S DAT6=$P($G(^DIC(36,IBCNS,6)),U,1,8) ; get the Payer IDs again since they may have changed above.
;
; Make sure the first pair of ID/Qual are populated if the 2nd pair is. If not, move em over.
; This is done for institutional then professional
F PIECE=1,5 D
. I $P(DAT6,U,PIECE)]"" Q ; already has set one
. I $P(DAT6,U,PIECE+2)="" Q ; has no second set
. S DIE="^DIC(36,",(DA,Y)=IBCNS
. ; deleting the qualifier triggers deletion of the ID
. S DR="6.0"_PIECE_"////"_$P(DAT6,U,PIECE+2)_";6.0"_(PIECE+1)_"////"_$P(DAT6,U,PIECE+3)_";6.0"_(PIECE+2)_"////@"
. D ^DIE K DIE
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCNSC1 10419 printed Apr 09, 2024@21:06:19 Page 2
IBCNSC1 ;ALB/NLR - IBCNS INSURANCE COMPANY ;23-MAR-93
+1 ;;2.0;INTEGRATED BILLING;**62,137,232,291,320,348,349,371,400,519,516,547,592**;21-MAR-94;Build 58
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;
% GOTO EN^IBCNSC
+1 ;
AI ; -- (In)Activate Company
+1 DO FULL^VALM1
WRITE !!
+2 IF '$DATA(^XUSEC("IB INSURANCE SUPERVISOR",DUZ))
DO SORRY
GOTO EXIT
+3 DO ^IBCNSC2
+4 GOTO EXIT
CC ; -- Change Insurance Company
+1 DO FULL^VALM1
WRITE !!
+2 SET IBCNS1=IBCNS
KILL IBCNS
DO INSCO^IBCNSC
+3 IF '$DATA(IBCNS)
SET IBCNS=IBCNS1
+4 KILL IBCNS1,VALMQUIT
+5 GOTO EXIT
EA ; -- Billing,Claims,Appeals,Inquiry,Telephone,Main,Remarks,Synonyms
+1 DO FULL^VALM1
+2 ;
+3 ; IB*2*320 - check key for associate company action
+4 IF $GET(IBY)=",13,"
IF '$$KCHK^XUSRB("IB EDI INSURANCE EDIT")
Begin DoDot:1
+5 WRITE !!?5,"You must hold the IB EDI INSURANCE EDIT key to access this option."
+6 DO PAUSE^VALM1
+7 QUIT
End DoDot:1
GOTO EXIT
+8 ;
+9 WRITE !!
+10 DO MAIN
+11 ;
+12 ; -- was company deleted
+13 IF '$DATA(^DIC(36,IBCNS))
WRITE !!,"<DELETED>",!!
SET VALMQUIT=""
QUIT
+14 ;
EXIT ;
+1 DO HDR^IBCNSC
DO BLD^IBCNSC
+2 SET VALMBCK="R"
+3 QUIT
MAIN ; -- Call edit template
+1 NEW IBEDIKEY,Z
+2 LOCK +^DIC(36,+IBCNS):5
IF '$TEST
DO LOCKED^IBTRCD1
GOTO MAINQ
+3 IF $GET(IBY)=",12,"
DO FACID
+4 ;JWS;IB*2.0*592;add field .15 (piece 15) Dental EDI Payer ID
+5 ;IA# 5292
+6 ; save EDI data fields
FOR Z=1,2,4,9,13,14,15
SET IBEDIKEY(Z)=$PIECE($GET(^DIC(36,+IBCNS,3)),U,Z)
+7 ; save EDI data fields
FOR Z=1:1:8
SET IBEDIKEY(Z,6)=$PIECE($GET(^DIC(36,+IBCNS,6)),U,Z)
+8 IF $GET(IBY)'=",12,"
NEW DIE,DA,DR
SET DIE="^DIC(36,"
SET (DA,Y)=IBCNS
SET DR="[IBEDIT INS CO1]"
DO ^DIE
KILL DIE
if $DATA(Y)
SET IB("^")=1
if $TRANSLATE($PIECE($GET(^DIC(36,IBCNS,6)),U,1,8),U)]""
DO CUIDS(IBCNS)
+9 IF $GET(IBY)=",12,"
DO EDITID^IBCEP(+IBCNS)
+10 ;clean up any errant nodes on alternate payert IDS
IF $FIND(",6,1,",$GET(IBY))
DO CLEANIDS^IBCNSC(+IBCNS)
+11 ; parent/child management
IF $FIND(",6,13,",$GET(IBY))
DO PARENT^IBCNSC02(+IBCNS)
+12 LOCK -^DIC(36,+IBCNS)
+13 ; IB*2.0*519: If field 3.02 or 3.04 has changed, trigger HL7 to update the NIF
+14 IF (IBEDIKEY(2)'=$PIECE($GET(^DIC(36,+IBCNS,3)),U,2))!(IBEDIKEY(4)'=$PIECE($GET(^DIC(36,+IBCNS,3)),U,4))
DO EXR^IBCNHUT1(IBCNS)
DO SEND^IBCNHHLO(IBCNS)
MAINQ QUIT
+1 ;
FACID ; -- Edit facility ids
+1 DO FACID^IBCEP2B(+IBCNS,"E")
+2 QUIT
+3 ;
SORRY ; -- can't inactivate, don't have key
+1 WRITE !!,"You do not have access to Inactivate entries. See your application coordinator.",!
DO PAUSE^VALM1
+2 QUIT
PRESCR ;
+1 NEW OFFSET,START,IBCNS18,IBADD
+2 ;
+3 ;WCJ;IB*2.0*547;Call New API
+4 ;S IBCNS18=$$ADDRESS^IBCNSC0(IBCNS,.18,11)
+5 SET IBCNS18=$$ADD2^IBCNSC0(IBCNS,.18,11)
+6 ;
+7 ;WCJ;IB*2.0*547
+8 ;S START=41,OFFSET=2
+9 SET START=42+(2*$GET(IBACMAX))
SET OFFSET=2
PRESCRAD ; KDM US2487 IB*2.0*592 call in tag from IBCNSI
+1 DO SET^IBCNSP(START,OFFSET+19," Prescription Claims Office Information ",IORVON,IORVOFF)
+2 DO SET^IBCNSP(START+1,OFFSET," Company Name: "_$PIECE($GET(^DIC(36,+$PIECE(IBCNS18,"^",7),0)),"^",1))
+3 DO SET^IBCNSP(START+2,OFFSET," Street: "_$PIECE(IBCNS18,"^",1))
+4 DO SET^IBCNSP(START+3,OFFSET," Street 2: "_$PIECE(IBCNS18,"^",2))
+5 ; D SET^IBCNSP(START+4,OFFSET,"Claim Off. ID: "_$P(IBCNS18,"^",11))
+6 SET OFFSET=45
+7 DO SET^IBCNSP(START+1,OFFSET," Street 3: "_$PIECE(IBCNS18,"^",3))
SET IBADD=1
+8 DO SET^IBCNSP(START+1+IBADD,OFFSET," City/State: "_$EXTRACT($PIECE(IBCNS18,"^",4),1,15)_$SELECT($PIECE(IBCNS18,"^",4)="":"",1:", ")_$PIECE($GET(^DIC(5,+$PIECE(IBCNS18,"^",5),0)),"^",2)_" "_$EXTRACT($PIECE(IBCNS18,"^",6),1,5))
+9 DO SET^IBCNSP(START+2+IBADD,OFFSET," Phone: "_$PIECE(IBCNS18,"^",8))
+10 DO SET^IBCNSP(START+3+IBADD,OFFSET," Fax: "_$PIECE(IBCNS18,"^",9))
+11 QUIT
+12 ;
PROVID NEW OFFSET,START,IBCNS4,IBCNS3,IBDISP,Z,LINE
+1 SET START=$ORDER(^TMP("IBCNSC",$JOB,""),-1)+1
+2 SET (IB1ST("PROVID"),LINE)=START
+3 SET OFFSET=2
SET IBCNS4=$GET(^DIC(36,IBCNS,4))
SET IBCNS3=$GET(^(3))
+4 ;
+5 DO SET^IBCNSP(LINE,OFFSET+25,"Provider IDs",IORVON,IORVOFF)
+6 SET LINE=LINE+1
SET OFFSET=1
+7 DO SET^IBCNSP(LINE,OFFSET,"Billing Provider Secondary ID")
+8 ;
+9 NEW Z,Z0,Z1,IBS,I,DIV,FT,CU,CUF,DIVISION,FORMTYPE,PIDT
+10 SET Z=0
FOR
SET Z=$ORDER(^IBA(355.92,"B",+IBCNS,Z))
if 'Z
QUIT
Begin DoDot:1
+11 SET Z0=$GET(^IBA(355.92,Z,0))
+12 ; Quit if no provider id or id type
if '$PIECE(Z0,U,6)!($PIECE(Z0,U,7)="")
QUIT
+13 if '($PIECE(Z0,U,8)="E")
QUIT
+14 SET IBS(+$PIECE(Z0,U,5),+$PIECE(Z0,U,3),+$PIECE(Z0,U,4))=$PIECE(Z0,U,6)_U_$PIECE(Z0,U,7)
End DoDot:1
+15 ;
+16 SET DIV=""
FOR
SET DIV=$ORDER(IBS(DIV))
if DIV=""
QUIT
Begin DoDot:1
+17 SET DIVISION=$$DIV^IBCEP7(DIV)
+18 SET CU=""
SET CUF=0
FOR
SET CU=$ORDER(IBS(DIV,CU))
if CU=""
QUIT
Begin DoDot:2
+19 SET FT=""
FOR
SET FT=$ORDER(IBS(DIV,CU,FT))
if FT=""
QUIT
Begin DoDot:3
+20 SET FORMTYPE=$SELECT(FT=1:"UB-04",FT=2:"1500",1:"UNKNOWN")
+21 SET LINE=LINE+1
+22 IF 'CUF
IF +CU
SET CUF=1
SET TEXT=$PIECE(DIVISION,"/")_" Care Units :"
SET OFFSET=5
DO SET^IBCNSP(LINE,OFFSET,TEXT)
SET LINE=LINE+1
+23 IF CU=0
SET TEXT=DIVISION_"/"_FORMTYPE_": "_$$GET1^DIQ(355.97,$PIECE(IBS(DIV,CU,FT),U),.03,"E")_" "_$PIECE(IBS(DIV,CU,FT),U,2)
SET OFFSET=2
+24 IF +CU
SET TEXT=$$EXPAND^IBTRE(355.92,.03,CU)_"/"_FORMTYPE_": "_$$GET1^DIQ(355.97,$PIECE(IBS(DIV,CU,FT),U),.03,"E")_" "_$PIECE(IBS(DIV,CU,FT),U,2)
SET OFFSET=5
+25 DO SET^IBCNSP(LINE,OFFSET,TEXT)
End DoDot:3
End DoDot:2
End DoDot:1
+26 ;
+27 SET LINE=LINE+1
DO SET^IBCNSP(LINE,2," ")
+28 ;
+29 KILL IBS
+30 SET OFFSET=1
SET LINE=LINE+1
+31 DO SET^IBCNSP(LINE,OFFSET,"Additional Billing Provider Secondary IDs")
+32 SET Z=0
FOR
SET Z=$ORDER(^IBA(355.92,"B",+IBCNS,Z))
if 'Z
QUIT
Begin DoDot:1
+33 SET Z0=$GET(^IBA(355.92,Z,0))
+34 ; Quit if no provider id or id type
if '$PIECE(Z0,U,6)!($PIECE(Z0,U,7)="")
QUIT
+35 if '($PIECE(Z0,U,8)="A")
QUIT
+36 ; IBS(DIVISION,FORMTYPE,IDTYPE)=ID
+37 SET IBS(+$PIECE(Z0,U,5),+$PIECE(Z0,U,4),+$PIECE(Z0,U,6))=$PIECE(Z0,U,7)
End DoDot:1
+38 ;
+39 SET DIVISION=$$DIV^IBCEP7(0)
+40 SET DIV=""
FOR
SET DIV=$ORDER(IBS(DIV))
if DIV=""
QUIT
Begin DoDot:1
+41 SET FT=""
FOR
SET FT=$ORDER(IBS(DIV,FT))
if FT=""
QUIT
Begin DoDot:2
+42 SET FORMTYPE=$SELECT(FT=1:"UB-04",FT=2:"1500",1:"UNKNOWN")
+43 SET TEXT=DIVISION_"/"_FORMTYPE_": "
+44 SET LINE=LINE+1
SET OFFSET=2
+45 DO SET^IBCNSP(LINE,OFFSET,TEXT)
+46 SET PIDT=""
FOR
SET PIDT=$ORDER(IBS(DIV,FT,PIDT))
if PIDT=""
QUIT
Begin DoDot:3
+47 SET LINE=LINE+1
+48 SET TEXT=$$GET1^DIQ(355.97,PIDT,.03,"E")_" "_IBS(DIV,FT,PIDT)
SET OFFSET=5
+49 DO SET^IBCNSP(LINE,OFFSET,TEXT)
End DoDot:3
End DoDot:2
End DoDot:1
+50 ;
+51 SET LINE=LINE+1
DO SET^IBCNSP(LINE,2," ")
+52 ;
+53 KILL IBS
+54 SET OFFSET=1
SET LINE=LINE+1
+55 DO SET^IBCNSP(LINE,OFFSET,"VA-Laboratory or Facility Secondary IDs")
+56 SET Z=0
FOR
SET Z=$ORDER(^IBA(355.92,"B",+IBCNS,Z))
if 'Z
QUIT
Begin DoDot:1
+57 SET Z0=$GET(^IBA(355.92,Z,0))
+58 ; Quit if no provider id or id type
if '$PIECE(Z0,U,6)!($PIECE(Z0,U,7)="")
QUIT
+59 if '($PIECE(Z0,U,8)="LF")
QUIT
+60 ; IBS(DIVISION,FORMTYPE,IDTYPE)=ID
+61 SET IBS(+$PIECE(Z0,U,5),+$PIECE(Z0,U,4),+$PIECE(Z0,U,6))=$PIECE(Z0,U,7)
End DoDot:1
+62 ;
+63 SET DIVISION=$$DIV^IBCEP7(0)
+64 SET DIV=""
FOR
SET DIV=$ORDER(IBS(DIV))
if DIV=""
QUIT
Begin DoDot:1
+65 SET FT=""
FOR
SET FT=$ORDER(IBS(DIV,FT))
if FT=""
QUIT
Begin DoDot:2
+66 SET FORMTYPE=$SELECT(FT=1:"UB-04",FT=2:"1500",1:"UNKNOWN")
+67 SET TEXT=DIVISION_"/"_FORMTYPE_": "
+68 SET LINE=LINE+1
SET OFFSET=2
+69 DO SET^IBCNSP(LINE,OFFSET,TEXT)
+70 SET PIDT=""
FOR
SET PIDT=$ORDER(IBS(DIV,FT,PIDT))
if PIDT=""
QUIT
Begin DoDot:3
+71 SET LINE=LINE+1
+72 ;S TEXT=$$EXPAND^IBTRE(355.92,.06,PIDT)_" "_IBS(DIV,FT,PIDT),OFFSET=5
+73 SET TEXT=$$GET1^DIQ(355.97,PIDT,.03,"E")_" "_IBS(DIV,FT,PIDT)
SET OFFSET=5
+74 DO SET^IBCNSP(LINE,OFFSET,TEXT)
End DoDot:3
End DoDot:2
End DoDot:1
+75 ;
+76 SET LINE=LINE+1
DO SET^IBCNSP(LINE,2," ")
+77 SET LINE=LINE+1
DO SET^IBCNSP(LINE,2," ")
+78 SET OFFSET=2
+79 SET LINE=LINE+1
DO SET^IBCNSP(LINE,OFFSET+25,"ID Parameters",IORVON,IORVOFF)
+80 ;
+81 SET IBCNS4=$GET(^DIC(36,IBCNS,4))
SET IBCNS3=$GET(^(3))
SET OFFSET=1
+82 SET TEXT="Attending/Rendering Provider Secondary ID Qualifier (1500): "_$$EXPAND^IBTRE(36,4.01,+$PIECE(IBCNS4,U))
+83 SET LINE=LINE+1
+84 DO SET^IBCNSP(LINE,OFFSET,TEXT)
+85 ;
+86 SET TEXT="Attending/Rendering Provider Secondary ID Qualifier (UB-04): "_$$EXPAND^IBTRE(36,4.02,+$PIECE(IBCNS4,U,2))
+87 SET LINE=LINE+1
+88 DO SET^IBCNSP(LINE,OFFSET,TEXT)
+89 ;
+90 SET TEXT="Attending/Rendering Secondary ID Requirement: "_$$EXPAND^IBTRE(36,4.03,+$PIECE(IBCNS4,U,3))
+91 SET LINE=LINE+1
+92 DO SET^IBCNSP(LINE,OFFSET,TEXT)
+93 ;
+94 SET TEXT="Referring Provider Secondary ID Qualifier (1500): "_$$EXPAND^IBTRE(36,4.04,+$PIECE(IBCNS4,U,4))
+95 SET LINE=LINE+1
+96 DO SET^IBCNSP(LINE,OFFSET,TEXT)
+97 ;
+98 SET TEXT="Referring Provider Secondary ID Requirement: "_$$EXPAND^IBTRE(36,4.05,+$PIECE(IBCNS4,U,5))
+99 SET LINE=LINE+1
+100 DO SET^IBCNSP(LINE,OFFSET,TEXT)
+101 ;
+102 SET TEXT="Use Att/Rend ID as Billing Provider Sec. ID (1500): "_$$EXPAND^IBTRE(36,4.06,+$PIECE(IBCNS4,U,6))
+103 SET LINE=LINE+1
+104 DO SET^IBCNSP(LINE,OFFSET,TEXT)
+105 ;
+106 SET TEXT="Use Att/Rend ID as Billing Provider Sec. ID (UB-04): "_$$EXPAND^IBTRE(36,4.08,+$PIECE(IBCNS4,U,8))
+107 SET LINE=LINE+1
+108 DO SET^IBCNSP(LINE,OFFSET,TEXT)
+109 ;
+110 ; MRD;IB*2.0*516 - Marked fields 4.07, 4.11, 4.12 and 4.13 for
+111 ; deletion and removed all references to them.
+112 ;S TEXT="Always use main VAMC as Billing Provider (1500)?: "_$$EXPAND^IBTRE(36,4.11,+$P(IBCNS4,U,11))
+113 ;S LINE=LINE+1
+114 ;D SET^IBCNSP(LINE,OFFSET,TEXT)
+115 ;
+116 ;S TEXT="Always use main VAMC as Billing Provider (UB-04)?: "_$$EXPAND^IBTRE(36,4.12,+$P(IBCNS4,U,12))
+117 ;S LINE=LINE+1
+118 ;D SET^IBCNSP(LINE,OFFSET,TEXT)
+119 ;
+120 ;I $P(IBCNS4,U,11)!($P(IBCNS4,U,12)) D
+121 ;.S TEXT="Send VA Lab/Facility IDs or Facility Data for VAMC?: "_$$EXPAND^IBTRE(36,4.07,+$P(IBCNS4,U,7))
+122 ;.S LINE=LINE+1
+123 ;.D SET^IBCNSP(LINE,OFFSET,TEXT)
+124 ;.;
+125 ;.S TEXT="Use the Billing Provider (VAMC) Name and Street Address?: "_$$EXPAND^IBTRE(36,4.13,+$P(IBCNS4,U,13))
+126 ;.S LINE=LINE+1
+127 ;.D SET^IBCNSP(LINE,OFFSET,TEXT)
+128 ;.Q
+129 ;
+130 SET TEXT="Transmit no Billing Provider Sec. ID for the Electronic Plan Types: "
+131 SET LINE=LINE+1
+132 DO SET^IBCNSP(LINE,OFFSET,TEXT)
+133 ;
+134 NEW TAR,ERR,IBCT
+135 DO LIST^DIC(36.013,","_IBCNS_",",".01",,10,,,,,,"TAR","ERR")
+136 FOR IBCT=1:1:+$GET(TAR("DILIST",0))
Begin DoDot:1
+137 SET TEXT=TAR("DILIST",1,IBCT)
+138 SET LINE=LINE+1
+139 DO SET^IBCNSP(LINE,OFFSET,TEXT)
End DoDot:1
+140 ;
+141 SET LINE=LINE+1
DO SET^IBCNSP(LINE,2," ")
+142 SET LINE=LINE+1
DO SET^IBCNSP(LINE,2," ")
+143 QUIT
+144 ;
INSDEF(IBINS,IBPTYP) ; Returns the default id # for an ins co, if possible
+1 NEW X
+2 SET X=""
+3 IF IBINS
IF IBPTYP
SET X=$PIECE($GET(^IBA(355.91,+$ORDER(^IBA(355.91,"AC",IBINS,IBPTYP,"*N/A*","")),0)),U,7)
+4 QUIT X
+5 ;
CUIDS(IBCNS) ;
+1 NEW DIE,DA,DR,PIECE,DAT6,Y
+2 ; get the Payer IDs
SET DAT6=$PIECE(^DIC(36,IBCNS,6),U,1,8)
+3 ;
+4 ; Make sure each qualifier has an ID and vice versa
+5 FOR PIECE=1,3,5,7
Begin DoDot:1
+6 ; both blank
IF $TRANSLATE($PIECE(DAT6,U,PIECE,PIECE+1),U)=""
QUIT
+7 ; both have data
IF $PIECE(DAT6,U,PIECE)]""
IF $PIECE(DAT6,U,PIECE+1)]""
QUIT
+8 SET DIE="^DIC(36,"
SET (DA,Y)=IBCNS
SET DR="6.0"_$SELECT($PIECE(DAT6,U,PIECE)]"":PIECE,1:PIECE+1)_"////@"
+9 DO ^DIE
KILL DIE
End DoDot:1
+10 ;
+11 ; get the Payer IDs again since they may have changed above.
SET DAT6=$PIECE($GET(^DIC(36,IBCNS,6)),U,1,8)
+12 ;
+13 ; Make sure the first pair of ID/Qual are populated if the 2nd pair is. If not, move em over.
+14 ; This is done for institutional then professional
+15 FOR PIECE=1,5
Begin DoDot:1
+16 ; already has set one
IF $PIECE(DAT6,U,PIECE)]""
QUIT
+17 ; has no second set
IF $PIECE(DAT6,U,PIECE+2)=""
QUIT
+18 SET DIE="^DIC(36,"
SET (DA,Y)=IBCNS
+19 ; deleting the qualifier triggers deletion of the ID
+20 SET DR="6.0"_PIECE_"////"_$PIECE(DAT6,U,PIECE+2)_";6.0"_(PIECE+1)_"////"_$PIECE(DAT6,U,PIECE+3)_";6.0"_(PIECE+2)_"////@"
+21 DO ^DIE
KILL DIE
End DoDot:1
+22 QUIT
