Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: IBCNSC1

IBCNSC1.m

Go to the documentation of this file.
  1. 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
  1. ;;Per VA Directive 6402, this routine should not be modified.
  1. ;
  1. % G EN^IBCNSC
  1. ;
  1. AI ; -- (In)Activate Company
  1. D FULL^VALM1 W !!
  1. I '$D(^XUSEC("IB INSURANCE SUPERVISOR",DUZ)) D SORRY G EXIT
  1. D ^IBCNSC2
  1. G EXIT
  1. CC ; -- Change Insurance Company
  1. D FULL^VALM1 W !!
  1. S IBCNS1=IBCNS K IBCNS D INSCO^IBCNSC
  1. I '$D(IBCNS) S IBCNS=IBCNS1
  1. K IBCNS1,VALMQUIT
  1. G EXIT
  1. EA ; -- Billing,Claims,Appeals,Inquiry,Telephone,Main,Remarks,Synonyms
  1. D FULL^VALM1
  1. ;
  1. ; IB*2*320 - check key for associate company action
  1. I $G(IBY)=",13,",'$$KCHK^XUSRB("IB EDI INSURANCE EDIT") D G EXIT
  1. . W !!?5,"You must hold the IB EDI INSURANCE EDIT key to access this option."
  1. . D PAUSE^VALM1
  1. . Q
  1. ;
  1. W !!
  1. D MAIN
  1. ;
  1. ; -- was company deleted
  1. I '$D(^DIC(36,IBCNS)) W !!,"<DELETED>",!! S VALMQUIT="" Q
  1. ;
  1. EXIT ;
  1. D HDR^IBCNSC,BLD^IBCNSC
  1. S VALMBCK="R"
  1. Q
  1. MAIN ; -- Call edit template
  1. N IBEDIKEY,Z
  1. L +^DIC(36,+IBCNS):5 I '$T D LOCKED^IBTRCD1 G MAINQ
  1. I $G(IBY)=",12," D FACID
  1. ;JWS;IB*2.0*592;add field .15 (piece 15) Dental EDI Payer ID
  1. ;IA# 5292
  1. F Z=1,2,4,9,13,14,15 S IBEDIKEY(Z)=$P($G(^DIC(36,+IBCNS,3)),U,Z) ; save EDI data fields
  1. F Z=1:1:8 S IBEDIKEY(Z,6)=$P($G(^DIC(36,+IBCNS,6)),U,Z) ; save EDI data fields
  1. 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)
  1. I $G(IBY)=",12," D EDITID^IBCEP(+IBCNS)
  1. I $F(",6,1,",$G(IBY)) D CLEANIDS^IBCNSC(+IBCNS) ;clean up any errant nodes on alternate payert IDS
  1. I $F(",6,13,",$G(IBY)) D PARENT^IBCNSC02(+IBCNS) ; parent/child management
  1. L -^DIC(36,+IBCNS)
  1. ; IB*2.0*519: If field 3.02 or 3.04 has changed, trigger HL7 to update the NIF
  1. 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)
  1. MAINQ Q
  1. ;
  1. FACID ; -- Edit facility ids
  1. D FACID^IBCEP2B(+IBCNS,"E")
  1. Q
  1. ;
  1. SORRY ; -- can't inactivate, don't have key
  1. W !!,"You do not have access to Inactivate entries. See your application coordinator.",! D PAUSE^VALM1
  1. Q
  1. PRESCR ;
  1. N OFFSET,START,IBCNS18,IBADD
  1. ;
  1. ;WCJ;IB*2.0*547;Call New API
  1. ;S IBCNS18=$$ADDRESS^IBCNSC0(IBCNS,.18,11)
  1. S IBCNS18=$$ADD2^IBCNSC0(IBCNS,.18,11)
  1. ;
  1. ;WCJ;IB*2.0*547
  1. ;S START=41,OFFSET=2
  1. S START=42+(2*$G(IBACMAX)),OFFSET=2
  1. PRESCRAD ; KDM US2487 IB*2.0*592 call in tag from IBCNSI
  1. D SET^IBCNSP(START,OFFSET+19," Prescription Claims Office Information ",IORVON,IORVOFF)
  1. D SET^IBCNSP(START+1,OFFSET," Company Name: "_$P($G(^DIC(36,+$P(IBCNS18,"^",7),0)),"^",1))
  1. D SET^IBCNSP(START+2,OFFSET," Street: "_$P(IBCNS18,"^",1))
  1. D SET^IBCNSP(START+3,OFFSET," Street 2: "_$P(IBCNS18,"^",2))
  1. ; D SET^IBCNSP(START+4,OFFSET,"Claim Off. ID: "_$P(IBCNS18,"^",11))
  1. S OFFSET=45
  1. D SET^IBCNSP(START+1,OFFSET," Street 3: "_$P(IBCNS18,"^",3)) S IBADD=1
  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))
  1. D SET^IBCNSP(START+2+IBADD,OFFSET," Phone: "_$P(IBCNS18,"^",8))
  1. D SET^IBCNSP(START+3+IBADD,OFFSET," Fax: "_$P(IBCNS18,"^",9))
  1. Q
  1. ;
  1. PROVID N OFFSET,START,IBCNS4,IBCNS3,IBDISP,Z,LINE
  1. S START=$O(^TMP("IBCNSC",$J,""),-1)+1
  1. S (IB1ST("PROVID"),LINE)=START
  1. S OFFSET=2,IBCNS4=$G(^DIC(36,IBCNS,4)),IBCNS3=$G(^(3))
  1. ;
  1. D SET^IBCNSP(LINE,OFFSET+25,"Provider IDs",IORVON,IORVOFF)
  1. S LINE=LINE+1,OFFSET=1
  1. D SET^IBCNSP(LINE,OFFSET,"Billing Provider Secondary ID")
  1. ;
  1. N Z,Z0,Z1,IBS,I,DIV,FT,CU,CUF,DIVISION,FORMTYPE,PIDT
  1. S Z=0 F S Z=$O(^IBA(355.92,"B",+IBCNS,Z)) Q:'Z D
  1. . S Z0=$G(^IBA(355.92,Z,0))
  1. . Q:'$P(Z0,U,6)!($P(Z0,U,7)="") ; Quit if no provider id or id type
  1. . Q:'($P(Z0,U,8)="E")
  1. . S IBS(+$P(Z0,U,5),+$P(Z0,U,3),+$P(Z0,U,4))=$P(Z0,U,6)_U_$P(Z0,U,7)
  1. ;
  1. S DIV="" F S DIV=$O(IBS(DIV)) Q:DIV="" D
  1. . S DIVISION=$$DIV^IBCEP7(DIV)
  1. . S CU="",CUF=0 F S CU=$O(IBS(DIV,CU)) Q:CU="" D
  1. .. S FT="" F S FT=$O(IBS(DIV,CU,FT)) Q:FT="" D
  1. ... S FORMTYPE=$S(FT=1:"UB-04",FT=2:"1500",1:"UNKNOWN")
  1. ... S LINE=LINE+1
  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
  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
  1. ... 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
  1. ... D SET^IBCNSP(LINE,OFFSET,TEXT)
  1. ;
  1. S LINE=LINE+1 D SET^IBCNSP(LINE,2," ")
  1. ;
  1. K IBS
  1. S OFFSET=1,LINE=LINE+1
  1. D SET^IBCNSP(LINE,OFFSET,"Additional Billing Provider Secondary IDs")
  1. S Z=0 F S Z=$O(^IBA(355.92,"B",+IBCNS,Z)) Q:'Z D
  1. . S Z0=$G(^IBA(355.92,Z,0))
  1. . Q:'$P(Z0,U,6)!($P(Z0,U,7)="") ; Quit if no provider id or id type
  1. . Q:'($P(Z0,U,8)="A")
  1. . ; IBS(DIVISION,FORMTYPE,IDTYPE)=ID
  1. . S IBS(+$P(Z0,U,5),+$P(Z0,U,4),+$P(Z0,U,6))=$P(Z0,U,7)
  1. ;
  1. S DIVISION=$$DIV^IBCEP7(0)
  1. S DIV="" F S DIV=$O(IBS(DIV)) Q:DIV="" D
  1. . S FT="" F S FT=$O(IBS(DIV,FT)) Q:FT="" D
  1. .. S FORMTYPE=$S(FT=1:"UB-04",FT=2:"1500",1:"UNKNOWN")
  1. .. S TEXT=DIVISION_"/"_FORMTYPE_": "
  1. .. S LINE=LINE+1,OFFSET=2
  1. .. D SET^IBCNSP(LINE,OFFSET,TEXT)
  1. .. S PIDT="" F S PIDT=$O(IBS(DIV,FT,PIDT)) Q:PIDT="" D
  1. ... S LINE=LINE+1
  1. ... S TEXT=$$GET1^DIQ(355.97,PIDT,.03,"E")_" "_IBS(DIV,FT,PIDT),OFFSET=5
  1. ... D SET^IBCNSP(LINE,OFFSET,TEXT)
  1. ;
  1. S LINE=LINE+1 D SET^IBCNSP(LINE,2," ")
  1. ;
  1. K IBS
  1. S OFFSET=1,LINE=LINE+1
  1. D SET^IBCNSP(LINE,OFFSET,"VA-Laboratory or Facility Secondary IDs")
  1. S Z=0 F S Z=$O(^IBA(355.92,"B",+IBCNS,Z)) Q:'Z D
  1. . S Z0=$G(^IBA(355.92,Z,0))
  1. . Q:'$P(Z0,U,6)!($P(Z0,U,7)="") ; Quit if no provider id or id type
  1. . Q:'($P(Z0,U,8)="LF")
  1. . ; IBS(DIVISION,FORMTYPE,IDTYPE)=ID
  1. . S IBS(+$P(Z0,U,5),+$P(Z0,U,4),+$P(Z0,U,6))=$P(Z0,U,7)
  1. ;
  1. S DIVISION=$$DIV^IBCEP7(0)
  1. S DIV="" F S DIV=$O(IBS(DIV)) Q:DIV="" D
  1. . S FT="" F S FT=$O(IBS(DIV,FT)) Q:FT="" D
  1. .. S FORMTYPE=$S(FT=1:"UB-04",FT=2:"1500",1:"UNKNOWN")
  1. .. S TEXT=DIVISION_"/"_FORMTYPE_": "
  1. .. S LINE=LINE+1,OFFSET=2
  1. .. D SET^IBCNSP(LINE,OFFSET,TEXT)
  1. .. S PIDT="" F S PIDT=$O(IBS(DIV,FT,PIDT)) Q:PIDT="" D
  1. ... S LINE=LINE+1
  1. ... ;S TEXT=$$EXPAND^IBTRE(355.92,.06,PIDT)_" "_IBS(DIV,FT,PIDT),OFFSET=5
  1. ... S TEXT=$$GET1^DIQ(355.97,PIDT,.03,"E")_" "_IBS(DIV,FT,PIDT),OFFSET=5
  1. ... D SET^IBCNSP(LINE,OFFSET,TEXT)
  1. ;
  1. S LINE=LINE+1 D SET^IBCNSP(LINE,2," ")
  1. S LINE=LINE+1 D SET^IBCNSP(LINE,2," ")
  1. S OFFSET=2
  1. S LINE=LINE+1 D SET^IBCNSP(LINE,OFFSET+25,"ID Parameters",IORVON,IORVOFF)
  1. ;
  1. S IBCNS4=$G(^DIC(36,IBCNS,4)),IBCNS3=$G(^(3)),OFFSET=1
  1. S TEXT="Attending/Rendering Provider Secondary ID Qualifier (1500): "_$$EXPAND^IBTRE(36,4.01,+$P(IBCNS4,U))
  1. S LINE=LINE+1
  1. D SET^IBCNSP(LINE,OFFSET,TEXT)
  1. ;
  1. S TEXT="Attending/Rendering Provider Secondary ID Qualifier (UB-04): "_$$EXPAND^IBTRE(36,4.02,+$P(IBCNS4,U,2))
  1. S LINE=LINE+1
  1. D SET^IBCNSP(LINE,OFFSET,TEXT)
  1. ;
  1. S TEXT="Attending/Rendering Secondary ID Requirement: "_$$EXPAND^IBTRE(36,4.03,+$P(IBCNS4,U,3))
  1. S LINE=LINE+1
  1. D SET^IBCNSP(LINE,OFFSET,TEXT)
  1. ;
  1. S TEXT="Referring Provider Secondary ID Qualifier (1500): "_$$EXPAND^IBTRE(36,4.04,+$P(IBCNS4,U,4))
  1. S LINE=LINE+1
  1. D SET^IBCNSP(LINE,OFFSET,TEXT)
  1. ;
  1. S TEXT="Referring Provider Secondary ID Requirement: "_$$EXPAND^IBTRE(36,4.05,+$P(IBCNS4,U,5))
  1. S LINE=LINE+1
  1. D SET^IBCNSP(LINE,OFFSET,TEXT)
  1. ;
  1. S TEXT="Use Att/Rend ID as Billing Provider Sec. ID (1500): "_$$EXPAND^IBTRE(36,4.06,+$P(IBCNS4,U,6))
  1. S LINE=LINE+1
  1. D SET^IBCNSP(LINE,OFFSET,TEXT)
  1. ;
  1. S TEXT="Use Att/Rend ID as Billing Provider Sec. ID (UB-04): "_$$EXPAND^IBTRE(36,4.08,+$P(IBCNS4,U,8))
  1. S LINE=LINE+1
  1. D SET^IBCNSP(LINE,OFFSET,TEXT)
  1. ;
  1. ; MRD;IB*2.0*516 - Marked fields 4.07, 4.11, 4.12 and 4.13 for
  1. ; deletion and removed all references to them.
  1. ;S TEXT="Always use main VAMC as Billing Provider (1500)?: "_$$EXPAND^IBTRE(36,4.11,+$P(IBCNS4,U,11))
  1. ;S LINE=LINE+1
  1. ;D SET^IBCNSP(LINE,OFFSET,TEXT)
  1. ;
  1. ;S TEXT="Always use main VAMC as Billing Provider (UB-04)?: "_$$EXPAND^IBTRE(36,4.12,+$P(IBCNS4,U,12))
  1. ;S LINE=LINE+1
  1. ;D SET^IBCNSP(LINE,OFFSET,TEXT)
  1. ;
  1. ;I $P(IBCNS4,U,11)!($P(IBCNS4,U,12)) D
  1. ;.S TEXT="Send VA Lab/Facility IDs or Facility Data for VAMC?: "_$$EXPAND^IBTRE(36,4.07,+$P(IBCNS4,U,7))
  1. ;.S LINE=LINE+1
  1. ;.D SET^IBCNSP(LINE,OFFSET,TEXT)
  1. ;.;
  1. ;.S TEXT="Use the Billing Provider (VAMC) Name and Street Address?: "_$$EXPAND^IBTRE(36,4.13,+$P(IBCNS4,U,13))
  1. ;.S LINE=LINE+1
  1. ;.D SET^IBCNSP(LINE,OFFSET,TEXT)
  1. ;.Q
  1. ;
  1. S TEXT="Transmit no Billing Provider Sec. ID for the Electronic Plan Types: "
  1. S LINE=LINE+1
  1. D SET^IBCNSP(LINE,OFFSET,TEXT)
  1. ;
  1. N TAR,ERR,IBCT
  1. D LIST^DIC(36.013,","_IBCNS_",",".01",,10,,,,,,"TAR","ERR")
  1. F IBCT=1:1:+$G(TAR("DILIST",0)) D
  1. . S TEXT=TAR("DILIST",1,IBCT)
  1. . S LINE=LINE+1
  1. . D SET^IBCNSP(LINE,OFFSET,TEXT)
  1. ;
  1. S LINE=LINE+1 D SET^IBCNSP(LINE,2," ")
  1. S LINE=LINE+1 D SET^IBCNSP(LINE,2," ")
  1. Q
  1. ;
  1. INSDEF(IBINS,IBPTYP) ; Returns the default id # for an ins co, if possible
  1. N X
  1. S X=""
  1. I IBINS,IBPTYP S X=$P($G(^IBA(355.91,+$O(^IBA(355.91,"AC",IBINS,IBPTYP,"*N/A*","")),0)),U,7)
  1. Q X
  1. ;
  1. CUIDS(IBCNS) ;
  1. N DIE,DA,DR,PIECE,DAT6,Y
  1. S DAT6=$P(^DIC(36,IBCNS,6),U,1,8) ; get the Payer IDs
  1. ;
  1. ; Make sure each qualifier has an ID and vice versa
  1. F PIECE=1,3,5,7 D
  1. . I $TR($P(DAT6,U,PIECE,PIECE+1),U)="" Q ; both blank
  1. . I $P(DAT6,U,PIECE)]"",$P(DAT6,U,PIECE+1)]"" Q ; both have data
  1. . S DIE="^DIC(36,",(DA,Y)=IBCNS,DR="6.0"_$S($P(DAT6,U,PIECE)]"":PIECE,1:PIECE+1)_"////@"
  1. . D ^DIE K DIE
  1. ;
  1. S DAT6=$P($G(^DIC(36,IBCNS,6)),U,1,8) ; get the Payer IDs again since they may have changed above.
  1. ;
  1. ; Make sure the first pair of ID/Qual are populated if the 2nd pair is. If not, move em over.
  1. ; This is done for institutional then professional
  1. F PIECE=1,5 D
  1. . I $P(DAT6,U,PIECE)]"" Q ; already has set one
  1. . I $P(DAT6,U,PIECE+2)="" Q ; has no second set
  1. . S DIE="^DIC(36,",(DA,Y)=IBCNS
  1. . ; deleting the qualifier triggers deletion of the ID
  1. . S DR="6.0"_PIECE_"////"_$P(DAT6,U,PIECE+2)_";6.0"_(PIECE+1)_"////"_$P(DAT6,U,PIECE+3)_";6.0"_(PIECE+2)_"////@"
  1. . D ^DIE K DIE
  1. Q