- 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 Feb 18, 2025@23:43:48 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