IBCNRPMT ;DAOU/ALA - Match Group Plan to Pharmacy Plan ;14-NOV-2003
;;2.0;INTEGRATED BILLING;**251,516**;21-MAR-94;Build 123
;;Per VA Directive 6402, this routine should not be modified.
;
;**Program Description**
; This program select an insurance company and displays
; all the active group plans for that insurance company
;
EN ; Select an insurance company
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 IBCNSP=+Y I Y<1 G EXIT
I $P($G(^DIC(36,+IBCNSP,0)),"^",2)="N" W !,"This company does not reimburse. "
I $P($G(^DIC(36,+IBCNSP,0)),"^",5) W !,*7,"Warning: Inactive Company" H 3 K IBCNSP G EXIT
;
GRP NEW DIC,DTOUT,DUOUT,X,Y
S (IBIND,IBMULT,IBW)=1
S DIC(0)="BEFSXZ"
S DIC("S")="S DNM=$NA(^(0)),DIEN=$QS(DNM,2),GST=$$GPS^IBCNRPMT(IBCNSP,DIEN),DIEN=$G(@DNM) I GST'=0"
; MRD;IB*2.0*516 - Look at new fields for Group Name and Number.
;S DIC("W")="W $P(^(0),U,3),"" - "",$P(^(0),U,4)"
S DIC("W")="W $P(^(2),U,1),"" - "",$P(^(2),U,2)"
S DIC="^IBA(355.3,"
S D="B",X=IBCNSP
D IX^DIC I Y<1 G EN
S IBCNGP=+Y
;
D EN^IBCNRP
G EN
;
GPS(INIEN,GPIEN) ; screen for valid GIPF
;W !,"***",GPIEN
N GST1,GP0,IBCOV,LIM,IBCOV
S GST1=1
S GP0=$G(^IBA(355.3,GPIEN,0))
;chk insurance company
I $P(GP0,U,1)'=INIEN S GST1=0 Q GST1
;chk for active group
I $P(GP0,U,11)=1 S GST1=0 Q GST1
;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 S GST1=0
;W !,"***",GPIEN," - ",GST1 ;
Q GST1
;
EXIT K IBCNSP,IBCPOL,IBIND,IBMULT,IBSEL,IBW,IBALR,IBGRP,IBCNGP
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCNRPMT 1864 printed Apr 09, 2024@21:16:56 Page 2
IBCNRPMT ;DAOU/ALA - Match Group Plan to Pharmacy Plan ;14-NOV-2003
+1 ;;2.0;INTEGRATED BILLING;**251,516**;21-MAR-94;Build 123
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;
+4 ;**Program Description**
+5 ; This program select an insurance company and displays
+6 ; all the active group plans for that insurance company
+7 ;
EN ; Select an insurance company
+1 SET DIR(0)="350.9,4.06"
+2 SET DIR("A")="Select INSURANCE COMPANY"
SET DIR("??")="^D ADH^IBCNSM3"
+3 SET DIR("?")="Select the Insurance Company for the plan you are entering"
+4 DO ^DIR
KILL DIR
SET IBCNSP=+Y
IF Y<1
GOTO EXIT
+5 IF $PIECE($GET(^DIC(36,+IBCNSP,0)),"^",2)="N"
WRITE !,"This company does not reimburse. "
+6 IF $PIECE($GET(^DIC(36,+IBCNSP,0)),"^",5)
WRITE !,*7,"Warning: Inactive Company"
HANG 3
KILL IBCNSP
GOTO EXIT
+7 ;
GRP NEW DIC,DTOUT,DUOUT,X,Y
+1 SET (IBIND,IBMULT,IBW)=1
+2 SET DIC(0)="BEFSXZ"
+3 SET DIC("S")="S DNM=$NA(^(0)),DIEN=$QS(DNM,2),GST=$$GPS^IBCNRPMT(IBCNSP,DIEN),DIEN=$G(@DNM) I GST'=0"
+4 ; MRD;IB*2.0*516 - Look at new fields for Group Name and Number.
+5 ;S DIC("W")="W $P(^(0),U,3),"" - "",$P(^(0),U,4)"
+6 SET DIC("W")="W $P(^(2),U,1),"" - "",$P(^(2),U,2)"
+7 SET DIC="^IBA(355.3,"
+8 SET D="B"
SET X=IBCNSP
+9 DO IX^DIC
IF Y<1
GOTO EN
+10 SET IBCNGP=+Y
+11 ;
+12 DO EN^IBCNRP
+13 GOTO EN
+14 ;
GPS(INIEN,GPIEN) ; screen for valid GIPF
+1 ;W !,"***",GPIEN
+2 NEW GST1,GP0,IBCOV,LIM,IBCOV
+3 SET GST1=1
+4 SET GP0=$GET(^IBA(355.3,GPIEN,0))
+5 ;chk insurance company
+6 IF $PIECE(GP0,U,1)'=INIEN
SET GST1=0
QUIT GST1
+7 ;chk for active group
+8 IF $PIECE(GP0,U,11)=1
SET GST1=0
QUIT GST1
+9 ;chk for pharm plan coverage
+10 SET IBCOV=$ORDER(^IBE(355.31,"B","PHARMACY",""))
+11 SET LIM=""
SET IBCVRD=0
+12 FOR
SET LIM=$ORDER(^IBA(355.32,"B",GPIEN,LIM))
if LIM=""
QUIT
Begin DoDot:1
+13 IF $PIECE(^IBA(355.32,LIM,0),U,2)=IBCOV
Begin DoDot:2
+14 ;chk covered status
+15 SET IBCVRD=$PIECE(^IBA(355.32,LIM,0),U,4)
End DoDot:2
End DoDot:1
+16 IF IBCVRD=0
SET GST1=0
+17 ;W !,"***",GPIEN," - ",GST1 ;
+18 QUIT GST1
+19 ;
EXIT KILL IBCNSP,IBCPOL,IBIND,IBMULT,IBSEL,IBW,IBALR,IBGRP,IBCNGP
+1 QUIT
