- 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 Jan 18, 2025@03:19:02 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