- 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 Jan 18, 2025@03:19:07 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