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