IBCNRPS2 ;BHAM ISC/ALA - Plan Match ListMan ;13-NOV-2003
;;2.0;INTEGRATED BILLING;**276,516**;21-MAR-94;Build 123
;;Per VA Directive 6402, this routine should not be modified.
;;
EN ; -- main entry point for IBCNR PLAN MATCH
D EN^VALM("IBCNR PLAN STATUS INQUIRY")
Q
;
HDR ; -- header code
N IBCNS0,IBCNS11,IBCNS13,IBLEAD,X,X1,X2
S IBCNS0=$G(^DIC(36,+IBCNSP,0))
S IBCNS11=$G(^DIC(36,+IBCNSP,.11))
S IBCNS13=$G(^DIC(36,+IBCNSP,.13))
S IBLEAD="All Plans for: "
S X="Phone: "_$S($P(IBCNS13,"^")]"":$P(IBCNS13,"^"),1:"<not filed>")
S VALMHDR(1)=$$SETSTR^VALM1(X,IBLEAD_$P(IBCNS0,"^"),81-$L(X),40)
S X1="Precerts: "_$S($P(IBCNS13,"^",3)]"":$P(IBCNS13,"^",3),1:"<not filed>")
S X=$TR($J("",$L(IBLEAD)),""," ")_$S($P(IBCNS11,"^")]"":$P(IBCNS11,"^"),1:"<no street address>")
S VALMHDR(2)=$$SETSTR^VALM1(X1,X,81-$L(X1),40)
S X=$S($P(IBCNS11,"^",4)]"":$P(IBCNS11,"^",4),1:"<no city>")_", "
S X=X_$S($P(IBCNS11,"^",5):$P($G(^DIC(5,$P(IBCNS11,"^",5),0)),"^",2),1:"<no state>")_" "_$E($P(IBCNS11,"^",6),1,5)_$S($E($P(IBCNS11,"^",6),6,9)]"":"-"_$E($P(IBCNS11,"^",6),6,9),1:"")
S VALMHDR(3)=$$SETSTR^VALM1(X,"",$L(IBLEAD)+1,80)
S X="For: ",X=$E(X_$J("",23),1,23)_$S(IBCNTYP="A":"All",IBCNTYP="P":"Pharmacy Covered",1:"Matched")_" Group Plans."
S VALMHDR(4)=$$SETSTR^VALM1(" ",X,64,17)
Q
;
INIT ; -- init variables and create list array or report array
N IBGP0,IBCPOLD,X,IBCPD6,IBCNRPP,IBCOV,IBCVRD,LIM
K ^TMP("IBCNR",$J)
S VALMCNT=0,VALMBG=1,IBCNGP=0
F S IBCNGP=$O(^IBA(355.3,"B",IBCNSP,IBCNGP)) Q:'IBCNGP D
. ; if we want all plans, let it pass
. I IBCNTYP="A" D Q
. . D SETPLAN(IBCNGP)
. ; if we want Pharmacy plans, check for pharms
. I IBCNTYP="P" D Q
. . S IBCOV=$O(^IBE(355.31,"B","PHARMACY",""))
. . S LIM="",IBCVRD=0
. . F S LIM=$O(^IBA(355.32,"B",IBCNGP,LIM)) Q:LIM="" D
. . . I $P(^IBA(355.32,LIM,0),U,2)=IBCOV S IBCVRD=$P(^IBA(355.32,LIM,0),U,4)
. . I IBCVRD 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("IBCNR",$J,"SI",1,0)="No Plans Available"
. S ^TMP("IBCNR",$J,"SI","IDX",1,1)=IBCNGP
Q
;
SETPLAN(IBCNGP) ;
; create text
N IBGPZ,I,IBPLN,IBPLNA
S VALMCNT=VALMCNT+1
S IBGPZ=^IBA(355.3,+IBCNGP,0)
; if creating report and not a list
I $G(IBCNRRPT) D Q
. ; Group Name, Group #, Group Type, Plan ID, Plan Status
. ;Get new HIPAA field - IB*2*516/df
. ;S X=$$FO^IBCNEUT1($P(IBGPZ,U,3),18)
. ;S X=X_" "_$$FO^IBCNEUT1($P(IBGPZ,U,4),17)
. 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($$EXPAND^IBTRE(355.3,.09,$P(IBGPZ,U,9)),13)
. S IBPLN=$P($G(^IBA(355.3,+IBCNGP,6)),U)
. ; check for plan
. I IBPLN="" D Q
. . S ^TMP("IBCNR",$J,"DSPDATA",VALMCNT)=X
. . S VALMCNT=VALMCNT+1,^TMP("IBCNR",$J,"DSPDATA",VALMCNT)="No Plan Found."
. ; 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("IBCNR",$J,"DSPDATA",VALMCNT)=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("IBCNR",$J,"DSPDATA",VALMCNT)=" "_$G(STATAR($P(ARRAY(6),",",I)))
;
S X=$$SETFLD^VALM1(VALMCNT,"","NUMBER")
;
I '$P(IBGPZ,U,2) S $E(X,4)="+"
S X=$$SETFLD^VALM1($$GET1^DIQ(355.3,IBCNGP,2.01),X,"GNAME") ;Get new HIPAA field - IB*2*516
;
I '$P(IBGPZ,U,11) S $E(X,24)="*"
S X=$$SETFLD^VALM1($$GET1^DIQ(355.3,IBCNGP,2.02),X,"GNUM") ;Get new HIPAA field - IB*2*516
;
S X=$$SETFLD^VALM1($$EXPAND^IBTRE(355.3,.09,$P(IBGPZ,U,9)),X,"TYPE")
; matched plan active or not
S IBPLN=$P($G(^IBA(355.3,+IBCNGP,6)),U)
I IBPLN'="" D
. S IBPLNA=$P($G(^IBCNR(366.03,+IBPLN,0)),U)
. S X=$$SETFLD^VALM1(IBPLNA,X,"PHARM")
. N ARRAY
. D STCHK^IBCNRU1(IBPLN,.ARRAY)
. S X=$$SETFLD^VALM1($S($G(ARRAY(1))="A":"ACTIVE",1:"INACTIVE"),X,"COV")
S ^TMP("IBCNR",$J,"SI",VALMCNT,0)=X
S ^TMP("IBCNR",$J,"SI","IDX",VALMCNT,VALMCNT)=IBCNGP
Q
;
HELP ; -- help code
S X="?" D DISP^XQORM1 W !!
Q
;
EXIT ; -- exit code
K ^TMP("IBCNR",$J),VALMBCK,VALMY
D CLEAN^VALM10,CLEAR^VALM1
Q
;
SEL ; -- select plan
N IBSEL,IBX
D S1
I 'IBX Q ; no group selected
;
D
. N IBCNRRPT,IBCNGP,VALMCNT,LST,IBCNRDEV
. S VALMCNT=0,IBCNRRPT=1,IBCNRDEV=0,IBCNGP=IBSEL
. K ^TMP("IBCNR",$J,"DSPDATA")
. D SETPLAN(IBSEL)
. D PRINT^IBCNRPSI
D SPQ
Q
S1 ;
N DIR,DIRUT,DUOUT,DTOUT,DIROUT,IBOK,IBQUIT,Y
D EN^VALM2($G(XQORNOD(0)),"S"),FULL^VALM1
S IBX=$O(VALMY(0)),VALMBCK="R"
;
I 'IBX W !!,"No group selected!" G SPQ
S IBSEL=+$G(^TMP("IBCNR",$J,"SI","IDX",IBX,IBX))
Q
;
SPQ ;
I '$O(IBSEL(0)),VALMBCK="R" D PAUSE^VALM1
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCNRPS2 4982 printed Oct 16, 2024@18:17:07 Page 2
IBCNRPS2 ;BHAM ISC/ALA - Plan Match ListMan ;13-NOV-2003
+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 ; -- main entry point for IBCNR PLAN MATCH
+1 DO EN^VALM("IBCNR PLAN STATUS INQUIRY")
+2 QUIT
+3 ;
HDR ; -- header code
+1 NEW IBCNS0,IBCNS11,IBCNS13,IBLEAD,X,X1,X2
+2 SET IBCNS0=$GET(^DIC(36,+IBCNSP,0))
+3 SET IBCNS11=$GET(^DIC(36,+IBCNSP,.11))
+4 SET IBCNS13=$GET(^DIC(36,+IBCNSP,.13))
+5 SET IBLEAD="All Plans for: "
+6 SET X="Phone: "_$SELECT($PIECE(IBCNS13,"^")]"":$PIECE(IBCNS13,"^"),1:"<not filed>")
+7 SET VALMHDR(1)=$$SETSTR^VALM1(X,IBLEAD_$PIECE(IBCNS0,"^"),81-$LENGTH(X),40)
+8 SET X1="Precerts: "_$SELECT($PIECE(IBCNS13,"^",3)]"":$PIECE(IBCNS13,"^",3),1:"<not filed>")
+9 SET X=$TRANSLATE($JUSTIFY("",$LENGTH(IBLEAD)),""," ")_$SELECT($PIECE(IBCNS11,"^")]"":$PIECE(IBCNS11,"^"),1:"<no street address>")
+10 SET VALMHDR(2)=$$SETSTR^VALM1(X1,X,81-$LENGTH(X1),40)
+11 SET X=$SELECT($PIECE(IBCNS11,"^",4)]"":$PIECE(IBCNS11,"^",4),1:"<no city>")_", "
+12 SET X=X_$SELECT($PIECE(IBCNS11,"^",5):$PIECE($GET(^DIC(5,$PIECE(IBCNS11,"^",5),0)),"^",2),1:"<no state>")_" "_$EXTRACT($PIECE(IBCNS11,"^",6),1,5)_$SELECT($EXTRACT($PIECE(IBCNS11,"^",6),6,9)]"":"-"_$EXTRACT($PIECE(IBCNS11,"^",6),6,9),1:"")
+13 SET VALMHDR(3)=$$SETSTR^VALM1(X,"",$LENGTH(IBLEAD)+1,80)
+14 SET X="For: "
SET X=$EXTRACT(X_$JUSTIFY("",23),1,23)_$SELECT(IBCNTYP="A":"All",IBCNTYP="P":"Pharmacy Covered",1:"Matched")_" Group Plans."
+15 SET VALMHDR(4)=$$SETSTR^VALM1(" ",X,64,17)
+16 QUIT
+17 ;
INIT ; -- init variables and create list array or report array
+1 NEW IBGP0,IBCPOLD,X,IBCPD6,IBCNRPP,IBCOV,IBCVRD,LIM
+2 KILL ^TMP("IBCNR",$JOB)
+3 SET VALMCNT=0
SET VALMBG=1
SET IBCNGP=0
+4 FOR
SET IBCNGP=$ORDER(^IBA(355.3,"B",IBCNSP,IBCNGP))
if 'IBCNGP
QUIT
Begin DoDot:1
+5 ; if we want all plans, let it pass
+6 IF IBCNTYP="A"
Begin DoDot:2
+7 DO SETPLAN(IBCNGP)
End DoDot:2
QUIT
+8 ; if we want Pharmacy plans, check for pharms
+9 IF IBCNTYP="P"
Begin DoDot:2
+10 SET IBCOV=$ORDER(^IBE(355.31,"B","PHARMACY",""))
+11 SET LIM=""
SET IBCVRD=0
+12 FOR
SET LIM=$ORDER(^IBA(355.32,"B",IBCNGP,LIM))
if LIM=""
QUIT
Begin DoDot:3
+13 IF $PIECE(^IBA(355.32,LIM,0),U,2)=IBCOV
SET IBCVRD=$PIECE(^IBA(355.32,LIM,0),U,4)
End DoDot:3
+14 IF IBCVRD
DO SETPLAN(IBCNGP)
End DoDot:2
QUIT
+15 ; if we want Matched plans, check for existence of Plan ID
+16 IF IBCNTYP="M"
Begin DoDot:2
+17 IF $PIECE($GET(^IBA(355.3,IBCNGP,6)),U)'=""
DO SETPLAN(IBCNGP)
End DoDot:2
QUIT
End DoDot:1
+18 IF VALMCNT=0
Begin DoDot:1
+19 SET ^TMP("IBCNR",$JOB,"SI",1,0)="No Plans Available"
+20 SET ^TMP("IBCNR",$JOB,"SI","IDX",1,1)=IBCNGP
End DoDot:1
+21 QUIT
+22 ;
SETPLAN(IBCNGP) ;
+1 ; create text
+2 NEW IBGPZ,I,IBPLN,IBPLNA
+3 SET VALMCNT=VALMCNT+1
+4 SET IBGPZ=^IBA(355.3,+IBCNGP,0)
+5 ; if creating report and not a list
+6 IF $GET(IBCNRRPT)
Begin DoDot:1
+7 ; Group Name, Group #, Group Type, Plan ID, Plan Status
+8 ;Get new HIPAA field - IB*2*516/df
+9 ;S X=$$FO^IBCNEUT1($P(IBGPZ,U,3),18)
+10 ;S X=X_" "_$$FO^IBCNEUT1($P(IBGPZ,U,4),17)
+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($$EXPAND^IBTRE(355.3,.09,$PIECE(IBGPZ,U,9)),13)
+14 SET IBPLN=$PIECE($GET(^IBA(355.3,+IBCNGP,6)),U)
+15 ; check for plan
+16 IF IBPLN=""
Begin DoDot:2
+17 SET ^TMP("IBCNR",$JOB,"DSPDATA",VALMCNT)=X
+18 SET VALMCNT=VALMCNT+1
SET ^TMP("IBCNR",$JOB,"DSPDATA",VALMCNT)="No Plan Found."
End DoDot:2
QUIT
+19 ; check plan status information
+20 SET IBPLNA=$PIECE($GET(^IBCNR(366.03,IBPLN,0)),U)
+21 SET X=X_" "_$$FO^IBCNEUT1(IBPLNA,13)
+22 ;
+23 NEW ARRAY
DO STCHK^IBCNRU1(IBPLN,.ARRAY)
+24 SET X=X_" "_$$FO^IBCNEUT1($SELECT($GET(ARRAY(1))="I":"INACTIVE",1:"ACTIVE"),8)
+25 SET ^TMP("IBCNR",$JOB,"DSPDATA",VALMCNT)=X
+26 IF $GET(ARRAY(6))
Begin DoDot:2
+27 NEW STATAR
+28 DO STATAR^IBCNRU1(.STATAR)
+29 FOR I=1:1:$LENGTH(ARRAY(6),",")
Begin DoDot:3
+30 SET VALMCNT=VALMCNT+1
+31 SET ^TMP("IBCNR",$JOB,"DSPDATA",VALMCNT)=" "_$GET(STATAR($PIECE(ARRAY(6),",",I)))
End DoDot:3
End DoDot:2
End DoDot:1
QUIT
+32 ;
+33 SET X=$$SETFLD^VALM1(VALMCNT,"","NUMBER")
+34 ;
+35 IF '$PIECE(IBGPZ,U,2)
SET $EXTRACT(X,4)="+"
+36 ;Get new HIPAA field - IB*2*516
SET X=$$SETFLD^VALM1($$GET1^DIQ(355.3,IBCNGP,2.01),X,"GNAME")
+37 ;
+38 IF '$PIECE(IBGPZ,U,11)
SET $EXTRACT(X,24)="*"
+39 ;Get new HIPAA field - IB*2*516
SET X=$$SETFLD^VALM1($$GET1^DIQ(355.3,IBCNGP,2.02),X,"GNUM")
+40 ;
+41 SET X=$$SETFLD^VALM1($$EXPAND^IBTRE(355.3,.09,$PIECE(IBGPZ,U,9)),X,"TYPE")
+42 ; matched plan active or not
+43 SET IBPLN=$PIECE($GET(^IBA(355.3,+IBCNGP,6)),U)
+44 IF IBPLN'=""
Begin DoDot:1
+45 SET IBPLNA=$PIECE($GET(^IBCNR(366.03,+IBPLN,0)),U)
+46 SET X=$$SETFLD^VALM1(IBPLNA,X,"PHARM")
+47 NEW ARRAY
+48 DO STCHK^IBCNRU1(IBPLN,.ARRAY)
+49 SET X=$$SETFLD^VALM1($SELECT($GET(ARRAY(1))="A":"ACTIVE",1:"INACTIVE"),X,"COV")
End DoDot:1
+50 SET ^TMP("IBCNR",$JOB,"SI",VALMCNT,0)=X
+51 SET ^TMP("IBCNR",$JOB,"SI","IDX",VALMCNT,VALMCNT)=IBCNGP
+52 QUIT
+53 ;
HELP ; -- help code
+1 SET X="?"
DO DISP^XQORM1
WRITE !!
+2 QUIT
+3 ;
EXIT ; -- exit code
+1 KILL ^TMP("IBCNR",$JOB),VALMBCK,VALMY
+2 DO CLEAN^VALM10
DO CLEAR^VALM1
+3 QUIT
+4 ;
SEL ; -- select plan
+1 NEW IBSEL,IBX
+2 DO S1
+3 ; no group selected
IF 'IBX
QUIT
+4 ;
+5 Begin DoDot:1
+6 NEW IBCNRRPT,IBCNGP,VALMCNT,LST,IBCNRDEV
+7 SET VALMCNT=0
SET IBCNRRPT=1
SET IBCNRDEV=0
SET IBCNGP=IBSEL
+8 KILL ^TMP("IBCNR",$JOB,"DSPDATA")
+9 DO SETPLAN(IBSEL)
+10 DO PRINT^IBCNRPSI
End DoDot:1
+11 DO SPQ
+12 QUIT
S1 ;
+1 NEW DIR,DIRUT,DUOUT,DTOUT,DIROUT,IBOK,IBQUIT,Y
+2 DO EN^VALM2($GET(XQORNOD(0)),"S")
DO FULL^VALM1
+3 SET IBX=$ORDER(VALMY(0))
SET VALMBCK="R"
+4 ;
+5 IF 'IBX
WRITE !!,"No group selected!"
GOTO SPQ
+6 SET IBSEL=+$GET(^TMP("IBCNR",$JOB,"SI","IDX",IBX,IBX))
+7 QUIT
+8 ;
SPQ ;
+1 IF '$ORDER(IBSEL(0))
IF VALMBCK="R"
DO PAUSE^VALM1
+2 QUIT
