IBCNSP3 ;ALB/AAS - INSURANCE MANAGEMENT EDIT ;27-APR-2015
;;2.0;INTEGRATED BILLING;**28,52,85,251,371,497,528,549**;21-MAR-94;Build 54
;;Per VA Directive 6402, this routine should not be modified.
;
% G ^IBCNSM4
;
SAVEPT(DFN,DA) ; -- Save the global before editing
K ^TMP($J,"IBCNSPT")
S ^TMP($J,"IBCNSPT",2.312,DFN,+DA,0)=$G(^DPT(DFN,.312,+DA,0))
S ^TMP($J,"IBCNSPT",2.312,DFN,+DA,1)=$G(^DPT(DFN,.312,+DA,1))
S ^TMP($J,"IBCNSPT",2.312,DFN,+DA,2)=$G(^DPT(DFN,.312,+DA,2))
S ^TMP($J,"IBCNSPT",2.312,DFN,+DA,3)=$G(^DPT(DFN,.312,+DA,3))
S ^TMP($J,"IBCNSPT",2.312,DFN,+DA,4)=$G(^DPT(DFN,.312,+DA,4))
S ^TMP($J,"IBCNSPT",2.312,DFN,+DA,5)=$G(^DPT(DFN,.312,+DA,5))
S ^TMP($J,"IBCNSPT",2.312,DFN,+DA,7)=$G(^DPT(DFN,.312,+DA,7)) ; IB*2.0*497 (vd)
Q
;
COMPPT(DFN,DA) ; -- Compare before editing with globals
S IBDIF=0
I $G(^DPT(DFN,.312,+DA,0))'=$G(^TMP($J,"IBCNSPT",2.312,DFN,+DA,0)) S IBDIF=1 G COMPPTQ
I $G(^DPT(DFN,.312,+DA,1))'=$G(^TMP($J,"IBCNSPT",2.312,DFN,+DA,1)) S IBDIF=1 G COMPPTQ
I $G(^DPT(DFN,.312,+DA,2))'=$G(^TMP($J,"IBCNSPT",2.312,DFN,+DA,2)) S IBDIF=1 G COMPPTQ
I $G(^DPT(DFN,.312,+DA,3))'=$G(^TMP($J,"IBCNSPT",2.312,DFN,+DA,3)) S IBDIF=1 G COMPPTQ
I $G(^DPT(DFN,.312,+DA,4))'=$G(^TMP($J,"IBCNSPT",2.312,DFN,+DA,4)) S IBDIF=1 G COMPPTQ
I $G(^DPT(DFN,.312,+DA,5))'=$G(^TMP($J,"IBCNSPT",2.312,DFN,+DA,5)) S IBDIF=1 G COMPPTQ
I $G(^DPT(DFN,.312,+DA,7))'=$G(^TMP($J,"IBCNSPT",2.312,DFN,+DA,7)) S IBDIF=1 G COMPPTQ ; IB*2.0*497 (vd)
;
COMPPTQ I IBDIF D:'$D(IBCOVP) COVERED^IBCNSM31(DFN,$P($G(^DPT(DFN,.31)),"^",11))
Q
;
UPDATPT(DFN,DA) ; -- enter date and user if editing has taken place
N DR,DIE,DIC
S DIE="^DPT("_DFN_",.312,",DA(1)=DFN
S DR="1.05///NOW;1.06////"_DUZ
D ^DIE
Q
;
EM ; -- Employer for claims update
D FULL^VALM1 W !!
N IBDIF,DA,DR,DIC,DIE
D SAVEPT(DFN,IBCDFN)
D VARS
L +^DPT(DFN,.312,+$P($G(IBPPOL),"^",4)):5 I '$T D LOCKED^IBTRCD1 G EMQ
;
;S DR="2.01;S:'$P($G(^DPT(DFN,.312,+$G(DA),2)),U) Y=""@999"";W !!,""*** If ROI applies, make sure current consent is signed! ***"",!;2.015;2.02;2.03;2.04;2.05;2.06;2.07;2.08;2.09;@999"
;
S DR="2.1" D ^DIE K DIE,DR
;
I +$P($G(^DPT(DFN,.312,+$G(DA),2)),U,10),$P($G(^DPT(DFN,.312,+$G(DA),2)),U,9)="" D EMPSET(DFN,$G(DA)) ; curr emp
;
I +$P($G(^DPT(DFN,.312,+$G(DA),2)),U,10) D VARS S DR="2.015;2.11;2.12;2.01;W:+X !!,""*** If ROI applies, make sure current consent is signed! ***"",!!;2.02;2.03;2.04;2.05;2.06;2.07;2.08;@999" D ^DIE K DIE,DR
;
;I '$P($G(^DPT(DFN,.312,+$G(DA),2)),U) D VARS S DR="2.015///@;2.02///@;2.03///@;2.04///@;2.05///@;2.06///@;2.07///@;2.08///@" D ^DIE
;
I '$P($G(^DPT(DFN,.312,+$G(DA),2)),U,10) D VARS S DR="2.01///@;2.015///@;2.02///@;2.03///@;2.04///@;2.05///@;2.06///@;2.07///@;2.08///@;2.11///@;2.12///@" D ^DIE
;
D COMPPT(DFN,IBCDFN)
I IBDIF D UPDATPT(DFN,IBCDFN),BLD^IBCNSP
L -^DPT(DFN,.312,+$P($G(IBPPOL),"^",4))
EMQ S VALMBCK="R" Q
;
GC ;EP
; IB*2.0*549 Added Method
; Protocol action to add/edit a Group Plan Comment
; Input: DFN - IEN of the currently selected patient
; IBCPOL - IEN of the currently selected group plan
; Output: Group Plan Comment is added/edited (Potentially)
N DA,DR,DIE,DIC,X,Y
S VALMBCK="R"
D FULL^VALM1
W !!,"You may now enter comments about this Group Plan that pertains to all"
W " Patients",!!
L +^IBA(355.3,+IBCPOL):5 ; Lock the Group Plan for editing
I '$T D LOCKED^IBTRCD1 Q
S DIE="^IBA(355.3,",DA=IBCPOL,DR="11Group Plan Comment"
D ^DIE
D BLD^IBCNSP
L -^IBA(355.3,+IBCPOL) ; Unlock the Group Plan
Q
;
BLS(X,Y) ; -- blank a section of lines
N I
F I=X:1:Y D BLANK^IBCNSP(.I)
Q
;
VARS ; -- set vars for call to die for .312 node
S DA(1)=DFN,DA=$P(IBPPOL,"^",4)
S DIE="^DPT("_DA(1)_",.312,"
Q
;
SAVE(IBCPOL) ; -- Save the global before editing
K ^TMP($J,"IBCNSP")
S ^TMP($J,"IBCNSP",355.3,+IBCPOL,0)=$G(^IBA(355.3,+IBCPOL,0))
S ^TMP($J,"IBCNSP",355.3,+IBCPOL,1)=$G(^IBA(355.3,+IBCPOL,1))
S ^TMP($J,"IBCNSP",355.3,+IBCPOL,2)=$G(^IBA(355.3,+IBCPOL,2)) ; IB*2.0*497 (vd)
;;Daou/EEN - adding BIN and PCN
S ^TMP($J,"IBCNSP",355.3,+IBCPOL,6)=$G(^IBA(355.3,+IBCPOL,6))
Q
;
COMP(IBCPOL) ; -- Compare before editing with globals
S IBDIF=0
I $G(^IBA(355.3,+IBCPOL,0))'=$G(^TMP($J,"IBCNSP",355.3,+IBCPOL,0)) S IBDIF=1 Q
I $G(^IBA(355.3,+IBCPOL,1))'=$G(^TMP($J,"IBCNSP",355.3,+IBCPOL,1)) S IBDIF=1 Q
I $G(^IBA(355.3,+IBCPOL,2))'=$G(^TMP($J,"IBCNSP",355.3,+IBCPOL,2)) S IBDIF=1 Q ; IB*2.0*497 (vd)
;;Daou/EEN - adding BIN and PCN
I $G(^IBA(355.3,+IBCPOL,6))'=$G(^TMP($J,"IBCNSP",355.3,+IBCPOL,6)) S IBDIF=1 Q
Q
;
UPDATE(IBCPOL) ; -- Update last edited by
N DA,DIC,DIE,DR
S DIE="^IBA(355.3,",DA=IBCPOL,DR="1.05///NOW;1.06////"_DUZ
D ^DIE
Q
;
RIDERS ; -- add/edit personal riders
;
D FULL^VALM1
N IBDIF,DA,DR,DIE,DIC,X,Y,IBCDFN,IBPRD,IBPRY
S IBCDFN=$P(IBPPOL,"^",4)
W ! D DISPR W !
;
R1 S DIC="^IBA(355.7,",DIC(0)="AEQML",DLAYGO=355.7
S DIC("DR")=".02////"_DFN_";.03////"_IBCDFN
S DIC("S")="I $P(^(0),U,2)=DFN,$P(^(0),U,3)=IBCDFN"
I $D(IBPRD) S DIC("B")=IBPRD
D ^DIC K DIC,IBPRD
I +Y<1 G RIDERQ
S IBPRY=+Y
L +^IBA(355.7,IBPRY):5 I '$T D LOCKED^IBTRCD1 G RIDERQ
S DIE="^IBA(355.7,",DA=+Y,DR=".01",DIDEL=355.7
D ^DIE K DA,DR,DIE,DIC,DIDEL,DLAYGO
L -^IBA(355.7,IBPRY)
W ! G R1
RIDERQ S VALMBCK="R"
Q
;
RD ; -- Add riders/ for multiple policies
D FULL^VALM1
N I,J,IBXX,VALMY
D EN^VALM2($G(XQORNOD(0)))
I $D(VALMY) S IBXX=0 F S IBXX=$O(VALMY(IBXX)) Q:'IBXX D
.S IBPPOL=$G(^TMP("IBNSMDX",$J,$O(^TMP("IBNSM",$J,"IDX",IBXX,0))))
.Q:IBPPOL=""
.D RIDERS
.Q
D BLD^IBCNSM
S VALMBCK="R"
Q
;
DISPR ; -- Display riders
N IBPR,I,J
S I=0
I '$G(IBCDFN)!('$G(DFN)) G DISPRQ
W !,"Current Personal Riders: "
F S I=$O(^IBA(355.7,"APP",DFN,IBCDFN,I)) Q:'I S J=$O(^(I,0)),IBPR=$G(^IBA(355.7,+J,0)) D
.S IBPRD=$$EXPAND^IBTRE(355.7,.01,+IBPR)
.W !?5,IBPRD
I '$D(IBPRD) W !?5,"None Indicated"
DISPRQ Q
;
EMPSET(DFN,IBCPOL) ; insert patient or spouses current employer as ESGHP address if that employer sponsors this plan
N IBWHOS,VAOA,DIR,IBE,IBEMPST,DR,X,Y
I +$G(DFN) S IBWHOS=$P($G(^DPT(DFN,.312,+$G(IBCPOL),0)),U,6) S VAOA("A")=$S(IBWHOS="v":5,IBWHOS="s":6,1:"")
I $G(VAOA("A"))'="" D OAD^VADPT I $G(VAOA(9))'="" D
. ;
. S DIR("A")="Current Employer "_VAOA(9)_" Sponsors this Plan",DIR("B")="No",DIR(0)="Y" W ! D ^DIR W ! Q:'Y W "...."
. D VARS S IBE=$S(IBWHOS="v":.311,1:.25),IBEMPST=$P($G(^DPT(DFN,IBE)),U,15)
. ;
. S DR="2.015///"_VAOA(9)_";2.02///"_VAOA(1)_";2.03///"_VAOA(2)_";2.04///"_VAOA(3)_";2.05///"_VAOA(4) D ^DIE
. S DR="2.06////"_$P(VAOA(5),U,1)_";2.07////"_$P(VAOA(11),U,1)_";2.08///"_$E(VAOA(8),1,15)_";2.11////"_IBEMPST D ^DIE
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCNSP3 6823 printed Dec 13, 2024@02:17:55 Page 2
IBCNSP3 ;ALB/AAS - INSURANCE MANAGEMENT EDIT ;27-APR-2015
+1 ;;2.0;INTEGRATED BILLING;**28,52,85,251,371,497,528,549**;21-MAR-94;Build 54
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;
% GOTO ^IBCNSM4
+1 ;
SAVEPT(DFN,DA) ; -- Save the global before editing
+1 KILL ^TMP($JOB,"IBCNSPT")
+2 SET ^TMP($JOB,"IBCNSPT",2.312,DFN,+DA,0)=$GET(^DPT(DFN,.312,+DA,0))
+3 SET ^TMP($JOB,"IBCNSPT",2.312,DFN,+DA,1)=$GET(^DPT(DFN,.312,+DA,1))
+4 SET ^TMP($JOB,"IBCNSPT",2.312,DFN,+DA,2)=$GET(^DPT(DFN,.312,+DA,2))
+5 SET ^TMP($JOB,"IBCNSPT",2.312,DFN,+DA,3)=$GET(^DPT(DFN,.312,+DA,3))
+6 SET ^TMP($JOB,"IBCNSPT",2.312,DFN,+DA,4)=$GET(^DPT(DFN,.312,+DA,4))
+7 SET ^TMP($JOB,"IBCNSPT",2.312,DFN,+DA,5)=$GET(^DPT(DFN,.312,+DA,5))
+8 ; IB*2.0*497 (vd)
SET ^TMP($JOB,"IBCNSPT",2.312,DFN,+DA,7)=$GET(^DPT(DFN,.312,+DA,7))
+9 QUIT
+10 ;
COMPPT(DFN,DA) ; -- Compare before editing with globals
+1 SET IBDIF=0
+2 IF $GET(^DPT(DFN,.312,+DA,0))'=$GET(^TMP($JOB,"IBCNSPT",2.312,DFN,+DA,0))
SET IBDIF=1
GOTO COMPPTQ
+3 IF $GET(^DPT(DFN,.312,+DA,1))'=$GET(^TMP($JOB,"IBCNSPT",2.312,DFN,+DA,1))
SET IBDIF=1
GOTO COMPPTQ
+4 IF $GET(^DPT(DFN,.312,+DA,2))'=$GET(^TMP($JOB,"IBCNSPT",2.312,DFN,+DA,2))
SET IBDIF=1
GOTO COMPPTQ
+5 IF $GET(^DPT(DFN,.312,+DA,3))'=$GET(^TMP($JOB,"IBCNSPT",2.312,DFN,+DA,3))
SET IBDIF=1
GOTO COMPPTQ
+6 IF $GET(^DPT(DFN,.312,+DA,4))'=$GET(^TMP($JOB,"IBCNSPT",2.312,DFN,+DA,4))
SET IBDIF=1
GOTO COMPPTQ
+7 IF $GET(^DPT(DFN,.312,+DA,5))'=$GET(^TMP($JOB,"IBCNSPT",2.312,DFN,+DA,5))
SET IBDIF=1
GOTO COMPPTQ
+8 ; IB*2.0*497 (vd)
IF $GET(^DPT(DFN,.312,+DA,7))'=$GET(^TMP($JOB,"IBCNSPT",2.312,DFN,+DA,7))
SET IBDIF=1
GOTO COMPPTQ
+9 ;
COMPPTQ IF IBDIF
if '$DATA(IBCOVP)
DO COVERED^IBCNSM31(DFN,$PIECE($GET(^DPT(DFN,.31)),"^",11))
+1 QUIT
+2 ;
UPDATPT(DFN,DA) ; -- enter date and user if editing has taken place
+1 NEW DR,DIE,DIC
+2 SET DIE="^DPT("_DFN_",.312,"
SET DA(1)=DFN
+3 SET DR="1.05///NOW;1.06////"_DUZ
+4 DO ^DIE
+5 QUIT
+6 ;
EM ; -- Employer for claims update
+1 DO FULL^VALM1
WRITE !!
+2 NEW IBDIF,DA,DR,DIC,DIE
+3 DO SAVEPT(DFN,IBCDFN)
+4 DO VARS
+5 LOCK +^DPT(DFN,.312,+$PIECE($GET(IBPPOL),"^",4)):5
IF '$TEST
DO LOCKED^IBTRCD1
GOTO EMQ
+6 ;
+7 ;S DR="2.01;S:'$P($G(^DPT(DFN,.312,+$G(DA),2)),U) Y=""@999"";W !!,""*** If ROI applies, make sure current consent is signed! ***"",!;2.015;2.02;2.03;2.04;2.05;2.06;2.07;2.08;2.09;@999"
+8 ;
+9 SET DR="2.1"
DO ^DIE
KILL DIE,DR
+10 ;
+11 ; curr emp
IF +$PIECE($GET(^DPT(DFN,.312,+$GET(DA),2)),U,10)
IF $PIECE($GET(^DPT(DFN,.312,+$GET(DA),2)),U,9)=""
DO EMPSET(DFN,$GET(DA))
+12 ;
+13 IF +$PIECE($GET(^DPT(DFN,.312,+$GET(DA),2)),U,10)
DO VARS
SET DR="2.015;2.11;2.12;2.01;W:+X !!,""*** If ROI applies, make sure current consent is signed! ***"",!!;2.02;2.03;2.04;2.05;2.06;2.07;2.08;@999"
DO ^DIE
KILL DIE,DR
+14 ;
+15 ;I '$P($G(^DPT(DFN,.312,+$G(DA),2)),U) D VARS S DR="2.015///@;2.02///@;2.03///@;2.04///@;2.05///@;2.06///@;2.07///@;2.08///@" D ^DIE
+16 ;
+17 IF '$PIECE($GET(^DPT(DFN,.312,+$GET(DA),2)),U,10)
DO VARS
SET DR="2.01///@;2.015///@;2.02///@;2.03///@;2.04///@;2.05///@;2.06///@;2.07///@;2.08///@;2.11///@;2.12///@"
DO ^DIE
+18 ;
+19 DO COMPPT(DFN,IBCDFN)
+20 IF IBDIF
DO UPDATPT(DFN,IBCDFN)
DO BLD^IBCNSP
+21 LOCK -^DPT(DFN,.312,+$PIECE($GET(IBPPOL),"^",4))
EMQ SET VALMBCK="R"
QUIT
+1 ;
GC ;EP
+1 ; IB*2.0*549 Added Method
+2 ; Protocol action to add/edit a Group Plan Comment
+3 ; Input: DFN - IEN of the currently selected patient
+4 ; IBCPOL - IEN of the currently selected group plan
+5 ; Output: Group Plan Comment is added/edited (Potentially)
+6 NEW DA,DR,DIE,DIC,X,Y
+7 SET VALMBCK="R"
+8 DO FULL^VALM1
+9 WRITE !!,"You may now enter comments about this Group Plan that pertains to all"
+10 WRITE " Patients",!!
+11 ; Lock the Group Plan for editing
LOCK +^IBA(355.3,+IBCPOL):5
+12 IF '$TEST
DO LOCKED^IBTRCD1
QUIT
+13 SET DIE="^IBA(355.3,"
SET DA=IBCPOL
SET DR="11Group Plan Comment"
+14 DO ^DIE
+15 DO BLD^IBCNSP
+16 ; Unlock the Group Plan
LOCK -^IBA(355.3,+IBCPOL)
+17 QUIT
+18 ;
BLS(X,Y) ; -- blank a section of lines
+1 NEW I
+2 FOR I=X:1:Y
DO BLANK^IBCNSP(.I)
+3 QUIT
+4 ;
VARS ; -- set vars for call to die for .312 node
+1 SET DA(1)=DFN
SET DA=$PIECE(IBPPOL,"^",4)
+2 SET DIE="^DPT("_DA(1)_",.312,"
+3 QUIT
+4 ;
SAVE(IBCPOL) ; -- Save the global before editing
+1 KILL ^TMP($JOB,"IBCNSP")
+2 SET ^TMP($JOB,"IBCNSP",355.3,+IBCPOL,0)=$GET(^IBA(355.3,+IBCPOL,0))
+3 SET ^TMP($JOB,"IBCNSP",355.3,+IBCPOL,1)=$GET(^IBA(355.3,+IBCPOL,1))
+4 ; IB*2.0*497 (vd)
SET ^TMP($JOB,"IBCNSP",355.3,+IBCPOL,2)=$GET(^IBA(355.3,+IBCPOL,2))
+5 ;;Daou/EEN - adding BIN and PCN
+6 SET ^TMP($JOB,"IBCNSP",355.3,+IBCPOL,6)=$GET(^IBA(355.3,+IBCPOL,6))
+7 QUIT
+8 ;
COMP(IBCPOL) ; -- Compare before editing with globals
+1 SET IBDIF=0
+2 IF $GET(^IBA(355.3,+IBCPOL,0))'=$GET(^TMP($JOB,"IBCNSP",355.3,+IBCPOL,0))
SET IBDIF=1
QUIT
+3 IF $GET(^IBA(355.3,+IBCPOL,1))'=$GET(^TMP($JOB,"IBCNSP",355.3,+IBCPOL,1))
SET IBDIF=1
QUIT
+4 ; IB*2.0*497 (vd)
IF $GET(^IBA(355.3,+IBCPOL,2))'=$GET(^TMP($JOB,"IBCNSP",355.3,+IBCPOL,2))
SET IBDIF=1
QUIT
+5 ;;Daou/EEN - adding BIN and PCN
+6 IF $GET(^IBA(355.3,+IBCPOL,6))'=$GET(^TMP($JOB,"IBCNSP",355.3,+IBCPOL,6))
SET IBDIF=1
QUIT
+7 QUIT
+8 ;
UPDATE(IBCPOL) ; -- Update last edited by
+1 NEW DA,DIC,DIE,DR
+2 SET DIE="^IBA(355.3,"
SET DA=IBCPOL
SET DR="1.05///NOW;1.06////"_DUZ
+3 DO ^DIE
+4 QUIT
+5 ;
RIDERS ; -- add/edit personal riders
+1 ;
+2 DO FULL^VALM1
+3 NEW IBDIF,DA,DR,DIE,DIC,X,Y,IBCDFN,IBPRD,IBPRY
+4 SET IBCDFN=$PIECE(IBPPOL,"^",4)
+5 WRITE !
DO DISPR
WRITE !
+6 ;
R1 SET DIC="^IBA(355.7,"
SET DIC(0)="AEQML"
SET DLAYGO=355.7
+1 SET DIC("DR")=".02////"_DFN_";.03////"_IBCDFN
+2 SET DIC("S")="I $P(^(0),U,2)=DFN,$P(^(0),U,3)=IBCDFN"
+3 IF $DATA(IBPRD)
SET DIC("B")=IBPRD
+4 DO ^DIC
KILL DIC,IBPRD
+5 IF +Y<1
GOTO RIDERQ
+6 SET IBPRY=+Y
+7 LOCK +^IBA(355.7,IBPRY):5
IF '$TEST
DO LOCKED^IBTRCD1
GOTO RIDERQ
+8 SET DIE="^IBA(355.7,"
SET DA=+Y
SET DR=".01"
SET DIDEL=355.7
+9 DO ^DIE
KILL DA,DR,DIE,DIC,DIDEL,DLAYGO
+10 LOCK -^IBA(355.7,IBPRY)
+11 WRITE !
GOTO R1
RIDERQ SET VALMBCK="R"
+1 QUIT
+2 ;
RD ; -- Add riders/ for multiple policies
+1 DO FULL^VALM1
+2 NEW I,J,IBXX,VALMY
+3 DO EN^VALM2($GET(XQORNOD(0)))
+4 IF $DATA(VALMY)
SET IBXX=0
FOR
SET IBXX=$ORDER(VALMY(IBXX))
if 'IBXX
QUIT
Begin DoDot:1
+5 SET IBPPOL=$GET(^TMP("IBNSMDX",$JOB,$ORDER(^TMP("IBNSM",$JOB,"IDX",IBXX,0))))
+6 if IBPPOL=""
QUIT
+7 DO RIDERS
+8 QUIT
End DoDot:1
+9 DO BLD^IBCNSM
+10 SET VALMBCK="R"
+11 QUIT
+12 ;
DISPR ; -- Display riders
+1 NEW IBPR,I,J
+2 SET I=0
+3 IF '$GET(IBCDFN)!('$GET(DFN))
GOTO DISPRQ
+4 WRITE !,"Current Personal Riders: "
+5 FOR
SET I=$ORDER(^IBA(355.7,"APP",DFN,IBCDFN,I))
if 'I
QUIT
SET J=$ORDER(^(I,0))
SET IBPR=$GET(^IBA(355.7,+J,0))
Begin DoDot:1
+6 SET IBPRD=$$EXPAND^IBTRE(355.7,.01,+IBPR)
+7 WRITE !?5,IBPRD
End DoDot:1
+8 IF '$DATA(IBPRD)
WRITE !?5,"None Indicated"
DISPRQ QUIT
+1 ;
EMPSET(DFN,IBCPOL) ; insert patient or spouses current employer as ESGHP address if that employer sponsors this plan
+1 NEW IBWHOS,VAOA,DIR,IBE,IBEMPST,DR,X,Y
+2 IF +$GET(DFN)
SET IBWHOS=$PIECE($GET(^DPT(DFN,.312,+$GET(IBCPOL),0)),U,6)
SET VAOA("A")=$SELECT(IBWHOS="v":5,IBWHOS="s":6,1:"")
+3 IF $GET(VAOA("A"))'=""
DO OAD^VADPT
IF $GET(VAOA(9))'=""
Begin DoDot:1
+4 ;
+5 SET DIR("A")="Current Employer "_VAOA(9)_" Sponsors this Plan"
SET DIR("B")="No"
SET DIR(0)="Y"
WRITE !
DO ^DIR
WRITE !
if 'Y
QUIT
WRITE "...."
+6 DO VARS
SET IBE=$SELECT(IBWHOS="v":.311,1:.25)
SET IBEMPST=$PIECE($GET(^DPT(DFN,IBE)),U,15)
+7 ;
+8 SET DR="2.015///"_VAOA(9)_";2.02///"_VAOA(1)_";2.03///"_VAOA(2)_";2.04///"_VAOA(3)_";2.05///"_VAOA(4)
DO ^DIE
+9 SET DR="2.06////"_$PIECE(VAOA(5),U,1)_";2.07////"_$PIECE(VAOA(11),U,1)_";2.08///"_$EXTRACT(VAOA(8),1,15)_";2.11////"_IBEMPST
DO ^DIE
End DoDot:1
+10 QUIT
