IBCNSP0 ;ALB/AAS - INSURANCE MANAGEMENT - EXPANDED POLICY ;05-MAR-1993
;;2.0;INTEGRATED BILLING;**28,43,52,85,93,103,137,229,251,363,371,399,438,458,497,516,528,778,794**;21-MAR-94;Build 9
;;Per VA Directive 6402, this routine should not be modified.
;
;
CONTACT ; -- Insurance Contact Information
N OFFSET,START
;
; The start of this section is designed to start on the same line
; as the User Information section (see VER^IBCNSP01).
;
S START=$O(^TMP("IBCNSVP",$J,""),-1)-8
S IB1ST("CONTACT")=START
S OFFSET=42
N IBTRC,IBTRCD,IBTCOD,IBCREFN
S IBTCOD=$O(^IBE(356.11,"ACODE",85,0))
;
S IBTRC=0,IBTRCD="",IBCREFN=""
F S IBTRC=$O(^IBT(356.2,"D",DFN,IBTRC)) Q:'IBTRC D
.Q:$P($G(^IBT(356.2,+IBTRC,1)),"^",5)'=IBCDFN ; must be same policy
.Q:$P($G(^IBT(356.2,+IBTRC,0)),"^",4)'=IBTCOD ; must be ins. ver. type
.S IBTRCD=$G(^IBT(356.2,+IBTRC,0)),IBCREFN=$P($G(^IBT(356.2,+IBTRC,2)),U,1)
;
D SET(START,OFFSET," Insurance Contact (last) ",IORVON,IORVOFF)
D SET(START+1,OFFSET," Person Contacted: "_$$EXPAND^IBTRE(356.2,.06,$P(IBTRCD,"^",6)))
D SET(START+2,OFFSET,"Method of Contact: "_$$EXPAND^IBTRE(356.2,.17,$P(IBTRCD,"^",17)))
D SET(START+3,OFFSET," Contact's Phone: "_$$EXPAND^IBTRE(356.2,.07,$P(IBTRCD,"^",7)))
D SET(START+4,OFFSET," Call Ref. No.: "_$E(IBCREFN,1,19)_$S($L(IBCREFN)>19:"*",1:""))
D SET(START+5,OFFSET," Contact Date: "_$$EXPAND^IBTRE(356.2,.01,$P(IBTRCD,"^")))
; no blank lines here because the User Information section is on the
; left and it is bigger than this section
Q
;
POLICY ; -- Policy Region
; -- if pointer to policy file exists get data from policy file
; MRD;IB*2.0*516 - Increased length of Group Name and Type of Plan.
N OFFSET,START,IBP,IBX,IBPLNID,IBPLNNM,IBPLNNA,IBPLNLA,IBTOP
S (IBPLNID,IBPLNNM,IBPLNNA,IBPLNLA)=""
S START=$O(^TMP("IBCNSVP",$J,""),-1)+1,OFFSET=2
D GPLAN(+IBCPOLD2)
D SET(START,OFFSET," Plan Information ",IORVON,IORVOFF)
D SET(START+1,OFFSET," Is Group Plan: "_$S($P(IBCPOLD,"^",2)=1:"YES",1:"NO"))
D SET(START+2,OFFSET," Group Name: "_$E($P(IBCPOLDL,"^"),1,60))
S IBX=3
I $TR($E($P(IBCPOLDL,"^"),61,80)," ","")'="" D SET(START+IBX,OFFSET,$$REPEAT^XLFSTR(" ",18)_$E($P(IBCPOLDL,"^"),61,80)) S IBX=IBX+1
D SET(START+IBX,OFFSET," Group Number: "_$P(IBCPOLDL,"^",2)) S IBX=IBX+1
D SET(START+IBX,OFFSET," BIN: "_$P(IBCPOLD2,"^",2)) S IBX=IBX+1
D SET(START+IBX,OFFSET," PCN: "_$P(IBCPOLD2,"^",3)) S IBX=IBX+1
;
; -- use the abbreviations for the following type of plans
S IBTOP=$P($G(^IBE(355.1,+$P(IBCPOLD,"^",9),0)),"^") I IBTOP]"" D
. I IBTOP="HIGH DEDUCTIBLE HEALTH PLAN" S IBTOP=$P($G(^IBE(355.1,+$P(IBCPOLD,"^",9),0)),"^",2) Q
. I IBTOP="HIGH DEDUCTIBLE HEALTH PLAN W/HEALTH REIMBURSEMENT ARRANGEMENT" S IBTOP=$P($G(^IBE(355.1,+$P(IBCPOLD,"^",9),0)),"^",2) Q
. I IBTOP="HIGH DEDUCTIBLE HEALTH PLAN W/HEALTH SAVINGS ACCOUNT" S IBTOP=$P($G(^IBE(355.1,+$P(IBCPOLD,"^",9),0)),"^",2) Q
. I IBTOP="HEALTH MAINTENANCE ORGANIZATION W/OUT OF NETWORK BENEFITS" S IBTOP=$P($G(^IBE(355.1,+$P(IBCPOLD,"^",9),0)),"^",2) Q
. ; IB*778/DTG For the Exclusive Provider Org, Med. Advantage, & Vision use the name not abbrev.
. ;I IBTOP="EXCLUSIVE PROVIDER ORGANIZATION" S IBTOP=$P($G(^IBE(355.1,+$P(IBCPOLD,"^",9),0)),"^",2) Q
. ;I IBTOP="MEDICARE ADVANTAGE" S IBTOP=$P($G(^IBE(355.1,+$P(IBCPOLD,"^",9),0)),"^",2) Q
. ;I IBTOP="VISION" S IBTOP=$P($G(^IBE(355.1,+$P(IBCPOLD,"^",9),0)),"^",2)
D SET(START+IBX,OFFSET," Type of Plan: "_$E(IBTOP,1,61)) S IBX=IBX+1
;
I $P(IBCPOLD,U,14)]"" D SET(START+IBX,OFFSET," Plan Category: "_$$EXPAND^IBTRE(355.3,.14,$P(IBCPOLD,"^",14))) S IBX=IBX+1
I $P(IBCPOLD,U,15)]"" D SET(START+IBX,OFFSET," Electronic Type: "_$$EXPAND^IBTRE(355.3,.15,$P(IBCPOLD,"^",15))) S IBX=IBX+1
D SET(START+IBX,OFFSET," Plan Filing TF: "_$P(IBCPOLD,"^",13)_$S($P(IBCPOLD,U,16):" ("_$$FTFN^IBCNSU31(IBCPOL)_")",1:"")) S IBX=IBX+1
;
D SET(START+IBX,OFFSET," ePharmacy Plan ID: "_IBPLNID) S IBX=IBX+1
D SET(START+IBX,OFFSET," ePharmacy Plan Name: "_IBPLNNM) S IBX=IBX+1
D SET(START+IBX,OFFSET," ePharmacy Natl Status: "_IBPLNNA) S IBX=IBX+1
D SET(START+IBX,OFFSET," ePharmacy Local Status: "_IBPLNLA) S IBX=IBX+1
D SET(START+IBX,OFFSET," ")
;
; -- in case pointer is missing
I '$G(^IBA(355.3,+$P(IBCDFND,"^",18),0)) D
.D SET(START+1,OFFSET,"Insurance Number: "_$P(IBCDFND,"^",2))
.D SET(START+2,OFFSET," Group Name: "_$P(IBCDFND,"^",15))
.D SET(START+3,OFFSET," Group Number: "_$P(IBCDFND,"^",3))
.Q
Q
;
INS ; -- Insurance Co. Region ;IB*2*497 offset changed to display starting at offset 2
N OFFSET,START,IBADD,IBPPORT,BCDFNDA,IBCDFNDB ;IB*794/CKB
S START=1,OFFSET=2
D SET(START,OFFSET," Insurance Company ",IORVON,IORVOFF)
;IB*794/CKB - Realigned the labels, added 'Precert Portal' and 'Fax'
D SET(START+1,OFFSET+4," Company: "_$P($G(^DIC(36,+IBCDFND,0)),"^"))
S IBCDFNDA=$G(^DIC(36,+IBCDFND,.11)),IBCDFNDB=$G(^(.13))
G:IBCDFNDA="" INSQ
D SET(START+2,OFFSET+4," Street: "_$P(IBCDFNDA,"^")) S IBADD=1
I $P(IBCDFNDA,"^",2)'="" D SET(START+3,OFFSET+4," Street 2: "_$P(IBCDFNDA,"^",2)) S IBADD=2
I $P(IBCDFNDA,"^",3)'="" D SET(START+4,OFFSET+4," Street 3: "_$P(IBCDFNDA,"^",3)) S IBADD=3
D SET(START+2+IBADD,OFFSET+4,"City/State: "_$E($P(IBCDFNDA,"^",4),1,15)_$S($P(IBCDFNDA,"^",4)="":"",1:", ")_$P($G(^DIC(5,+$P(IBCDFNDA,"^",5),0)),"^",2)_" "_$E($P(IBCDFNDA,"^",6),1,5))
D SET(START+3+IBADD,OFFSET+4,"Billing Ph: "_$P(IBCDFNDB,"^",2))
D SET(START+4+IBADD,OFFSET+4," Fax: "_$P(IBCDFNDA,"^",9))
D SET(START+5+IBADD,OFFSET+4,"Precert Ph: "_$$PHONE^IBCNSC01(IBCDFNDB))
;D SET(START+5+IBADD,OFFSET," ")
S IBPPORT=$$PORTAL^IBCNSC01(IBCDFNDB)
D SET(START+6+IBADD,OFFSET,"Precert Portal: "_$E(IBPPORT,1,55))
D SET(START+7+IBADD,OFFSET+16,$E(IBPPORT,56,80))
D SET(START+8+IBADD,OFFSET," ")
;
INSQ Q
;
SPON ; -- Sponsor (Insured Person) Region ;IB*2*497 rearrange lines and move all lines into a single column
N IBC3,IBZIP,START,OFFSET,IBA,DA,DR,DIC,DIQ,Y
S IBC3=$G(^DPT(DFN,.312,IBCDFN,3))
S DA=+$P(IBC3,"^",2),DR=.01,DIQ(0)="E",DIC="^DIC(23,",DIQ="IBA" D EN^DIQ1
S START=$O(^TMP("IBCNSVP",$J,""),-1)+1,OFFSET=2
D SET(START,OFFSET," Subscriber's Information (use Subscriber Update Action) ",IORVON,IORVOFF)
D SET(START+1,OFFSET,$$RJ^XLFSTR("Subscriber's DOB: ",18)_$$DAT3^IBOUTL($P(IBC3,"^")))
S Y=$P(IBC3,"^",10) D ZIPOUT^VAFADDR S IBZIP=Y
D SET(START+2,OFFSET,$$RJ^XLFSTR("Str 1: ",18)_$P(IBC3,"^",6))
D SET(START+3,OFFSET,$$RJ^XLFSTR("Str 2: ",18)_$P(IBC3,"^",7))
D SET(START+4,OFFSET,$$RJ^XLFSTR("City: ",18)_$P(IBC3,"^",8))
D SET(START+5,OFFSET,$$RJ^XLFSTR("St/Zip: ",18)_$P($G(^DIC(5,+$P(IBC3,"^",9),0)),"^",2)_" "_IBZIP)
D SET(START+6,OFFSET,$$RJ^XLFSTR("SubDiv: ",18)_$P(IBC3,"^",14))
D SET(START+7,OFFSET,$$RJ^XLFSTR("Country: ",18)_$P(IBC3,"^",13))
D SET(START+8,OFFSET,$$RJ^XLFSTR("Phone: ",18)_$P(IBC3,"^",11))
D SET(START+9,OFFSET,$$RJ^XLFSTR("Subscriber's Sex: ",18)_$$EXTERNAL^DILFD(2.312,3.12,,$P(IBC3,U,12)))
D SET(START+10,OFFSET,$$RJ^XLFSTR("Subscr's Branch: ",18)_$G(IBA(23,DA,.01,"E")))
D SET(START+11,OFFSET,$$RJ^XLFSTR("Subscr's Rank: ",18)_$P(IBC3,"^",3))
; blank lines at end of section
D SET(START+12,2," ")
D SET(START+13,2," ")
Q
;
BLANK(LINE) ; -- Build blank line
D SET^VALM10(.LINE,$J("",80))
Q
;
SET(LINE,COL,TEXT,ON,OFF) ; -- set display info in array
D:'$D(@VALMAR@(LINE,0)) BLANK(.LINE)
D SET^VALM10(.LINE,$$SETSTR^VALM1(.TEXT,@VALMAR@(LINE,0),.COL,$L(TEXT)))
D:$G(ON)]""!($G(OFF)]"") CNTRL^VALM10(.LINE,.COL,$L(TEXT),$G(ON),$G(OFF))
W:'(LINE#5) "."
Q
;
GPLAN(IBPLDA) ; get data from PLAN file (#366.03) related to the
; GROUP INSURANCE PLAN file (#355.3) and the INSURANCE COMPANY file (#36)
; that is associated with the PATIENT
; input - IBPLDA - ien of the PLAN file (#366.03)
N IBPLN0,IBAIEN,IBAPIEN,IBAP0
S IBPLN0=$G(^IBCNR(366.03,IBPLDA,0)) ;; Q:'$P(IBPLN0,"^",3) ;quit if payer not defined
S IBPLNID=$P(IBPLN0,"^"),IBPLNNM=$P(IBPLN0,"^",2)
S IBAIEN=$O(^IBCNR(366.13,"B","E-PHARM","")) Q:'IBAIEN
S IBAPIEN=$O(^IBCNR(366.03,IBPLDA,3,"B",IBAIEN,"")) Q:'IBAPIEN
S IBAP0=$G(^IBCNR(366.03,IBPLDA,3,IBAPIEN,0))
S IBPLNNA=$S($P(IBAP0,"^",2)=0:"NOT ACTIVE",1:"ACTIVE")
S IBPLNLA=$S($P(IBAP0,"^",3)=0:"NOT ACTIVE",1:"ACTIVE")
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCNSP0 8368 printed Dec 13, 2024@02:17:49 Page 2
IBCNSP0 ;ALB/AAS - INSURANCE MANAGEMENT - EXPANDED POLICY ;05-MAR-1993
+1 ;;2.0;INTEGRATED BILLING;**28,43,52,85,93,103,137,229,251,363,371,399,438,458,497,516,528,778,794**;21-MAR-94;Build 9
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;
+4 ;
CONTACT ; -- Insurance Contact Information
+1 NEW OFFSET,START
+2 ;
+3 ; The start of this section is designed to start on the same line
+4 ; as the User Information section (see VER^IBCNSP01).
+5 ;
+6 SET START=$ORDER(^TMP("IBCNSVP",$JOB,""),-1)-8
+7 SET IB1ST("CONTACT")=START
+8 SET OFFSET=42
+9 NEW IBTRC,IBTRCD,IBTCOD,IBCREFN
+10 SET IBTCOD=$ORDER(^IBE(356.11,"ACODE",85,0))
+11 ;
+12 SET IBTRC=0
SET IBTRCD=""
SET IBCREFN=""
+13 FOR
SET IBTRC=$ORDER(^IBT(356.2,"D",DFN,IBTRC))
if 'IBTRC
QUIT
Begin DoDot:1
+14 ; must be same policy
if $PIECE($GET(^IBT(356.2,+IBTRC,1)),"^",5)'=IBCDFN
QUIT
+15 ; must be ins. ver. type
if $PIECE($GET(^IBT(356.2,+IBTRC,0)),"^",4)'=IBTCOD
QUIT
+16 SET IBTRCD=$GET(^IBT(356.2,+IBTRC,0))
SET IBCREFN=$PIECE($GET(^IBT(356.2,+IBTRC,2)),U,1)
End DoDot:1
+17 ;
+18 DO SET(START,OFFSET," Insurance Contact (last) ",IORVON,IORVOFF)
+19 DO SET(START+1,OFFSET," Person Contacted: "_$$EXPAND^IBTRE(356.2,.06,$PIECE(IBTRCD,"^",6)))
+20 DO SET(START+2,OFFSET,"Method of Contact: "_$$EXPAND^IBTRE(356.2,.17,$PIECE(IBTRCD,"^",17)))
+21 DO SET(START+3,OFFSET," Contact's Phone: "_$$EXPAND^IBTRE(356.2,.07,$PIECE(IBTRCD,"^",7)))
+22 DO SET(START+4,OFFSET," Call Ref. No.: "_$EXTRACT(IBCREFN,1,19)_$SELECT($LENGTH(IBCREFN)>19:"*",1:""))
+23 DO SET(START+5,OFFSET," Contact Date: "_$$EXPAND^IBTRE(356.2,.01,$PIECE(IBTRCD,"^")))
+24 ; no blank lines here because the User Information section is on the
+25 ; left and it is bigger than this section
+26 QUIT
+27 ;
POLICY ; -- Policy Region
+1 ; -- if pointer to policy file exists get data from policy file
+2 ; MRD;IB*2.0*516 - Increased length of Group Name and Type of Plan.
+3 NEW OFFSET,START,IBP,IBX,IBPLNID,IBPLNNM,IBPLNNA,IBPLNLA,IBTOP
+4 SET (IBPLNID,IBPLNNM,IBPLNNA,IBPLNLA)=""
+5 SET START=$ORDER(^TMP("IBCNSVP",$JOB,""),-1)+1
SET OFFSET=2
+6 DO GPLAN(+IBCPOLD2)
+7 DO SET(START,OFFSET," Plan Information ",IORVON,IORVOFF)
+8 DO SET(START+1,OFFSET," Is Group Plan: "_$SELECT($PIECE(IBCPOLD,"^",2)=1:"YES",1:"NO"))
+9 DO SET(START+2,OFFSET," Group Name: "_$EXTRACT($PIECE(IBCPOLDL,"^"),1,60))
+10 SET IBX=3
+11 IF $TRANSLATE($EXTRACT($PIECE(IBCPOLDL,"^"),61,80)," ","")'=""
DO SET(START+IBX,OFFSET,$$REPEAT^XLFSTR(" ",18)_$EXTRACT($PIECE(IBCPOLDL,"^"),61,80))
SET IBX=IBX+1
+12 DO SET(START+IBX,OFFSET," Group Number: "_$PIECE(IBCPOLDL,"^",2))
SET IBX=IBX+1
+13 DO SET(START+IBX,OFFSET," BIN: "_$PIECE(IBCPOLD2,"^",2))
SET IBX=IBX+1
+14 DO SET(START+IBX,OFFSET," PCN: "_$PIECE(IBCPOLD2,"^",3))
SET IBX=IBX+1
+15 ;
+16 ; -- use the abbreviations for the following type of plans
+17 SET IBTOP=$PIECE($GET(^IBE(355.1,+$PIECE(IBCPOLD,"^",9),0)),"^")
IF IBTOP]""
Begin DoDot:1
+18 IF IBTOP="HIGH DEDUCTIBLE HEALTH PLAN"
SET IBTOP=$PIECE($GET(^IBE(355.1,+$PIECE(IBCPOLD,"^",9),0)),"^",2)
QUIT
+19 IF IBTOP="HIGH DEDUCTIBLE HEALTH PLAN W/HEALTH REIMBURSEMENT ARRANGEMENT"
SET IBTOP=$PIECE($GET(^IBE(355.1,+$PIECE(IBCPOLD,"^",9),0)),"^",2)
QUIT
+20 IF IBTOP="HIGH DEDUCTIBLE HEALTH PLAN W/HEALTH SAVINGS ACCOUNT"
SET IBTOP=$PIECE($GET(^IBE(355.1,+$PIECE(IBCPOLD,"^",9),0)),"^",2)
QUIT
+21 IF IBTOP="HEALTH MAINTENANCE ORGANIZATION W/OUT OF NETWORK BENEFITS"
SET IBTOP=$PIECE($GET(^IBE(355.1,+$PIECE(IBCPOLD,"^",9),0)),"^",2)
QUIT
+22 ; IB*778/DTG For the Exclusive Provider Org, Med. Advantage, & Vision use the name not abbrev.
+23 ;I IBTOP="EXCLUSIVE PROVIDER ORGANIZATION" S IBTOP=$P($G(^IBE(355.1,+$P(IBCPOLD,"^",9),0)),"^",2) Q
+24 ;I IBTOP="MEDICARE ADVANTAGE" S IBTOP=$P($G(^IBE(355.1,+$P(IBCPOLD,"^",9),0)),"^",2) Q
+25 ;I IBTOP="VISION" S IBTOP=$P($G(^IBE(355.1,+$P(IBCPOLD,"^",9),0)),"^",2)
End DoDot:1
+26 DO SET(START+IBX,OFFSET," Type of Plan: "_$EXTRACT(IBTOP,1,61))
SET IBX=IBX+1
+27 ;
+28 IF $PIECE(IBCPOLD,U,14)]""
DO SET(START+IBX,OFFSET," Plan Category: "_$$EXPAND^IBTRE(355.3,.14,$PIECE(IBCPOLD,"^",14)))
SET IBX=IBX+1
+29 IF $PIECE(IBCPOLD,U,15)]""
DO SET(START+IBX,OFFSET," Electronic Type: "_$$EXPAND^IBTRE(355.3,.15,$PIECE(IBCPOLD,"^",15)))
SET IBX=IBX+1
+30 DO SET(START+IBX,OFFSET," Plan Filing TF: "_$PIECE(IBCPOLD,"^",13)_$SELECT($PIECE(IBCPOLD,U,16):" ("_$$FTFN^IBCNSU31(IBCPOL)_")",1:""))
SET IBX=IBX+1
+31 ;
+32 DO SET(START+IBX,OFFSET," ePharmacy Plan ID: "_IBPLNID)
SET IBX=IBX+1
+33 DO SET(START+IBX,OFFSET," ePharmacy Plan Name: "_IBPLNNM)
SET IBX=IBX+1
+34 DO SET(START+IBX,OFFSET," ePharmacy Natl Status: "_IBPLNNA)
SET IBX=IBX+1
+35 DO SET(START+IBX,OFFSET," ePharmacy Local Status: "_IBPLNLA)
SET IBX=IBX+1
+36 DO SET(START+IBX,OFFSET," ")
+37 ;
+38 ; -- in case pointer is missing
+39 IF '$GET(^IBA(355.3,+$PIECE(IBCDFND,"^",18),0))
Begin DoDot:1
+40 DO SET(START+1,OFFSET,"Insurance Number: "_$PIECE(IBCDFND,"^",2))
+41 DO SET(START+2,OFFSET," Group Name: "_$PIECE(IBCDFND,"^",15))
+42 DO SET(START+3,OFFSET," Group Number: "_$PIECE(IBCDFND,"^",3))
+43 QUIT
End DoDot:1
+44 QUIT
+45 ;
INS ; -- Insurance Co. Region ;IB*2*497 offset changed to display starting at offset 2
+1 ;IB*794/CKB
NEW OFFSET,START,IBADD,IBPPORT,BCDFNDA,IBCDFNDB
+2 SET START=1
SET OFFSET=2
+3 DO SET(START,OFFSET," Insurance Company ",IORVON,IORVOFF)
+4 ;IB*794/CKB - Realigned the labels, added 'Precert Portal' and 'Fax'
+5 DO SET(START+1,OFFSET+4," Company: "_$PIECE($GET(^DIC(36,+IBCDFND,0)),"^"))
+6 SET IBCDFNDA=$GET(^DIC(36,+IBCDFND,.11))
SET IBCDFNDB=$GET(^(.13))
+7 if IBCDFNDA=""
GOTO INSQ
+8 DO SET(START+2,OFFSET+4," Street: "_$PIECE(IBCDFNDA,"^"))
SET IBADD=1
+9 IF $PIECE(IBCDFNDA,"^",2)'=""
DO SET(START+3,OFFSET+4," Street 2: "_$PIECE(IBCDFNDA,"^",2))
SET IBADD=2
+10 IF $PIECE(IBCDFNDA,"^",3)'=""
DO SET(START+4,OFFSET+4," Street 3: "_$PIECE(IBCDFNDA,"^",3))
SET IBADD=3
+11 DO SET(START+2+IBADD,OFFSET+4,"City/State: "_$EXTRACT($PIECE(IBCDFNDA,"^",4),1,15)_$SELECT($PIECE(IBCDFNDA,"^",4)="":"",1:", ")_$PIECE($GET(^DIC(5,+$PIECE(IBCDFNDA,"^",5),0)),"^",2)_" "_$EXTRACT($PIECE(IBCDFNDA,"^",6),1,5))
+12 DO SET(START+3+IBADD,OFFSET+4,"Billing Ph: "_$PIECE(IBCDFNDB,"^",2))
+13 DO SET(START+4+IBADD,OFFSET+4," Fax: "_$PIECE(IBCDFNDA,"^",9))
+14 DO SET(START+5+IBADD,OFFSET+4,"Precert Ph: "_$$PHONE^IBCNSC01(IBCDFNDB))
+15 ;D SET(START+5+IBADD,OFFSET," ")
+16 SET IBPPORT=$$PORTAL^IBCNSC01(IBCDFNDB)
+17 DO SET(START+6+IBADD,OFFSET,"Precert Portal: "_$EXTRACT(IBPPORT,1,55))
+18 DO SET(START+7+IBADD,OFFSET+16,$EXTRACT(IBPPORT,56,80))
+19 DO SET(START+8+IBADD,OFFSET," ")
+20 ;
INSQ QUIT
+1 ;
SPON ; -- Sponsor (Insured Person) Region ;IB*2*497 rearrange lines and move all lines into a single column
+1 NEW IBC3,IBZIP,START,OFFSET,IBA,DA,DR,DIC,DIQ,Y
+2 SET IBC3=$GET(^DPT(DFN,.312,IBCDFN,3))
+3 SET DA=+$PIECE(IBC3,"^",2)
SET DR=.01
SET DIQ(0)="E"
SET DIC="^DIC(23,"
SET DIQ="IBA"
DO EN^DIQ1
+4 SET START=$ORDER(^TMP("IBCNSVP",$JOB,""),-1)+1
SET OFFSET=2
+5 DO SET(START,OFFSET," Subscriber's Information (use Subscriber Update Action) ",IORVON,IORVOFF)
+6 DO SET(START+1,OFFSET,$$RJ^XLFSTR("Subscriber's DOB: ",18)_$$DAT3^IBOUTL($PIECE(IBC3,"^")))
+7 SET Y=$PIECE(IBC3,"^",10)
DO ZIPOUT^VAFADDR
SET IBZIP=Y
+8 DO SET(START+2,OFFSET,$$RJ^XLFSTR("Str 1: ",18)_$PIECE(IBC3,"^",6))
+9 DO SET(START+3,OFFSET,$$RJ^XLFSTR("Str 2: ",18)_$PIECE(IBC3,"^",7))
+10 DO SET(START+4,OFFSET,$$RJ^XLFSTR("City: ",18)_$PIECE(IBC3,"^",8))
+11 DO SET(START+5,OFFSET,$$RJ^XLFSTR("St/Zip: ",18)_$PIECE($GET(^DIC(5,+$PIECE(IBC3,"^",9),0)),"^",2)_" "_IBZIP)
+12 DO SET(START+6,OFFSET,$$RJ^XLFSTR("SubDiv: ",18)_$PIECE(IBC3,"^",14))
+13 DO SET(START+7,OFFSET,$$RJ^XLFSTR("Country: ",18)_$PIECE(IBC3,"^",13))
+14 DO SET(START+8,OFFSET,$$RJ^XLFSTR("Phone: ",18)_$PIECE(IBC3,"^",11))
+15 DO SET(START+9,OFFSET,$$RJ^XLFSTR("Subscriber's Sex: ",18)_$$EXTERNAL^DILFD(2.312,3.12,,$PIECE(IBC3,U,12)))
+16 DO SET(START+10,OFFSET,$$RJ^XLFSTR("Subscr's Branch: ",18)_$GET(IBA(23,DA,.01,"E")))
+17 DO SET(START+11,OFFSET,$$RJ^XLFSTR("Subscr's Rank: ",18)_$PIECE(IBC3,"^",3))
+18 ; blank lines at end of section
+19 DO SET(START+12,2," ")
+20 DO SET(START+13,2," ")
+21 QUIT
+22 ;
BLANK(LINE) ; -- Build blank line
+1 DO SET^VALM10(.LINE,$JUSTIFY("",80))
+2 QUIT
+3 ;
SET(LINE,COL,TEXT,ON,OFF) ; -- set display info in array
+1 if '$DATA(@VALMAR@(LINE,0))
DO BLANK(.LINE)
+2 DO SET^VALM10(.LINE,$$SETSTR^VALM1(.TEXT,@VALMAR@(LINE,0),.COL,$LENGTH(TEXT)))
+3 if $GET(ON)]""!($GET(OFF)]"")
DO CNTRL^VALM10(.LINE,.COL,$LENGTH(TEXT),$GET(ON),$GET(OFF))
+4 if '(LINE#5)
WRITE "."
+5 QUIT
+6 ;
GPLAN(IBPLDA) ; get data from PLAN file (#366.03) related to the
+1 ; GROUP INSURANCE PLAN file (#355.3) and the INSURANCE COMPANY file (#36)
+2 ; that is associated with the PATIENT
+3 ; input - IBPLDA - ien of the PLAN file (#366.03)
+4 NEW IBPLN0,IBAIEN,IBAPIEN,IBAP0
+5 ;; Q:'$P(IBPLN0,"^",3) ;quit if payer not defined
SET IBPLN0=$GET(^IBCNR(366.03,IBPLDA,0))
+6 SET IBPLNID=$PIECE(IBPLN0,"^")
SET IBPLNNM=$PIECE(IBPLN0,"^",2)
+7 SET IBAIEN=$ORDER(^IBCNR(366.13,"B","E-PHARM",""))
if 'IBAIEN
QUIT
+8 SET IBAPIEN=$ORDER(^IBCNR(366.03,IBPLDA,3,"B",IBAIEN,""))
if 'IBAPIEN
QUIT
+9 SET IBAP0=$GET(^IBCNR(366.03,IBPLDA,3,IBAPIEN,0))
+10 SET IBPLNNA=$SELECT($PIECE(IBAP0,"^",2)=0:"NOT ACTIVE",1:"ACTIVE")
+11 SET IBPLNLA=$SELECT($PIECE(IBAP0,"^",3)=0:"NOT ACTIVE",1:"ACTIVE")
+12 QUIT
