IBCNSM31 ;ALB/AAS/JNM - INSURANCE MANAGEMENT - OUTPUTS ;28-MAY-93
;;2.0;INTEGRATED BILLING;**6,28,68,413,497,516,549**;21-MAR-94;Build 54
;;Per VA Directive 6402, this routine should not be modified.
;
% G EN^IBCNSM
;
EA ; -- Edit all insurance policy data
N IBDIF,I,J,IBXX,IBCDFN,IBTRC,VALMY
D EN^VALM2($G(XQORNOD(0)))
D FULL^VALM1
;
;IB*2.0*549 - Added Security Key check
I '$D(^XUSEC("IB GROUP PLAN EDIT",DUZ)) D Q
. W !!,*7,"Sorry, but you do not have the required privileges to Edit All"
. K DIR
. D PAUSE^VALM1
. D EAQ
;
I $D(VALMY) S IBXX=0 F S IBXX=$O(VALMY(IBXX)) Q:'IBXX D ;W !,"Entry ",X,"Selected" D
.S IBPPOL=$G(^TMP("IBNSMDX",$J,$O(^TMP("IBNSM",$J,"IDX",IBXX,0))))
.Q:IBPPOL=""
.S IBCDFN=$P($G(IBPPOL),"^",4) I 'IBCDFN W !!,"Can't identify the policy!" Q
.; -- edit patient data
.N IBQUIT S IBQUIT=0
.S IBCNSEH=$P($G(^IBE(350.9,1,4)),"^",1) D PAT^IBCNSEH
.D BEFORE^IBCNSEVT
.D PATPOL^IBCNSM32(IBCDFN)
.D AFTER^IBCNSEVT,^IBCNSEVT
.; -- edit policy data
.D:'$G(IBQUIT) POL^IBCNSEH,EDPOL^IBCNSM3(IBCDFN)
.W ! D AI^IBCNSP1 D:$G(IBTRC) AIP^IBCNSP02(IBTRC)
.Q
;
EAQ D BLD^IBCNSM
S VALMBCK="R"
Q
;
LK(IBCNS) ; -- screened look up to policy file
; input: IBCNS = pointer to insurance company file (36)
;
N DIC,IBX,DIR,DUOUT,DTOUT,DIROUT,DIRUT,X,Y,IBCPOL
S IBCPOL=""
I $G(IBCNS)="" G LKQ
;
I '$$ANYGP^IBCNSJ(IBCNS) W !!,"This company does not offer any active group plans." G LKQ
;
S DIR(0)="Y",DIR("A")="This company offers active group plans. Do you wish to select one"
S DIR("?")="The look-up facility to select an active group plan has been enhanced to use the List Manager. Enter 'YES' if you wish to select a plan from this look-up, or 'NO' to add your own plan."
D ^DIR K DIR I 'Y G LKQ
;
S DIR(0)="Y",DIR("B")="YES",DIR("A")="Do you wish to directly enter this plan"
S DIR("?")="The look-up facility to select an active group plan has been enhanced to use the List Manager. Enter 'NO' if you wish to select a plan from this look-up, or 'YES' to directly enter the plan."
D ^DIR K DIR I $D(DIRUT) G LKQ
;
I 'Y D LKP^IBCNSU2(IBCNS,0,0,.IBCPOL,$G(IBALR)) G LKQ
;
; MRD;IB*2.0*516 - Display new Group Name and Number fields.
S DIC("A")="Select an Active GROUP PLAN: "
S DIC="^IBA(355.3,",DIC(0)="AEQM",DIC("S")="I +^(0)=IBCNS,$P(^(0),U,2),'$P(^(0),U,11),$G(IBALR)'=+Y"
;S DIC("W")="N IBX S IBX=$G(^(0)) W "" Name: "",$E($S($P(IBX,U,3)]"""":$P(IBX,U,3),1:""<none>"")_$J("""",20),1,20),"" Number: "",$S($P(IBX,U,4)]"""":$P(IBX,U,4),1:""<none>"")"
S DIC("W")="N IBX S IBX=$G(^(2)) W "" Name: "",$E($S($P(IBX,U,1)]"""":$P(IBX,U,1),1:""<none>"")_$J("""",20),1,20),"" Number: "",$E($S($P(IBX,U,2)]"""":$P(IBX,U,2),1:""<none>""),1,14)"
D ^DIC K DIC I +Y>0 S IBCPOL=+Y
;
; -- see if only one policy
;I '$O(^IBA(355.3,"B",+IBCNS,IBX) D G LKQ
;
; -- is more than one plan to choose from, let fileman do it.
;S DIC("A")="Select GROUP INSURANCE PLAN: "
;
;S DIC="^IBA(355.3,",DIC(0)="AEQM",DIC("S")="I $P(^(0),U)=IBCNS,($P(^(0),U,2)=1!($P(^(0),U,10)=$G(DFN)))"
;
;D ^DIC K DIC I +Y>0 S IBCPOL=+Y
;
LKQ Q IBCPOL
;
FUTURE ; -- if expiration date in future give warning
I $G(IBFUTUR) K IBFUTUR Q
I $P(^DPT(DFN,.312,IBCDFN,0),"^",4),$P(^(0),"^",4)>DT W !!,*7,"WARNING: The expiration date for this policy is in the future!",!," Normally this is a past date or left blank or a past date",! S Y="@333"
S IBFUTUR=1
Q
;
COVERED(DFN,IBCOVP) ; -- update covered by insurance in background
; -- input ibcovp = the covered by insurance field prior to editing
; (add/edit/delete) of the 2.312 insurance type mult.
;
Q:$G(DFN)<1
N X,Y,I,IBCOV,IBNCOV,DA,DR,DIE,DIC,IBINS,IBINSD
S (IBCOV,IBNCOV)=$P($G(^DPT(DFN,.31)),"^",11)
D ALL^IBCNS1(DFN,"IBINS",2,DT) S IBINSD=+$G(IBINS(0))
;
; -- initial value ="" or Unknown
I $G(IBCOVP)=""!($G(IBCOVP)="U") S IBNCOV=$S('$O(^DPT(DFN,.312,0)):"U",IBINSD:"Y",1:"N")
;
; -- initial value = YES or NO (treat the same)
I $G(IBCOVP)="Y"!($G(IBCOVP)="N") S IBNCOV=$S('$O(^DPT(DFN,.312,0)):"N",IBINSD:"Y",1:"N")
;
;
I IBCOV'=IBNCOV D
.S DIE="^DPT(",DR=".3192////"_IBNCOV,DA=DFN D ^DIE
.I '$D(ZTQUEUED)&($G(IBSUPRES)'>0) W !!,"COVERED BY HEALTH INSURANCE changed to '"_$S(IBNCOV="Y":"YES",IBNCOV="N":"NO",1:"UNKNOWN"),"'.",! H 3
.Q
Q
;
3 ; -- display group name as uneditable
; called by die, expects da = entry in 355.3
N X
S X=$P($G(^IBA(355.3,DA,2)),"^",1) ; IB*2.0*497 (vd)
W !,"GROUP NAME: ",X,$S(X'="":"// ",1:"")," (No Editing)"
Q
;
4 ; -- display group number as uneditable
; called by die, expects da = entry in 355.3
N X
S X=$P($G(^IBA(355.3,DA,2)),"^",2) ; IB*2.0*497 (vd)
W !,"GROUP NUMBER: ",X,$S(X'="":"// ",1:"")," (No Editing)"
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCNSM31 4849 printed Dec 13, 2024@02:17:28 Page 2
IBCNSM31 ;ALB/AAS/JNM - INSURANCE MANAGEMENT - OUTPUTS ;28-MAY-93
+1 ;;2.0;INTEGRATED BILLING;**6,28,68,413,497,516,549**;21-MAR-94;Build 54
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;
% GOTO EN^IBCNSM
+1 ;
EA ; -- Edit all insurance policy data
+1 NEW IBDIF,I,J,IBXX,IBCDFN,IBTRC,VALMY
+2 DO EN^VALM2($GET(XQORNOD(0)))
+3 DO FULL^VALM1
+4 ;
+5 ;IB*2.0*549 - Added Security Key check
+6 IF '$DATA(^XUSEC("IB GROUP PLAN EDIT",DUZ))
Begin DoDot:1
+7 WRITE !!,*7,"Sorry, but you do not have the required privileges to Edit All"
+8 KILL DIR
+9 DO PAUSE^VALM1
+10 DO EAQ
End DoDot:1
QUIT
+11 ;
+12 ;W !,"Entry ",X,"Selected" D
IF $DATA(VALMY)
SET IBXX=0
FOR
SET IBXX=$ORDER(VALMY(IBXX))
if 'IBXX
QUIT
Begin DoDot:1
+13 SET IBPPOL=$GET(^TMP("IBNSMDX",$JOB,$ORDER(^TMP("IBNSM",$JOB,"IDX",IBXX,0))))
+14 if IBPPOL=""
QUIT
+15 SET IBCDFN=$PIECE($GET(IBPPOL),"^",4)
IF 'IBCDFN
WRITE !!,"Can't identify the policy!"
QUIT
+16 ; -- edit patient data
+17 NEW IBQUIT
SET IBQUIT=0
+18 SET IBCNSEH=$PIECE($GET(^IBE(350.9,1,4)),"^",1)
DO PAT^IBCNSEH
+19 DO BEFORE^IBCNSEVT
+20 DO PATPOL^IBCNSM32(IBCDFN)
+21 DO AFTER^IBCNSEVT
DO ^IBCNSEVT
+22 ; -- edit policy data
+23 if '$GET(IBQUIT)
DO POL^IBCNSEH
DO EDPOL^IBCNSM3(IBCDFN)
+24 WRITE !
DO AI^IBCNSP1
if $GET(IBTRC)
DO AIP^IBCNSP02(IBTRC)
+25 QUIT
End DoDot:1
+26 ;
EAQ DO BLD^IBCNSM
+1 SET VALMBCK="R"
+2 QUIT
+3 ;
LK(IBCNS) ; -- screened look up to policy file
+1 ; input: IBCNS = pointer to insurance company file (36)
+2 ;
+3 NEW DIC,IBX,DIR,DUOUT,DTOUT,DIROUT,DIRUT,X,Y,IBCPOL
+4 SET IBCPOL=""
+5 IF $GET(IBCNS)=""
GOTO LKQ
+6 ;
+7 IF '$$ANYGP^IBCNSJ(IBCNS)
WRITE !!,"This company does not offer any active group plans."
GOTO LKQ
+8 ;
+9 SET DIR(0)="Y"
SET DIR("A")="This company offers active group plans. Do you wish to select one"
+10 SET DIR("?")="The look-up facility to select an active group plan has been enhanced to use the List Manager. Enter 'YES' if you wish to select a plan from this look-up, or 'NO' to add your own plan."
+11 DO ^DIR
KILL DIR
IF 'Y
GOTO LKQ
+12 ;
+13 SET DIR(0)="Y"
SET DIR("B")="YES"
SET DIR("A")="Do you wish to directly enter this plan"
+14 SET DIR("?")="The look-up facility to select an active group plan has been enhanced to use the List Manager. Enter 'NO' if you wish to select a plan from this look-up, or 'YES' to directly enter the plan."
+15 DO ^DIR
KILL DIR
IF $DATA(DIRUT)
GOTO LKQ
+16 ;
+17 IF 'Y
DO LKP^IBCNSU2(IBCNS,0,0,.IBCPOL,$GET(IBALR))
GOTO LKQ
+18 ;
+19 ; MRD;IB*2.0*516 - Display new Group Name and Number fields.
+20 SET DIC("A")="Select an Active GROUP PLAN: "
+21 SET DIC="^IBA(355.3,"
SET DIC(0)="AEQM"
SET DIC("S")="I +^(0)=IBCNS,$P(^(0),U,2),'$P(^(0),U,11),$G(IBALR)'=+Y"
+22 ;S DIC("W")="N IBX S IBX=$G(^(0)) W "" Name: "",$E($S($P(IBX,U,3)]"""":$P(IBX,U,3),1:""<none>"")_$J("""",20),1,20),"" Number: "",$S($P(IBX,U,4)]"""":$P(IBX,U,4),1:""<none>"")"
+23 SET DIC("W")="N IBX S IBX=$G(^(2)) W "" Name: "",$E($S($P(IBX,U,1)]"""":$P(IBX,U,1),1:""<none>"")_$J("""",20),1,20),"" Number: "",$E($S($P(IBX,U,2)]"""":$P(IBX,U,2),1:""<none>""),1,14)"
+24 DO ^DIC
KILL DIC
IF +Y>0
SET IBCPOL=+Y
+25 ;
+26 ; -- see if only one policy
+27 ;I '$O(^IBA(355.3,"B",+IBCNS,IBX) D G LKQ
+28 ;
+29 ; -- is more than one plan to choose from, let fileman do it.
+30 ;S DIC("A")="Select GROUP INSURANCE PLAN: "
+31 ;
+32 ;S DIC="^IBA(355.3,",DIC(0)="AEQM",DIC("S")="I $P(^(0),U)=IBCNS,($P(^(0),U,2)=1!($P(^(0),U,10)=$G(DFN)))"
+33 ;
+34 ;D ^DIC K DIC I +Y>0 S IBCPOL=+Y
+35 ;
LKQ QUIT IBCPOL
+1 ;
FUTURE ; -- if expiration date in future give warning
+1 IF $GET(IBFUTUR)
KILL IBFUTUR
QUIT
+2 IF $PIECE(^DPT(DFN,.312,IBCDFN,0),"^",4)
IF $PIECE(^(0),"^",4)>DT
WRITE !!,*7,"WARNING: The expiration date for this policy is in the future!",!," Normally this is a past date or left blank or a past date",!
SET Y="@333"
+3 SET IBFUTUR=1
+4 QUIT
+5 ;
COVERED(DFN,IBCOVP) ; -- update covered by insurance in background
+1 ; -- input ibcovp = the covered by insurance field prior to editing
+2 ; (add/edit/delete) of the 2.312 insurance type mult.
+3 ;
+4 if $GET(DFN)<1
QUIT
+5 NEW X,Y,I,IBCOV,IBNCOV,DA,DR,DIE,DIC,IBINS,IBINSD
+6 SET (IBCOV,IBNCOV)=$PIECE($GET(^DPT(DFN,.31)),"^",11)
+7 DO ALL^IBCNS1(DFN,"IBINS",2,DT)
SET IBINSD=+$GET(IBINS(0))
+8 ;
+9 ; -- initial value ="" or Unknown
+10 IF $GET(IBCOVP)=""!($GET(IBCOVP)="U")
SET IBNCOV=$SELECT('$ORDER(^DPT(DFN,.312,0)):"U",IBINSD:"Y",1:"N")
+11 ;
+12 ; -- initial value = YES or NO (treat the same)
+13 IF $GET(IBCOVP)="Y"!($GET(IBCOVP)="N")
SET IBNCOV=$SELECT('$ORDER(^DPT(DFN,.312,0)):"N",IBINSD:"Y",1:"N")
+14 ;
+15 ;
+16 IF IBCOV'=IBNCOV
Begin DoDot:1
+17 SET DIE="^DPT("
SET DR=".3192////"_IBNCOV
SET DA=DFN
DO ^DIE
+18 IF '$DATA(ZTQUEUED)&($GET(IBSUPRES)'>0)
WRITE !!,"COVERED BY HEALTH INSURANCE changed to '"_$SELECT(IBNCOV="Y":"YES",IBNCOV="N":"NO",1:"UNKNOWN"),"'.",!
HANG 3
+19 QUIT
End DoDot:1
+20 QUIT
+21 ;
3 ; -- display group name as uneditable
+1 ; called by die, expects da = entry in 355.3
+2 NEW X
+3 ; IB*2.0*497 (vd)
SET X=$PIECE($GET(^IBA(355.3,DA,2)),"^",1)
+4 WRITE !,"GROUP NAME: ",X,$SELECT(X'="":"// ",1:"")," (No Editing)"
+5 QUIT
+6 ;
4 ; -- display group number as uneditable
+1 ; called by die, expects da = entry in 355.3
+2 NEW X
+3 ; IB*2.0*497 (vd)
SET X=$PIECE($GET(^IBA(355.3,DA,2)),"^",2)
+4 WRITE !,"GROUP NUMBER: ",X,$SELECT(X'="":"// ",1:"")," (No Editing)"
+5 QUIT
