IBCNRPM1 ;DAOU/CMW - Match Multiple Group Plans to a Pharmacy Plan ;10-MAR-2004
;;2.0;INTEGRATED BILLING;**251,516,617,711**;21-MAR-94;Build 18
;;Per VA Directive 6402, this routine should not be modified.
;
;**Program Description**
; This program selects a plan and displays the
; Test Payer Sheets associated to the Plan.
;
EN ; Select a plan
NEW DA,DIC,DIE,DR,D,Y
S DIC="^IBCNR(366.03,",DIC(0)="ABEMZ",DIC("A")="Select PHARMACY PLAN: "
D ^DIC I X="^" G EXIT
K DIC("A")
I +Y<1 S D="F",DIC="^IBCNR(366.03,",DIC(0)="AEMNZ" D IX^DIC
I +Y<1 G EXIT
S IBCNRP=+Y
;
INS ; Select an insurance company
NEW DA,DIC,DIE,DR,D,Y,IBIND,IBMULT,IBW
S (IBIND,IBMULT,IBW)=1
S DIR(0)="350.9,4.06"
S DIR("A")="Select INSURANCE COMPANY",DIR("??")="^D ADH^IBCNSM3"
S DIR("?")="Select the Insurance Company for the plan you are entering"
D ^DIR K DIR S IBCNRI=+Y I Y<1 G EN
I $P($G(^DIC(36,+IBCNRI,0)),"^",2)="N" W !,"This company does not reimburse. " G INS
I $P($G(^DIC(36,+IBCNRI,0)),"^",5) W !,*7,"Warning: Inactive Company" G INS
;
D GIPF
I '$D(^TMP("IBCNR",$J,"GP")) D G INS
. W !,*7,"** No active Group Plans with Pharmacy coverage found for this Insurance Co."
;
D EN^IBCNRPM2(IBCNRP,IBCNRI,.IBCNRGP)
;
G INS
;
GIPF ; screen for valid GIPF
;
N GST1,GP0,GP6,IBCOV,LIM,IBCVRD
N GPIEN,GPMDT,GPMU,GPNAM,GPNUM
S GST1=1,GPIEN=""
K ^TMP("IBCNR",$J,"GP")
F S GPIEN=$O(^IBA(355.3,"B",IBCNRI,GPIEN)) Q:GPIEN="" D
. ;chk for active group
. S GP0=$G(^IBA(355.3,GPIEN,0)),GP6=$G(^IBA(355.3,GPIEN,6))
. I $P(GP0,U,11)=1 Q
. ;chk for pharm plan coverage
. S IBCOV=$O(^IBE(355.31,"B","PHARMACY",""))
. S LIM="",IBCVRD=0
. F S LIM=$O(^IBA(355.32,"B",GPIEN,LIM)) Q:LIM="" D
.. I $P(^IBA(355.32,LIM,0),U,2)=IBCOV D
... ;chk covered status
... S IBCVRD=$P(^IBA(355.32,LIM,0),U,4)
... I IBCVRD=0 Q
... ; IB*2*516/DF Get new HIPAA fields
... ;S GPNAM=$P($G(GP0),U,3),GPNUM=$P($G(GP0),U,4)
... S GPNAM=$$GET1^DIQ(355.3,GPIEN,2.01),GPNUM=$$GET1^DIQ(355.3,GPIEN,2.02)
... I $G(GPNAM)="" S GPNAM="<blank>"
... I $G(GPNUM)="" S GPNUM="<blank>"
... S GPMDT=$$GET1^DIQ(355.3,GPIEN,1.07,"E")
... S GPMU=$$GET1^DIQ(355.3,GPIEN,1.08,"E")
... ;
... S MATCH=0
... I $$GET1^DIQ(355.3,GPIEN,6.01)'="" S MATCH=1
... ;
... ;set array = pharm plan and plan type and match date and match user
... S ^TMP("IBCNR",$J,"GP",MATCH,GPNAM,GPNUM,GPIEN)=$P($G(GP6),U)_"^"_$P($G(GP0),U,9)_"^"_GPMDT_"^"_GPMU
... ;S ^TMP("IBCNR",$J,"GP",MATCH)=$G(^TMP("IBCNR",$J,"GP",MATCH))+1
... ;
F MATCH=0,1 D
. S ^TMP("IBCNR",$J,"GP",MATCH)=0
. S (GPNAM,GPNUM,GPIEN)=""
. F S GPNAM=$O(^TMP("IBCNR",$J,"GP",MATCH,GPNAM)) Q:GPNAM="" D
.. F S GPNUM=$O(^TMP("IBCNR",$J,"GP",MATCH,GPNAM,GPNUM)) Q:GPNUM="" D
... F S GPIEN=$O(^TMP("IBCNR",$J,"GP",MATCH,GPNAM,GPNUM,GPIEN)) Q:GPIEN="" D
.... S ^TMP("IBCNR",$J,"GP",MATCH)=^TMP("IBCNR",$J,"GP",MATCH)+1
;
Q
;
EXIT K IBCNRP,IBCNRI,IBCNRGP
K ^TMP("IBCNR",$J)
;
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCNRPM1 3003 printed Nov 22, 2024@17:26:28 Page 2
IBCNRPM1 ;DAOU/CMW - Match Multiple Group Plans to a Pharmacy Plan ;10-MAR-2004
+1 ;;2.0;INTEGRATED BILLING;**251,516,617,711**;21-MAR-94;Build 18
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;
+4 ;**Program Description**
+5 ; This program selects a plan and displays the
+6 ; Test Payer Sheets associated to the Plan.
+7 ;
EN ; Select a plan
+1 NEW DA,DIC,DIE,DR,D,Y
+2 SET DIC="^IBCNR(366.03,"
SET DIC(0)="ABEMZ"
SET DIC("A")="Select PHARMACY PLAN: "
+3 DO ^DIC
IF X="^"
GOTO EXIT
+4 KILL DIC("A")
+5 IF +Y<1
SET D="F"
SET DIC="^IBCNR(366.03,"
SET DIC(0)="AEMNZ"
DO IX^DIC
+6 IF +Y<1
GOTO EXIT
+7 SET IBCNRP=+Y
+8 ;
INS ; Select an insurance company
+1 NEW DA,DIC,DIE,DR,D,Y,IBIND,IBMULT,IBW
+2 SET (IBIND,IBMULT,IBW)=1
+3 SET DIR(0)="350.9,4.06"
+4 SET DIR("A")="Select INSURANCE COMPANY"
SET DIR("??")="^D ADH^IBCNSM3"
+5 SET DIR("?")="Select the Insurance Company for the plan you are entering"
+6 DO ^DIR
KILL DIR
SET IBCNRI=+Y
IF Y<1
GOTO EN
+7 IF $PIECE($GET(^DIC(36,+IBCNRI,0)),"^",2)="N"
WRITE !,"This company does not reimburse. "
GOTO INS
+8 IF $PIECE($GET(^DIC(36,+IBCNRI,0)),"^",5)
WRITE !,*7,"Warning: Inactive Company"
GOTO INS
+9 ;
+10 DO GIPF
+11 IF '$DATA(^TMP("IBCNR",$JOB,"GP"))
Begin DoDot:1
+12 WRITE !,*7,"** No active Group Plans with Pharmacy coverage found for this Insurance Co."
End DoDot:1
GOTO INS
+13 ;
+14 DO EN^IBCNRPM2(IBCNRP,IBCNRI,.IBCNRGP)
+15 ;
+16 GOTO INS
+17 ;
GIPF ; screen for valid GIPF
+1 ;
+2 NEW GST1,GP0,GP6,IBCOV,LIM,IBCVRD
+3 NEW GPIEN,GPMDT,GPMU,GPNAM,GPNUM
+4 SET GST1=1
SET GPIEN=""
+5 KILL ^TMP("IBCNR",$JOB,"GP")
+6 FOR
SET GPIEN=$ORDER(^IBA(355.3,"B",IBCNRI,GPIEN))
if GPIEN=""
QUIT
Begin DoDot:1
+7 ;chk for active group
+8 SET GP0=$GET(^IBA(355.3,GPIEN,0))
SET GP6=$GET(^IBA(355.3,GPIEN,6))
+9 IF $PIECE(GP0,U,11)=1
QUIT
+10 ;chk for pharm plan coverage
+11 SET IBCOV=$ORDER(^IBE(355.31,"B","PHARMACY",""))
+12 SET LIM=""
SET IBCVRD=0
+13 FOR
SET LIM=$ORDER(^IBA(355.32,"B",GPIEN,LIM))
if LIM=""
QUIT
Begin DoDot:2
+14 IF $PIECE(^IBA(355.32,LIM,0),U,2)=IBCOV
Begin DoDot:3
+15 ;chk covered status
+16 SET IBCVRD=$PIECE(^IBA(355.32,LIM,0),U,4)
+17 IF IBCVRD=0
QUIT
+18 ; IB*2*516/DF Get new HIPAA fields
+19 ;S GPNAM=$P($G(GP0),U,3),GPNUM=$P($G(GP0),U,4)
+20 SET GPNAM=$$GET1^DIQ(355.3,GPIEN,2.01)
SET GPNUM=$$GET1^DIQ(355.3,GPIEN,2.02)
+21 IF $GET(GPNAM)=""
SET GPNAM="<blank>"
+22 IF $GET(GPNUM)=""
SET GPNUM="<blank>"
+23 SET GPMDT=$$GET1^DIQ(355.3,GPIEN,1.07,"E")
+24 SET GPMU=$$GET1^DIQ(355.3,GPIEN,1.08,"E")
+25 ;
+26 SET MATCH=0
+27 IF $$GET1^DIQ(355.3,GPIEN,6.01)'=""
SET MATCH=1
+28 ;
+29 ;set array = pharm plan and plan type and match date and match user
+30 SET ^TMP("IBCNR",$JOB,"GP",MATCH,GPNAM,GPNUM,GPIEN)=$PIECE($GET(GP6),U)_"^"_$PIECE($GET(GP0),U,9)_"^"_GPMDT_"^"_GPMU
+31 ;S ^TMP("IBCNR",$J,"GP",MATCH)=$G(^TMP("IBCNR",$J,"GP",MATCH))+1
+32 ;
End DoDot:3
End DoDot:2
End DoDot:1
+33 FOR MATCH=0,1
Begin DoDot:1
+34 SET ^TMP("IBCNR",$JOB,"GP",MATCH)=0
+35 SET (GPNAM,GPNUM,GPIEN)=""
+36 FOR
SET GPNAM=$ORDER(^TMP("IBCNR",$JOB,"GP",MATCH,GPNAM))
if GPNAM=""
QUIT
Begin DoDot:2
+37 FOR
SET GPNUM=$ORDER(^TMP("IBCNR",$JOB,"GP",MATCH,GPNAM,GPNUM))
if GPNUM=""
QUIT
Begin DoDot:3
+38 FOR
SET GPIEN=$ORDER(^TMP("IBCNR",$JOB,"GP",MATCH,GPNAM,GPNUM,GPIEN))
if GPIEN=""
QUIT
Begin DoDot:4
+39 SET ^TMP("IBCNR",$JOB,"GP",MATCH)=^TMP("IBCNR",$JOB,"GP",MATCH)+1
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+40 ;
+41 QUIT
+42 ;
EXIT KILL IBCNRP,IBCNRI,IBCNRGP
+1 KILL ^TMP("IBCNR",$JOB)
+2 ;
+3 QUIT
