IBCNSM ;ALB/AAS - INSURANCE MANAGEMENT, LIST MANAGER INIT ROUTINE ; 30-NOV-2021
;;2.0;INTEGRATED BILLING;**28,46,56,52,82,103,199,276,435,528,659,713,763,778**;21-MAR-94;Build 28
;;Per VA Directive 6402, this routine should not be modified.
;
;
% ; -- main entry point
EN ;
D DT^DICRW
K XQORS,VALMEVL
D EN^VALM("IBCNS INSURANCE MANAGEMENT")
ENQ K DFN
Q
;
;
INIT ; -- set up inital variables
S U="^",VALMCNT=0,VALMBG=1
K ^TMP("IBNSM",$J),^TMP("IBNSMDX",$J)
;K I,X,SDBEG,SDEND,SDB,XQORNOD,SDFN,SDCLN,DA,DR,DIE,DNM,DQ
S DIR(0)="350.9,4.02",DIR("A")="Select Patient Name or Insurance Co."
D ^DIR K DIR I $D(DIRUT) S VALMQUIT="" G INITQ
S IBY=Y
I IBY["DPT(" S IBTYP="P",DFN=+IBY D BLD
I IBY["DIC(" S IBTYP="I",IBCNS=+IBY D EN^VALM("IBCNS INSURANCE COMPANY") S VALMQUIT=""
;
INITQ Q
;
;
PAT ; -- select patient you are working with
N DPTNOFZY S DPTNOFZY=1 ;Suppress PATIENT file fuzzy lookups
S DIC(0)="AEQMN",DIC="^DPT(" D ^DIC I +Y<1 S VALMQUIT="" Q
S DFN=+Y
Q
;
;
BLD ; -- build list of bills
K ^TMP("IBNSM",$J),^TMP("IBNSMDX",$J)
N I,J,K,IBDOD,IBHOLD,IBGRP,IBINS,IBCNT,IBCDFND,IBCDFND1,IBCPOLD,IBPL
S (IBN,IBCNT,VALMCNT)=0,IBFILE=2
;
; -- find all ins. co data
K IBINS S IBINS=0
D POL^IBCNSU41(DFN)
I '$G(IBNCPIVD) D ALL^IBCNS1(DFN,"IBINS") ; all insurances
I $G(IBNCPIVD) D ALL^IBCNS1(DFN,"IBINS",1,IBNCPIVD) ; IB*2*435 - Rx policies active as of this date
;
I $G(IBINS(0)) S K=0 F S K=$O(IBINS(K)) Q:'K D
.; -- add to list
.W "."
.S IBCDFND=$G(IBINS(K,0))
.S IBCDFND1=$G(IBINS(K,1))
.S IBPL=+$P(IBCDFND,U,18)
.S IBCPOLD=$G(^IBA(355.3,IBPL,0))
.;
.; IB*2*435 - esg - 9/27/10 - active Rx policies only if this variable is set
.I $G(IBNCPIVD),'$$PLCOV^IBCNSU3(IBPL,IBNCPIVD,3) Q
.;
.S IBCNT=IBCNT+1
.S X=""
.S X=$$SETFLD^VALM1(IBCNT,X,"NUMBER")
.I $D(^DIC(36,+IBCDFND,0)) S X=$$SETFLD^VALM1($P(^(0),"^"),X,"NAME")
.S X=$$SETFLD^VALM1($E($P(IBCDFND,"^",2),1,14),X,"POLICY")
.S IBHOLD=$P(IBCDFND,"^",6),X=$$SETFLD^VALM1($S(IBHOLD="v":"SELF",IBHOLD="s":"SPOUSE",IBHOLD="o":"OTHER",1:"UNKNOWN"),X,"HOLDER")
.S X=$$SETFLD^VALM1($E($$GRP^IBCNS($P(IBCDFND,"^",18)),1,10),X,"GROUP")
.S X=$$SETFLD^VALM1($$DAT1^IBOUTL($P(IBCDFND,"^",8)),X,"EFFDT")
.S X=$$SETFLD^VALM1($$DAT1^IBOUTL($P(IBCDFND,"^",4)),X,"EXPIRE")
.S X=$$SETFLD^VALM1($E($P($G(^IBE(355.1,+$P(IBCPOLD,"^",9),0)),U),1,8),X,"TYPE")
.;
.; IB*778/DTG change to display abbreviation if Type of Plan name is longer than 15 characters.
.;S X=$$SETFLD^VALM1($P($G(^IBE(355.1,+$P($G(^IBA(355.3,+$P(IBCDFND,"^",18),0)),"^",9),0)),"^"),X,"TYPEPOL")
.N IBTYPA,IBTYPN,IBTYPO,IB3551IEN
.S IB3551IEN=$$GET1^DIQ(355.3,+$P(IBCDFND,"^",18)_",",".09","I")
.S IBTYPN=$$GET1^DIQ(355.1,IB3551IEN_",",".01") ;name
.S IBTYPA=$$GET1^DIQ(355.1,IB3551IEN_",",".02") ;abbrev
.S IBTYPO=IBTYPN I $L(IBTYPN)>15&(IBTYPA'="") S IBTYPO=IBTYPA
.S X=$$SETFLD^VALM1(IBTYPO,X,"TYPEPOL") ; type of plan
.;
.S X=$$SETFLD^VALM1($E($P($G(^VA(200,+$P(IBCDFND1,"^",4),0)),U),1,15),X,"VERIFIED BY")
.S X=$$SETFLD^VALM1($$DAT1^IBOUTL($P(IBCDFND1,"^",3)),X,"VERIFIED ON")
.S X=$$SETFLD^VALM1($$YN($P(IBCPOLD,"^",6)),X,"PRECERT")
.S X=$$SETFLD^VALM1($$YN($P(IBCPOLD,"^",5)),X,"UR")
.;S X=$$SETFLD^VALM1($$YN($P(IBCDFND,"^",20)),X,"COB") ;/vd-IB*2*659 - Replaced this line with the line below.
.S X=$$SETFLD^VALM1($$COB($P(IBCDFND,"^",20)),X,"COB")
.K IBHOLD,IBGRP
.D SET(X)
.Q
;
I '$D(^TMP("IBNSM",$J)) D
.S VALMCNT=2,IBCNT=2,^TMP("IBNSM",$J,1,0)=" "
.S ^TMP("IBNSM",$J,2,0)=" No Insurance Policies on file for this patient."
.I $G(IBNCPIVD) S ^TMP("IBNSM",$J,2,0)=" No Active Rx Policies found as of Effective Date "_$$FMTE^XLFDT(IBNCPIVD,"2Z")_"."
.Q
;
S X=$G(^IBA(354,DFN,60)) I X D
.S IBCNT=IBCNT+1
.S ^TMP("IBNSM",$J,IBCNT,0)=" Verification of No Coverage "_$$FMTE^XLFDT(X)
.Q
;
; IB*713/CKB - adding Date of Death message
S IBDOD=$$GET1^DIQ(2,DFN_",",.351,"I") I IBDOD D
. S IBCNT=IBCNT+1
. S ^TMP("IBNSM",$J,IBCNT,0)=" Date of Death: "_$$FMTE^XLFDT(IBDOD\1,"5Z")
;
BLDQ ;
Q
;
SET(X) ; -- set arrays
S VALMCNT=VALMCNT+1,^TMP("IBNSM",$J,VALMCNT,0)=X
S ^TMP("IBNSM",$J,"IDX",VALMCNT,IBCNT)=""
S ^TMP("IBNSMDX",$J,IBCNT)=VALMCNT_"^"_IBFILE_"^"_DFN_"^"_K_"^"_IBCDFND
Q
;
HDR ; -- screen header for initial screen
D PID^VADPT
; -- AWC/ ib*2.0*528 add the patient dob to display screen
S VALMHDR(1)="Insurance Management for Patient: "_$E($P($G(^DPT(DFN,0)),"^"),1,20)_" "_$E($G(^(0)),1)_VA("BID")_" "_$$FMTE^XLFDT($P($G(^DPT(DFN,0)),"^",3),5)
S VALMHDR(2)=" "
I +$$BUFFER^IBCNBU1(DFN) S VALMHDR(2)="*** Patient has Insurance Buffer Records"
Q
;
FNL ; -- exit and clean up
K ^TMP("IBNSM",$J),^TMP("IBNSMDX",$J)
K IBFASTXT
D CLEAN^VALM10
Q
;
YN(X,Y) ; -- convert 1 or 0 to yes/no/unknown
Q $S($G(X)="":$S($G(Y):"",1:"UNK"),X=0:"NO",X=1:"YES",1:"")
;
;/vd-IB*2*659 - Created the new module below to convert COB to appropriate display.
COB(X) ; -- convert COB value to "UNK", "P", "S" or "T"
Q $S(+X:$E("PST",+X),1:"UNK")
;
CP ; -- change patient
N VALMQUIT
D FULL^VALM1
S IBDFN=DFN D PAT
I $D(VALMQUIT) S DFN=IBDFN
D HDR,BLD
;IB*763/CKB - reset VALMBG to prevent broken breadcrumbs
S VALMBCK="R",VALMBG=1
CPQ K IBDFN
Q
;
PCI S VALMBCK="R" Q
;
FASTEXIT ;just sets a flag signaling system should be exited
S VALMBCK="Q"
D FULL^VALM1
K DIR S DIR(0)="Y",DIR("A")="Exit option entirely",DIR("B")="NO" D ^DIR
I $D(DIRUT)!(Y) S IBFASTXT=1
K DIR
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCNSM 5573 printed Sep 23, 2025@19:53:39 Page 2
IBCNSM ;ALB/AAS - INSURANCE MANAGEMENT, LIST MANAGER INIT ROUTINE ; 30-NOV-2021
+1 ;;2.0;INTEGRATED BILLING;**28,46,56,52,82,103,199,276,435,528,659,713,763,778**;21-MAR-94;Build 28
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;
+4 ;
% ; -- main entry point
EN ;
+1 DO DT^DICRW
+2 KILL XQORS,VALMEVL
+3 DO EN^VALM("IBCNS INSURANCE MANAGEMENT")
ENQ KILL DFN
+1 QUIT
+2 ;
+3 ;
INIT ; -- set up inital variables
+1 SET U="^"
SET VALMCNT=0
SET VALMBG=1
+2 KILL ^TMP("IBNSM",$JOB),^TMP("IBNSMDX",$JOB)
+3 ;K I,X,SDBEG,SDEND,SDB,XQORNOD,SDFN,SDCLN,DA,DR,DIE,DNM,DQ
+4 SET DIR(0)="350.9,4.02"
SET DIR("A")="Select Patient Name or Insurance Co."
+5 DO ^DIR
KILL DIR
IF $DATA(DIRUT)
SET VALMQUIT=""
GOTO INITQ
+6 SET IBY=Y
+7 IF IBY["DPT("
SET IBTYP="P"
SET DFN=+IBY
DO BLD
+8 IF IBY["DIC("
SET IBTYP="I"
SET IBCNS=+IBY
DO EN^VALM("IBCNS INSURANCE COMPANY")
SET VALMQUIT=""
+9 ;
INITQ QUIT
+1 ;
+2 ;
PAT ; -- select patient you are working with
+1 ;Suppress PATIENT file fuzzy lookups
NEW DPTNOFZY
SET DPTNOFZY=1
+2 SET DIC(0)="AEQMN"
SET DIC="^DPT("
DO ^DIC
IF +Y<1
SET VALMQUIT=""
QUIT
+3 SET DFN=+Y
+4 QUIT
+5 ;
+6 ;
BLD ; -- build list of bills
+1 KILL ^TMP("IBNSM",$JOB),^TMP("IBNSMDX",$JOB)
+2 NEW I,J,K,IBDOD,IBHOLD,IBGRP,IBINS,IBCNT,IBCDFND,IBCDFND1,IBCPOLD,IBPL
+3 SET (IBN,IBCNT,VALMCNT)=0
SET IBFILE=2
+4 ;
+5 ; -- find all ins. co data
+6 KILL IBINS
SET IBINS=0
+7 DO POL^IBCNSU41(DFN)
+8 ; all insurances
IF '$GET(IBNCPIVD)
DO ALL^IBCNS1(DFN,"IBINS")
+9 ; IB*2*435 - Rx policies active as of this date
IF $GET(IBNCPIVD)
DO ALL^IBCNS1(DFN,"IBINS",1,IBNCPIVD)
+10 ;
+11 IF $GET(IBINS(0))
SET K=0
FOR
SET K=$ORDER(IBINS(K))
if 'K
QUIT
Begin DoDot:1
+12 ; -- add to list
+13 WRITE "."
+14 SET IBCDFND=$GET(IBINS(K,0))
+15 SET IBCDFND1=$GET(IBINS(K,1))
+16 SET IBPL=+$PIECE(IBCDFND,U,18)
+17 SET IBCPOLD=$GET(^IBA(355.3,IBPL,0))
+18 ;
+19 ; IB*2*435 - esg - 9/27/10 - active Rx policies only if this variable is set
+20 IF $GET(IBNCPIVD)
IF '$$PLCOV^IBCNSU3(IBPL,IBNCPIVD,3)
QUIT
+21 ;
+22 SET IBCNT=IBCNT+1
+23 SET X=""
+24 SET X=$$SETFLD^VALM1(IBCNT,X,"NUMBER")
+25 IF $DATA(^DIC(36,+IBCDFND,0))
SET X=$$SETFLD^VALM1($PIECE(^(0),"^"),X,"NAME")
+26 SET X=$$SETFLD^VALM1($EXTRACT($PIECE(IBCDFND,"^",2),1,14),X,"POLICY")
+27 SET IBHOLD=$PIECE(IBCDFND,"^",6)
SET X=$$SETFLD^VALM1($SELECT(IBHOLD="v":"SELF",IBHOLD="s":"SPOUSE",IBHOLD="o":"OTHER",1:"UNKNOWN"),X,"HOLDER")
+28 SET X=$$SETFLD^VALM1($EXTRACT($$GRP^IBCNS($PIECE(IBCDFND,"^",18)),1,10),X,"GROUP")
+29 SET X=$$SETFLD^VALM1($$DAT1^IBOUTL($PIECE(IBCDFND,"^",8)),X,"EFFDT")
+30 SET X=$$SETFLD^VALM1($$DAT1^IBOUTL($PIECE(IBCDFND,"^",4)),X,"EXPIRE")
+31 SET X=$$SETFLD^VALM1($EXTRACT($PIECE($GET(^IBE(355.1,+$PIECE(IBCPOLD,"^",9),0)),U),1,8),X,"TYPE")
+32 ;
+33 ; IB*778/DTG change to display abbreviation if Type of Plan name is longer than 15 characters.
+34 ;S X=$$SETFLD^VALM1($P($G(^IBE(355.1,+$P($G(^IBA(355.3,+$P(IBCDFND,"^",18),0)),"^",9),0)),"^"),X,"TYPEPOL")
+35 NEW IBTYPA,IBTYPN,IBTYPO,IB3551IEN
+36 SET IB3551IEN=$$GET1^DIQ(355.3,+$PIECE(IBCDFND,"^",18)_",",".09","I")
+37 ;name
SET IBTYPN=$$GET1^DIQ(355.1,IB3551IEN_",",".01")
+38 ;abbrev
SET IBTYPA=$$GET1^DIQ(355.1,IB3551IEN_",",".02")
+39 SET IBTYPO=IBTYPN
IF $LENGTH(IBTYPN)>15&(IBTYPA'="")
SET IBTYPO=IBTYPA
+40 ; type of plan
SET X=$$SETFLD^VALM1(IBTYPO,X,"TYPEPOL")
+41 ;
+42 SET X=$$SETFLD^VALM1($EXTRACT($PIECE($GET(^VA(200,+$PIECE(IBCDFND1,"^",4),0)),U),1,15),X,"VERIFIED BY")
+43 SET X=$$SETFLD^VALM1($$DAT1^IBOUTL($PIECE(IBCDFND1,"^",3)),X,"VERIFIED ON")
+44 SET X=$$SETFLD^VALM1($$YN($PIECE(IBCPOLD,"^",6)),X,"PRECERT")
+45 SET X=$$SETFLD^VALM1($$YN($PIECE(IBCPOLD,"^",5)),X,"UR")
+46 ;S X=$$SETFLD^VALM1($$YN($P(IBCDFND,"^",20)),X,"COB") ;/vd-IB*2*659 - Replaced this line with the line below.
+47 SET X=$$SETFLD^VALM1($$COB($PIECE(IBCDFND,"^",20)),X,"COB")
+48 KILL IBHOLD,IBGRP
+49 DO SET(X)
+50 QUIT
End DoDot:1
+51 ;
+52 IF '$DATA(^TMP("IBNSM",$JOB))
Begin DoDot:1
+53 SET VALMCNT=2
SET IBCNT=2
SET ^TMP("IBNSM",$JOB,1,0)=" "
+54 SET ^TMP("IBNSM",$JOB,2,0)=" No Insurance Policies on file for this patient."
+55 IF $GET(IBNCPIVD)
SET ^TMP("IBNSM",$JOB,2,0)=" No Active Rx Policies found as of Effective Date "_$$FMTE^XLFDT(IBNCPIVD,"2Z")_"."
+56 QUIT
End DoDot:1
+57 ;
+58 SET X=$GET(^IBA(354,DFN,60))
IF X
Begin DoDot:1
+59 SET IBCNT=IBCNT+1
+60 SET ^TMP("IBNSM",$JOB,IBCNT,0)=" Verification of No Coverage "_$$FMTE^XLFDT(X)
+61 QUIT
End DoDot:1
+62 ;
+63 ; IB*713/CKB - adding Date of Death message
+64 SET IBDOD=$$GET1^DIQ(2,DFN_",",.351,"I")
IF IBDOD
Begin DoDot:1
+65 SET IBCNT=IBCNT+1
+66 SET ^TMP("IBNSM",$JOB,IBCNT,0)=" Date of Death: "_$$FMTE^XLFDT(IBDOD\1,"5Z")
End DoDot:1
+67 ;
BLDQ ;
+1 QUIT
+2 ;
SET(X) ; -- set arrays
+1 SET VALMCNT=VALMCNT+1
SET ^TMP("IBNSM",$JOB,VALMCNT,0)=X
+2 SET ^TMP("IBNSM",$JOB,"IDX",VALMCNT,IBCNT)=""
+3 SET ^TMP("IBNSMDX",$JOB,IBCNT)=VALMCNT_"^"_IBFILE_"^"_DFN_"^"_K_"^"_IBCDFND
+4 QUIT
+5 ;
HDR ; -- screen header for initial screen
+1 DO PID^VADPT
+2 ; -- AWC/ ib*2.0*528 add the patient dob to display screen
+3 SET VALMHDR(1)="Insurance Management for Patient: "_$EXTRACT($PIECE($GET(^DPT(DFN,0)),"^"),1,20)_" "_$EXTRACT($GET(^(0)),1)_VA("BID")_" "_$$FMTE^XLFDT($PIECE($GET(^DPT(DFN,0)),"^",3),5)
+4 SET VALMHDR(2)=" "
+5 IF +$$BUFFER^IBCNBU1(DFN)
SET VALMHDR(2)="*** Patient has Insurance Buffer Records"
+6 QUIT
+7 ;
FNL ; -- exit and clean up
+1 KILL ^TMP("IBNSM",$JOB),^TMP("IBNSMDX",$JOB)
+2 KILL IBFASTXT
+3 DO CLEAN^VALM10
+4 QUIT
+5 ;
YN(X,Y) ; -- convert 1 or 0 to yes/no/unknown
+1 QUIT $SELECT($GET(X)="":$SELECT($GET(Y):"",1:"UNK"),X=0:"NO",X=1:"YES",1:"")
+2 ;
+3 ;/vd-IB*2*659 - Created the new module below to convert COB to appropriate display.
COB(X) ; -- convert COB value to "UNK", "P", "S" or "T"
+1 QUIT $SELECT(+X:$EXTRACT("PST",+X),1:"UNK")
+2 ;
CP ; -- change patient
+1 NEW VALMQUIT
+2 DO FULL^VALM1
+3 SET IBDFN=DFN
DO PAT
+4 IF $DATA(VALMQUIT)
SET DFN=IBDFN
+5 DO HDR
DO BLD
+6 ;IB*763/CKB - reset VALMBG to prevent broken breadcrumbs
+7 SET VALMBCK="R"
SET VALMBG=1
CPQ KILL IBDFN
+1 QUIT
+2 ;
PCI SET VALMBCK="R"
QUIT
+1 ;
FASTEXIT ;just sets a flag signaling system should be exited
+1 SET VALMBCK="Q"
+2 DO FULL^VALM1
+3 KILL DIR
SET DIR(0)="Y"
SET DIR("A")="Exit option entirely"
SET DIR("B")="NO"
DO ^DIR
+4 IF $DATA(DIRUT)!(Y)
SET IBFASTXT=1
+5 KILL DIR
+6 QUIT
