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 Oct 16, 2024@18:17:01 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
