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