IBCNSJ3 ;ALB/CPM - ADD NEW INSURANCE PLAN ; 11-JAN-95
;;2.0;INTEGRATED BILLING;**28,497,506,519,652**;21-MAR-94;Build 23
;;Per VA Directive 6402, this routine should not be modified.
;
NEW(IBCNS,IBCPOL,IBFG,IBKEY,BYPASS) ; Add a new insurance plan
; Input: IBCNS -- Pointer to an insurance company in file #36
; IBFG -- [Optional] -> Set to 1 to force creation
; of a group plan
; IBKEY -- [Optional] -> Set to 1 to check for security key
; BYPASS -- Bypass new insurance plan
; Output: IBCPOL -- 0, if a new plan was not added, or
; >0 => pointer to the new plan in file #355.3
;
N DA,DIR,DIRUT,DIROUT,DTOUT,DUOUT,IBTL,IBGRP,IBGNA,IBGNU,X,Y
S IBCPOL=0
I '$G(IBCNS) G NEWQ
;
;IB*2.0*652/TAZ - Moved so user exits before being prompted for a new policy if they don't have the key.
; IB*2.0*506 Added the following line.
I $G(IBKEY),'$D(^XUSEC("IB GROUP PLAN EDIT",DUZ)) W !!,"Sorry, you are not authorized to create a new Insurance Plan" D WAIT^IBCNBAA G NEWQ
;
;IB*2.0*652/TAZ - Bypass prompt for Insurance Company New Policy Action
I '$G(BYPASS) D G:(Y<1!$D(DIRUT)) NEWQ G NEW1
. S DIR(0)="Y",DIR("B")="NO",DIR("A")="Do you wish to add a new Insurance Plan"
. S DIR("?")="If you have identified a new plan that has not been previously entered, and you wish to add it, answer 'YES'. If you do not wish to add a new plan, enter 'NO'."
. D ^DIR K DIR
;
W !!,"You are about to add a new Insurance Plan."
;
NEW1 ;
; - collect plan characteristics
I $G(IBFG) S IBGRP=1 G MORE
;IB*2.0*652/TAZ Added default response
S DIR(0)="355.3,.02",DIR("A")=" IS THIS A GROUP PLAN",DIR("B")="YES" D ^DIR K DIR S IBGRP=Y
I $D(DIRUT) G NEWQ
;
MORE S IBTL=" "_$S(IBGRP:"GROUP",1:"INDIVIDUAL")_" PLAN "
S DIR(0)="355.3,2.01",DIR("A")=IBTL_"NAME" D ^DIR K DIR G NEWQ:$D(DUOUT)!$D(DTOUT) S IBGNA=Y
S DIR(0)="355.3,2.02",DIR("A")=IBTL_"NUMBER" D ^DIR K DIR G NEWQ:$D(DUOUT)!$D(DTOUT) S IBGNU=Y
;
; - check for duplicates and file the plan
I $$CHECK(IBCNS,IBGNA,IBGNU) S IBCPOL=$$ADDH^IBCNSU(IBCNS,IBGRP,IBGNA,IBGNU)
; IB*2.0*519: If new group added, check to see if we already have a NIF ID for this insurance company.
Q:IBCPOL<1
Q:$$NIF^IBCNHUT1(IBCNS)
; if no NIF and we have not yet requested one, send an HL7
I '$D(^IBCNH(367.1,"INS",IBCNS)) D SEND^IBCNHHLO(IBCNS)
NEWQ Q
;
;
CHECK(IBCNS,IBGNA,IBGNU) ; Check for potential duplicate plans
; Input: IBCNS -- Pointer to an insurance company in file #36
; IBGNA -- Plan Name for potential new plan
; IBGNU -- Plan Number for potential new plan
; Output: IBANS -- 1 -> Okay to add the new plan
; 0 -> Don't add the new plan.
;
N IBANS,IBCT,IBCNSD
S (IBANS,IBCT)=1
S IBCNSD=$G(^DIC(36,+$G(IBCNS),0)) I IBCNSD="" G CHECKQ
K ^TMP($J,"DUP"),^TMP($J,"DUP1")
W !!," Searching for potential duplicate plans offered by ",$E($P(IBCNSD,"^"),1,20),"..."
I '$D(^IBA(355.3,"B",IBCNS)) G CHECKQ
;
; - look for potential duplicate plans
D:$G(IBGNA)]"" FIND(IBCNS,IBGNA)
D:$G(IBGNU)]"" FIND(IBCNS,IBGNU)
;
; - display potential duplicates and see if plan should be filed
I $D(^TMP($J,"DUP")) D LIST
;
CHECKQ I '$D(^TMP($J,"DUP")) W !!," No potential duplicate plans have been identified."
K ^TMP($J,"DUP"),^TMP($J,"DUP1")
Q IBANS
;
;
FIND(IBCNS,IBGN) ; Check cross-references for duplicate plans
; Input: IBCNS -- Pointer to the insurance company in file #36
; IBGN -- value to use to find duplicates
;
N INP,LEN,SUB,TYPE
F SUB="AGNA","AGNU","ACCP" D
.I SUB="ACCP" S IBGN=$$COMP^IBCNSJ(IBGN)
.S INP=IBGN,LEN=$L(INP) Q:LEN<2!(LEN>20)
.S TYPE=$S(IBGN?1N.N:"NUM",1:"STR")
.I $D(^IBA(355.3,SUB,IBCNS,INP)) D GDATA
.I TYPE="STR" F S INP=$O(^IBA(355.3,SUB,IBCNS,INP)) Q:$E(INP,1,LEN)'=IBGN D GDATA
.I TYPE="NUM" F S INP=$O(^IBA(355.3,SUB,IBCNS,INP)) Q:INP="" I $E(INP,1,LEN)=IBGN D GDATA
Q
;
GDATA ; Place potential duplicate plan into an array.
N X,Y,Y2 S X=0 ; IB*2.0*497 (vd)
F S X=$O(^IBA(355.3,SUB,IBCNS,INP,X)) Q:'X I '$D(^TMP($J,"DUP",X)) D
.S Y=$G(^IBA(355.3,X,0)),Y2=$G(^IBA(355.3,X,2)),IBCT=IBCT+1 ; IB*2.0*497 (vd)
.S ^TMP($J,"DUP",X)="",^TMP($J,"DUP1",IBCT)=$P(Y2,"^",2)_U_$P(Y2,"^",1)_U_$P(Y,"^",2)_U_$P(Y,"^",11) ; IB*2.0*497 (vd)
Q
;
LIST ; List potential duplicates to screen and prompt to add plan.
W !!," The following plans have been identified as potential duplicates:"
W !!,?3,"PLAN",?22,"PLAN",?45,"GROUP",?55,"ACTIVE",!,?2,"NUMBER",?22,"NAME",?45,"PLAN?",?55,"PLAN?",!
S IBCT=0 F S IBCT=$O(^TMP($J,"DUP1",IBCT)) Q:'IBCT D
.S IBST=$G(^TMP($J,"DUP1",IBCT))
.W !?2,$S($P(IBST,"^")'="":$P(IBST,"^"),1:"<NO PLAN NUM>"),?22,$S($P(IBST,"^",2)'="":$P(IBST,"^",2),1:"<NO PLAN NAME>")
.W ?45,$S($P(IBST,"^",3)'="":$$EXPAND^IBTRE(355.3,.02,$P(IBST,"^",3)),1:"<UNK>"),?55,$S($P(IBST,"^",4):"NO",1:"YES")
;
; - see if it is okay to add the plan
S DIR(0)="Y",DIR("A",1)="Do you still want to add a new plan with Plan Name "_$S(IBGNA'="":IBGNA,1:"<NO PLAN NAME>")
S DIR("A")="and Plan Number "_$S(IBGNU'="":IBGNU,1:"<NO PLAN NUMBER>")
S DIR("B")="NO"
W ! D ^DIR K DIR S IBANS=Y
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCNSJ3 5286 printed Oct 16, 2024@18:17:59 Page 2
IBCNSJ3 ;ALB/CPM - ADD NEW INSURANCE PLAN ; 11-JAN-95
+1 ;;2.0;INTEGRATED BILLING;**28,497,506,519,652**;21-MAR-94;Build 23
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;
NEW(IBCNS,IBCPOL,IBFG,IBKEY,BYPASS) ; Add a new insurance plan
+1 ; Input: IBCNS -- Pointer to an insurance company in file #36
+2 ; IBFG -- [Optional] -> Set to 1 to force creation
+3 ; of a group plan
+4 ; IBKEY -- [Optional] -> Set to 1 to check for security key
+5 ; BYPASS -- Bypass new insurance plan
+6 ; Output: IBCPOL -- 0, if a new plan was not added, or
+7 ; >0 => pointer to the new plan in file #355.3
+8 ;
+9 NEW DA,DIR,DIRUT,DIROUT,DTOUT,DUOUT,IBTL,IBGRP,IBGNA,IBGNU,X,Y
+10 SET IBCPOL=0
+11 IF '$GET(IBCNS)
GOTO NEWQ
+12 ;
+13 ;IB*2.0*652/TAZ - Moved so user exits before being prompted for a new policy if they don't have the key.
+14 ; IB*2.0*506 Added the following line.
+15 IF $GET(IBKEY)
IF '$DATA(^XUSEC("IB GROUP PLAN EDIT",DUZ))
WRITE !!,"Sorry, you are not authorized to create a new Insurance Plan"
DO WAIT^IBCNBAA
GOTO NEWQ
+16 ;
+17 ;IB*2.0*652/TAZ - Bypass prompt for Insurance Company New Policy Action
+18 IF '$GET(BYPASS)
Begin DoDot:1
+19 SET DIR(0)="Y"
SET DIR("B")="NO"
SET DIR("A")="Do you wish to add a new Insurance Plan"
+20 SET DIR("?")="If you have identified a new plan that has not been previously entered, and you wish to add it, answer 'YES'. If you do not wish to add a new plan, enter 'NO'."
+21 DO ^DIR
KILL DIR
End DoDot:1
if (Y<1!$DATA(DIRUT))
GOTO NEWQ
GOTO NEW1
+22 ;
+23 WRITE !!,"You are about to add a new Insurance Plan."
+24 ;
NEW1 ;
+1 ; - collect plan characteristics
+2 IF $GET(IBFG)
SET IBGRP=1
GOTO MORE
+3 ;IB*2.0*652/TAZ Added default response
+4 SET DIR(0)="355.3,.02"
SET DIR("A")=" IS THIS A GROUP PLAN"
SET DIR("B")="YES"
DO ^DIR
KILL DIR
SET IBGRP=Y
+5 IF $DATA(DIRUT)
GOTO NEWQ
+6 ;
MORE SET IBTL=" "_$SELECT(IBGRP:"GROUP",1:"INDIVIDUAL")_" PLAN "
+1 SET DIR(0)="355.3,2.01"
SET DIR("A")=IBTL_"NAME"
DO ^DIR
KILL DIR
if $DATA(DUOUT)!$DATA(DTOUT)
GOTO NEWQ
SET IBGNA=Y
+2 SET DIR(0)="355.3,2.02"
SET DIR("A")=IBTL_"NUMBER"
DO ^DIR
KILL DIR
if $DATA(DUOUT)!$DATA(DTOUT)
GOTO NEWQ
SET IBGNU=Y
+3 ;
+4 ; - check for duplicates and file the plan
+5 IF $$CHECK(IBCNS,IBGNA,IBGNU)
SET IBCPOL=$$ADDH^IBCNSU(IBCNS,IBGRP,IBGNA,IBGNU)
+6 ; IB*2.0*519: If new group added, check to see if we already have a NIF ID for this insurance company.
+7 if IBCPOL<1
QUIT
+8 if $$NIF^IBCNHUT1(IBCNS)
QUIT
+9 ; if no NIF and we have not yet requested one, send an HL7
+10 IF '$DATA(^IBCNH(367.1,"INS",IBCNS))
DO SEND^IBCNHHLO(IBCNS)
NEWQ QUIT
+1 ;
+2 ;
CHECK(IBCNS,IBGNA,IBGNU) ; Check for potential duplicate plans
+1 ; Input: IBCNS -- Pointer to an insurance company in file #36
+2 ; IBGNA -- Plan Name for potential new plan
+3 ; IBGNU -- Plan Number for potential new plan
+4 ; Output: IBANS -- 1 -> Okay to add the new plan
+5 ; 0 -> Don't add the new plan.
+6 ;
+7 NEW IBANS,IBCT,IBCNSD
+8 SET (IBANS,IBCT)=1
+9 SET IBCNSD=$GET(^DIC(36,+$GET(IBCNS),0))
IF IBCNSD=""
GOTO CHECKQ
+10 KILL ^TMP($JOB,"DUP"),^TMP($JOB,"DUP1")
+11 WRITE !!," Searching for potential duplicate plans offered by ",$EXTRACT($PIECE(IBCNSD,"^"),1,20),"..."
+12 IF '$DATA(^IBA(355.3,"B",IBCNS))
GOTO CHECKQ
+13 ;
+14 ; - look for potential duplicate plans
+15 if $GET(IBGNA)]""
DO FIND(IBCNS,IBGNA)
+16 if $GET(IBGNU)]""
DO FIND(IBCNS,IBGNU)
+17 ;
+18 ; - display potential duplicates and see if plan should be filed
+19 IF $DATA(^TMP($JOB,"DUP"))
DO LIST
+20 ;
CHECKQ IF '$DATA(^TMP($JOB,"DUP"))
WRITE !!," No potential duplicate plans have been identified."
+1 KILL ^TMP($JOB,"DUP"),^TMP($JOB,"DUP1")
+2 QUIT IBANS
+3 ;
+4 ;
FIND(IBCNS,IBGN) ; Check cross-references for duplicate plans
+1 ; Input: IBCNS -- Pointer to the insurance company in file #36
+2 ; IBGN -- value to use to find duplicates
+3 ;
+4 NEW INP,LEN,SUB,TYPE
+5 FOR SUB="AGNA","AGNU","ACCP"
Begin DoDot:1
+6 IF SUB="ACCP"
SET IBGN=$$COMP^IBCNSJ(IBGN)
+7 SET INP=IBGN
SET LEN=$LENGTH(INP)
if LEN<2!(LEN>20)
QUIT
+8 SET TYPE=$SELECT(IBGN?1N.N:"NUM",1:"STR")
+9 IF $DATA(^IBA(355.3,SUB,IBCNS,INP))
DO GDATA
+10 IF TYPE="STR"
FOR
SET INP=$ORDER(^IBA(355.3,SUB,IBCNS,INP))
if $EXTRACT(INP,1,LEN)'=IBGN
QUIT
DO GDATA
+11 IF TYPE="NUM"
FOR
SET INP=$ORDER(^IBA(355.3,SUB,IBCNS,INP))
if INP=""
QUIT
IF $EXTRACT(INP,1,LEN)=IBGN
DO GDATA
End DoDot:1
+12 QUIT
+13 ;
GDATA ; Place potential duplicate plan into an array.
+1 ; IB*2.0*497 (vd)
NEW X,Y,Y2
SET X=0
+2 FOR
SET X=$ORDER(^IBA(355.3,SUB,IBCNS,INP,X))
if 'X
QUIT
IF '$DATA(^TMP($JOB,"DUP",X))
Begin DoDot:1
+3 ; IB*2.0*497 (vd)
SET Y=$GET(^IBA(355.3,X,0))
SET Y2=$GET(^IBA(355.3,X,2))
SET IBCT=IBCT+1
+4 ; IB*2.0*497 (vd)
SET ^TMP($JOB,"DUP",X)=""
SET ^TMP($JOB,"DUP1",IBCT)=$PIECE(Y2,"^",2)_U_$PIECE(Y2,"^",1)_U_$PIECE(Y,"^",2)_U_$PIECE(Y,"^",11)
End DoDot:1
+5 QUIT
+6 ;
LIST ; List potential duplicates to screen and prompt to add plan.
+1 WRITE !!," The following plans have been identified as potential duplicates:"
+2 WRITE !!,?3,"PLAN",?22,"PLAN",?45,"GROUP",?55,"ACTIVE",!,?2,"NUMBER",?22,"NAME",?45,"PLAN?",?55,"PLAN?",!
+3 SET IBCT=0
FOR
SET IBCT=$ORDER(^TMP($JOB,"DUP1",IBCT))
if 'IBCT
QUIT
Begin DoDot:1
+4 SET IBST=$GET(^TMP($JOB,"DUP1",IBCT))
+5 WRITE !?2,$SELECT($PIECE(IBST,"^")'="":$PIECE(IBST,"^"),1:"<NO PLAN NUM>"),?22,$SELECT($PIECE(IBST,"^",2)'="":$PIECE(IBST,"^",2),1:"<NO PLAN NAME>")
+6 WRITE ?45,$SELECT($PIECE(IBST,"^",3)'="":$$EXPAND^IBTRE(355.3,.02,$PIECE(IBST,"^",3)),1:"<UNK>"),?55,$SELECT($PIECE(IBST,"^",4):"NO",1:"YES")
End DoDot:1
+7 ;
+8 ; - see if it is okay to add the plan
+9 SET DIR(0)="Y"
SET DIR("A",1)="Do you still want to add a new plan with Plan Name "_$SELECT(IBGNA'="":IBGNA,1:"<NO PLAN NAME>")
+10 SET DIR("A")="and Plan Number "_$SELECT(IBGNU'="":IBGNU,1:"<NO PLAN NUMBER>")
+11 SET DIR("B")="NO"
+12 WRITE !
DO ^DIR
KILL DIR
SET IBANS=Y
+13 QUIT
