IBCNSJ12 ;ALB/CPM - INACTIVATE AN INSURANCE PLAN (CON'T) ; 18-JAN-95
;;2.0;INTEGRATED BILLING;**28,62,142,506**;21-MAR-94;Build 74
;;Per VHA Directive 10-93-142, this routine should not be modified.
;
GETPL ; Select an active group plan or add a new one.
; Required variable input:
; IBCNS -- Pointer to the company in file #36 offering the plan
; IBPLAN -- Pointer to the current plan in file #355.3
; IBFG -- [Optional] -> set to 1 to force creation, if
; necessary, of a group plan
;
; Variable output:
; IBCPOL -- 0 if no plan was selected/added, or
; >0 points to the added/selected plan in file #355.3
; IBNEWP -- [optional]: set to 1 if a new plan was added.
;
N IBALR
S IBCPOL=0,IBALR=IBPLAN
I '$$ANYGP^IBCNSJ(IBCNS,IBPLAN) W !!,$P($G(^DIC(36,IBCNS,0)),"^")," offers no other active group plans!" G ADD
;
; - select an active group plan
S IBCPOL=$$LK^IBCNSM31(IBCNS) I 'IBCPOL W !,"No plan selected!",!
;
ADD ; - propose to add a new plan to which the patient may subscribe
I 'IBCPOL D
.W !,"You may ",$S($G(IBREP):"repoint these policies",1:"change the policy plan")," to a newly-added plan."
.; IB*2.0*506 added IBKEY parameter (4th) to the NEW^IBCNSJ3 call (check user's security keys)
.D NEW^IBCNSJ3(IBCNS,.IBCPOL,+$G(IBFG),1) W ! I IBCPOL S IBNEWP=1
I 'IBCPOL W !,"No Insurance Plan has been added or selected."
Q
;
NAC(IBPLAN,IBPR,IBDEL,IBQ) ; Inactivate the plan.
; Input: IBPLAN -- Pointer to the plan in file #355.3
; IBPR -- Prompt for the Reader call
; IBDEL -- [optional]: set to 1 if the plan may be deleted
; Output: IBQ -- set to 1 if the plan is not inactivated
;
N DIR,DIRUT,DIROUT,DUOUT,DTOUT
I '$G(IBPLAN) G NACQ
S IBQ=0,DIR(0)="Y",DIR("?")="To inactivate this plan, answer 'YES.' Otherwise, answer 'NO.'"
S DIR("A")=$S($G(IBPR)]"":IBPR,1:"Is it okay to inactivate this plan")
W ! D ^DIR I 'Y W !,"The plan was not inactivated." D DELP^IBCNSJ11 S IBQ=1 G NACQ
W !,"Inactivating the plan... " D IRACT^IBCNSJ(IBPLAN,1) W "done."
I $G(IBDEL) D DEL^IBCNSJ11(IBPLAN)
NACQ Q
;
MSG(IBCNS,IBPLAN) ; Send the subscription list to the user.
; Input: IBCNS -- Pointer to the company in file #36 offering the plan
; IBPLAN -- Pointer to the current plan in file #355.3
;
N DFN,IBCDFN,IBCDFND,IBPLAND,IBC,IBSUB1,VA,VAOA,VAERR,XMDUZ,XMTEXT,XMY,XMSUB,IBX
I '$G(IBCNS)!'$G(IBPLAN) G MSGQ
S IBPLAND=$G(^IBA(355.3,IBPLAN,0)) I 'IBPLAND G MSGQ
W !,"Building the list of inactivated subscriptions to send to you..."
;
; - build message header
K ^TMP($J,"IBSUB-LIST")
S XMSUB="SUBSCRIPTION LIST FOR INACTIVATED PLAN"
S ^TMP($J,"IBSUB-LIST",1)="The following plan offered by "_$E($P($G(^DIC(36,+IBCNS,0)),"^"),1,20)_" has been inactivated:"
S ^TMP($J,"IBSUB-LIST",2)=" "
S IBX=" Group Plan Number: "_$S($P(IBPLAND,"^",4)]"":$P(IBPLAND,"^",4),1:"<no number>")
S ^TMP($J,"IBSUB-LIST",3)=$E(IBX_$J("",25),1,43)_"Plan Number: "_$S($P(IBPLAND,"^",3)]"":$P(IBPLAND,"^",3),1:"<no name>")
S ^TMP($J,"IBSUB-LIST",4)=" "
S ^TMP($J,"IBSUB-LIST",5)="The following plan subscriptions, which may have been active, were"
S ^TMP($J,"IBSUB-LIST",6)="automatically inactivated:"
S ^TMP($J,"IBSUB-LIST",7)=" "
S ^TMP($J,"IBSUB-LIST",8)="Patient Name/ID Whose Employer Effective Expires"
S ^TMP($J,"IBSUB-LIST",9)=" ",IBC=9
;
; - build message subscription list
K ^TMP($J,"IBSUBS")
S IBSUB1=$$SUBS^IBCNSJ(IBCNS,IBPLAN,0,"^TMP($J,""IBSUBS"")")
S DFN=0 F S DFN=$O(^TMP($J,"IBSUBS",DFN)) Q:'DFN D
.D COV^IBCNSJ(DFN)
.S X=$$PT^IBEFUNC(DFN),IBM=1
.S X=$E($P(X,"^"),1,20)_" "_$P(X,"^",3)
.S IBC=IBC+1,^TMP($J,"IBSUB-LIST",IBC)=$E(X_$J("",28),1,28)
.S IBCDFN=0 F S IBCDFN=$O(^TMP($J,"IBSUBS",DFN,IBCDFN)) Q:'IBCDFN D
..S IBCDFND=$G(^DPT(DFN,.312,IBCDFN,0))
..I 'IBM S IBC=IBC+1,^TMP($J,"IBSUB-LIST",IBC)=$J("",28) S IBM=1
..S X=$$EXPAND^IBTRE(2.312,6,$P(IBCDFND,"^",6))
..S IBX=^TMP($J,"IBSUB-LIST",IBC)
..S IBX=IBX_$E(X_$J("",9),1,9)
..S VAOA("A")=$S($P(IBCDFND,"^",6)="s":6,1:5) D OAD^VADPT
..S IBX=IBX_$E($E(VAOA(9),1,21)_$J("",22),1,22)
..S IBX=IBX_$E($$DAT1^IBOUTL($P(IBCDFND,"^",8))_$J("",10),1,10)
..S IBX=IBX_$E($$DAT1^IBOUTL($P(IBCDFND,"^",4))_$J("",10),1,10)
..S ^TMP($J,"IBSUB-LIST",IBC)=IBX
;
; - build message trailer and transmit
S IBC=IBC+1,^TMP($J,"IBSUB-LIST",IBC)=" "
S IBC=IBC+1,^TMP($J,"IBSUB-LIST",IBC)="You should review this list and change the policy plan for any of"
S IBC=IBC+1,^TMP($J,"IBSUB-LIST",IBC)="these subscriptions if necessary."
S XMDUZ="INTEGRATED BILLING PACKAGE",XMTEXT="^TMP($J,""IBSUB-LIST"","
K XMY S XMY(DUZ)=""
D ^XMD
MSGQ K ^TMP($J,"IBSUBS"),^TMP($J,"IBSUB-LIST")
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCNSJ12 4829 printed Oct 16, 2024@18:17:54 Page 2
IBCNSJ12 ;ALB/CPM - INACTIVATE AN INSURANCE PLAN (CON'T) ; 18-JAN-95
+1 ;;2.0;INTEGRATED BILLING;**28,62,142,506**;21-MAR-94;Build 74
+2 ;;Per VHA Directive 10-93-142, this routine should not be modified.
+3 ;
GETPL ; Select an active group plan or add a new one.
+1 ; Required variable input:
+2 ; IBCNS -- Pointer to the company in file #36 offering the plan
+3 ; IBPLAN -- Pointer to the current plan in file #355.3
+4 ; IBFG -- [Optional] -> set to 1 to force creation, if
+5 ; necessary, of a group plan
+6 ;
+7 ; Variable output:
+8 ; IBCPOL -- 0 if no plan was selected/added, or
+9 ; >0 points to the added/selected plan in file #355.3
+10 ; IBNEWP -- [optional]: set to 1 if a new plan was added.
+11 ;
+12 NEW IBALR
+13 SET IBCPOL=0
SET IBALR=IBPLAN
+14 IF '$$ANYGP^IBCNSJ(IBCNS,IBPLAN)
WRITE !!,$PIECE($GET(^DIC(36,IBCNS,0)),"^")," offers no other active group plans!"
GOTO ADD
+15 ;
+16 ; - select an active group plan
+17 SET IBCPOL=$$LK^IBCNSM31(IBCNS)
IF 'IBCPOL
WRITE !,"No plan selected!",!
+18 ;
ADD ; - propose to add a new plan to which the patient may subscribe
+1 IF 'IBCPOL
Begin DoDot:1
+2 WRITE !,"You may ",$SELECT($GET(IBREP):"repoint these policies",1:"change the policy plan")," to a newly-added plan."
+3 ; IB*2.0*506 added IBKEY parameter (4th) to the NEW^IBCNSJ3 call (check user's security keys)
+4 DO NEW^IBCNSJ3(IBCNS,.IBCPOL,+$GET(IBFG),1)
WRITE !
IF IBCPOL
SET IBNEWP=1
End DoDot:1
+5 IF 'IBCPOL
WRITE !,"No Insurance Plan has been added or selected."
+6 QUIT
+7 ;
NAC(IBPLAN,IBPR,IBDEL,IBQ) ; Inactivate the plan.
+1 ; Input: IBPLAN -- Pointer to the plan in file #355.3
+2 ; IBPR -- Prompt for the Reader call
+3 ; IBDEL -- [optional]: set to 1 if the plan may be deleted
+4 ; Output: IBQ -- set to 1 if the plan is not inactivated
+5 ;
+6 NEW DIR,DIRUT,DIROUT,DUOUT,DTOUT
+7 IF '$GET(IBPLAN)
GOTO NACQ
+8 SET IBQ=0
SET DIR(0)="Y"
SET DIR("?")="To inactivate this plan, answer 'YES.' Otherwise, answer 'NO.'"
+9 SET DIR("A")=$SELECT($GET(IBPR)]"":IBPR,1:"Is it okay to inactivate this plan")
+10 WRITE !
DO ^DIR
IF 'Y
WRITE !,"The plan was not inactivated."
DO DELP^IBCNSJ11
SET IBQ=1
GOTO NACQ
+11 WRITE !,"Inactivating the plan... "
DO IRACT^IBCNSJ(IBPLAN,1)
WRITE "done."
+12 IF $GET(IBDEL)
DO DEL^IBCNSJ11(IBPLAN)
NACQ QUIT
+1 ;
MSG(IBCNS,IBPLAN) ; Send the subscription list to the user.
+1 ; Input: IBCNS -- Pointer to the company in file #36 offering the plan
+2 ; IBPLAN -- Pointer to the current plan in file #355.3
+3 ;
+4 NEW DFN,IBCDFN,IBCDFND,IBPLAND,IBC,IBSUB1,VA,VAOA,VAERR,XMDUZ,XMTEXT,XMY,XMSUB,IBX
+5 IF '$GET(IBCNS)!'$GET(IBPLAN)
GOTO MSGQ
+6 SET IBPLAND=$GET(^IBA(355.3,IBPLAN,0))
IF 'IBPLAND
GOTO MSGQ
+7 WRITE !,"Building the list of inactivated subscriptions to send to you..."
+8 ;
+9 ; - build message header
+10 KILL ^TMP($JOB,"IBSUB-LIST")
+11 SET XMSUB="SUBSCRIPTION LIST FOR INACTIVATED PLAN"
+12 SET ^TMP($JOB,"IBSUB-LIST",1)="The following plan offered by "_$EXTRACT($PIECE($GET(^DIC(36,+IBCNS,0)),"^"),1,20)_" has been inactivated:"
+13 SET ^TMP($JOB,"IBSUB-LIST",2)=" "
+14 SET IBX=" Group Plan Number: "_$SELECT($PIECE(IBPLAND,"^",4)]"":$PIECE(IBPLAND,"^",4),1:"<no number>")
+15 SET ^TMP($JOB,"IBSUB-LIST",3)=$EXTRACT(IBX_$JUSTIFY("",25),1,43)_"Plan Number: "_$SELECT($PIECE(IBPLAND,"^",3)]"":$PIECE(IBPLAND,"^",3),1:"<no name>")
+16 SET ^TMP($JOB,"IBSUB-LIST",4)=" "
+17 SET ^TMP($JOB,"IBSUB-LIST",5)="The following plan subscriptions, which may have been active, were"
+18 SET ^TMP($JOB,"IBSUB-LIST",6)="automatically inactivated:"
+19 SET ^TMP($JOB,"IBSUB-LIST",7)=" "
+20 SET ^TMP($JOB,"IBSUB-LIST",8)="Patient Name/ID Whose Employer Effective Expires"
+21 SET ^TMP($JOB,"IBSUB-LIST",9)=" "
SET IBC=9
+22 ;
+23 ; - build message subscription list
+24 KILL ^TMP($JOB,"IBSUBS")
+25 SET IBSUB1=$$SUBS^IBCNSJ(IBCNS,IBPLAN,0,"^TMP($J,""IBSUBS"")")
+26 SET DFN=0
FOR
SET DFN=$ORDER(^TMP($JOB,"IBSUBS",DFN))
if 'DFN
QUIT
Begin DoDot:1
+27 DO COV^IBCNSJ(DFN)
+28 SET X=$$PT^IBEFUNC(DFN)
SET IBM=1
+29 SET X=$EXTRACT($PIECE(X,"^"),1,20)_" "_$PIECE(X,"^",3)
+30 SET IBC=IBC+1
SET ^TMP($JOB,"IBSUB-LIST",IBC)=$EXTRACT(X_$JUSTIFY("",28),1,28)
+31 SET IBCDFN=0
FOR
SET IBCDFN=$ORDER(^TMP($JOB,"IBSUBS",DFN,IBCDFN))
if 'IBCDFN
QUIT
Begin DoDot:2
+32 SET IBCDFND=$GET(^DPT(DFN,.312,IBCDFN,0))
+33 IF 'IBM
SET IBC=IBC+1
SET ^TMP($JOB,"IBSUB-LIST",IBC)=$JUSTIFY("",28)
SET IBM=1
+34 SET X=$$EXPAND^IBTRE(2.312,6,$PIECE(IBCDFND,"^",6))
+35 SET IBX=^TMP($JOB,"IBSUB-LIST",IBC)
+36 SET IBX=IBX_$EXTRACT(X_$JUSTIFY("",9),1,9)
+37 SET VAOA("A")=$SELECT($PIECE(IBCDFND,"^",6)="s":6,1:5)
DO OAD^VADPT
+38 SET IBX=IBX_$EXTRACT($EXTRACT(VAOA(9),1,21)_$JUSTIFY("",22),1,22)
+39 SET IBX=IBX_$EXTRACT($$DAT1^IBOUTL($PIECE(IBCDFND,"^",8))_$JUSTIFY("",10),1,10)
+40 SET IBX=IBX_$EXTRACT($$DAT1^IBOUTL($PIECE(IBCDFND,"^",4))_$JUSTIFY("",10),1,10)
+41 SET ^TMP($JOB,"IBSUB-LIST",IBC)=IBX
End DoDot:2
End DoDot:1
+42 ;
+43 ; - build message trailer and transmit
+44 SET IBC=IBC+1
SET ^TMP($JOB,"IBSUB-LIST",IBC)=" "
+45 SET IBC=IBC+1
SET ^TMP($JOB,"IBSUB-LIST",IBC)="You should review this list and change the policy plan for any of"
+46 SET IBC=IBC+1
SET ^TMP($JOB,"IBSUB-LIST",IBC)="these subscriptions if necessary."
+47 SET XMDUZ="INTEGRATED BILLING PACKAGE"
SET XMTEXT="^TMP($J,""IBSUB-LIST"","
+48 KILL XMY
SET XMY(DUZ)=""
+49 DO ^XMD
MSGQ KILL ^TMP($JOB,"IBSUBS"),^TMP($JOB,"IBSUB-LIST")
+1 QUIT
