- 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 Feb 18, 2025@23:43:20 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