IBCNSC ;ALB/NLR - INSURANCE COMPANY EDIT ;6/1/05 9:42am
;;2.0;INTEGRATED BILLING;**46,137,184,276,320,371,400,488,547,592,668,752,763**;21-MAR-94;Build 29
;;Per VA Directive 6402, this routine should not be modified.
;
;also used for IA #4694
;
EN ; -- main entry point for IBCNS INSURANCE COMPANY, IBCNS VIEW INS CO
NEW IB1ST
K IBFASTXT,VALMQUIT,VALMEVL,XQORS,^TMP("XQORS",$J),IBCNS
S IBCHANGE="OKAY"
I '$G(IBVIEW) D EN^VALM("IBCNS INSURANCE COMPANY") G ENQ
D EN^VALM("IBCNS VIEW INS CO")
ENQ Q
;
HDR ; -- header code
S VALMHDR(1)="Insurance Company Information for: "_$E($P(^DIC(36,IBCNS,0),"^"),1,30)
S VALMHDR(2)="Type of Company: "_$E($P($G(^IBE(355.2,+$P($G(^DIC(36,+IBCNS,0)),"^",13),0)),"^"),1,20)_" Currently "_$S(+($P($G(^DIC(36,+IBCNS,0)),"^",5)):"Inactive",1:"Active")
Q
;
INIT ; -- init variables and list array
K VALMQUIT
S VALMCNT=0,VALMBG=1
I '$D(IBCNS) D INSCO Q:$D(VALMQUIT)
D BLD,HDR
Q
BLD ; -- list builder
;WCJ;IB*2.0*547
;NEW BLNKI
NEW BLNKI,IBACMAX ; new variable set in PARAM section and needed throughout for display
;
K ^TMP("IBCNSC",$J)
D KILL^VALM10() ; delete all video attributes
F BLNKI=1:1:62 D BLANK(.BLNKI) ; 62 blank lines to start with
D PARAM^IBCNSC01 ; billing parameters
D MAIN^IBCNSC01 ; main mailing address
D CLAIMS1^IBCNSC0 ; inpatient claims office
D CLAIMS2^IBCNSC0 ; outpatient claims office
D PRESCR^IBCNSC1 ; prescription claims office
D APPEALS ; appeals office
D INQUIRY ; inquiry office
D DENTAL ; Dental Claims Office KDM US2487 IB*2.0*592
D DISP^IBCNSC02 ; parent/child associations (ESG 11/3/05)
D PROVID^IBCNSC1 ; provider IDs
D PAYER^IBCNSC01 ; payer/payer apps (ESG 7/29/02 IIV project)
D REMARKS^IBCNSC01 ; remarks
D SYN^IBCNSC01 ; synonyms
S VALMCNT=+$O(^TMP("IBCNSC",$J,""),-1)
Q
;
APPEALS ;
N OFFSET,START,IBCNS14,IBADD
;
;WCJ;IB*2.0*547;Call new API
;S IBCNS14=$$ADDRESS^IBCNSC0(IBCNS,.14,7)
;
;WCJ;IB*2.0*547
;S START=48,OFFSET=2
S START=49+(2*$G(IBACMAX)),OFFSET=2
APPEALAD ; KDM US2487 IB*2.0*592 call in tag from IBCNSI
S IBCNS14=$$ADD2^IBCNSC0(IBCNS,.14,7) ;KDM moved to be able to call into from IBCNSI
D SET^IBCNSP(START,OFFSET+25," Appeals Office Information ",IORVON,IORVOFF)
;IA# 5292
D SET^IBCNSP(START+1,OFFSET," Company Name: "_$P($G(^DIC(36,+$P(IBCNS14,"^",7),0)),"^",1))
D SET^IBCNSP(START+2,OFFSET," Street: "_$P(IBCNS14,"^",1))
D SET^IBCNSP(START+3,OFFSET," Street 2: "_$P(IBCNS14,"^",2))
N OFFSET S OFFSET=45
D SET^IBCNSP(START+1,OFFSET," Street 3: "_$P(IBCNS14,"^",3)) S IBADD=1
;IA# 650
D SET^IBCNSP(START+1+IBADD,OFFSET," City/State: "_$E($P(IBCNS14,"^",4),1,15)_$S($P(IBCNS14,"^",4)="":"",1:", ")_$P($G(^DIC(5,+$P(IBCNS14,"^",5),0)),"^",2)_" "_$E($P(IBCNS14,"^",6),1,5))
D SET^IBCNSP(START+2+IBADD,OFFSET," Phone: "_$P(IBCNS14,"^",8))
D SET^IBCNSP(START+3+IBADD,OFFSET," Fax: "_$P(IBCNS14,"^",9))
Q
;
INQUIRY ;
;
N OFFSET,START,IBCNS15,IBADD
;
;WCJ;IB*2.0*547;Call new API
;S IBCNS15=$$ADDRESS^IBCNSC0(IBCNS,.15,8)
;
;WCJ;IB*2.0*547
;S START=55,OFFSET=2
S START=56+(2*$G(IBACMAX)),OFFSET=2
INQAD ; KDM US2487 IB*2.0*592 call in tag from IBCNSI
S IBCNS15=$$ADD2^IBCNSC0(IBCNS,.15,8) ;KDM moved to be able to call into from IBCNSI
D SET^IBCNSP(START,OFFSET+25," Inquiry Office Information ",IORVON,IORVOFF)
;IA# 5292
D SET^IBCNSP(START+1,OFFSET," Company Name: "_$P($G(^DIC(36,+$P(IBCNS15,"^",7),0)),"^",1))
D SET^IBCNSP(START+2,OFFSET," Street: "_$P(IBCNS15,"^"))
D SET^IBCNSP(START+3,OFFSET," Street 2: "_$P(IBCNS15,"^",2))
N OFFSET S OFFSET=45
D SET^IBCNSP(START+1,OFFSET," Street 3: "_$P(IBCNS15,"^",3)) S IBADD=1
;IA# 650
D SET^IBCNSP(START+1+IBADD,OFFSET," City/State: "_$E($P(IBCNS15,"^",4),1,15)_$S($P(IBCNS15,"^",4)="":"",1:", ")_$P($G(^DIC(5,+$P(IBCNS15,"^",5),0)),"^",2)_" "_$E($P(IBCNS15,"^",6),1,5))
D SET^IBCNSP(START+2+IBADD,OFFSET," Phone: "_$P(IBCNS15,"^",8))
D SET^IBCNSP(START+3+IBADD,OFFSET," Fax: "_$P(IBCNS15,"^",9))
Q
;
DENTAL ; Display Dental Claims office information
;KDM US2487 IB*2.0*592
;
N OFFSET,START,IBCNS19,IBADD
S START=63+(2*$G(IBACMAX)),OFFSET=2
DENTALAD ; KDM US2487 IB*2.0*592 call in tag from IBCNSI
D SET^IBCNSP(START,OFFSET+20," Dental Claims Office Information ",IORVON,IORVOFF)
;
S IBCNS19=$$ADD2^IBCNSC0(IBCNS,.19,6)
;IA# 5292
D SET^IBCNSP(START+1,OFFSET," Company Name: "_$P($G(^DIC(36,+$P(IBCNS19,"^",7),0)),"^",1))
D SET^IBCNSP(START+2,OFFSET," Street: "_$P(IBCNS19,"^",1))
D SET^IBCNSP(START+3,OFFSET," Street 2: "_$P(IBCNS19,"^",2))
S OFFSET=45,IBADD=1
;IA# 650
D SET^IBCNSP(START+1+IBADD,OFFSET," City/State: "_$E($P(IBCNS19,"^",4),1,15)_$S($P(IBCNS19,"^",4)="":"",1:", ")_$P($G(^DIC(5,+$P(IBCNS19,"^",5),0)),"^",2)_" "_$E($P(IBCNS19,"^",6),1,5))
D SET^IBCNSP(START+2+IBADD,OFFSET," Phone: "_$P(IBCNS19,"^",8))
D SET^IBCNSP(START+3+IBADD,OFFSET," Fax: "_$P(IBCNS19,"^",9))
;/vd-IB*2.0*668 The following 2 lines were added to fix pre-mature ending of display.
D BLANK(START+4+IBADD)
D BLANK(START+5+IBADD)
Q
;
HELP ; -- help code
S X="?" D DISP^XQORM1 W !!
Q
;
EXIT ; -- exit code
K VALMQUIT,IBCNS,IBCHANGE,IBFASTXT
D CLEAN^VALM10
Q
;
INSCO ; -- select insurance company
;JWS;IB*2.0*592;new of DR
;IB*752/TAZ - Restructured to call new utility for case insensitive lookups
NEW ARRAY,DLAYGO,DIC,DR,X,Y,DTOUT,DUOUT,IBCNS3,SCR
I '$D(IBCNS) D G:$D(VALMQUIT) INSCOQ G:'$D(IBCNS) INSCO
. S SCR="I '$G(^DIC(36,+Y,5))"
. D INSOCAS^IBCNINSC(.ARRAY,1,,.SCR)
. I $D(ARRAY)>1 S IBCNS=$O(ARRAY("")) Q
. I ARRAY="^"!(ARRAY="") S VALMQUIT=1 Q
. S IBCNS=ARRAY
. ; Quit if lookup was successful
. ;I IBCNS Q ;IB*763/DTG removed in order to continue to add ins co. if failing the $D check above
. ; lookup was not successful, quit if View only.
. I $G(IBVIEW) W !,"Insurance Company not found." K IBCNS Q
. ; Add new entry in upper case only
. S DIC="^DIC(36,",DIC(0)="BEQZL",DLAYGO=36
. ;Force upper case before calling ^DIC before
. S X=$$UP^XLFSTR(ARRAY)
. D ^DIC K DIC
. I +Y<0 W !,"Insurance Company was not added." K IBCNS Q
. S IBCNS=+Y
. ; /Beginning of IB*2.0*488 (vd)
. I +IBCNS I $P($G(^DIC(36,+IBCNS,3)),"^",1)="" D ; Set default for EDI=Transmit? to YES-LIVE
.. S DR="3.01////1",DIE="^DIC(36,",DA=IBCNS D ^DIE K DIE
.. ; /End of IB*2.0*488 (vd)
I $G(IBCNS)<1 K IBCNS S VALMQUIT="" G INSCOQ
INSCOQ ;
K DIC
Q
;
BLANK(LINE) ; -- Build blank line
D SET^VALM10(.LINE,$J("",80))
Q
;
EDIKEY() ; input transform code to determine if user is allowed to edit
; certain fields in the insurance company file
NEW OK S OK=0
I $$KCHK^XUSRB("IB EDI INSURANCE EDIT") S OK=1 G EDIKEYX
D EN^DDIOL("You must hold the IB EDI INSURANCE EDIT security key to edit this field.",,"!!")
D EN^DDIOL("",,"!!?5")
EDIKEYX ;
Q OK
;
DUPQUAL(IBCNS,QUAL,FIELD) ; input transform to make sure that the same qualifier is not used twice for
; payer secondary IDs. There are two sets of fields in file 36 that can not be duplicated.
; 6.01 EDI INST SECONDARY ID QUAL(1) can not be the same as 6.03 EDI INST SECONDARY ID QUAL(2)
; 6.05 EDI PROF SECONDARY ID QUAL(1) can not be the same as 6.07 EDI PROF SECONDARY ID QUAL(2)
;
; Input:
; IBCNS is the insurance company internal number
; QUAL is the internal code of the value being input.
; FIELD is the field it is being compare with.
;
; Returns:
; TRUE/1 if they are the same (duplicate)
; FALSE/0 if they are not
;
Q:$G(QUAL)="" 0 ; should not happen because this is invoked as an input transform
Q:'+$G(IBCNS) 1 ; stop from editing through fileman
N DUP
S DUP=$$GET1^DIQ(36,+$G(IBCNS)_",",+$G(FIELD),"I")
D CLEAN^DILF
Q QUAL=DUP
;
;WCJ;IB*2.0*547
ALLOWED(IBAC) ; input transform to make sure that Administrative Contractor is set up in the site parameters.
; it will be set up for either commercial or medicare. Since the type is defined my the plan and we are at a higher
; level in the Insurance Company, we have to allow both.
; called from ^DD(36.015,.01,0) and ^DD(36.016,.01,0)
;
;3/17/2016 - A decision was made to limit which type is allowed by using the TYPE OF COVERAGE field. (TAZ)
;
;
; Input:
; IBAC is the internal code of the value being input.
;
; Returns:
; TRUE/1 if allowed (set up in site parameters)
; FALSE/0 if they are not
;
Q:$D(^IBE(350.9,1,$S($$GET1^DIQ(36,IBCNS_",","TYPE OF COVERAGE")="MEDICARE":81,1:82),"B",IBAC)) 1
Q 0
;
; WCJ;IB*2.0*547
; This is to clean up any extraneous nodes if a user entered an alternate ID type, but not an actual ID.
CLEANIDS(INSIEN) ;
; INSIEN=Insurance Company IEN
;
N NODE,LOOP,DATA,CLEANUP
F NODE=15,16 D
.S LOOP=0 F S LOOP=$O(^DIC(36,INSIEN,NODE,LOOP)) Q:'+LOOP S DATA=$G(^(LOOP,0)) I DATA]"",$P(DATA,U,2)="" D
..N DIK,DA
..S DA=LOOP,DA(1)=INSIEN
..S DIK="^DIC(36,"_INSIEN_","_NODE_","
..D ^DIK
..S CLEANUP=1
I $G(CLEANUP) D
. N DIR
. S DIR("A",1)="Payer ID Types without corresponding ID# were deleted."
. S DIR(0)="EA",DIR("A")="PRESS ENTER TO CONTINUE "
. D ^DIR
.Q
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCNSC 9362 printed Dec 13, 2024@02:16:52 Page 2
IBCNSC ;ALB/NLR - INSURANCE COMPANY EDIT ;6/1/05 9:42am
+1 ;;2.0;INTEGRATED BILLING;**46,137,184,276,320,371,400,488,547,592,668,752,763**;21-MAR-94;Build 29
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;
+4 ;also used for IA #4694
+5 ;
EN ; -- main entry point for IBCNS INSURANCE COMPANY, IBCNS VIEW INS CO
+1 NEW IB1ST
+2 KILL IBFASTXT,VALMQUIT,VALMEVL,XQORS,^TMP("XQORS",$JOB),IBCNS
+3 SET IBCHANGE="OKAY"
+4 IF '$GET(IBVIEW)
DO EN^VALM("IBCNS INSURANCE COMPANY")
GOTO ENQ
+5 DO EN^VALM("IBCNS VIEW INS CO")
ENQ QUIT
+1 ;
HDR ; -- header code
+1 SET VALMHDR(1)="Insurance Company Information for: "_$EXTRACT($PIECE(^DIC(36,IBCNS,0),"^"),1,30)
+2 SET VALMHDR(2)="Type of Company: "_$EXTRACT($PIECE($GET(^IBE(355.2,+$PIECE($GET(^DIC(36,+IBCNS,0)),"^",13),0)),"^"),1,20)_" Currently "_$SELECT(+($PIECE($GET(^DIC(36,+IBCNS,0)),"^",5)):"Inactive",1:"Active")
+3 QUIT
+4 ;
INIT ; -- init variables and list array
+1 KILL VALMQUIT
+2 SET VALMCNT=0
SET VALMBG=1
+3 IF '$DATA(IBCNS)
DO INSCO
if $DATA(VALMQUIT)
QUIT
+4 DO BLD
DO HDR
+5 QUIT
BLD ; -- list builder
+1 ;WCJ;IB*2.0*547
+2 ;NEW BLNKI
+3 ; new variable set in PARAM section and needed throughout for display
NEW BLNKI,IBACMAX
+4 ;
+5 KILL ^TMP("IBCNSC",$JOB)
+6 ; delete all video attributes
DO KILL^VALM10()
+7 ; 62 blank lines to start with
FOR BLNKI=1:1:62
DO BLANK(.BLNKI)
+8 ; billing parameters
DO PARAM^IBCNSC01
+9 ; main mailing address
DO MAIN^IBCNSC01
+10 ; inpatient claims office
DO CLAIMS1^IBCNSC0
+11 ; outpatient claims office
DO CLAIMS2^IBCNSC0
+12 ; prescription claims office
DO PRESCR^IBCNSC1
+13 ; appeals office
DO APPEALS
+14 ; inquiry office
DO INQUIRY
+15 ; Dental Claims Office KDM US2487 IB*2.0*592
DO DENTAL
+16 ; parent/child associations (ESG 11/3/05)
DO DISP^IBCNSC02
+17 ; provider IDs
DO PROVID^IBCNSC1
+18 ; payer/payer apps (ESG 7/29/02 IIV project)
DO PAYER^IBCNSC01
+19 ; remarks
DO REMARKS^IBCNSC01
+20 ; synonyms
DO SYN^IBCNSC01
+21 SET VALMCNT=+$ORDER(^TMP("IBCNSC",$JOB,""),-1)
+22 QUIT
+23 ;
APPEALS ;
+1 NEW OFFSET,START,IBCNS14,IBADD
+2 ;
+3 ;WCJ;IB*2.0*547;Call new API
+4 ;S IBCNS14=$$ADDRESS^IBCNSC0(IBCNS,.14,7)
+5 ;
+6 ;WCJ;IB*2.0*547
+7 ;S START=48,OFFSET=2
+8 SET START=49+(2*$GET(IBACMAX))
SET OFFSET=2
APPEALAD ; KDM US2487 IB*2.0*592 call in tag from IBCNSI
+1 ;KDM moved to be able to call into from IBCNSI
SET IBCNS14=$$ADD2^IBCNSC0(IBCNS,.14,7)
+2 DO SET^IBCNSP(START,OFFSET+25," Appeals Office Information ",IORVON,IORVOFF)
+3 ;IA# 5292
+4 DO SET^IBCNSP(START+1,OFFSET," Company Name: "_$PIECE($GET(^DIC(36,+$PIECE(IBCNS14,"^",7),0)),"^",1))
+5 DO SET^IBCNSP(START+2,OFFSET," Street: "_$PIECE(IBCNS14,"^",1))
+6 DO SET^IBCNSP(START+3,OFFSET," Street 2: "_$PIECE(IBCNS14,"^",2))
+7 NEW OFFSET
SET OFFSET=45
+8 DO SET^IBCNSP(START+1,OFFSET," Street 3: "_$PIECE(IBCNS14,"^",3))
SET IBADD=1
+9 ;IA# 650
+10 DO SET^IBCNSP(START+1+IBADD,OFFSET," City/State: "_$EXTRACT($PIECE(IBCNS14,"^",4),1,15)_$SELECT($PIECE(IBCNS14,"^",4)="":"",1:", ")_$PIECE($GET(^DIC(5,+$PIECE(IBCNS14,"^",5),0)),"^",2)_" "_$EXTRACT($PIECE(IBCNS14,"^",6),1,5))
+11 DO SET^IBCNSP(START+2+IBADD,OFFSET," Phone: "_$PIECE(IBCNS14,"^",8))
+12 DO SET^IBCNSP(START+3+IBADD,OFFSET," Fax: "_$PIECE(IBCNS14,"^",9))
+13 QUIT
+14 ;
INQUIRY ;
+1 ;
+2 NEW OFFSET,START,IBCNS15,IBADD
+3 ;
+4 ;WCJ;IB*2.0*547;Call new API
+5 ;S IBCNS15=$$ADDRESS^IBCNSC0(IBCNS,.15,8)
+6 ;
+7 ;WCJ;IB*2.0*547
+8 ;S START=55,OFFSET=2
+9 SET START=56+(2*$GET(IBACMAX))
SET OFFSET=2
INQAD ; KDM US2487 IB*2.0*592 call in tag from IBCNSI
+1 ;KDM moved to be able to call into from IBCNSI
SET IBCNS15=$$ADD2^IBCNSC0(IBCNS,.15,8)
+2 DO SET^IBCNSP(START,OFFSET+25," Inquiry Office Information ",IORVON,IORVOFF)
+3 ;IA# 5292
+4 DO SET^IBCNSP(START+1,OFFSET," Company Name: "_$PIECE($GET(^DIC(36,+$PIECE(IBCNS15,"^",7),0)),"^",1))
+5 DO SET^IBCNSP(START+2,OFFSET," Street: "_$PIECE(IBCNS15,"^"))
+6 DO SET^IBCNSP(START+3,OFFSET," Street 2: "_$PIECE(IBCNS15,"^",2))
+7 NEW OFFSET
SET OFFSET=45
+8 DO SET^IBCNSP(START+1,OFFSET," Street 3: "_$PIECE(IBCNS15,"^",3))
SET IBADD=1
+9 ;IA# 650
+10 DO SET^IBCNSP(START+1+IBADD,OFFSET," City/State: "_$EXTRACT($PIECE(IBCNS15,"^",4),1,15)_$SELECT($PIECE(IBCNS15,"^",4)="":"",1:", ")_$PIECE($GET(^DIC(5,+$PIECE(IBCNS15,"^",5),0)),"^",2)_" "_$EXTRACT($PIECE(IBCNS15,"^",6),1,5))
+11 DO SET^IBCNSP(START+2+IBADD,OFFSET," Phone: "_$PIECE(IBCNS15,"^",8))
+12 DO SET^IBCNSP(START+3+IBADD,OFFSET," Fax: "_$PIECE(IBCNS15,"^",9))
+13 QUIT
+14 ;
DENTAL ; Display Dental Claims office information
+1 ;KDM US2487 IB*2.0*592
+2 ;
+3 NEW OFFSET,START,IBCNS19,IBADD
+4 SET START=63+(2*$GET(IBACMAX))
SET OFFSET=2
DENTALAD ; KDM US2487 IB*2.0*592 call in tag from IBCNSI
+1 DO SET^IBCNSP(START,OFFSET+20," Dental Claims Office Information ",IORVON,IORVOFF)
+2 ;
+3 SET IBCNS19=$$ADD2^IBCNSC0(IBCNS,.19,6)
+4 ;IA# 5292
+5 DO SET^IBCNSP(START+1,OFFSET," Company Name: "_$PIECE($GET(^DIC(36,+$PIECE(IBCNS19,"^",7),0)),"^",1))
+6 DO SET^IBCNSP(START+2,OFFSET," Street: "_$PIECE(IBCNS19,"^",1))
+7 DO SET^IBCNSP(START+3,OFFSET," Street 2: "_$PIECE(IBCNS19,"^",2))
+8 SET OFFSET=45
SET IBADD=1
+9 ;IA# 650
+10 DO SET^IBCNSP(START+1+IBADD,OFFSET," City/State: "_$EXTRACT($PIECE(IBCNS19,"^",4),1,15)_$SELECT($PIECE(IBCNS19,"^",4)="":"",1:", ")_$PIECE($GET(^DIC(5,+$PIECE(IBCNS19,"^",5),0)),"^",2)_" "_$EXTRACT($PIECE(IBCNS19,"^",6),1,5))
+11 DO SET^IBCNSP(START+2+IBADD,OFFSET," Phone: "_$PIECE(IBCNS19,"^",8))
+12 DO SET^IBCNSP(START+3+IBADD,OFFSET," Fax: "_$PIECE(IBCNS19,"^",9))
+13 ;/vd-IB*2.0*668 The following 2 lines were added to fix pre-mature ending of display.
+14 DO BLANK(START+4+IBADD)
+15 DO BLANK(START+5+IBADD)
+16 QUIT
+17 ;
HELP ; -- help code
+1 SET X="?"
DO DISP^XQORM1
WRITE !!
+2 QUIT
+3 ;
EXIT ; -- exit code
+1 KILL VALMQUIT,IBCNS,IBCHANGE,IBFASTXT
+2 DO CLEAN^VALM10
+3 QUIT
+4 ;
INSCO ; -- select insurance company
+1 ;JWS;IB*2.0*592;new of DR
+2 ;IB*752/TAZ - Restructured to call new utility for case insensitive lookups
+3 NEW ARRAY,DLAYGO,DIC,DR,X,Y,DTOUT,DUOUT,IBCNS3,SCR
+4 IF '$DATA(IBCNS)
Begin DoDot:1
+5 SET SCR="I '$G(^DIC(36,+Y,5))"
+6 DO INSOCAS^IBCNINSC(.ARRAY,1,,.SCR)
+7 IF $DATA(ARRAY)>1
SET IBCNS=$ORDER(ARRAY(""))
QUIT
+8 IF ARRAY="^"!(ARRAY="")
SET VALMQUIT=1
QUIT
+9 SET IBCNS=ARRAY
+10 ; Quit if lookup was successful
+11 ;I IBCNS Q ;IB*763/DTG removed in order to continue to add ins co. if failing the $D check above
+12 ; lookup was not successful, quit if View only.
+13 IF $GET(IBVIEW)
WRITE !,"Insurance Company not found."
KILL IBCNS
QUIT
+14 ; Add new entry in upper case only
+15 SET DIC="^DIC(36,"
SET DIC(0)="BEQZL"
SET DLAYGO=36
+16 ;Force upper case before calling ^DIC before
+17 SET X=$$UP^XLFSTR(ARRAY)
+18 DO ^DIC
KILL DIC
+19 IF +Y<0
WRITE !,"Insurance Company was not added."
KILL IBCNS
QUIT
+20 SET IBCNS=+Y
+21 ; /Beginning of IB*2.0*488 (vd)
+22 ; Set default for EDI=Transmit? to YES-LIVE
IF +IBCNS
IF $PIECE($GET(^DIC(36,+IBCNS,3)),"^",1)=""
Begin DoDot:2
+23 SET DR="3.01////1"
SET DIE="^DIC(36,"
SET DA=IBCNS
DO ^DIE
KILL DIE
+24 ; /End of IB*2.0*488 (vd)
End DoDot:2
End DoDot:1
if $DATA(VALMQUIT)
GOTO INSCOQ
if '$DATA(IBCNS)
GOTO INSCO
+25 IF $GET(IBCNS)<1
KILL IBCNS
SET VALMQUIT=""
GOTO INSCOQ
INSCOQ ;
+1 KILL DIC
+2 QUIT
+3 ;
BLANK(LINE) ; -- Build blank line
+1 DO SET^VALM10(.LINE,$JUSTIFY("",80))
+2 QUIT
+3 ;
EDIKEY() ; input transform code to determine if user is allowed to edit
+1 ; certain fields in the insurance company file
+2 NEW OK
SET OK=0
+3 IF $$KCHK^XUSRB("IB EDI INSURANCE EDIT")
SET OK=1
GOTO EDIKEYX
+4 DO EN^DDIOL("You must hold the IB EDI INSURANCE EDIT security key to edit this field.",,"!!")
+5 DO EN^DDIOL("",,"!!?5")
EDIKEYX ;
+1 QUIT OK
+2 ;
DUPQUAL(IBCNS,QUAL,FIELD) ; input transform to make sure that the same qualifier is not used twice for
+1 ; payer secondary IDs. There are two sets of fields in file 36 that can not be duplicated.
+2 ; 6.01 EDI INST SECONDARY ID QUAL(1) can not be the same as 6.03 EDI INST SECONDARY ID QUAL(2)
+3 ; 6.05 EDI PROF SECONDARY ID QUAL(1) can not be the same as 6.07 EDI PROF SECONDARY ID QUAL(2)
+4 ;
+5 ; Input:
+6 ; IBCNS is the insurance company internal number
+7 ; QUAL is the internal code of the value being input.
+8 ; FIELD is the field it is being compare with.
+9 ;
+10 ; Returns:
+11 ; TRUE/1 if they are the same (duplicate)
+12 ; FALSE/0 if they are not
+13 ;
+14 ; should not happen because this is invoked as an input transform
if $GET(QUAL)=""
QUIT 0
+15 ; stop from editing through fileman
if '+$GET(IBCNS)
QUIT 1
+16 NEW DUP
+17 SET DUP=$$GET1^DIQ(36,+$GET(IBCNS)_",",+$GET(FIELD),"I")
+18 DO CLEAN^DILF
+19 QUIT QUAL=DUP
+20 ;
+21 ;WCJ;IB*2.0*547
ALLOWED(IBAC) ; input transform to make sure that Administrative Contractor is set up in the site parameters.
+1 ; it will be set up for either commercial or medicare. Since the type is defined my the plan and we are at a higher
+2 ; level in the Insurance Company, we have to allow both.
+3 ; called from ^DD(36.015,.01,0) and ^DD(36.016,.01,0)
+4 ;
+5 ;3/17/2016 - A decision was made to limit which type is allowed by using the TYPE OF COVERAGE field. (TAZ)
+6 ;
+7 ;
+8 ; Input:
+9 ; IBAC is the internal code of the value being input.
+10 ;
+11 ; Returns:
+12 ; TRUE/1 if allowed (set up in site parameters)
+13 ; FALSE/0 if they are not
+14 ;
+15 if $DATA(^IBE(350.9,1,$SELECT($$GET1^DIQ(36,IBCNS_",","TYPE OF COVERAGE")="MEDICARE"
QUIT 1
+16 QUIT 0
+17 ;
+18 ; WCJ;IB*2.0*547
+19 ; This is to clean up any extraneous nodes if a user entered an alternate ID type, but not an actual ID.
CLEANIDS(INSIEN) ;
+1 ; INSIEN=Insurance Company IEN
+2 ;
+3 NEW NODE,LOOP,DATA,CLEANUP
+4 FOR NODE=15,16
Begin DoDot:1
+5 SET LOOP=0
FOR
SET LOOP=$ORDER(^DIC(36,INSIEN,NODE,LOOP))
if '+LOOP
QUIT
SET DATA=$GET(^(LOOP,0))
IF DATA]""
IF $PIECE(DATA,U,2)=""
Begin DoDot:2
+6 NEW DIK,DA
+7 SET DA=LOOP
SET DA(1)=INSIEN
+8 SET DIK="^DIC(36,"_INSIEN_","_NODE_","
+9 DO ^DIK
+10 SET CLEANUP=1
End DoDot:2
End DoDot:1
+11 IF $GET(CLEANUP)
Begin DoDot:1
+12 NEW DIR
+13 SET DIR("A",1)="Payer ID Types without corresponding ID# were deleted."
+14 SET DIR(0)="EA"
SET DIR("A")="PRESS ENTER TO CONTINUE "
+15 DO ^DIR
+16 QUIT
End DoDot:1
+17 QUIT
