IBCNSP ;ALB/AAS - INSURANCE MANAGEMENT - EXPANDED POLICY ;05-MAR-1993
;;2.0;INTEGRATED BILLING;**6,28,43,52,85,251,363,371,416,497,516,528,549,602**;21-MAR-94;Build 22
;;Per VA Directive 6402, this routine should not be modified.
% ;
EN ; -- main entry point for IBCNS EXPANDED POLICY
N IB1ST
K VALMQUIT,IBPPOL,IBTOP
S IBTOP="IBCNSP"
D EN^VALM("IBCNS EXPANDED POLICY")
Q
;
HDR ; -- header code
N DOD,IBDOB,IBNAME,W,X,Y,Z ; IB*2.0*549 Added DOD
S IBNAME=^DPT(DFN,0) ; Direct global read on file 2 supported by IA 10035
S IBDOB=$P(IBNAME,"^",3)
S IBNAME=$E($P(IBNAME,U),1,20)
;
; IB*2.0*549 Shortened 'Expanded Policy Information For ' to 'For: ' below
S VALMHDR(1)="For: "_IBNAME_" "_$P($$PT^IBEFUNC(DFN),U,2)_" "_$$FMTE^XLFDT(IBDOB,"5DZ")
;
; IB*2.0*549 Added next 4 lines
S DOD=$$GET1^DIQ(2,DFN_",",.351,"I")
I DOD'="" D
. S DOD=$$FMTE^XLFDT(DOD,"5DZ")
. ;IB*2.0*602/DM display DoD properly with long patient name
. S VALMHDR(1)=VALMHDR(1)_" DoD: "_DOD
S Z=$G(^DPT(DFN,.312,+$P(IBPPOL,U,4),0))
S W=$P($G(^IBA(355.3,+$P(Z,U,18),0)),U,11)
S Y=$E($P($G(^DIC(36,+Z,0)),U),1,20)_" Insurance Company"
S X="** Plan Currently "_$S(W:"Ina",1:"A")_"ctive **"
S VALMHDR(2)=$$SETSTR^VALM1(X,Y,48,29)
Q
;
INIT ; -- init variables and list array
K VALMQUIT
S VALMCNT=0,VALMBG=1
I '$D(IBPPOL) D PPOL Q:$D(VALMQUIT)
D BLD,HDR
Q
;
BLD ; -- list builder
K ^TMP("IBCNSVP",$J),^TMP("IBCNSVPDX",$J)
D KILL^VALM10()
N IBCDFND,IBCDFND1,IBCDFND2,IBCDFND4,IBCDFND5,IBCDFND7
S IBCDFND=$G(^DPT(DFN,.312,$P(IBPPOL,U,4),0)),IBCDFND1=$G(^(1)),IBCDFND2=$G(^(2)),IBCDFND4=$G(^(4)),IBCDFND5=$G(^(5)),IBCDFND7=$G(^(7))
; MRD;IB*2.0*516 - Use $$ZND^IBCNS1 to pull zero node of 2.312.
S IBCDFND=$$ZND^IBCNS1(DFN,$P(IBPPOL,U,4))
S IBCPOL=+$P(IBCDFND,U,18),IBCNS=+IBCDFND,IBCDFN=$P(IBPPOL,U,4)
S IBCPOLD=$G(^IBA(355.3,+$P(IBCDFND,U,18),0)),IBCPOLD1=$G(^(1))
S IBCPOLD2=$G(^IBA(355.3,+$G(IBCPOL),6)) ;; Daou/EEN adding BIN and PCN
S IBCPOLDL=$G(^IBA(355.3,+$G(IBCPOL),2)) ;IB*2*497 new group name and group number locations
;
D INS^IBCNSP0 ; insurance company
D POLICY^IBCNSP0 ; plan information
D UR ; utilization review info
D EFFECT ; effective dates & source of info
D SUBSC^IBCNSP01 ; subscriber info
D EMP ; subscriber's employer info
D PRV^IBCNSP01 ; subscriber's provider contact info ;IB*2*497
D SPON^IBCNSP0 ; insured person's info
D ID^IBCNSP01 ; ins co ID numbers (IB*2*371)
D PLIM ; plan coverage limitations
D VER^IBCNSP01 ; user/verifier/editor info
;
;IB*2.0*549 Removed next line
;D CONTACT^IBCNSP0 ; last insurance contact
D COMMENT ; comments - policy & plan
D RIDER^IBCNSP01 ; policy rider info
;
S VALMCNT=+$O(^TMP("IBCNSVP",$J,""),-1)
Q
;
; Input: DFN - IEN of the currently selected patient
; IBCPOL -
; IBPPOL - O node of the selected Patient Policy
; ^TMP("IBCNSVP",$J) - Current global Array of display lines
; Output: IB1ST("COMMENT") - 1st line of comments display
; ^TMP("IBCNSVP",$J) - Updated global Array of display lines
;
;IB*2.0*549 Moved Group Plan Comment above Patient Policy Comment. Changed
; Patient Policy Comment to display the two most recent comments
; in the patient policy comment multiple (2.342,1.18)
N COMDT,COMIEN,COMCTR,COMSTOP,IBI,IBIIEN,IBL,OFFSET,XX
S IBL=$O(^TMP("IBCNSVP",$J,""),-1)+1,OFFSET=2
S IB1ST("COMMENT")=IBL
;
; Display Group Plan Comment
D SET(IBL,OFFSET," Comment -- Group Plan ",IORVON,IORVOFF)
S IBI=0
F S IBI=$O(^IBA(355.3,+IBCPOL,11,IBI)) Q:IBI<1 D
. S IBL=IBL+1
. D SET(IBL,OFFSET," "_$E($G(^IBA(355.3,+IBCPOL,11,IBI,0)),1,80))
S IBL=IBL+1
D SET(IBL,OFFSET," ")
;
; Display Last two Patient Policy Comments
S IBIIEN=$P(IBPPOL,"^",4),IBL=IBL+1
D SET(IBL,OFFSET," Comment -- Patient Policy ",IORVON,IORVOFF)
S IBL=IBL+1,XX=" Dt Entered Entered By Method Person Contacted"
S XX=XX_$J("",78-$L(XX))
D SET(IBL,OFFSET,XX,IOUON,IOUOFF)
S COMDT="",(COMCTR,COMSTOP)=0
F D Q:(COMDT="")!COMSTOP
. S COMDT=$O(^DPT(DFN,.312,IBIIEN,13,"B",COMDT),-1)
. Q:COMDT=""
. S COMIEN=""
. F D Q:(COMIEN="")!COMSTOP
. . S COMIEN=$O(^DPT(DFN,.312,IBIIEN,13,"B",COMDT,COMIEN),-1)
. . Q:COMIEN=""
. . S COMCTR=COMCTR+1
. . I COMCTR>2 S COMSTOP=1 Q
. . I COMCTR=2 D
. . . S IBL=IBL+1
. . . D SET(IBL,OFFSET," ")
. . D DISPPPC(.IBL,DFN,IBIIEN,COMIEN) ; Display Patient Policy Comment
;
; Add two blank lines at end
S IBL=IBL+1
D SET(IBL,OFFSET," ")
S IBL=IBL+1
D SET(IBL,OFFSET," ")
Q
;
DISPPPC(IBL,DFN,IBIIEN,COMIEN) ; Display one Patient Policy Comment
;IB*2.0*549 - Added sub-routine
; Input: IBL - Current Display Line Counter
; DFN - IEN of the currently selected patient
; IBIIEN - ^DPT(DFN,.312,IBIIEN,0) Where IBIIEN is the
; multiple IEN of the selected patient policy
; COMIEN - ^DPT(DFN,.312,IBIIEN,13,COMIEN,0) Where
; COMIEN is the multiple IEN of the selected
; Patient Policy Comment
; ^TMP("IBCNSVP",$J) - Current global Array of display lines
; Output: IBL - Updated Display Line Counter
; ^TMP("IBCNSVP",$J) - Updated global Array of display lines
N COMDATA,LINE,XX,ZZ
S COMDATA=$$GETONEC^IBCNCH2(DFN,IBIIEN,COMIEN,0,77,0,1)
S LINE=$P(COMDATA,"^",1)_" "
S XX=$P(COMDATA,"^",2),ZZ=$J("",26-$L(XX))
S LINE=LINE_XX_ZZ
S XX=$P(COMDATA,"^",4),ZZ=$J("",11-$L(XX))
S LINE=LINE_XX_ZZ_$P(COMDATA,"^",3),IBL=IBL+1
D SET(IBL,OFFSET,LINE)
S IBL=IBL+1,LINE=" "_$P(COMDATA,"^",8)
D SET(IBL,OFFSET,LINE)
Q
;
EFFECT ; -- Effective date region
N START,OFFSET
S START=$O(^TMP("IBCNSVP",$J,""),-1)-6 ;ib*2*497 lines need to be displayed alongside UR region
S OFFSET=45
D SET(START,OFFSET-4," Effective Dates & Source ",IORVON,IORVOFF)
D SET(START+1,OFFSET," Effective Date: "_$$DAT1^IBOUTL($P(IBCDFND,U,8)))
D SET(START+2,OFFSET,"Expiration Date: "_$$DAT1^IBOUTL($P(IBCDFND,U,4)))
D SET(START+3,OFFSET," Source of Info: "_$$EXPAND^IBTRE(2.312,1.09,$P($G(IBCDFND1),U,9)))
;
;IB*2.0*549 Changed OFFSET-4 to OFFSET-8
; Changed 'Policy Not Billable' to 'Stop Policy From Billing'
D SET(START+4,OFFSET-9,"Stop Policy From Billing: "_$S($P($G(^DPT(DFN,.312,IBCDFN,3)),"^",4):"YES",1:"NO"))
Q
;
UR ; -- UR of insurance region
N START,OFFSET
S START=$O(^TMP("IBCNSVP",$J,""),-1)+1,OFFSET=2 ;IB*2*497
D SET(START,OFFSET," Utilization Review Info ",IORVON,IORVOFF)
D SET(START+1,OFFSET," Require UR: "_$$EXPAND^IBTRE(355.3,.05,$P(IBCPOLD,U,5)))
D SET(START+2,OFFSET," Require Amb Cert: "_$$EXPAND^IBTRE(355.3,.12,$P(IBCPOLD,U,12)))
D SET(START+3,OFFSET," Require Pre-Cert: "_$$EXPAND^IBTRE(355.3,.06,$P(IBCPOLD,U,6)))
D SET(START+4,OFFSET," Exclude Pre-Cond: "_$$EXPAND^IBTRE(355.3,.07,$P(IBCPOLD,U,7)))
D SET(START+5,OFFSET,"Benefits Assignable: "_$$EXPAND^IBTRE(355.3,.08,$P(IBCPOLD,U,8)))
D SET(START+6,2," ")
Q
EMP ; -- Insurance Employer Region
; ib*2*497 move employer lines around
N OFFSET,START,IBADD,COL2
S START=$O(^TMP("IBCNSVP",$J,""),-1)+1,OFFSET=2
D SET(START,OFFSET," Subscriber's Employer Information ",IORVON,IORVOFF)
D SET(START+1,OFFSET,$$RJ^XLFSTR(" Employment Status: ",20)_$$EXPAND^IBTRE(2.312,2.11,$P(IBCDFND2,U,11)))
S COL2=START+1
D SET(START+2,OFFSET,$$RJ^XLFSTR("Employer: ",20)_$P(IBCDFND2,U,9))
D SET(START+3,OFFSET,$$RJ^XLFSTR("Street: ",20)_$P(IBCDFND2,U,2)) S IBADD=1
I $P(IBCDFND2,U,3)'="" D SET(START+4,OFFSET,$$RJ^XLFSTR("Street 2: ",20)_$P(IBCDFND2,U,3)) S IBADD=2
I $P(IBCDFND2,U,4)'="" D SET(START+5,OFFSET,$$RJ^XLFSTR("Street 3: ",20)_$P(IBCDFND2,U,4)) S IBADD=3
D SET(START+3+IBADD,OFFSET,$$RJ^XLFSTR("City/State: ",20)_$E($P(IBCDFND2,U,5),1,15)_$S($P(IBCDFND2,U,5)="":"",1:", ")_$P($G(^DIC(5,+$P(IBCDFND2,U,6),0)),U,2)_" "_$E($P(IBCDFND2,U,7),1,5))
D SET(START+4+IBADD,OFFSET,$$RJ^XLFSTR("Phone: ",20)_$P(IBCDFND2,U,8))
D SET(START+5+IBADD,OFFSET," ") ; ib*2*497 only 1 blank line to end the section
;
S START=COL2,OFFSET=40
D SET(START,OFFSET,"Emp Sponsored Plan: "_$S(+$P(IBCDFND2,U,10):"Yes",1:"No"))
D SET(START+1,OFFSET,"Claims to Employer: "_$S(+IBCDFND2:"Yes, Send to Employer",1:"No, Send to Insurance Company"))
D SET(START+2,OFFSET," Retirement Date: "_$$DAT1^IBOUTL($P(IBCDFND2,U,12)))
;
EMPQ Q
;
PLIM ; plan coverage limitations/plan limitation category display
N START,END S START=$O(^TMP("IBCNSVP",$J,""),-1)+1
S IB1ST("PLIM")=START
D LIMBLD^IBCNSC41(START,2)
S END=$O(^TMP("IBCNSVP",$J,""),-1) ; last line constructed
D SET(END+1,2," ") ; 2 blank lines to end this section
D SET(END+2,2," ")
PLIMX ;
Q
;
HELP ; -- help code
S X="?" D DISP^XQORM1 W !!
Q
;
EXIT ; -- exit code
K IBPPOL,VALMQUIT,IBCNS,IBCDFN,IBCPOL,IBCPOLD,IBCPOLD1,IBCPOLD2,IBCPOLDL,IBCDFND,IBCDFND1,IBCDFND2,IBVPCLBG,IBVPCLEN
D CLEAN^VALM10,CLEAR^VALM1
Q
;
EXPND ; -- expand code
Q
;
PPOL ; -- select patient, select policy
I '$D(DFN) D G:$D(VALMQUIT) PPOLQ
.S DIC="^DPT(",DIC(0)="AEQMN" D ^DIC
.S DFN=+Y
I $G(DFN)<1 S VALMQUIT="" G PPOLQ
;
I '$O(^DPT(DFN,.312,0)) W !!,"Patient doesn't have Insurance" K DFN G PPOL
;
S DIC="^DPT("_DFN_",.312,",DIC(0)="AEQMN",DIC("A")="Select Patient Policy: "
D ^DIC I +Y<1 S VALMQUIT=""
G:$D(VALMQUIT) PPOLQ
S IBPPOL="^2^"_DFN_U_+Y_U_$G(^DPT(DFN,.312,+Y,0))
PPOLQ K DIC Q
;
BLANK(LINE) ; -- Build blank line
D SET^VALM10(.LINE,$J("",80))
Q
;
SET(LINE,COL,TEXT,ON,OFF) ; -- set display info in array
I '$D(@VALMAR@(LINE,0)) D BLANK(.LINE) S VALMCNT=$G(VALMCNT)+1
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
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCNSP 10429 printed Sep 23, 2025@19:54:03 Page 2
IBCNSP ;ALB/AAS - INSURANCE MANAGEMENT - EXPANDED POLICY ;05-MAR-1993
+1 ;;2.0;INTEGRATED BILLING;**6,28,43,52,85,251,363,371,416,497,516,528,549,602**;21-MAR-94;Build 22
+2 ;;Per VA Directive 6402, this routine should not be modified.
% ;
EN ; -- main entry point for IBCNS EXPANDED POLICY
+1 NEW IB1ST
+2 KILL VALMQUIT,IBPPOL,IBTOP
+3 SET IBTOP="IBCNSP"
+4 DO EN^VALM("IBCNS EXPANDED POLICY")
+5 QUIT
+6 ;
HDR ; -- header code
+1 ; IB*2.0*549 Added DOD
NEW DOD,IBDOB,IBNAME,W,X,Y,Z
+2 ; Direct global read on file 2 supported by IA 10035
SET IBNAME=^DPT(DFN,0)
+3 SET IBDOB=$PIECE(IBNAME,"^",3)
+4 SET IBNAME=$EXTRACT($PIECE(IBNAME,U),1,20)
+5 ;
+6 ; IB*2.0*549 Shortened 'Expanded Policy Information For ' to 'For: ' below
+7 SET VALMHDR(1)="For: "_IBNAME_" "_$PIECE($$PT^IBEFUNC(DFN),U,2)_" "_$$FMTE^XLFDT(IBDOB,"5DZ")
+8 ;
+9 ; IB*2.0*549 Added next 4 lines
+10 SET DOD=$$GET1^DIQ(2,DFN_",",.351,"I")
+11 IF DOD'=""
Begin DoDot:1
+12 SET DOD=$$FMTE^XLFDT(DOD,"5DZ")
+13 ;IB*2.0*602/DM display DoD properly with long patient name
+14 SET VALMHDR(1)=VALMHDR(1)_" DoD: "_DOD
End DoDot:1
+15 SET Z=$GET(^DPT(DFN,.312,+$PIECE(IBPPOL,U,4),0))
+16 SET W=$PIECE($GET(^IBA(355.3,+$PIECE(Z,U,18),0)),U,11)
+17 SET Y=$EXTRACT($PIECE($GET(^DIC(36,+Z,0)),U),1,20)_" Insurance Company"
+18 SET X="** Plan Currently "_$SELECT(W:"Ina",1:"A")_"ctive **"
+19 SET VALMHDR(2)=$$SETSTR^VALM1(X,Y,48,29)
+20 QUIT
+21 ;
INIT ; -- init variables and list array
+1 KILL VALMQUIT
+2 SET VALMCNT=0
SET VALMBG=1
+3 IF '$DATA(IBPPOL)
DO PPOL
if $DATA(VALMQUIT)
QUIT
+4 DO BLD
DO HDR
+5 QUIT
+6 ;
BLD ; -- list builder
+1 KILL ^TMP("IBCNSVP",$JOB),^TMP("IBCNSVPDX",$JOB)
+2 DO KILL^VALM10()
+3 NEW IBCDFND,IBCDFND1,IBCDFND2,IBCDFND4,IBCDFND5,IBCDFND7
+4 SET IBCDFND=$GET(^DPT(DFN,.312,$PIECE(IBPPOL,U,4),0))
SET IBCDFND1=$GET(^(1))
SET IBCDFND2=$GET(^(2))
SET IBCDFND4=$GET(^(4))
SET IBCDFND5=$GET(^(5))
SET IBCDFND7=$GET(^(7))
+5 ; MRD;IB*2.0*516 - Use $$ZND^IBCNS1 to pull zero node of 2.312.
+6 SET IBCDFND=$$ZND^IBCNS1(DFN,$PIECE(IBPPOL,U,4))
+7 SET IBCPOL=+$PIECE(IBCDFND,U,18)
SET IBCNS=+IBCDFND
SET IBCDFN=$PIECE(IBPPOL,U,4)
+8 SET IBCPOLD=$GET(^IBA(355.3,+$PIECE(IBCDFND,U,18),0))
SET IBCPOLD1=$GET(^(1))
+9 ;; Daou/EEN adding BIN and PCN
SET IBCPOLD2=$GET(^IBA(355.3,+$GET(IBCPOL),6))
+10 ;IB*2*497 new group name and group number locations
SET IBCPOLDL=$GET(^IBA(355.3,+$GET(IBCPOL),2))
+11 ;
+12 ; insurance company
DO INS^IBCNSP0
+13 ; plan information
DO POLICY^IBCNSP0
+14 ; utilization review info
DO UR
+15 ; effective dates & source of info
DO EFFECT
+16 ; subscriber info
DO SUBSC^IBCNSP01
+17 ; subscriber's employer info
DO EMP
+18 ; subscriber's provider contact info ;IB*2*497
DO PRV^IBCNSP01
+19 ; insured person's info
DO SPON^IBCNSP0
+20 ; ins co ID numbers (IB*2*371)
DO ID^IBCNSP01
+21 ; plan coverage limitations
DO PLIM
+22 ; user/verifier/editor info
DO VER^IBCNSP01
+23 ;
+24 ;IB*2.0*549 Removed next line
+25 ;D CONTACT^IBCNSP0 ; last insurance contact
+26 ; comments - policy & plan
DO COMMENT
+27 ; policy rider info
DO RIDER^IBCNSP01
+28 ;
+29 SET VALMCNT=+$ORDER(^TMP("IBCNSVP",$JOB,""),-1)
+30 QUIT
+31 ;
+1 ; Input: DFN - IEN of the currently selected patient
+2 ; IBCPOL -
+3 ; IBPPOL - O node of the selected Patient Policy
+4 ; ^TMP("IBCNSVP",$J) - Current global Array of display lines
+5 ; Output: IB1ST("COMMENT") - 1st line of comments display
+6 ; ^TMP("IBCNSVP",$J) - Updated global Array of display lines
+7 ;
+8 ;IB*2.0*549 Moved Group Plan Comment above Patient Policy Comment. Changed
+9 ; Patient Policy Comment to display the two most recent comments
+10 ; in the patient policy comment multiple (2.342,1.18)
+11 NEW COMDT,COMIEN,COMCTR,COMSTOP,IBI,IBIIEN,IBL,OFFSET,XX
+12 SET IBL=$ORDER(^TMP("IBCNSVP",$JOB,""),-1)+1
SET OFFSET=2
+13 SET IB1ST("COMMENT")=IBL
+14 ;
+15 ; Display Group Plan Comment
+16 DO SET(IBL,OFFSET," Comment -- Group Plan ",IORVON,IORVOFF)
+17 SET IBI=0
+18 FOR
SET IBI=$ORDER(^IBA(355.3,+IBCPOL,11,IBI))
if IBI<1
QUIT
Begin DoDot:1
+19 SET IBL=IBL+1
+20 DO SET(IBL,OFFSET," "_$EXTRACT($GET(^IBA(355.3,+IBCPOL,11,IBI,0)),1,80))
End DoDot:1
+21 SET IBL=IBL+1
+22 DO SET(IBL,OFFSET," ")
+23 ;
+24 ; Display Last two Patient Policy Comments
+25 SET IBIIEN=$PIECE(IBPPOL,"^",4)
SET IBL=IBL+1
+26 DO SET(IBL,OFFSET," Comment -- Patient Policy ",IORVON,IORVOFF)
+27 SET IBL=IBL+1
SET XX=" Dt Entered Entered By Method Person Contacted"
+28 SET XX=XX_$JUSTIFY("",78-$LENGTH(XX))
+29 DO SET(IBL,OFFSET,XX,IOUON,IOUOFF)
+30 SET COMDT=""
SET (COMCTR,COMSTOP)=0
+31 FOR
Begin DoDot:1
+32 SET COMDT=$ORDER(^DPT(DFN,.312,IBIIEN,13,"B",COMDT),-1)
+33 if COMDT=""
QUIT
+34 SET COMIEN=""
+35 FOR
Begin DoDot:2
+36 SET COMIEN=$ORDER(^DPT(DFN,.312,IBIIEN,13,"B",COMDT,COMIEN),-1)
+37 if COMIEN=""
QUIT
+38 SET COMCTR=COMCTR+1
+39 IF COMCTR>2
SET COMSTOP=1
QUIT
+40 IF COMCTR=2
Begin DoDot:3
+41 SET IBL=IBL+1
+42 DO SET(IBL,OFFSET," ")
End DoDot:3
+43 ; Display Patient Policy Comment
DO DISPPPC(.IBL,DFN,IBIIEN,COMIEN)
End DoDot:2
if (COMIEN="")!COMSTOP
QUIT
End DoDot:1
if (COMDT="")!COMSTOP
QUIT
+44 ;
+45 ; Add two blank lines at end
+46 SET IBL=IBL+1
+47 DO SET(IBL,OFFSET," ")
+48 SET IBL=IBL+1
+49 DO SET(IBL,OFFSET," ")
+50 QUIT
+51 ;
DISPPPC(IBL,DFN,IBIIEN,COMIEN) ; Display one Patient Policy Comment
+1 ;IB*2.0*549 - Added sub-routine
+2 ; Input: IBL - Current Display Line Counter
+3 ; DFN - IEN of the currently selected patient
+4 ; IBIIEN - ^DPT(DFN,.312,IBIIEN,0) Where IBIIEN is the
+5 ; multiple IEN of the selected patient policy
+6 ; COMIEN - ^DPT(DFN,.312,IBIIEN,13,COMIEN,0) Where
+7 ; COMIEN is the multiple IEN of the selected
+8 ; Patient Policy Comment
+9 ; ^TMP("IBCNSVP",$J) - Current global Array of display lines
+10 ; Output: IBL - Updated Display Line Counter
+11 ; ^TMP("IBCNSVP",$J) - Updated global Array of display lines
+12 NEW COMDATA,LINE,XX,ZZ
+13 SET COMDATA=$$GETONEC^IBCNCH2(DFN,IBIIEN,COMIEN,0,77,0,1)
+14 SET LINE=$PIECE(COMDATA,"^",1)_" "
+15 SET XX=$PIECE(COMDATA,"^",2)
SET ZZ=$JUSTIFY("",26-$LENGTH(XX))
+16 SET LINE=LINE_XX_ZZ
+17 SET XX=$PIECE(COMDATA,"^",4)
SET ZZ=$JUSTIFY("",11-$LENGTH(XX))
+18 SET LINE=LINE_XX_ZZ_$PIECE(COMDATA,"^",3)
SET IBL=IBL+1
+19 DO SET(IBL,OFFSET,LINE)
+20 SET IBL=IBL+1
SET LINE=" "_$PIECE(COMDATA,"^",8)
+21 DO SET(IBL,OFFSET,LINE)
+22 QUIT
+23 ;
EFFECT ; -- Effective date region
+1 NEW START,OFFSET
+2 ;ib*2*497 lines need to be displayed alongside UR region
SET START=$ORDER(^TMP("IBCNSVP",$JOB,""),-1)-6
+3 SET OFFSET=45
+4 DO SET(START,OFFSET-4," Effective Dates & Source ",IORVON,IORVOFF)
+5 DO SET(START+1,OFFSET," Effective Date: "_$$DAT1^IBOUTL($PIECE(IBCDFND,U,8)))
+6 DO SET(START+2,OFFSET,"Expiration Date: "_$$DAT1^IBOUTL($PIECE(IBCDFND,U,4)))
+7 DO SET(START+3,OFFSET," Source of Info: "_$$EXPAND^IBTRE(2.312,1.09,$PIECE($GET(IBCDFND1),U,9)))
+8 ;
+9 ;IB*2.0*549 Changed OFFSET-4 to OFFSET-8
+10 ; Changed 'Policy Not Billable' to 'Stop Policy From Billing'
+11 DO SET(START+4,OFFSET-9,"Stop Policy From Billing: "_$SELECT($PIECE($GET(^DPT(DFN,.312,IBCDFN,3)),"^",4):"YES",1:"NO"))
+12 QUIT
+13 ;
UR ; -- UR of insurance region
+1 NEW START,OFFSET
+2 ;IB*2*497
SET START=$ORDER(^TMP("IBCNSVP",$JOB,""),-1)+1
SET OFFSET=2
+3 DO SET(START,OFFSET," Utilization Review Info ",IORVON,IORVOFF)
+4 DO SET(START+1,OFFSET," Require UR: "_$$EXPAND^IBTRE(355.3,.05,$PIECE(IBCPOLD,U,5)))
+5 DO SET(START+2,OFFSET," Require Amb Cert: "_$$EXPAND^IBTRE(355.3,.12,$PIECE(IBCPOLD,U,12)))
+6 DO SET(START+3,OFFSET," Require Pre-Cert: "_$$EXPAND^IBTRE(355.3,.06,$PIECE(IBCPOLD,U,6)))
+7 DO SET(START+4,OFFSET," Exclude Pre-Cond: "_$$EXPAND^IBTRE(355.3,.07,$PIECE(IBCPOLD,U,7)))
+8 DO SET(START+5,OFFSET,"Benefits Assignable: "_$$EXPAND^IBTRE(355.3,.08,$PIECE(IBCPOLD,U,8)))
+9 DO SET(START+6,2," ")
+10 QUIT
EMP ; -- Insurance Employer Region
+1 ; ib*2*497 move employer lines around
+2 NEW OFFSET,START,IBADD,COL2
+3 SET START=$ORDER(^TMP("IBCNSVP",$JOB,""),-1)+1
SET OFFSET=2
+4 DO SET(START,OFFSET," Subscriber's Employer Information ",IORVON,IORVOFF)
+5 DO SET(START+1,OFFSET,$$RJ^XLFSTR(" Employment Status: ",20)_$$EXPAND^IBTRE(2.312,2.11,$PIECE(IBCDFND2,U,11)))
+6 SET COL2=START+1
+7 DO SET(START+2,OFFSET,$$RJ^XLFSTR("Employer: ",20)_$PIECE(IBCDFND2,U,9))
+8 DO SET(START+3,OFFSET,$$RJ^XLFSTR("Street: ",20)_$PIECE(IBCDFND2,U,2))
SET IBADD=1
+9 IF $PIECE(IBCDFND2,U,3)'=""
DO SET(START+4,OFFSET,$$RJ^XLFSTR("Street 2: ",20)_$PIECE(IBCDFND2,U,3))
SET IBADD=2
+10 IF $PIECE(IBCDFND2,U,4)'=""
DO SET(START+5,OFFSET,$$RJ^XLFSTR("Street 3: ",20)_$PIECE(IBCDFND2,U,4))
SET IBADD=3
+11 DO SET(START+3+IBADD,OFFSET,$$RJ^XLFSTR("City/State: ",20)_$EXTRACT($PIECE(IBCDFND2,U,5),1,15)_$SELECT($PIECE(IBCDFND2,U,5)="":"",1:", ")_$PIECE($GET(^DIC(5,+$PIECE(IBCDFND2,U,6),0)),U,2)_" "_$EXTRACT($PIECE(IBCDFND2,U,7),1,5))
+12 DO SET(START+4+IBADD,OFFSET,$$RJ^XLFSTR("Phone: ",20)_$PIECE(IBCDFND2,U,8))
+13 ; ib*2*497 only 1 blank line to end the section
DO SET(START+5+IBADD,OFFSET," ")
+14 ;
+15 SET START=COL2
SET OFFSET=40
+16 DO SET(START,OFFSET,"Emp Sponsored Plan: "_$SELECT(+$PIECE(IBCDFND2,U,10):"Yes",1:"No"))
+17 DO SET(START+1,OFFSET,"Claims to Employer: "_$SELECT(+IBCDFND2:"Yes, Send to Employer",1:"No, Send to Insurance Company"))
+18 DO SET(START+2,OFFSET," Retirement Date: "_$$DAT1^IBOUTL($PIECE(IBCDFND2,U,12)))
+19 ;
EMPQ QUIT
+1 ;
PLIM ; plan coverage limitations/plan limitation category display
+1 NEW START,END
SET START=$ORDER(^TMP("IBCNSVP",$JOB,""),-1)+1
+2 SET IB1ST("PLIM")=START
+3 DO LIMBLD^IBCNSC41(START,2)
+4 ; last line constructed
SET END=$ORDER(^TMP("IBCNSVP",$JOB,""),-1)
+5 ; 2 blank lines to end this section
DO SET(END+1,2," ")
+6 DO SET(END+2,2," ")
PLIMX ;
+1 QUIT
+2 ;
HELP ; -- help code
+1 SET X="?"
DO DISP^XQORM1
WRITE !!
+2 QUIT
+3 ;
EXIT ; -- exit code
+1 KILL IBPPOL,VALMQUIT,IBCNS,IBCDFN,IBCPOL,IBCPOLD,IBCPOLD1,IBCPOLD2,IBCPOLDL,IBCDFND,IBCDFND1,IBCDFND2,IBVPCLBG,IBVPCLEN
+2 DO CLEAN^VALM10
DO CLEAR^VALM1
+3 QUIT
+4 ;
EXPND ; -- expand code
+1 QUIT
+2 ;
PPOL ; -- select patient, select policy
+1 IF '$DATA(DFN)
Begin DoDot:1
+2 SET DIC="^DPT("
SET DIC(0)="AEQMN"
DO ^DIC
+3 SET DFN=+Y
End DoDot:1
if $DATA(VALMQUIT)
GOTO PPOLQ
+4 IF $GET(DFN)<1
SET VALMQUIT=""
GOTO PPOLQ
+5 ;
+6 IF '$ORDER(^DPT(DFN,.312,0))
WRITE !!,"Patient doesn't have Insurance"
KILL DFN
GOTO PPOL
+7 ;
+8 SET DIC="^DPT("_DFN_",.312,"
SET DIC(0)="AEQMN"
SET DIC("A")="Select Patient Policy: "
+9 DO ^DIC
IF +Y<1
SET VALMQUIT=""
+10 if $DATA(VALMQUIT)
GOTO PPOLQ
+11 SET IBPPOL="^2^"_DFN_U_+Y_U_$GET(^DPT(DFN,.312,+Y,0))
PPOLQ KILL DIC
QUIT
+1 ;
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)
SET VALMCNT=$GET(VALMCNT)+1
+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 ;
