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

IBCNRP5.m

Go to the documentation of this file.
  1. IBCNRP5 ;BHAM ISC/CMW - Group Plan Status Report ;01-NOV-2004
  1. ;;2.0;INTEGRATED BILLING;**276,516**;21-MAR-94;Build 123
  1. ;;Per VA Directive 6402, this routine should not be modified.
  1. ;
  1. EN ;
  1. ; Initialize variables
  1. N STOP,IBCNRRTN,IBCNRSPC,RESORT,IBCNTYP,IBSEL
  1. D:'$D(IOF) HOME^%ZIS
  1. ;
  1. S STOP=0,IBPXT=$G(IBPXT)
  1. W @IOF
  1. W !,"ePHARM GROUP PLAN STATUS REPORT",!
  1. W !,"NCPDP process requires that the users match Group Plans to Pharmacy Plans."
  1. W !,"This report will assist users in matching Group Insurance Plans to Pharmacy"
  1. W !," Plans by searching through GIPF file for Group Plans that "
  1. W !," are linked to an Insurance with active Pharmacy Plan coverage."
  1. ;
  1. ; Prompts
  1. ; lock global
  1. S IBCNRRPT=1
  1. N IBCNRDEV S IBCNRDEV=1
  1. L +^XTMP("IBCNRP5"):5 I '$T W !!,"Sorry, Status Report in use." H 2 G EXIT
  1. ;Check for prior compile
  1. P10 D RESORT(.RESORT) I STOP G EXIT
  1. I $G(RESORT) G P30
  1. K ^XTMP("IBCNRP5")
  1. ; compile valid insurance file
  1. P20 D GIPF
  1. ; select insurance company
  1. P30 D INS I $G(IBSEL)="" G EXIT
  1. D TYPE I $G(IBCNTYP)="" G EXIT
  1. ; perform sort/selection
  1. P40 D INSEL
  1. I '$D(^TMP("IBCNRP5")) G EXIT
  1. ; print selection
  1. P50 D PRINT^IBCNRP5P
  1. ;
  1. EXIT ; unlock global
  1. L -^XTMP("IBCNRP5")
  1. K IBPXT
  1. K IBCNSP,IBCPOL,IBIND,IBMULT,IBSEL,IBW,IBALR,IBGRP,IBCNGP
  1. K IBCNRRPT,IBCNTYP,IBCNRDEV,ZTDESC,ZTSTOP
  1. K IBCNRP,IBCNRI,IBCNRGP
  1. K IBICPT,IBICF,IBICL,IBIC,IBINA,IBIEN,INIEN
  1. K ^TMP("IBCNRP5",$J)
  1. Q
  1. ;
  1. RESORT(RESORT) ; check for prior compile
  1. NEW DIR,BDT,EDT,RDT,HDR,IBDT,X,Y,DIRUT
  1. I '$D(^XTMP("IBCNRP5")) Q
  1. S RDT=$P($G(^XTMP("IBCNRP5",0)),U,2)
  1. S RESORT=0
  1. S HDR=$$FMTE^XLFDT(RDT,"5Z")
  1. W !!,"Current Insurance company list compiled on: ",HDR,!
  1. S DIR(0)="Y"
  1. S DIR("A")="Do you want to use the existing compiled file"
  1. S DIR("B")="YES"
  1. S DIR("?",1)=" Enter YES to use the existing compiled file."
  1. S DIR("?")=" Enter NO to DELETE existing file and recompile,"
  1. D ^DIR K DIR
  1. I $D(DIRUT) S STOP=1 G RESRTX
  1. S RESORT=Y
  1. S IBCNRSPC("RESORT")=Y
  1. ;
  1. RESRTX ;RESORT EXIT
  1. Q
  1. ;
  1. GIPF ; compiler valid insurance
  1. W !,"*** COMPILING ......"
  1. N GST1,GP0,GP6,IBCOV,LIM,IBCVRD,IBIEN
  1. N GPIEN,GPNAM,GPNUM,IBINA
  1. S GST1=1,(GPIEN,INIEN)=""
  1. S ^XTMP("IBCNRP5",0)=($$NOW^XLFDT+30)_"^"_$$NOW^XLFDT_"^"_"Group Plan Status Report"
  1. F S INIEN=$O(^IBA(355.3,"B",INIEN)) Q:INIEN="" D
  1. . S IBINA=$P($G(^DIC(36,+INIEN,0)),U)
  1. . ; company does not reimburse
  1. . I $P($G(^DIC(36,+INIEN,0)),U,2)="N" Q
  1. . ; company is inactive
  1. . I $P($G(^DIC(36,INIEN,0)),U,5) Q
  1. . ;
  1. . F S GPIEN=$O(^IBA(355.3,"B",INIEN,GPIEN)) Q:GPIEN="" D
  1. .. ;chk for active group
  1. .. S GP0=$G(^IBA(355.3,GPIEN,0)),GP6=$G(^IBA(355.3,GPIEN,6))
  1. .. I $P(GP0,U,11)=1 Q
  1. .. ;
  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 Q
  1. ... ;chk covered status
  1. ... S IBCVRD=$P(^IBA(355.32,LIM,0),U,4)
  1. ... I IBCVRD=0 Q
  1. ... ;set valid insurance/group array
  1. ... S ^XTMP("IBCNRP5",IBINA,INIEN,GPIEN)=""
  1. Q
  1. ;
  1. INS ;
  1. S IBSEL=""
  1. W !,"Run Report "
  1. W " for (S)PECIFIC insurance companies or a (R)ANGE: RANGE// "
  1. R X:DTIME Q:'$T!(X["^")
  1. S:X="" X="R" S X=$E(X)
  1. I "RSrs"'[X W !,"Enter <CR> for Range; 'S' for specific insurance; '^' to quit." G INS
  1. W " ",$S("Ss"[X:"SPECIFIC",1:"RANGE") G:"Rr"[X INSO1
  1. INSO S DIC="^DIC(36,",DIC(0)="AEQMZ",DIC("S")="I '$G(^(5))"
  1. S DIC("A")=" Select "_$S($G(IBICPT):"another ",1:"")_"INSURANCE CO.: "
  1. D ^DIC K DIC I Y'>0 G INS:'$G(IBICPT) S IBSEL=1 Q
  1. I $D(IBICPT(+Y)) D G INSO
  1. .W !!?3,"Already selected. Choose another insurance company.",!,*7
  1. S IBICPT(+Y)="",IBICPT=$G(IBICPT)+1 G INSO
  1. ;
  1. INSO1 W !?3,"Start with INSURANCE COMPANY: FIRST// " R X:DTIME
  1. G:'$T!(X["^") INS
  1. I $E(X)="?" W !,"Enter value up to 40 char; <CR> to start with 'first' value; '^' to quit." G INSO1
  1. S IBICF=X
  1. INSO2 W !?8,"Go to INSURANCE COMPANY: LAST// " R X:DTIME
  1. G:'$T!(X["^") INSO1
  1. I $E(X)="?" W !,"Enter value up to 40 char; <CR> to go to 'last' value; '^' to quit." G INSO1
  1. I X="" S IBICL="zzzzz" S:IBICF="" IBIC="ALL" S IBSEL=1 Q
  1. I IBICF]X D G INSO2
  1. .W *7,!!?3,"The LAST value must follow the FIRST.",!
  1. S IBICL=X,IBSEL=1
  1. Q
  1. ;
  1. TYPE ; Prompt to allow users to inquire for All group plans, or Matched group plans
  1. N DIR,X,Y,DIRUT
  1. S IBCNTYP="A"
  1. S DIR(0)="S^A:All Group Plans;M:Matched Group Plans"
  1. S DIR("A")=" Select the type of Group Plans you want to see for Insurance selected."
  1. S DIR("B")="A"
  1. S DIR("?",1)=" A - All Group Plans"
  1. S DIR("?",2)=" M - Matched Group Plans"
  1. D ^DIR K DIR
  1. I $D(DIRUT) G TYPEX
  1. S IBCNTYP=Y
  1. TYPEX Q
  1. ;
  1. INSEL ; - Perform selection for insurance company.
  1. S VALMCNT=0,VALMBG=1,IBCNGP=0
  1. K ^TMP("IBCNRP5",$J)
  1. ; check for specific insurance companies
  1. I $G(IBICPT) D Q
  1. . S (IBINA,IBIEN)=""
  1. . F S IBIEN=$O(IBICPT(IBIEN)) Q:IBIEN="" D
  1. .. S IBINA=$P($G(^DIC(36,+IBIEN,0)),U)
  1. .. I '$D(^XTMP("IBCNRP5",IBINA,IBIEN)) D Q
  1. ... W *7,!?3,"**NO pharmacy data found for "
  1. ... W $P(^DIC(36,IBIEN,0),U)_" "_$P(^DIC(36,IBIEN,.11),U),! R X:2
  1. .. D INIT
  1. ;
  1. ; check for range of insurance companies
  1. I '$D(IBICL) Q
  1. S IBIEN=0,IBINA=""
  1. F S IBINA=$O(^XTMP("IBCNRP5",IBINA)) Q:IBINA="" D
  1. . F S IBIEN=$O(^XTMP("IBCNRP5",IBINA,IBIEN)) Q:IBIEN="" D
  1. ..; for selection "ALL"
  1. .. I $G(IBIC)="ALL" D INIT Q
  1. .. ;
  1. .. ;check for match within first/last range
  1. .. I (IBICF]IBINA)!(IBINA]IBICL) Q
  1. .. D INIT
  1. Q
  1. ;
  1. INIT ; -- init variables and create list array or report array
  1. N IBGP0,IBCPOLD,X,IBCPD6,IBCNRPP,IBCOV,IBCVRD,LIM
  1. F S IBCNGP=$O(^XTMP("IBCNRP5",IBINA,IBIEN,IBCNGP)) Q:'IBCNGP D
  1. . I '$D(^IBA(355.3,+IBCNGP,0)) Q
  1. . ; if we want all plans, let it pass
  1. . I IBCNTYP="A" D Q
  1. . . D SETPLAN(IBCNGP)
  1. . ; if we want Matched plans, check for existence of Plan ID
  1. . I IBCNTYP="M" D Q
  1. . . I $P($G(^IBA(355.3,IBCNGP,6)),U)'="" D SETPLAN(IBCNGP)
  1. I VALMCNT=0 D
  1. . S ^TMP("IBCNRP5",$J,"DSPDATA",1)=IBIEN
  1. . S ^TMP("IBCNRP5",$J,"DSPDATA",2)="No data for this Insurance"
  1. Q
  1. ;
  1. SETPLAN(IBCNGP) ;
  1. ; create text
  1. ;N IBGPZ,I,IBPLN,IBPLNA,LINE
  1. N I,IBPLN,IBPLNA,LINE
  1. S VALMCNT=VALMCNT+1,$P(LINE,"-",80)=""
  1. ;Get new HIPAA fields - IB*2*516
  1. ;S IBGPZ=^IBA(355.3,+IBCNGP,0))
  1. ;S X=$$FO^IBCNEUT1($P(IBGPZ,U,3),18)
  1. ;S X=X_" "_$$FO^IBCNEUT1($P(IBGPZ,U,4),17)
  1. ;S X=X_" "_$$FO^IBCNEUT1($$EXPAND^IBTRE(355.3,.09,$P(IBGPZ,U,9)),13)
  1. ; Group Name, Group #, Group Type, Plan ID, Plan Status
  1. S X=$$FO^IBCNEUT1($$GET1^DIQ(355.3,IBCNGP,2.01),18)
  1. S X=X_" "_$$FO^IBCNEUT1($$GET1^DIQ(355.3,IBCNGP,2.02),17)
  1. S X=X_" "_$$FO^IBCNEUT1($$GET1^DIQ(355.3,IBCNGP,.09,"E"),13)
  1. S IBPLN=$P($G(^IBA(355.3,+IBCNGP,6)),U)
  1. ; check for plan
  1. I IBPLN="" D Q
  1. . S ^TMP("IBCNRP5",$J,"DSPDATA",VALMCNT)=IBIEN_"^"_X
  1. . S VALMCNT=VALMCNT+1,^TMP("IBCNRP5",$J,"DSPDATA",VALMCNT)=IBIEN_"^"_"No Plan Found."
  1. . S VALMCNT=VALMCNT+1,^TMP("IBCNRP5",$J,"DSPDATA",VALMCNT)=IBIEN_"^"_LINE
  1. ; check plan status information
  1. S IBPLNA=$P($G(^IBCNR(366.03,IBPLN,0)),U)
  1. S X=X_" "_$$FO^IBCNEUT1(IBPLNA,13)
  1. ;
  1. N ARRAY D STCHK^IBCNRU1(IBPLN,.ARRAY)
  1. S X=X_" "_$$FO^IBCNEUT1($S($G(ARRAY(1))="I":"INACTIVE",1:"ACTIVE"),8)
  1. S ^TMP("IBCNRP5",$J,"DSPDATA",VALMCNT)=IBIEN_"^"_X
  1. I $G(ARRAY(6)) D
  1. . N STATAR
  1. . D STATAR^IBCNRU1(.STATAR)
  1. . F I=1:1:$L(ARRAY(6),",") D
  1. .. S VALMCNT=VALMCNT+1
  1. .. S ^TMP("IBCNRP5",$J,"DSPDATA",VALMCNT)=IBIEN_"^"_" "_$G(STATAR($P(ARRAY(6),",",I)))
  1. . S VALMCNT=VALMCNT+1,^TMP("IBCNRP5",$J,"DSPDATA",VALMCNT)=IBIEN_"^"_LINE
  1. ;
  1. Q