Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: IBCNRPMT

IBCNRPMT.m

Go to the documentation of this file.
  1. IBCNRPMT ;DAOU/ALA - Match Group Plan to Pharmacy Plan ;14-NOV-2003
  1. ;;2.0;INTEGRATED BILLING;**251,516**;21-MAR-94;Build 123
  1. ;;Per VA Directive 6402, this routine should not be modified.
  1. ;
  1. ;**Program Description**
  1. ; This program select an insurance company and displays
  1. ; all the active group plans for that insurance company
  1. ;
  1. EN ; Select an insurance company
  1. S DIR(0)="350.9,4.06"
  1. S DIR("A")="Select INSURANCE COMPANY",DIR("??")="^D ADH^IBCNSM3"
  1. S DIR("?")="Select the Insurance Company for the plan you are entering"
  1. D ^DIR K DIR S IBCNSP=+Y I Y<1 G EXIT
  1. I $P($G(^DIC(36,+IBCNSP,0)),"^",2)="N" W !,"This company does not reimburse. "
  1. I $P($G(^DIC(36,+IBCNSP,0)),"^",5) W !,*7,"Warning: Inactive Company" H 3 K IBCNSP G EXIT
  1. ;
  1. GRP NEW DIC,DTOUT,DUOUT,X,Y
  1. S (IBIND,IBMULT,IBW)=1
  1. S DIC(0)="BEFSXZ"
  1. S DIC("S")="S DNM=$NA(^(0)),DIEN=$QS(DNM,2),GST=$$GPS^IBCNRPMT(IBCNSP,DIEN),DIEN=$G(@DNM) I GST'=0"
  1. ; MRD;IB*2.0*516 - Look at new fields for Group Name and Number.
  1. ;S DIC("W")="W $P(^(0),U,3),"" - "",$P(^(0),U,4)"
  1. S DIC("W")="W $P(^(2),U,1),"" - "",$P(^(2),U,2)"
  1. S DIC="^IBA(355.3,"
  1. S D="B",X=IBCNSP
  1. D IX^DIC I Y<1 G EN
  1. S IBCNGP=+Y
  1. ;
  1. D EN^IBCNRP
  1. G EN
  1. ;
  1. GPS(INIEN,GPIEN) ; screen for valid GIPF
  1. ;W !,"***",GPIEN
  1. N GST1,GP0,IBCOV,LIM,IBCOV
  1. S GST1=1
  1. S GP0=$G(^IBA(355.3,GPIEN,0))
  1. ;chk insurance company
  1. I $P(GP0,U,1)'=INIEN S GST1=0 Q GST1
  1. ;chk for active group
  1. I $P(GP0,U,11)=1 S GST1=0 Q GST1
  1. ;chk for pharm plan coverage
  1. S IBCOV=$O(^IBE(355.31,"B","PHARMACY",""))
  1. S LIM="",IBCVRD=0
  1. F S LIM=$O(^IBA(355.32,"B",GPIEN,LIM)) Q:LIM="" D
  1. . I $P(^IBA(355.32,LIM,0),U,2)=IBCOV D
  1. .. ;chk covered status
  1. .. S IBCVRD=$P(^IBA(355.32,LIM,0),U,4)
  1. I IBCVRD=0 S GST1=0
  1. ;W !,"***",GPIEN," - ",GST1 ;
  1. Q GST1
  1. ;
  1. EXIT K IBCNSP,IBCPOL,IBIND,IBMULT,IBSEL,IBW,IBALR,IBGRP,IBCNGP
  1. Q