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

IBCNSC01.m

Go to the documentation of this file. 
  1. IBCNSC01 ;ALB/NLR - INSURANCE COMPANY EDIT ;6/1/05 10:06am
  1.  ;;2.0;INTEGRATED BILLING;**52,137,191,184,232,320,349,371,399,416,432,494,519,547,592,608,668,687,713,778,794**;21-MAR-94;Build 9
  1.  ;;Per VA Directive 6402, this routine should not be modified.
  1.  ;
  1. PARAM ; -- Insurance company parameters region
  1.  N OFFSET,START,IBCNS0,IBCNS03,IBCNS06,IBCNS08,IBCNS13,IBCNS3,IBHPD,IBPPORT ;IB*784/CKB - added IBPPORT
  1.  S IBCNS0=$G(^DIC(36,+IBCNS,0)),IBCNS3=$G(^(3))
  1.  S IBCNS03=$P(IBCNS0,"^",3),IBCNS06=$P(IBCNS0,"^",6),IBCNS08=$P(IBCNS0,"^",8)
  1.  S IBCNS13=$G(^DIC(36,+IBCNS,.13))
  1.  S START=1,OFFSET=2
  1.  D SET^IBCNSP(START,OFFSET+25," Billing Parameters ",IORVON,IORVOFF)
  1.  ;
  1.  D SET^IBCNSP(START+1,OFFSET+1,"Signature Required?: "_$S(+IBCNS03:"YES",1:"NO"))
  1.  D SET^IBCNSP(START+2,OFFSET+10,"Reimburse?: "_$E($$EXPAND^IBTRE(36,1,$P(IBCNS0,"^",2)),1,21))
  1.  D SET^IBCNSP(START+3,OFFSET+3,"Mult. Bedsections: "_$S(+IBCNS06:"YES",IBCNS06=0:"NO",1:""))
  1.  D SET^IBCNSP(START+4,OFFSET+6,"One Opt. Visit: "_$S(+IBCNS08:"YES",1:"NO"))
  1.  ;IB*794/CKB - reorder screen, move Rec Codes, to allow for the 'Precert Portal'
  1.  D SET^IBCNSP(START+5,OFFSET+2,"Precert Comp. Name: "_$P($G(^DIC(36,+$P(IBCNS13,"^",9),0)),"^",1))
  1.  D SET^IBCNSP(START+6,OFFSET+7,"Precert Phone: "_$$PHONE(IBCNS13))
  1.  S IBPPORT=$$PORTAL(IBCNS13)
  1.  D SET^IBCNSP(START+7,OFFSET+6,"Precert Portal: "_$E(IBPPORT,1,55))
  1.  D SET^IBCNSP(START+8,OFFSET+21," "_$E(IBPPORT,56,80))
  1.  D SET^IBCNSP(START+9,OFFSET+3,"Filing Time Frame: "_$P(IBCNS0,"^",12)_$S(+$P(IBCNS0,"^",18):" ("_$$FTFN^IBCNSU31(,+IBCNS)_")",1:""))
  1.  D SET^IBCNSP(START+10,0," ") ;IB*794/CKB - blank line
  1.  I +IBCNS3=2 D SET^IBCNSP(START+10,OFFSET,"Max # Test Bills/Day: "_$P(IBCNS3,U,6))
  1.  ;
  1.  S OFFSET=45
  1.  D SET^IBCNSP(START+1,OFFSET+4,"Type Of Coverage: "_$$EXPAND^IBTRE(36,.13,+$P(IBCNS0,U,13)))
  1.  D SET^IBCNSP(START+2,OFFSET+7,"Billing Phone: "_$P(IBCNS13,"^",2))
  1.  D SET^IBCNSP(START+3,OFFSET+2,"Verification Phone: "_$P(IBCNS13,"^",4))
  1.  ;IB*794/CKB - moved Rev codes from above
  1.  D SET^IBCNSP(START+4,OFFSET+4,"Diff. Rev. Codes: "_$P(IBCNS0,"^",7))
  1.  D SET^IBCNSP(START+5,OFFSET+1,"Amb. Sur. Rev. Code: "_$P(IBCNS0,"^",9))
  1.  D SET^IBCNSP(START+6,OFFSET+1,"Rx Refill Rev. Code: "_$P(IBCNS0,"^",15))
  1.  ;
  1.  S START=12,OFFSET=2
  1.  D SET^IBCNSP(START,OFFSET+28," EDI Parameters ",IORVON,IORVOFF)
  1.  ;/IB*2*608 (vd) for US1909 changed the line below from "TEST ONLY" to "YES-TEST"
  1.  ;D SET^IBCNSP(START+1,OFFSET+13,"Transmit?: "_$S(+IBCNS3=1:"YES-LIVE",+IBCNS3=2:"TEST ONLY",$P(IBCNS3,U,1)="":"",1:"NO"))
  1.  D SET^IBCNSP(START+1,OFFSET+13,"Transmit?: "_$S(+IBCNS3=1:"YES-LIVE",+IBCNS3=2:"YES-TEST",$P(IBCNS3,U,1)="":"",1:"NO"))
  1.  D SET^IBCNSP(START+2,OFFSET+1,"Inst Payer Primary ID: "_$P(IBCNS3,U,4))
  1.  ;
  1.  ;WCJ;IB*2.0*547; Lots o Changes below to include new Alternate Primary ID
  1.  N IBAC,IBACND,LOOP
  1.  S IBACMAX=0
  1.  F IBACND=15,16 D
  1.  .S LOOP=0 F  S LOOP=$O(^DIC(36,+IBCNS,IBACND,LOOP)) Q:'+LOOP  D
  1.  ..S IBAC(IBACND,"CT")=$G(IBAC(IBACND,"CT"))+1 I IBAC(IBACND,"CT")>IBACMAX S IBACMAX=IBAC(IBACND,"CT")
  1.  ..S IBAC(IBACND,IBAC(IBACND,"CT"))=$P($G(^DIC(36,+IBCNS,IBACND,LOOP,0)),U,1,2)
  1.  ;
  1.  S LOOP=0 F  S LOOP=$O(IBAC(15,LOOP)) Q:'LOOP  D
  1.  .D SET^IBCNSP(START+2+(LOOP*2-1),OFFSET,"Alt-I Payer Prim ID Type: "_$$GET1^DIQ(355.98,+$P($G(IBAC(15,LOOP)),U),.01))
  1.  .D SET^IBCNSP(START+2+(LOOP*2),OFFSET,"Alt-Inst Payer Prim ID: "_$P($G(IBAC(15,LOOP)),U,2))
  1.  ;
  1.  D SET^IBCNSP(START+3+(2*IBACMAX),OFFSET,"Inst Payer Sec ID Qual: "_$$GET1^DIQ(36,+IBCNS,6.01))
  1.  D SET^IBCNSP(START+4+(2*IBACMAX),OFFSET+5,"Inst Payer Sec ID: "_$$GET1^DIQ(36,+IBCNS,6.02))
  1.  D SET^IBCNSP(START+5+(2*IBACMAX),OFFSET,"Inst Payer Sec ID Qual: "_$$GET1^DIQ(36,+IBCNS,6.03))
  1.  D SET^IBCNSP(START+6+(2*IBACMAX),OFFSET+5,"Inst Payer Sec ID: "_$$GET1^DIQ(36,+IBCNS,6.04))
  1.  ;
  1.  ;JWS;IB*2.0*592;Dental Payer ID, moved UMO ID and HPD down 1
  1.  D SET^IBCNSP(START+7+(2*IBACMAX),OFFSET+7,"Dental Payer ID: "_$P(IBCNS3,U,15))
  1.  D SET^IBCNSP(START+8+(2*IBACMAX),OFFSET+12,"Bin Number: "_$P($G(^DIC(36,+IBCNS,3)),"^",3))
  1.  ;IB*2.0*547;WCJ Added and bumped HPID down
  1.  D SET^IBCNSP(START+9+(2*IBACMAX),OFFSET+10,"UMO (278) ID: "_$P($G(^DIC(36,+IBCNS,7)),U))
  1.  ;ib*2.0*519
  1.  S IBHPD=$$HPD^IBCNHUT1(+IBCNS)
  1.  D SET^IBCNSP(START+10+(2*IBACMAX),OFFSET+13,$P($$HOD^IBCNHUT1(IBHPD),U,2)_": "_IBHPD)
  1.  ;
  1.  S OFFSET=41
  1.  D SET^IBCNSP(START+1,OFFSET+8," Insurance Type: "_$$EXPAND^IBTRE(36,3.09,+$P(IBCNS3,U,9)))
  1.  D SET^IBCNSP(START+2,OFFSET+1," Prof Payer Primary ID: "_$P(IBCNS3,U,2))
  1.  ;
  1.  S LOOP=0 F  S LOOP=$O(IBAC(16,LOOP)) Q:'LOOP  D
  1.  .D SET^IBCNSP(START+2+(LOOP*2-1),OFFSET+1,"Alt-P Payer Prim ID Type: "_$$GET1^DIQ(355.98,+$P($G(IBAC(16,LOOP)),U),.01))
  1.  .D SET^IBCNSP(START+2+(LOOP*2),OFFSET+1,"Alt-Prof Payer Prim ID: "_$P($G(IBAC(16,LOOP)),U,2))
  1.  ;
  1.  D SET^IBCNSP(START+3+(2*IBACMAX),OFFSET," Prof Payer Sec ID Qual: "_$$GET1^DIQ(36,+IBCNS,6.05))
  1.  D SET^IBCNSP(START+4+(2*IBACMAX),OFFSET+5," Prof Payer Sec ID: "_$$GET1^DIQ(36,+IBCNS,6.06))
  1.  D SET^IBCNSP(START+5+(2*IBACMAX),OFFSET," Prof Payer Sec ID Qual: "_$$GET1^DIQ(36,+IBCNS,6.07))
  1.  D SET^IBCNSP(START+6+(2*IBACMAX),OFFSET+5," Prof Payer Sec ID: "_$$GET1^DIQ(36,+IBCNS,6.08))
  1.  ;IB*2.0*432/TAZ Added fields 6.09 and 6.1
  1.  D SET^IBCNSP(START+8+(2*IBACMAX),OFFSET-3," Prnt Sec/Tert Auto Claims: "_$$GET1^DIQ(36,+IBCNS,6.09))
  1.  D SET^IBCNSP(START+9+(2*IBACMAX),OFFSET-5," Prnt Med Sec Claims w/o MRA: "_$$GET1^DIQ(36,+IBCNS,6.1))
  1.  Q
  1.  ;
  1. PHONE(IBCNS13) ; -- Compute precert company phone
  1.  N IBX,IBSAVE,IBCNT S IBX=""
  1.  I '$P(IBCNS13,"^",9) S IBX=$P(IBCNS13,"^",3) G PHONEQ
  1. REDOX S IBSAVE=+$P(IBCNS13,"^",9)
  1.  S IBCNT=$G(IBCNT)+1
  1.  ; -- if you process the same co. more than once you are in an infinite loop
  1.  I $D(IBCNT(IBCNS)) G PHONEQ
  1.  S IBCNT(IBCNS)=""
  1.  S IBCNS13=$G(^DIC(36,+$P(IBCNS13,"^",9),.13))
  1.  S IBX=$P(IBCNS13,"^") S:$L($P(IBCNS13,"^",3)) IBX=$P(IBCNS13,"^",3)
  1.  ; -- if process the same co. more than once you are in an infinite loop
  1.  I $P(IBCNS13,"^",9),$P(IBCNS13,"^",9)'=IBSAVE G REDOX
  1. PHONEQ Q IBX
  1.  ;
  1. PORTAL(IBCNS13)  ;IB*794/CKB - Compute precert portal
  1.  N IBX,IBSAVE,IBCNT
  1.  S IBX=""
  1.  ; if there isn't a PRECERT COMPANY NAME, use precert portal from current Insurance 
  1.  I '$P(IBCNS13,"^",9) S IBX=$P(IBCNS13,"^",12) G PORTALQ
  1. PORT ;
  1.  S IBSAVE=+$P(IBCNS13,"^",9)
  1.  S IBCNT=$G(IBCNT)+1
  1.  ; -- if you process the same co. more than once you are in an infinite loop
  1.  I $D(IBCNT(IBCNS)) G PORTALQ
  1.  S IBCNT(IBCNS)=""
  1.  S IBCNS13=$G(^DIC(36,+$P(IBCNS13,"^",9),.13))
  1.  S IBX=$P(IBCNS13,"^",12)
  1.  ; -- if process the same co. more than once you are in an infinite loop
  1.  I $P(IBCNS13,"^",9),$P(IBCNS13,"^",9)'=IBSAVE G PORT
  1. PORTALQ Q IBX
  1.  ;
  1. MAIN ; -- Insurance company main address
  1.  N OFFSET,START,IBCNS11,IBCNS13,IBADD
  1.  S IBCNS11=$G(^DIC(36,+IBCNS,.11))
  1.  S IBCNS13=$G(^DIC(36,+IBCNS,.13))
  1.  ;
  1.  ;S START=21,OFFSET=25
  1.  ;IB*794/CKB - fix display issue between here and MAINAD
  1.  ;S START=22+(2*IBACMAX),OFFSET=26 
  1.  S START=22+(2*IBACMAX) D SET^IBCNSP(START,0," ") ;blank line
  1.  S START=23+(2*IBACMAX),OFFSET=26
  1. MAINAD ; KDM US2487 IB*2.0*592  call in tag from IBCNSI
  1.  D SET^IBCNSP(START,OFFSET," Main Mailing Address ",IORVON,IORVOFF)
  1.  S OFFSET=2
  1.  D SET^IBCNSP(START+1,OFFSET,"       Street: "_$P(IBCNS11,"^",1)) S IBADD=1
  1.  D SET^IBCNSP(START+2,OFFSET,"     Street 2: "_$P(IBCNS11,"^",2)) S IBADD=2
  1.  D SET^IBCNSP(START+3,OFFSET,"     Street 3: "_$P(IBCNS11,"^",3)) S IBADD=3
  1.  ; D SET^IBCNSP(START+4,OFFSET,"Claim Off. ID: "_$P(IBCNS11,U,11))
  1.  S OFFSET=45
  1.  D SET^IBCNSP(START+1,OFFSET,"   City/State: "_$E($P(IBCNS11,"^",4),1,15)_$S($P(IBCNS11,"^",4)="":"",1:", ")_$P($G(^DIC(5,+$P(IBCNS11,"^",5),0)),"^",2)_" "_$E($P(IBCNS11,"^",6),1,5))
  1.  D SET^IBCNSP(START+2,OFFSET,"        Phone: "_$P(IBCNS13,"^",1))
  1.  D SET^IBCNSP(START+3,OFFSET,"          Fax: "_$P(IBCNS11,"^",9))
  1.  Q
  1.  ;
  1. PAYER ; This procedure builds the display for the payer associated with
  1.  ; this insurance company.
  1.  ; /vd-IB-2-687 - The following module has been restructured with new code to modify
  1.  ;                the display for how the payer and the "EIV" and "IIU" payer
  1.  ;                applications are displayed.
  1.  ; - 08/31/20 - IIU project
  1.  ; - 2/4/13 - remove ePharmacy references (IB*2*494)
  1.  ; - 9/9/09 - eIV updated
  1.  ; ESG - 7/29/02 - IIV project
  1.  ;
  1.  N APP,APPEIV,APPIIU,APPNAME,ARRAYEIV,ARRAYIIU,DEACTV8D,IBDATA,IBLINE,IENEIV,IENIIU,OFFSET,PIEN,PEINEIV,PEINIIU,START,TITLE
  1.  S PIEN=+$$GET1^DIQ(36,+IBCNS,3.10,"I"),DEACTV8D=0
  1.  S APPEIV=$$FIND1^DIC(365.13,,,"EIV"),APPIIU=$$FIND1^DIC(365.13,,,"IIU")
  1.  ;
  1.  S IBDATA=$G(^IBE(365.12,+PIEN,0))
  1.  S IENEIV=+$$PYRAPP^IBCNEUT5("EIV",+PIEN)   ; Get the ien of the EIV application
  1.  S IENIIU=+$$PYRAPP^IBCNEUT5("IIU",+PIEN)   ; Get the ien of the IIU application
  1.  ;
  1.  S (PEINEIV,PEINIIU)=""
  1.  I IENEIV D
  1.  . D PAYER^IBCNINSU(+PIEN,"EIV","*","I",.ARRAYEIV)   ; Get the Payer's EIV data.
  1.  . S PEINEIV=$O(ARRAYEIV(365.121,""))
  1.  I IENIIU D
  1.  . D PAYER^IBCNINSU(+PIEN,"IIU","*","I",.ARRAYIIU)   ; Get the Payer's IIU data.
  1.  . S PEINIIU=$O(ARRAYIIU(365.121,""))
  1.  ;
  1.  ; Display Payer data
  1.  S START=$O(^TMP("IBCNSC",$J,""),-1)+1
  1.  S IB1ST("PAYER")=START
  1.  S TITLE=" Payer: "_$P($G(IBDATA),U,1)
  1.  S OFFSET=(40-($L(TITLE)/2))\1+1
  1.  D SET^IBCNSP(START,OFFSET,TITLE,IORVON,IORVOFF)
  1.  ; IB*2.0*713/DTG - start add in set for a blank line for undef error when using SL
  1.  D SET^IBCNSP(START+1,2,"") ;blank line
  1.  ; IB*2.0*713/DTG - end add in set for a blank line for undef error when using SL
  1.  D SET^IBCNSP(START+2,5,"VA National ID: "_$P($G(IBDATA),U,2))
  1.  D SET^IBCNSP(START+2,51,"CMS National ID: "_$P($G(IBDATA),U,3))
  1.  ;
  1.  D SET^IBCNSP(START+3,2,"") ;IB*778/CKB - blank line
  1.  ;
  1.  I '$D(ARRAYEIV),'$D(ARRAYIIU) D  Q   ; Quit out if there is no payer data.
  1.  . D SET^IBCNSP(START+4,16,"Payer Application data is not defined!")
  1.  . D SET^IBCNSP(START+5,2,"") ;blank line
  1.  . S IBLINE=START+5
  1.  ;
  1.  S DEACTV8D=+$$PYRDEACT^IBCNINSU(+PIEN)   ; Deactivated status.
  1.  D SET^IBCNSP(START+3,8,"Deactivated: "_$$YESNO(+DEACTV8D))
  1.  S IBLINE=START+3
  1.  ;
  1.  ; If deactivated display date
  1.  I +DEACTV8D D
  1.  . D SET^IBCNSP(IBLINE,50,"Date Deactivated: "_$$FMTE^XLFDT($P($$GET1^DIQ(365.12,PIEN,.08,"I"),"."),"5Z"))
  1.  . S IBLINE=START+3
  1.  ;
  1.  ; Show eIV application data.
  1.  S IBLINE=IBLINE+1
  1.  D SET^IBCNSP(IBLINE,2,"") ;blank line
  1.  S IBLINE=IBLINE+1
  1.  D SET^IBCNSP(IBLINE,21,"Payer Application: eIV")   ; IB*2*416 - change external display to be eIV
  1.  I 'IENEIV D
  1.  . S IBLINE=IBLINE+1
  1.  . D SET^IBCNSP(IBLINE,16,"Payer Application data is not defined!")
  1.  I +IENEIV D
  1.  . S IBLINE=IBLINE+1
  1.  . D SET^IBCNSP(IBLINE,4,"Nationally Enabled: "_$$YESNO(ARRAYEIV(365.121,PEINEIV,.02,"I")))
  1.  . D SET^IBCNSP(IBLINE,51,"FSC Auto-Update: "_$$YESNO(ARRAYEIV(365.121,PEINEIV,4.01,"I")))
  1.  . ;
  1.  . S IBLINE=IBLINE+1
  1.  . D SET^IBCNSP(IBLINE,7,"Locally Enabled: "_$$YESNO(ARRAYEIV(365.121,PEINEIV,.03,"I")))
  1.  ;
  1.  ; Show IIU application data.
  1.  S IBLINE=IBLINE+1
  1.  D SET^IBCNSP(IBLINE,2,"") ;blank line
  1.  S IBLINE=IBLINE+1
  1.  D SET^IBCNSP(IBLINE,21,"Payer Application: IIU")
  1.  I 'IENIIU D
  1.  . S IBLINE=IBLINE+1
  1.  . D SET^IBCNSP(IBLINE,16,"Payer Application data is not defined!")
  1.  I +IENIIU D
  1.  . S IBLINE=IBLINE+1
  1.  . D SET^IBCNSP(IBLINE,4,"Nationally Enabled: "_$$YESNO(ARRAYIIU(365.121,PEINIIU,.02,"I")))
  1.  . D SET^IBCNSP(IBLINE,50,"Receive IIU Data: "_$$YESNO(ARRAYIIU(365.121,PEINIIU,5.01,"I")))
  1.  . ;
  1.  . S IBLINE=IBLINE+1
  1.  . D SET^IBCNSP(IBLINE,7,"Locally Enabled: "_$$YESNO(ARRAYIIU(365.121,PEINIIU,.03,"I")))
  1.  ;
  1.  ; Two trailing blank lines after payer information display
  1.  S IBLINE=IBLINE+1
  1.  D SET^IBCNSP(IBLINE,2," ") ; blank line
  1.  S IBLINE=IBLINE+1
  1.  D SET^IBCNSP(IBLINE,2," ") ; blank line
  1.  Q
  1.  ;/vd - IB-2-687 - End of newly structured code.
  1.  ;
  1. REMARKS ;
  1.  ;
  1.  N OFFSET,START,IBLCNT,IBI
  1.  S START=$O(^TMP("IBCNSC",$J,""),-1)+1,OFFSET=2
  1.  S IB1ST("REM")=START
  1.  ;
  1.  D SET^IBCNSP(START,OFFSET," Remarks ",IORVON,IORVOFF)
  1.  S (IBLCNT,IBI)=0 F  S IBI=$O(^DIC(36,+IBCNS,11,IBI)) Q:IBI<1  D
  1.  . S IBLCNT=IBLCNT+1
  1.  . D SET^IBCNSP(START+IBLCNT,OFFSET,"  "_$E($G(^DIC(36,+IBCNS,11,IBI,0)),1,80))
  1.  . Q
  1.  D SET^IBCNSP(START+IBLCNT+1,OFFSET," ")   ; blank line after remarks
  1.  Q
  1.  ;
  1. SYN ;
  1.  N OFFSET,START,SYN,SYNOI
  1.  S START=$O(^TMP("IBCNSC",$J,""),-1)+1,OFFSET=2
  1.  S IB1ST("SYN")=START
  1.  D SET^IBCNSP(START,OFFSET," Synonyms ",IORVON,IORVOFF)
  1.  S SYN="" F SYNOI=1:1:8 S SYN=$O(^DIC(36,+IBCNS,10,"B",SYN)) Q:SYN=""  D SET^IBCNSP(START+SYNOI,OFFSET,$S(SYNOI>7:"  ...edit to see more...",1:"  "_SYN))
  1.  Q
  1.  ;
  1. YESNO(VAL) ;Translate to a YES or NO value. - /vd - IB*2.0*687
  1.  ; INPUT:   VAL = Either 0 or 1
  1.  ; OUTPUT:  'YES' (for VAL=1), 'NO' (for VAL=0)
  1.  Q $S(VAL=1:"YES",1:"NO")