IBCNS3.m

IBCNS3 ;ALB/ARH - DISPLAY EXTENDED INSURANCE ; 01-DEC-04

 ;;2.0;INTEGRATED BILLING;**287,399,416,516**;21-MAR-94;Build 123

 ;;Per VA Directive 6402, this routine should not be modified.

 ;

DISP(DFN,DATE,DISPLAY) ;  Display all insurance company information

 ;    input: DFN     = pointer to patient

 ;           DATE    = date to check for coverage and riders

 ;           DISPLAY = contain indicators of data to display (1234)

 ;                     1 : first line of display ins company and plan data

 ;                     2 : extended data (Plan Filing Timeframe, Plan Coverage, Conditional Coverage Comments, and Riders)

 ;                     3 : ins. policy comments and plan comments

 ;                     4 : eIV eligibility/benefit information (IB*2*416)

 ;

 Q:'$G(DFN)  D:'$D(IOF) HOME^%ZIS

 N IBINS,IBPOLFN,IBPOL0,IBPLNFN S DISPLAY=$G(DISPLAY) I '$G(DATE) S DATE=DT

 K ^TMP($J,"IBCNS3")

 ;

 D ALL^IBCNS1(DFN,"IBINS",3,DATE)

 ;

 I '$D(IBINS) D SETLN(" "),SETLN("No Insurance Information")

 ;

 S IBPOLFN=0 F  S IBPOLFN=$O(IBINS(IBPOLFN)) Q:'IBPOLFN  D

 . S IBPOL0=IBINS(IBPOLFN,0),IBPLNFN=$P(IBPOL0,U,18)

 . S ^TMP($J,"IBCNS3")=IBPOLFN

 . ;

 . D GETLN(IBPOL0,DATE)

 . I DISPLAY[2 D GETEXT(DFN,IBPOLFN,IBPOL0,DATE) ; display extended

 . I DISPLAY[3 D GETCOM(IBPLNFN,$G(IBINS(IBPOLFN,1))) ; display extended 3, comments

 . I DISPLAY[4 D EB(DFN,IBPOLFN)    ; display eIV elig/ben data

 . Q

 ;

 S ^TMP($J,"IBCNS3")="" D GETNOTES(DFN)   ; display final notes/warning messages

 ;

 D PRINT

 ;

DISPQ K ^TMP($J,"IBCNS3")

 Q

 ;

PRINT ; display compiled array of patient insurance information in ^TMP($J,"IBCNS3")

 N IBSUB,IBCOUNT,IBQUIT,IBLEVEL,IBLNX,IBDASH,IBLINE,IBCNTLN S $P(IBDASH,"-",80)="-" S DISPLAY=+$G(DISPLAY)

 ;

 D HDR S IBSUB="IBCNS3",IBCOUNT=3,IBQUIT=0

 ;

 S IBLEVEL=0 F  S IBLEVEL=$O(^TMP($J,IBSUB,IBLEVEL)) Q:'IBLEVEL  D  Q:IBQUIT

 . S IBCNTLN=+$G(^TMP($J,IBSUB,IBLEVEL))+1

 . ;

 . I IBCOUNT>10,(IBCNTLN+IBCOUNT)>(IOSL-3) S IBQUIT=$$EOP Q:IBQUIT  D HDR S IBCOUNT=3

 . ;

 . S IBLNX=0 F  S IBLNX=$O(^TMP($J,IBSUB,IBLEVEL,IBLNX)) Q:'IBLNX  D  Q:IBQUIT

 .. ;

 .. S IBLINE=$G(^TMP($J,IBSUB,IBLEVEL,IBLNX))

 .. ;

 .. W !,IBLINE S IBCOUNT=IBCOUNT+1 I IBCOUNT>(IOSL-3) S IBQUIT=$$EOP Q:IBQUIT  W @IOF S IBCOUNT=2

 . ;

 . I 'IBQUIT,DISPLAY>1 W !,IBDASH S IBCOUNT=IBCOUNT+1

 ;

 I 'IBQUIT,IBCOUNT>2 S IBQUIT=$$EOP

 Q

 ;

SETLN(LINE) ; set line as next line for current policy

 N CNT,POL S LINE=$G(LINE)

 S POL=+$G(^TMP($J,"IBCNS3"))

 I 'POL S POL=$O(^TMP($J,"IBCNS3","~"),-1)+1 S ^TMP($J,"IBCNS3")=POL

 ;

 S CNT=+$G(^TMP($J,"IBCNS3",POL))+1

 S ^TMP($J,"IBCNS3",POL)=CNT

 S ^TMP($J,"IBCNS3",POL,CNT)=LINE

 Q

 ;

 ;

 ;

GETLN(IBPOL0,IBDATE) ; get single line of primary data on insurance policy

 ;     input:   IBPOL0 = line from array, zero node of patient policy (2,.312)

 ;              IBDATE = date to check coverage, default today

 ;    output:   formatted line of data for insurance policy in TMP($J,"IBCNS")

 ;

 N IBX,IBLINE S IBLINE=" " S IBPOL0=$G(IBPOL0)

 ;

 S IBX=$G(^DIC(36,+IBPOL0,0)),IBX=$S($P(IBX,U,1)'="":$P(IBX,U,1),1:"UNKNOWN") S IBLINE=$$FRMLN(IBX,IBLINE,11,0)

 S IBX=$P(IBPOL0,U,20),IBX=$S(IBX=1:"p",IBX=2:"s",IBX=3:"t",1:"") S IBLINE=$$FRMLN(IBX,IBLINE,1,14)

 S IBX=$P(IBPOL0,U,2) S IBLINE=$$FRMLN(IBX,IBLINE,16,17)

 S IBX=$$FNDGRP($P(IBPOL0,U,18)) S IBLINE=$$FRMLN(IBX,IBLINE,10,35)

 S IBX=$P(IBPOL0,U,6),IBX=$S(IBX="v":"SELF",IBX="s":"SPOUSE",1:"OTHER") S IBLINE=$$FRMLN(IBX,IBLINE,7,47)

 S IBX=$$DAT1^IBOUTL($P(IBPOL0,U,8)) S IBLINE=$$FRMLN(IBX,IBLINE,8,55)

 S IBX=$$DAT1^IBOUTL($P(IBPOL0,U,4)) S IBLINE=$$FRMLN(IBX,IBLINE,8,65)

 S IBX=$$FNDCOV(+IBPOL0,+$P(IBPOL0,U,18),$G(IBDATE)) S IBLINE=$$FRMLN(IBX,IBLINE,6,74)

 ;

 D SETLN(IBLINE)

GETLNQ Q

 ;

 ;

GETEXT(DFN,IBPOLFN,IBPOL0,DATE) ; display extended insurance information

 ; Plan Filing Timeframe, Plan Coverage, Conditional Coverage Comments, and Riders

 ;     input:   DFN     = pointer to patient (2)

 ;              IBPOLFN = pointer to patient insurance policy in 2.312

 ;              IBPOL0  = line from array, zero node of patient policy (2,.312)

 ;              DATE    = date to check coverage, default today

 ;              DISPARR = array to pass data back in, pass by reference

 ;    output:   array of extended data in TMP($J,"IBCNS")

 ;

 N IBX,IBY,IBZ,IBC,IBINSFN,IBPLNFN,IBPLN0,IBLINE,IBCAT,IBCATFN,IBCOVRD,IBU,ARR,ARR1 S:'$G(DATE) DATE=DT

 S IBINSFN=+$G(IBPOL0) Q:'IBINSFN  S IBPLNFN=+$P(IBPOL0,U,18),IBPLN0=$G(^IBA(355.3,IBPLNFN,0)) Q:IBPLN0=""

 ;

 S IBLINE="Last Verified:   ",(IBY,IBX)=""

 S IBY=$P($G(^DPT(DFN,.312,IBPOLFN,1)),U,3) I IBY'="" S IBX=$$DAT1^IBOUTL(IBY) S IBLINE=IBLINE_IBX D SETLN(" "),SETLN(IBLINE)

 ;

 S IBLINE="Plan Filing Time Frame: "

 S IBY=$P(IBPLN0,U,13) S:IBY'="" IBY=IBY_"  " I +$P(IBPLN0,U,16) S IBY=IBY_"("_$$FTFN^IBCNSU31(IBPLNFN)_")"

 I IBY'="" S IBLINE=IBLINE_IBY D:IBX="" SETLN(" ") D SETLN(IBLINE)

 ;

 S IBLINE="Insurance Comp:  "

 I $P($G(^DIC(36,IBINSFN,0)),U,2)="N" S IBLINE=IBLINE_"Will Not Reimburse" D SETLN(" "),SETLN(IBLINE)

 ;

 S IBLINE="Conditional: ",IBCOVRD="",IBU=""

 K ARR F IBCAT="INPATIENT","OUTPATIENT","PHARMACY","MENTAL HEALTH","DENTAL","LONG TERM CARE" D

 . S IBCATFN=+$O(^IBE(355.31,"B",IBCAT,"")) Q:'IBCATFN

 . S IBY=$$PLCOV^IBCNSU3(+IBPLNFN,DATE,IBCATFN,.ARR) Q:IBY'>0

 . I IBY=1 S IBCOVRD=$G(IBCOVRD)_IBU_$S(IBCAT["PATIENT":$P(IBCAT,"IENT",1),1:IBCAT),IBU=", " Q

 . S IBX=IBCAT_": ",IBC=$G(IBC)+100 S IBLINE=$$FRMLN(IBX,IBLINE,15,17)

 . S IBZ=0 F  S IBZ=$O(ARR(IBZ)) Q:'IBZ  S IBX=ARR(IBZ) D  S IBLINE=""

 .. S IBLINE=$$FRMLN(IBX,IBLINE,46,33) S ARR1(IBC+IBZ)=IBLINE

 I IBCOVRD'="" S IBLINE="Plan Coverage:   "_$G(IBCOVRD) D SETLN(" "),SETLN(IBLINE)

 I $O(ARR1("")) D:IBCOVRD="" SETLN(" ") S IBZ=0 F  S IBZ=$O(ARR1(IBZ)) Q:'IBZ  S IBX=ARR1(IBZ) D SETLN(IBX)

 ;

 S IBLINE="Policy Riders: "

 K ARR D RIDERS^IBCNSU3(+$G(DFN),+$G(IBPOLFN),.ARR) I $O(ARR("")) D SETLN(" ")

 S IBZ=0 F  S IBZ=$O(ARR(IBZ)) Q:'IBZ  S IBX=ARR(IBZ) D  S IBLINE=""

 . S IBLINE=$$FRMLN(IBX,IBLINE,62,17) D SETLN(IBLINE)

 Q

 ;

 ;

GETCOM(IBPLNFN,IBPOL1) ; get patient insurance and plan insurance comments in TMP($J,"IBCNS")

 N IBX,IBY

 ;

 S IBX=$P($G(IBPOL1),U,8) I IBX'="" S IBY="Patient Policy Comments: " D SETLN(" "),SETLN(IBY),SETLN(IBX)

 ;

 I +$G(IBPLNFN),$O(^IBA(355.3,+IBPLNFN,11,0)) S IBX="Group/Plan Comments:" D SETLN(" "),SETLN(IBX) D

 . S IBX=0 F  S IBX=$O(^IBA(355.3,+IBPLNFN,11,IBX)) Q:'IBX  S IBY=$G(^IBA(355.3,+IBPLNFN,11,IBX,0)) D SETLN(IBY)

 Q

 ;

 ;

GETNOTES(DFN) ; get final notes/warnings in TMP($J,"IBCNS")

 N IBX,IBY,IBLINE1,IBLINE2,IBFND S (IBFND,IBLINE1,IBLINE2)=""  Q:'$G(DFN)

 ;

 S IBX=+$G(^IBA(354,DFN,60)) I +IBX S IBY="*** Verification of No Coverage "_$$FMTE^XLFDT(IBX)_" ***" S IBLINE1=$$FRMLN(IBY,"",60,16),IBFND=1

 I $$BUFFER^IBCNBU1(DFN) S IBY="***  Patient has Insurance Buffer entries  ***" S IBLINE2=$$FRMLN(IBY,"",50,17),IBFND=1

 ;

 I +IBFND D SETLN(" ") D:IBLINE1'="" SETLN(IBLINE1) D:IBLINE2'="" SETLN(IBLINE2) D SETLN(" ")

 ;

 Q

 ;

 ;

EB(DFN,IBCDFN) ; Build eIV elig/benefit display for ?INX screen display

 NEW IBX,IBY

 D INIT^IBCNES(2.322,IBCDFN_","_DFN_",","A",,"?INX")

 D SETLN(" ")

 D SETLN("eIV Eligibility/Benefit Information:")

 S IBX=0

 F  S IBX=$O(^TMP("?INX",$J,"DISP",IBX)) Q:'IBX  D

 . S IBY=$G(^TMP("?INX",$J,"DISP",IBX,0))

 . D SETLN(IBY)

 . Q

 ;

 ; clean up scratch global

 K ^TMP("?INX",$J)

 ;

EBX ;

 Q

 ;

 ;

FRMLN(FIELD,IBLINE,FLNG,COL) ; format line data fields, returns IBLINE with FIELD of length FLNG at column COL

 N IBNEW,IBL S FIELD=$G(FIELD),IBLINE=$G(IBLINE),FLNG=$G(FLNG),COL=$G(COL)

 ;

 S IBNEW=$E(IBLINE,1,COL),IBL=$L(IBNEW),IBNEW=IBNEW_$J("",COL-IBL)

 S IBNEW=IBNEW_$E(FIELD,1,FLNG),IBL=$L(FIELD),IBNEW=IBNEW_$J("",FLNG-IBL)

 S IBNEW=IBNEW_$E(IBLINE,COL+FLNG+1,9999)

 Q IBNEW

 ;

 ;

 ;

FNDCOV(IBINSFN,IBPLNFN,IBDATE) ; -- return group/plan coverage limitations indications

 ;     input:   IBINSFN = pointer to insurance company entry in 36

 ;              IBPLNFN = pointer to insurance plan entry in 355.3

 ;              IBDATE  = date to check coverage, default today

 ;    output:   if insurance company will not reimburse = WNR, if all covered then returns null

 ;              otherwise list of first characters of types covered, if conditional then character in lower case

 ;              

 N IBOUT,IBX,IBY,IBCAT,IBCATFN S IBOUT="" S:'$G(IBDATE) IBDATE=DT I '$G(IBINSFN)!'$G(IBPLNFN) G FNDCOVQ

 ;

 I $P($G(^DIC(36,+IBINSFN,0)),U,2)="N" S IBOUT="*WNR*" G FNDCOVQ

 F IBCAT="INPATIENT","OUTPATIENT","PHARMACY","MENTAL HEALTH","DENTAL","LONG TERM CARE" D

 . S IBCATFN=+$O(^IBE(355.31,"B",IBCAT,"")) Q:'IBCATFN

 . S IBY=$$PLCOV^IBCNSU3(+IBPLNFN,IBDATE,+IBCATFN) Q:'IBY

 . S IBX=$S(IBCAT="PHARMACY":"R",1:$E(IBCAT)) S:IBY>1 IBX=$C($A(IBX)+32) S IBOUT=IBOUT_IBX

 S:IBOUT="" IBOUT="no CV" I IBOUT?6U S IBOUT=""

FNDCOVQ Q IBOUT

 ;

 ;

FNDGRP(IBPLNFN) ; -- return group name/group policy

 ;     input:   IBPLNFN = pointer to insurance plan entry in 355.3

 ;    output:   group name or group number, if both group NUMBER, check for Individual plans

 ;

 ;IB*2.0*516/TAZ - Use HIPAA compliant fields 

 ;N IBX,IBOUT S IBOUT=""

 ;S IBX=$G(^IBA(355.3,+$G(IBPLNFN),0))

 ;S IBOUT=$S($P(IBX,U,4)'="":$P(IBX,U,4),1:$P(IBX,U,3))

 ;I $P(IBX,U,10) S IBOUT="Ind. Plan "_IBOUT

FNDGRPQ ;

 ;Q IBOUT

 Q $$GRP^IBCNS(+$G(IBPLNFN))

 ;

 ;

 ;

 ;

HDR ; -- print header

 N IBX W @IOF

 W !,"Insurance",?13,"COB",?17,"Subscriber ID",?35,"Group",?47,"Holder",?55,"Effectve",?65,"Expires",?75,"Only"

 S IBX="",$P(IBX,"=",80)="=" W !,IBX

 Q

 ;

EOP() ; ask user for return at end of page, return 1 if '^' entered

 N IBQ,DIR,DIRUT,DUOUT,DTOUT,X,Y W ! S IBQ=0,DIR(0)="E" D ^DIR K DIR I $D(DUOUT)!($D(DIRUT)) S IBQ=1

 Q IBQ

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---IBCNS3   9804     printed  Feb 18, 2025@23:43:08                                                                                                                                                                                                      Page 2

IBCNS3    ;ALB/ARH - DISPLAY EXTENDED INSURANCE ; 01-DEC-04

 +1       ;;2.0;INTEGRATED BILLING;**287,399,416,516**;21-MAR-94;Build 123

 +2       ;;Per VA Directive 6402, this routine should not be modified.

 +3       ;

DISP(DFN,DATE,DISPLAY) ;  Display all insurance company information

 +1       ;    input: DFN     = pointer to patient

 +2       ;           DATE    = date to check for coverage and riders

 +3       ;           DISPLAY = contain indicators of data to display (1234)

 +4       ;                     1 : first line of display ins company and plan data

 +5       ;                     2 : extended data (Plan Filing Timeframe, Plan Coverage, Conditional Coverage Comments, and Riders)

 +6       ;                     3 : ins. policy comments and plan comments

 +7       ;                     4 : eIV eligibility/benefit information (IB*2*416)

 +8       ;

 +9        if '$GET(DFN)

               QUIT 

           if '$DATA(IOF)

               DO HOME^%ZIS

 +10       NEW IBINS,IBPOLFN,IBPOL0,IBPLNFN

           SET DISPLAY=$GET(DISPLAY)

           IF '$GET(DATE)

               SET DATE=DT

 +11       KILL ^TMP($JOB,"IBCNS3")

 +12      ;

 +13       DO ALL^IBCNS1(DFN,"IBINS",3,DATE)

 +14      ;

 +15       IF '$DATA(IBINS)

               DO SETLN(" ")

               DO SETLN("No Insurance Information")

 +16      ;

 +17       SET IBPOLFN=0

           FOR 

               SET IBPOLFN=$ORDER(IBINS(IBPOLFN))

               if 'IBPOLFN

                   QUIT 

               Begin DoDot:1

 +18               SET IBPOL0=IBINS(IBPOLFN,0)

                   SET IBPLNFN=$PIECE(IBPOL0,U,18)

 +19               SET ^TMP($JOB,"IBCNS3")=IBPOLFN

 +20      ;

 +21               DO GETLN(IBPOL0,DATE)

 +22      ; display extended

                   IF DISPLAY[2

                       DO GETEXT(DFN,IBPOLFN,IBPOL0,DATE)

 +23      ; display extended 3, comments

                   IF DISPLAY[3

                       DO GETCOM(IBPLNFN,$GET(IBINS(IBPOLFN,1)))

 +24      ; display eIV elig/ben data

                   IF DISPLAY[4

                       DO EB(DFN,IBPOLFN)

 +25               QUIT 

               End DoDot:1

 +26      ;

 +27      ; display final notes/warning messages

           SET ^TMP($JOB,"IBCNS3")=""

           DO GETNOTES(DFN)

 +28      ;

 +29       DO PRINT

 +30      ;

DISPQ      KILL ^TMP($JOB,"IBCNS3")

 +1        QUIT 

 +2       ;

PRINT     ; display compiled array of patient insurance information in ^TMP($J,"IBCNS3")

 +1        NEW IBSUB,IBCOUNT,IBQUIT,IBLEVEL,IBLNX,IBDASH,IBLINE,IBCNTLN

           SET $PIECE(IBDASH,"-",80)="-"

           SET DISPLAY=+$GET(DISPLAY)

 +2       ;

 +3        DO HDR

           SET IBSUB="IBCNS3"

           SET IBCOUNT=3

           SET IBQUIT=0

 +4       ;

 +5        SET IBLEVEL=0

           FOR 

               SET IBLEVEL=$ORDER(^TMP($JOB,IBSUB,IBLEVEL))

               if 'IBLEVEL

                   QUIT 

               Begin DoDot:1

 +6                SET IBCNTLN=+$GET(^TMP($JOB,IBSUB,IBLEVEL))+1

 +7       ;

 +8                IF IBCOUNT>10

                       IF (IBCNTLN+IBCOUNT)>(IOSL-3)

                           SET IBQUIT=$$EOP

                           if IBQUIT

                               QUIT 

                           DO HDR

                           SET IBCOUNT=3

 +9       ;

 +10               SET IBLNX=0

                   FOR 

                       SET IBLNX=$ORDER(^TMP($JOB,IBSUB,IBLEVEL,IBLNX))

                       if 'IBLNX

                           QUIT 

                       Begin DoDot:2

 +11      ;

 +12                       SET IBLINE=$GET(^TMP($JOB,IBSUB,IBLEVEL,IBLNX))

 +13      ;

 +14                       WRITE !,IBLINE

                           SET IBCOUNT=IBCOUNT+1

                           IF IBCOUNT>(IOSL-3)

                               SET IBQUIT=$$EOP

                               if IBQUIT

                                   QUIT 

                               WRITE @IOF

                               SET IBCOUNT=2

                       End DoDot:2

                       if IBQUIT

                           QUIT 

 +15      ;

 +16               IF 'IBQUIT

                       IF DISPLAY>1

                           WRITE !,IBDASH

                           SET IBCOUNT=IBCOUNT+1

               End DoDot:1

               if IBQUIT

                   QUIT 

 +17      ;

 +18       IF 'IBQUIT

               IF IBCOUNT>2

                   SET IBQUIT=$$EOP

 +19       QUIT 

 +20      ;

SETLN(LINE) ; set line as next line for current policy

 +1        NEW CNT,POL

           SET LINE=$GET(LINE)

 +2        SET POL=+$GET(^TMP($JOB,"IBCNS3"))

 +3        IF 'POL

               SET POL=$ORDER(^TMP($JOB,"IBCNS3","~"),-1)+1

               SET ^TMP($JOB,"IBCNS3")=POL

 +4       ;

 +5        SET CNT=+$GET(^TMP($JOB,"IBCNS3",POL))+1

 +6        SET ^TMP($JOB,"IBCNS3",POL)=CNT

 +7        SET ^TMP($JOB,"IBCNS3",POL,CNT)=LINE

 +8        QUIT 

 +9       ;

 +10      ;

 +11      ;

GETLN(IBPOL0,IBDATE) ; get single line of primary data on insurance policy

 +1       ;     input:   IBPOL0 = line from array, zero node of patient policy (2,.312)

 +2       ;              IBDATE = date to check coverage, default today

 +3       ;    output:   formatted line of data for insurance policy in TMP($J,"IBCNS")

 +4       ;

 +5        NEW IBX,IBLINE

           SET IBLINE=" "

           SET IBPOL0=$GET(IBPOL0)

 +6       ;

 +7        SET IBX=$GET(^DIC(36,+IBPOL0,0))

           SET IBX=$SELECT($PIECE(IBX,U,1)'="":$PIECE(IBX,U,1),1:"UNKNOWN")

           SET IBLINE=$$FRMLN(IBX,IBLINE,11,0)

 +8        SET IBX=$PIECE(IBPOL0,U,20)

           SET IBX=$SELECT(IBX=1:"p",IBX=2:"s",IBX=3:"t",1:"")

           SET IBLINE=$$FRMLN(IBX,IBLINE,1,14)

 +9        SET IBX=$PIECE(IBPOL0,U,2)

           SET IBLINE=$$FRMLN(IBX,IBLINE,16,17)

 +10       SET IBX=$$FNDGRP($PIECE(IBPOL0,U,18))

           SET IBLINE=$$FRMLN(IBX,IBLINE,10,35)

 +11       SET IBX=$PIECE(IBPOL0,U,6)

           SET IBX=$SELECT(IBX="v":"SELF",IBX="s":"SPOUSE",1:"OTHER")

           SET IBLINE=$$FRMLN(IBX,IBLINE,7,47)

 +12       SET IBX=$$DAT1^IBOUTL($PIECE(IBPOL0,U,8))

           SET IBLINE=$$FRMLN(IBX,IBLINE,8,55)

 +13       SET IBX=$$DAT1^IBOUTL($PIECE(IBPOL0,U,4))

           SET IBLINE=$$FRMLN(IBX,IBLINE,8,65)

 +14       SET IBX=$$FNDCOV(+IBPOL0,+$PIECE(IBPOL0,U,18),$GET(IBDATE))

           SET IBLINE=$$FRMLN(IBX,IBLINE,6,74)

 +15      ;

 +16       DO SETLN(IBLINE)

GETLNQ     QUIT 

 +1       ;

 +2       ;

GETEXT(DFN,IBPOLFN,IBPOL0,DATE) ; display extended insurance information

 +1       ; Plan Filing Timeframe, Plan Coverage, Conditional Coverage Comments, and Riders

 +2       ;     input:   DFN     = pointer to patient (2)

 +3       ;              IBPOLFN = pointer to patient insurance policy in 2.312

 +4       ;              IBPOL0  = line from array, zero node of patient policy (2,.312)

 +5       ;              DATE    = date to check coverage, default today

 +6       ;              DISPARR = array to pass data back in, pass by reference

 +7       ;    output:   array of extended data in TMP($J,"IBCNS")

 +8       ;

 +9        NEW IBX,IBY,IBZ,IBC,IBINSFN,IBPLNFN,IBPLN0,IBLINE,IBCAT,IBCATFN,IBCOVRD,IBU,ARR,ARR1

           if '$GET(DATE)

               SET DATE=DT

 +10       SET IBINSFN=+$GET(IBPOL0)

           if 'IBINSFN

               QUIT 

           SET IBPLNFN=+$PIECE(IBPOL0,U,18)

           SET IBPLN0=$GET(^IBA(355.3,IBPLNFN,0))

           if IBPLN0=""

               QUIT 

 +11      ;

 +12       SET IBLINE="Last Verified:   "

           SET (IBY,IBX)=""

 +13       SET IBY=$PIECE($GET(^DPT(DFN,.312,IBPOLFN,1)),U,3)

           IF IBY'=""

               SET IBX=$$DAT1^IBOUTL(IBY)

               SET IBLINE=IBLINE_IBX

               DO SETLN(" ")

               DO SETLN(IBLINE)

 +14      ;

 +15       SET IBLINE="Plan Filing Time Frame: "

 +16       SET IBY=$PIECE(IBPLN0,U,13)

           if IBY'=""

               SET IBY=IBY_"  "

           IF +$PIECE(IBPLN0,U,16)

               SET IBY=IBY_"("_$$FTFN^IBCNSU31(IBPLNFN)_")"

 +17       IF IBY'=""

               SET IBLINE=IBLINE_IBY

               if IBX=""

                   DO SETLN(" ")

               DO SETLN(IBLINE)

 +18      ;

 +19       SET IBLINE="Insurance Comp:  "

 +20       IF $PIECE($GET(^DIC(36,IBINSFN,0)),U,2)="N"

               SET IBLINE=IBLINE_"Will Not Reimburse"

               DO SETLN(" ")

               DO SETLN(IBLINE)

 +21      ;

 +22       SET IBLINE="Conditional: "

           SET IBCOVRD=""

           SET IBU=""

 +23       KILL ARR

           FOR IBCAT="INPATIENT","OUTPATIENT","PHARMACY","MENTAL HEALTH","DENTAL","LONG TERM CARE"

               Begin DoDot:1

 +24               SET IBCATFN=+$ORDER(^IBE(355.31,"B",IBCAT,""))

                   if 'IBCATFN

                       QUIT 

 +25               SET IBY=$$PLCOV^IBCNSU3(+IBPLNFN,DATE,IBCATFN,.ARR)

                   if IBY'>0

                       QUIT 

 +26               IF IBY=1

                       SET IBCOVRD=$GET(IBCOVRD)_IBU_$SELECT(IBCAT["PATIENT":$PIECE(IBCAT,"IENT",1),1:IBCAT)

                       SET IBU=", "

                       QUIT 

 +27               SET IBX=IBCAT_": "

                   SET IBC=$GET(IBC)+100

                   SET IBLINE=$$FRMLN(IBX,IBLINE,15,17)

 +28               SET IBZ=0

                   FOR 

                       SET IBZ=$ORDER(ARR(IBZ))

                       if 'IBZ

                           QUIT 

                       SET IBX=ARR(IBZ)

                       Begin DoDot:2

 +29                       SET IBLINE=$$FRMLN(IBX,IBLINE,46,33)

                           SET ARR1(IBC+IBZ)=IBLINE

                       End DoDot:2

                       SET IBLINE=""

               End DoDot:1

 +30       IF IBCOVRD'=""

               SET IBLINE="Plan Coverage:   "_$GET(IBCOVRD)

               DO SETLN(" ")

               DO SETLN(IBLINE)

 +31       IF $ORDER(ARR1(""))

               if IBCOVRD=""

                   DO SETLN(" ")

               SET IBZ=0

               FOR 

                   SET IBZ=$ORDER(ARR1(IBZ))

                   if 'IBZ

                       QUIT 

                   SET IBX=ARR1(IBZ)

                   DO SETLN(IBX)

 +32      ;

 +33       SET IBLINE="Policy Riders: "

 +34       KILL ARR

           DO RIDERS^IBCNSU3(+$GET(DFN),+$GET(IBPOLFN),.ARR)

           IF $ORDER(ARR(""))

               DO SETLN(" ")

 +35       SET IBZ=0

           FOR 

               SET IBZ=$ORDER(ARR(IBZ))

               if 'IBZ

                   QUIT 

               SET IBX=ARR(IBZ)

               Begin DoDot:1

 +36               SET IBLINE=$$FRMLN(IBX,IBLINE,62,17)

                   DO SETLN(IBLINE)

               End DoDot:1

               SET IBLINE=""

 +37       QUIT 

 +38      ;

 +39      ;

GETCOM(IBPLNFN,IBPOL1) ; get patient insurance and plan insurance comments in TMP($J,"IBCNS")

 +1        NEW IBX,IBY

 +2       ;

 +3        SET IBX=$PIECE($GET(IBPOL1),U,8)

           IF IBX'=""

               SET IBY="Patient Policy Comments: "

               DO SETLN(" ")

               DO SETLN(IBY)

               DO SETLN(IBX)

 +4       ;

 +5        IF +$GET(IBPLNFN)

               IF $ORDER(^IBA(355.3,+IBPLNFN,11,0))

                   SET IBX="Group/Plan Comments:"

                   DO SETLN(" ")

                   DO SETLN(IBX)

                   Begin DoDot:1

 +6                    SET IBX=0

                       FOR 

                           SET IBX=$ORDER(^IBA(355.3,+IBPLNFN,11,IBX))

                           if 'IBX

                               QUIT 

                           SET IBY=$GET(^IBA(355.3,+IBPLNFN,11,IBX,0))

                           DO SETLN(IBY)

                   End DoDot:1

 +7        QUIT 

 +8       ;

 +9       ;

GETNOTES(DFN) ; get final notes/warnings in TMP($J,"IBCNS")

 +1        NEW IBX,IBY,IBLINE1,IBLINE2,IBFND

           SET (IBFND,IBLINE1,IBLINE2)=""

           if '$GET(DFN)

               QUIT 

 +2       ;

 +3        SET IBX=+$GET(^IBA(354,DFN,60))

           IF +IBX

               SET IBY="*** Verification of No Coverage "_$$FMTE^XLFDT(IBX)_" ***"

               SET IBLINE1=$$FRMLN(IBY,"",60,16)

               SET IBFND=1

 +4        IF $$BUFFER^IBCNBU1(DFN)

               SET IBY="***  Patient has Insurance Buffer entries  ***"

               SET IBLINE2=$$FRMLN(IBY,"",50,17)

               SET IBFND=1

 +5       ;

 +6        IF +IBFND

               DO SETLN(" ")

               if IBLINE1'=""

                   DO SETLN(IBLINE1)

               if IBLINE2'=""

                   DO SETLN(IBLINE2)

               DO SETLN(" ")

 +7       ;

 +8        QUIT 

 +9       ;

 +10      ;

EB(DFN,IBCDFN) ; Build eIV elig/benefit display for ?INX screen display

 +1        NEW IBX,IBY

 +2        DO INIT^IBCNES(2.322,IBCDFN_","_DFN_",","A",,"?INX")

 +3        DO SETLN(" ")

 +4        DO SETLN("eIV Eligibility/Benefit Information:")

 +5        SET IBX=0

 +6        FOR 

               SET IBX=$ORDER(^TMP("?INX",$JOB,"DISP",IBX))

               if 'IBX

                   QUIT 

               Begin DoDot:1

 +7                SET IBY=$GET(^TMP("?INX",$JOB,"DISP",IBX,0))

 +8                DO SETLN(IBY)

 +9                QUIT 

               End DoDot:1

 +10      ;

 +11      ; clean up scratch global

 +12       KILL ^TMP("?INX",$JOB)

 +13      ;

EBX       ;

 +1        QUIT 

 +2       ;

 +3       ;

FRMLN(FIELD,IBLINE,FLNG,COL) ; format line data fields, returns IBLINE with FIELD of length FLNG at column COL

 +1        NEW IBNEW,IBL

           SET FIELD=$GET(FIELD)

           SET IBLINE=$GET(IBLINE)

           SET FLNG=$GET(FLNG)

           SET COL=$GET(COL)

 +2       ;

 +3        SET IBNEW=$EXTRACT(IBLINE,1,COL)

           SET IBL=$LENGTH(IBNEW)

           SET IBNEW=IBNEW_$JUSTIFY("",COL-IBL)

 +4        SET IBNEW=IBNEW_$EXTRACT(FIELD,1,FLNG)

           SET IBL=$LENGTH(FIELD)

           SET IBNEW=IBNEW_$JUSTIFY("",FLNG-IBL)

 +5        SET IBNEW=IBNEW_$EXTRACT(IBLINE,COL+FLNG+1,9999)

 +6        QUIT IBNEW

 +7       ;

 +8       ;

 +9       ;

FNDCOV(IBINSFN,IBPLNFN,IBDATE) ; -- return group/plan coverage limitations indications

 +1       ;     input:   IBINSFN = pointer to insurance company entry in 36

 +2       ;              IBPLNFN = pointer to insurance plan entry in 355.3

 +3       ;              IBDATE  = date to check coverage, default today

 +4       ;    output:   if insurance company will not reimburse = WNR, if all covered then returns null

 +5       ;              otherwise list of first characters of types covered, if conditional then character in lower case

 +6       ;              

 +7        NEW IBOUT,IBX,IBY,IBCAT,IBCATFN

           SET IBOUT=""

           if '$GET(IBDATE)

               SET IBDATE=DT

           IF '$GET(IBINSFN)!'$GET(IBPLNFN)

               GOTO FNDCOVQ

 +8       ;

 +9        IF $PIECE($GET(^DIC(36,+IBINSFN,0)),U,2)="N"

               SET IBOUT="*WNR*"

               GOTO FNDCOVQ

 +10       FOR IBCAT="INPATIENT","OUTPATIENT","PHARMACY","MENTAL HEALTH","DENTAL","LONG TERM CARE"

               Begin DoDot:1

 +11               SET IBCATFN=+$ORDER(^IBE(355.31,"B",IBCAT,""))

                   if 'IBCATFN

                       QUIT 

 +12               SET IBY=$$PLCOV^IBCNSU3(+IBPLNFN,IBDATE,+IBCATFN)

                   if 'IBY

                       QUIT 

 +13               SET IBX=$SELECT(IBCAT="PHARMACY":"R",1:$EXTRACT(IBCAT))

                   if IBY>1

                       SET IBX=$CHAR($ASCII(IBX)+32)

                   SET IBOUT=IBOUT_IBX

               End DoDot:1

 +14       if IBOUT=""

               SET IBOUT="no CV"

           IF IBOUT?6U

               SET IBOUT=""

FNDCOVQ    QUIT IBOUT

 +1       ;

 +2       ;

FNDGRP(IBPLNFN) ; -- return group name/group policy

 +1       ;     input:   IBPLNFN = pointer to insurance plan entry in 355.3

 +2       ;    output:   group name or group number, if both group NUMBER, check for Individual plans

 +3       ;

 +4       ;IB*2.0*516/TAZ - Use HIPAA compliant fields 

 +5       ;N IBX,IBOUT S IBOUT=""

 +6       ;S IBX=$G(^IBA(355.3,+$G(IBPLNFN),0))

 +7       ;S IBOUT=$S($P(IBX,U,4)'="":$P(IBX,U,4),1:$P(IBX,U,3))

 +8       ;I $P(IBX,U,10) S IBOUT="Ind. Plan "_IBOUT

FNDGRPQ   ;

 +1       ;Q IBOUT

 +2        QUIT $$GRP^IBCNS(+$GET(IBPLNFN))

 +3       ;

 +4       ;

 +5       ;

 +6       ;

HDR       ; -- print header

 +1        NEW IBX

           WRITE @IOF

 +2        WRITE !,"Insurance",?13,"COB",?17,"Subscriber ID",?35,"Group",?47,"Holder",?55,"Effectve",?65,"Expires",?75,"Only"

 +3        SET IBX=""

           SET $PIECE(IBX,"=",80)="="

           WRITE !,IBX

 +4        QUIT 

 +5       ;

EOP()     ; ask user for return at end of page, return 1 if '^' entered

 +1        NEW IBQ,DIR,DIRUT,DUOUT,DTOUT,X,Y

           WRITE !

           SET IBQ=0

           SET DIR(0)="E"

           DO ^DIR

           KILL DIR

           IF $DATA(DUOUT)!($DATA(DIRUT))

               SET IBQ=1

 +2        QUIT IBQ