IBCNSJ21 ;ALB/CPM - CHANGE POLICY PLAN (CON'T) ; 12-JAN-95
;;Version 2.0 ; INTEGRATED BILLING ;**28**; 21-MAR-94
;;Per VHA Directive 10-93-142, this routine should not be modified.
;
NOTES ; Display any necessary notes to the user.
N IBS S IBS=0
S IBIP='$P(IBPLAND,"^",2) I IBIP S IBS=1 W !,"Please note that this is an Individual Plan."
I $P(IBPLAND,"^",11) S IBS=1 W !,*7,"This plan is currently inactive."
D BU I $O(IBBU(0)) S IBS=1 W !,*7,"There are Benefits Used associated with this plan!"
I $O(^IBA(355.7,"APP",DFN,IBCDFN,0)) S IBS=1 W !,*7,"This patient has riders associated with this policy!"
I $$IR(DFN,IBCDFN) S IBS=1 W !,*7,"There are insurance reviews associated with this policy."
W:IBS !
Q
;
BU ; Are there any benefits used for this plan and policy?
; Input variables required:
; DFN -- ptr to patient in file #2
; IBPLAN -- ptr to policy plan in file #355.3
; IBCDFN -- ptr to policy in sub-file #2.312
;
; Output variable array:
; IBBU(X)=Y -- array of benefits used associated with the policy,
; where X is the benefit year, and Y points to the bu
; in file #355.5
N DATE,POL
S DATE="" F S DATE=$O(^IBA(355.5,"APPY",DFN,IBPLAN,DATE)) Q:DATE="" D
.S POL=0 F S POL=$O(^IBA(355.5,"APPY",DFN,IBPLAN,DATE,POL)) Q:'POL I POL=IBCDFN S IBBU(-DATE)=$O(^(POL,0))
Q
;
AB ; Find all Annual Benefits associated with an Insurance Plan.
; Input variables required:
; IBCPOL -- ptr to proposed plan in file #355.3
;
; Output variable array:
; IBAB(X) -- array of annual benefits, where X is the benefit year
;
N X S X=""
F S X=$O(^IBA(355.4,"APY",IBCPOL,X)) Q:X="" S IBAB(-X)=""
Q
;
IR(DFN,IBCDFN) ; Are there any Insurance reviews associated with the policy?
; Input: DFN -- Pointer to the patient in file #2
; IBCDFN -- Pointer to the policy in file #2.312
; Output: 1 -- There are associated insurance reviews, or
; 0 -- there are not.
N X,Y S X=0
I $G(DFN),$G(IBCDFN) S Y=0 F S Y=$O(^IBT(356.2,"D",DFN,Y)) Q:'Y I $P($G(^IBT(356.2,Y,1)),"^",5)=IBCDFN S X=1 Q
Q X
;
DMBU ; Display mergeable benefits used.
N IBMRG
S X=0 F S X=$O(IBAB(X)) Q:'X S IBMRG(X)=""
S X=0 F S X=$O(IBBU(X)) Q:'X S IBMRG(X)=""
W !!," Existing Benefit Used Yr",?31,"Annual Benefit for Proposed Plan",?66,"Merge BU?",!
S X=0 F S X=$O(IBMRG(X)) Q:'X D
.W ! W:$D(IBBU(X)) ?6,$$DAT2^IBOUTL(X) W:$D(IBAB(X)) ?40,$$DAT2^IBOUTL(X)
.W ?69 I '$D(IBAB(X)) W "NO" S IBMRGN=1 Q
.I '$D(IBBU(X)) W "-na-" Q
.S IBMRGF(X)=IBBU(X) W "YES"
Q
;
MD ; Merge/delete benefits used, if necessary.
I $G(IBMERGE) D
.W !,"Merging previous benefits used into the new plan... "
.S IBX="" F S IBX=$O(IBMRGF(IBX)) Q:IBX="" D MERG^IBCNSJ13(IBCPOL,+IBMRGF(IBX)) K IBBU(IBX)
.W "done."
;
; - delete any remaining benefits used
I $O(IBBU(0)) D
.W !,"Deleting previous benefits used... "
.S IBX="" F S IBX=$O(IBBU(IBX)) Q:IBX="" D DBU^IBCNSJ(IBBU(IBX))
.W "done."
MDQ Q
;
HLSW ; Reader help for switching plans.
W !!,"If you wish to change the subscribed-to plan the newly-",$S($G(IBNEWP):"added",1:"selected")," plan,"
W !,"enter 'YES'. Otherwise, enter 'NO'."
Q:'$O(IBBU(0))
W !!,"If you change the plan for this policy, "
I '$G(IBMERGE)!'$O(IBMRGF(0)) W "all existing benefits will be deleted." Q
I '$G(IBMRGN) W "all existing benefits will be merged." Q
W "all transferable benefits",!,"will be merged. All others will be deleted."
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCNSJ21 3574 printed Oct 16, 2024@18:17:58 Page 2
IBCNSJ21 ;ALB/CPM - CHANGE POLICY PLAN (CON'T) ; 12-JAN-95
+1 ;;Version 2.0 ; INTEGRATED BILLING ;**28**; 21-MAR-94
+2 ;;Per VHA Directive 10-93-142, this routine should not be modified.
+3 ;
NOTES ; Display any necessary notes to the user.
+1 NEW IBS
SET IBS=0
+2 SET IBIP='$PIECE(IBPLAND,"^",2)
IF IBIP
SET IBS=1
WRITE !,"Please note that this is an Individual Plan."
+3 IF $PIECE(IBPLAND,"^",11)
SET IBS=1
WRITE !,*7,"This plan is currently inactive."
+4 DO BU
IF $ORDER(IBBU(0))
SET IBS=1
WRITE !,*7,"There are Benefits Used associated with this plan!"
+5 IF $ORDER(^IBA(355.7,"APP",DFN,IBCDFN,0))
SET IBS=1
WRITE !,*7,"This patient has riders associated with this policy!"
+6 IF $$IR(DFN,IBCDFN)
SET IBS=1
WRITE !,*7,"There are insurance reviews associated with this policy."
+7 if IBS
WRITE !
+8 QUIT
+9 ;
BU ; Are there any benefits used for this plan and policy?
+1 ; Input variables required:
+2 ; DFN -- ptr to patient in file #2
+3 ; IBPLAN -- ptr to policy plan in file #355.3
+4 ; IBCDFN -- ptr to policy in sub-file #2.312
+5 ;
+6 ; Output variable array:
+7 ; IBBU(X)=Y -- array of benefits used associated with the policy,
+8 ; where X is the benefit year, and Y points to the bu
+9 ; in file #355.5
+10 NEW DATE,POL
+11 SET DATE=""
FOR
SET DATE=$ORDER(^IBA(355.5,"APPY",DFN,IBPLAN,DATE))
if DATE=""
QUIT
Begin DoDot:1
+12 SET POL=0
FOR
SET POL=$ORDER(^IBA(355.5,"APPY",DFN,IBPLAN,DATE,POL))
if 'POL
QUIT
IF POL=IBCDFN
SET IBBU(-DATE)=$ORDER(^(POL,0))
End DoDot:1
+13 QUIT
+14 ;
AB ; Find all Annual Benefits associated with an Insurance Plan.
+1 ; Input variables required:
+2 ; IBCPOL -- ptr to proposed plan in file #355.3
+3 ;
+4 ; Output variable array:
+5 ; IBAB(X) -- array of annual benefits, where X is the benefit year
+6 ;
+7 NEW X
SET X=""
+8 FOR
SET X=$ORDER(^IBA(355.4,"APY",IBCPOL,X))
if X=""
QUIT
SET IBAB(-X)=""
+9 QUIT
+10 ;
IR(DFN,IBCDFN) ; Are there any Insurance reviews associated with the policy?
+1 ; Input: DFN -- Pointer to the patient in file #2
+2 ; IBCDFN -- Pointer to the policy in file #2.312
+3 ; Output: 1 -- There are associated insurance reviews, or
+4 ; 0 -- there are not.
+5 NEW X,Y
SET X=0
+6 IF $GET(DFN)
IF $GET(IBCDFN)
SET Y=0
FOR
SET Y=$ORDER(^IBT(356.2,"D",DFN,Y))
if 'Y
QUIT
IF $PIECE($GET(^IBT(356.2,Y,1)),"^",5)=IBCDFN
SET X=1
QUIT
+7 QUIT X
+8 ;
DMBU ; Display mergeable benefits used.
+1 NEW IBMRG
+2 SET X=0
FOR
SET X=$ORDER(IBAB(X))
if 'X
QUIT
SET IBMRG(X)=""
+3 SET X=0
FOR
SET X=$ORDER(IBBU(X))
if 'X
QUIT
SET IBMRG(X)=""
+4 WRITE !!," Existing Benefit Used Yr",?31,"Annual Benefit for Proposed Plan",?66,"Merge BU?",!
+5 SET X=0
FOR
SET X=$ORDER(IBMRG(X))
if 'X
QUIT
Begin DoDot:1
+6 WRITE !
if $DATA(IBBU(X))
WRITE ?6,$$DAT2^IBOUTL(X)
if $DATA(IBAB(X))
WRITE ?40,$$DAT2^IBOUTL(X)
+7 WRITE ?69
IF '$DATA(IBAB(X))
WRITE "NO"
SET IBMRGN=1
QUIT
+8 IF '$DATA(IBBU(X))
WRITE "-na-"
QUIT
+9 SET IBMRGF(X)=IBBU(X)
WRITE "YES"
End DoDot:1
+10 QUIT
+11 ;
MD ; Merge/delete benefits used, if necessary.
+1 IF $GET(IBMERGE)
Begin DoDot:1
+2 WRITE !,"Merging previous benefits used into the new plan... "
+3 SET IBX=""
FOR
SET IBX=$ORDER(IBMRGF(IBX))
if IBX=""
QUIT
DO MERG^IBCNSJ13(IBCPOL,+IBMRGF(IBX))
KILL IBBU(IBX)
+4 WRITE "done."
End DoDot:1
+5 ;
+6 ; - delete any remaining benefits used
+7 IF $ORDER(IBBU(0))
Begin DoDot:1
+8 WRITE !,"Deleting previous benefits used... "
+9 SET IBX=""
FOR
SET IBX=$ORDER(IBBU(IBX))
if IBX=""
QUIT
DO DBU^IBCNSJ(IBBU(IBX))
+10 WRITE "done."
End DoDot:1
MDQ QUIT
+1 ;
HLSW ; Reader help for switching plans.
+1 WRITE !!,"If you wish to change the subscribed-to plan the newly-",$SELECT($GET(IBNEWP):"added",1:"selected")," plan,"
+2 WRITE !,"enter 'YES'. Otherwise, enter 'NO'."
+3 if '$ORDER(IBBU(0))
QUIT
+4 WRITE !!,"If you change the plan for this policy, "
+5 IF '$GET(IBMERGE)!'$ORDER(IBMRGF(0))
WRITE "all existing benefits will be deleted."
QUIT
+6 IF '$GET(IBMRGN)
WRITE "all existing benefits will be merged."
QUIT
+7 WRITE "all transferable benefits",!,"will be merged. All others will be deleted."
+8 QUIT
