- 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 Apr 23, 2025@18:30:56 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
