IBCNESI1 ;ALB/TAZ - MEDICARE POTENTIAL COB Patient Selection ;15 Jan 13
;;2.0;INTEGRATED BILLING;**497**;21-MAR-94;Build 120
;;Per VHA Directive 2004-038, this routine should not be modified.
;
Q ;Only enter at labels.
;
LIST ; Entry Point from IBCNESI
; IBSDT - Start Date
; IBEDT - End Date
; IBSORT - Sort Direction
; IBREP - Report or Screen
; IBCOMP -
; 1 = include completed entries only
; 2 = include completed entries only with comments
; 3 = exclude completed entries
; 4 = exclude completed entries with comments
;
N IBDT,IBDT1,IBPYR,IBMPYR,IBDFN,IBRIEN,IBRVIEN,IBEIEN,IBDATA,IENS,IBSEQ,IBCIEN,IBEIDCD,IBRVST,IBELIG,IBNOCMT,IBCNT
K ^TMP($J,"IBCNESI1"),^TMP($J,"IBCNESI2"),^TMP("IBCNESI1",$J),^UTILITY("VADM",$J)
S IBPYR=$P($G(^IBE(350.9,1,51)),U,25) ; get Medicare payer ien from IB site parameters
S IBDT=IBSDT-.1,IBCNT=0
D BLDTMP
I IBREP="R" D EN^IBCNERPI
Q
;
BLDTMP ; construct the temporary global array according to filter and sort criteria selected by user
F S IBDT=$O(^IBCN(365,"AD",IBDT)) Q:'IBDT!(IBDT>(IBEDT+1)) D
. S IBDFN=0
. F S IBDFN=$O(^IBCN(365,"AD",IBDT,IBPYR,IBDFN)) Q:'IBDFN D
.. S IBRIEN=0
.. F S IBRIEN=$O(^IBCN(365,"AD",IBDT,IBPYR,IBDFN,IBRIEN)) Q:'IBRIEN D
... ; Transmission Status must be "Response Received"
... I $$GET1^DIQ(365,IBRIEN_",",.06,"I")'=$O(^IBE(365.14,"B","Response Received","")) Q
... ; Get Response Review Status and check if there are comments. Include/exclude entries according to the report type.
... S IBRVIEN=$O(^IBCN(365.2,"B",IBRIEN,"")),IBRVST=+$$GET1^DIQ(365.2,IBRVIEN_",",.02,"I")
... S IBNOCMT=IBCOMP#2 ; 1 - don't print comments, 0 - print comments
... I "^1^2^"[(U_IBCOMP_U),IBRVST'=2 Q ; type = 1 or 2, status is not "review complete"
... I "^3^4^"[(U_IBCOMP_U),IBRVST=2 Q ; type = 3 or 4, status is "review complete"
... ; Get eligibility Data and set up COB nodes
... S IBDT1=(IBDT\1)*IBSORT
... S IBEIEN=0
... F S IBEIEN=$O(^IBCN(365,IBRIEN,2,IBEIEN)) Q:'IBEIEN D
.... ;Get Eligibility Code. We want R codes only.
.... S IENS=IBEIEN_","_IBRIEN_","
.... S IBELIG=$$GET1^DIQ(365.02,IENS,.02) I IBELIG'="R" Q
.... S IBEIDCD=$$GET1^DIQ(365.02,IENS,3.01) ;I ",PR,PRP,SEP,TTP,"'[(","_IBEIDCD_",") Q
.... S IBDATA=$$GET1^DIQ(365.02,IENS,3.03),^TMP($J,"IBCNESI1",IBDT1,IBDFN,IBRIEN,"INS",IBEIEN,"NAME")=IBDATA
.... S ^TMP($J,"IBCNESI1",IBDT1,IBDFN,IBRIEN,"INS",IBEIEN,"ENT ID CD")=$S(",PRP,SEP,TTP,"[(","_IBEIDCD_","):IBEIDCD,1:"")
.... S ^TMP($J,"IBCNESI1",IBDT1,IBDFN,IBRIEN,"INS",IBEIEN,"EMFLAG")=$$MATCH(IBDFN,IBDATA)
.... S IBDATA=$$GET1^DIQ(365.02,IENS,3.04) I IBDATA'="" S ^TMP($J,"IBCNESI1",IBDT1,IBDFN,IBRIEN,"INS",IBEIEN,"ID")=IBDATA
.... S IBDATA=$$GET1^DIQ(365.02,IENS,3.05,"I") I IBDATA'="" S ^TMP($J,"IBCNESI1",IBDT1,IBDFN,IBRIEN,"INS",IBEIEN,"ID QUAL")=$P(^IBE(365.023,IBDATA,0),U,2)
.... S IBDATA=$$GET1^DIQ(365.02,IENS,4.01) I IBDATA'="" S ^TMP($J,"IBCNESI1",IBDT1,IBDFN,IBRIEN,"INS",IBEIEN,"ADDRESS 1")=IBDATA
.... S IBDATA=$$GET1^DIQ(365.02,IENS,4.02) I IBDATA'="" S ^TMP($J,"IBCNESI1",IBDT1,IBDFN,IBRIEN,"INS",IBEIEN,"ADDRESS 2")=IBDATA
.... S IBDATA=$$GET1^DIQ(365.02,IENS,4.03) I IBDATA'="" S ^TMP($J,"IBCNESI1",IBDT1,IBDFN,IBRIEN,"INS",IBEIEN,"CITY")=IBDATA
.... S IBDATA=$$GET1^DIQ(365.02,IENS,4.04,"I") I IBDATA'="" S ^TMP($J,"IBCNESI1",IBDT1,IBDFN,IBRIEN,"INS",IBEIEN,"STATE")=$$GET1^DIQ(5,IBDATA_",",1)
.... S IBDATA=$$GET1^DIQ(365.02,IENS,4.05) I IBDATA'="" S ^TMP($J,"IBCNESI1",IBDT1,IBDFN,IBRIEN,"INS",IBEIEN,"ZIP")=IBDATA
.... S IBCIEN=0
.... ; display Contact Information
.... F S IBCIEN=$O(^IBCN(365,IBRIEN,2,IBEIEN,6,IBCIEN)) Q:'IBCIEN D
..... S IENS=IBCIEN_","_IBEIEN_","_IBRIEN_","
..... S IBDATA=$$GET1^DIQ(365.26,IENS,.04) I ",UR,TE,"'[(","_IBDATA_",") Q ;Phone and Web only
..... S IBSEQ=$$GET1^DIQ(365.26,IENS,.01)
..... S ^TMP($J,"IBCNESI1",IBDT1,IBDFN,IBRIEN,"INS",IBEIEN,IBDATA,IBSEQ)=$$GET1^DIQ(365.26,IENS,1)
... ;If COB data found set up Patient Info
... I $D(^TMP($J,"IBCNESI1",IBDT1,IBDFN,IBRIEN)) D
.... N VAHOW,DFN,VADM
.... S VAHOW=2,DFN=IBDFN D DEM^VADPT
.... S ^TMP($J,"IBCNESI1",IBDT1,IBDFN,IBRIEN,"PATIENT NAME")=$P($G(^UTILITY("VADM",$J,1)),U)
.... S ^TMP($J,"IBCNESI1",IBDT1,IBDFN,IBRIEN,"DOB")=$P($G(^UTILITY("VADM",$J,3)),U)
.... S ^TMP($J,"IBCNESI1",IBDT1,IBDFN,IBRIEN,"SSN")=$E($P($G(^UTILITY("VADM",$J,2)),U),6,10)
.... S ^TMP($J,"IBCNESI1",IBDT1,IBDFN,IBRIEN,"REV IEN")=+$G(IBRVIEN)
....;KML need to have capability of accessing the REV STATUS subscript when REVIEW STATUS is updated by user
.... S ^TMP($J,"IBCNESI1",IBDT1,IBDFN,IBRIEN,"REV STATUS")=+$G(IBRVST)_U_IBDT1_U_IBDFN
.... S ^TMP($J,"IBCNESI1",IBDT1,IBDFN,IBRIEN,"NO CMNT")=+$G(IBNOCMT)
.... K ^UTILITY("VADM",$J)
.... S IBCNT=IBCNT+1 I '$D(ZTQUEUED),'(IBCNT#15) W ". "
... M ^TMP($J,"IBCNESI2",IBRIEN)=^TMP($J,"IBCNESI1",IBDT1,IBDFN,IBRIEN)
I IBREP="S" D EN^VALM("IBCNE MEDICARE COB LIST")
Q
;
MATCH(IBDFN,INSCONM) ;Match Insurance Companies with Insurance Type subfile.
N EXPDT,MATCH,NAME,IENS,IBITYP
S MATCH=0
S IBITYP=0
F S IBITYP=$O(^DPT(IBDFN,.312,IBITYP)) Q:'IBITYP D I MATCH Q
. S IENS=IBITYP_","_IBDFN_","
. S EXPDT=$$GET1^DIQ(2.312,IENS,.03) I EXPDT&(DT>(EXPDT-1)) Q ;Only allow current Insurance Type entries
. S NAME=$$GET1^DIQ(2.312,IENS,.01)
. I NAME=$E(INSCONM,1,30) S MATCH=1 ;Names must be an exact match
MATCHQ ;
Q $S(MATCH:"*",1:"")
;
HDR ; -- header code
S VALMHDR(1)=""
S VALMHDR(2)="Sorted in "_$S((IBSORT<0):"Reverse ",1:"")_"Chronological Order."
S VALM("TITLE")="Medicare Potential COB List",VALMSG="*Exact Match"
Q
;
INIT ; -- init variables and list array
D BLDSCRN
Q
;
HELP ; -- help code
D FULL^VALM1
S VALMBCK="R"
W @IOF
W !,"Status of entries displayed:"
W !," Y - Entry has been reviewed but is not yet complete"
W !," N - Entry has not been reviewed"
W !
W !,"* Denotes that the Insurance Company in the Response Record"
W !," matches an Insurance Company in the Insurance Type "
W !," sub-file of the Patient File."
D PAUSE^VALM1
Q
;
EXIT ; -- exit code
K ^TMP($J,"IBCNESI1"),^TMP($J,"IBCNESI2"),^TMP("IBCNESI1",$J),^UTILITY("VADM",$J)
Q
;
EXPND ; -- expand code
N DA,DD,DIC,DIK,DLAYGO,X,Y,IBDA,IBIEN
D SEL(.IBDA,1) S:$O(IBDA(0)) IBRIEN=+IBDA($O(IBDA(0))) I '$G(IBRIEN) G EXPNDQ
D EN^IBCNESI2(IBRIEN)
EXPNDQ ;
D BLDSCRN
S VALMBCK="R"
Q
;
BLDSCRN ;build screen of worklist entries
N IBLN,IBRVSTAT,LINEVAR,DISPDATE
K @VALMAR
S IBDT="",(IBLN,VALMCNT)=0
F S IBDT=$O(^TMP($J,"IBCNESI1",IBDT)) Q:'IBDT D
. S DISPDATE=1
. S IBDFN=""
. F S IBDFN=$O(^TMP($J,"IBCNESI1",IBDT,IBDFN)) Q:'IBDFN D
.. S IBRIEN=""
.. F S IBRIEN=$O(^TMP($J,"IBCNESI1",IBDT,IBDFN,IBRIEN)) Q:'IBRIEN D
... S IBRVSTAT=$P($G(^TMP($J,"IBCNESI1",IBDT,IBDFN,IBRIEN,"REV STATUS")),U)
... I IBRVSTAT=2 Q ;Do not include completes on the screen
... ;Only display the date if there are incomplete entries on that date.
... I DISPDATE S LINEVAR="",LINEVAR=$$SETSTR^VALM1($$FMTE^XLFDT((IBDT*IBSORT),"2Z"),LINEVAR,3,11) D SET(LINEVAR,IBLN+1) S DISPDATE=0
... S LINEVAR="",IBLN=IBLN+1
... S LINEVAR=$$SETFLD^VALM1($J(IBLN,3),LINEVAR,"COUNTER")
... S LINEVAR=$$SETFLD^VALM1($J(" ",7)_$G(^TMP($J,"IBCNESI2",IBRIEN,"PATIENT NAME")),LINEVAR,"PATIENT")
... S LINEVAR=$$SETFLD^VALM1($G(^TMP($J,"IBCNESI2",IBRIEN,"SSN")),LINEVAR,"SSN")
... S LINEVAR=$$SETFLD^VALM1($$FMTE^XLFDT($G(^TMP($J,"IBCNESI2",IBRIEN,"DOB")),"2Z"),LINEVAR,"DOB")
... S LINEVAR=$$SETFLD^VALM1($J($S(IBRVSTAT:"Y",1:"N"),2),LINEVAR,"STATUS")
... ; Get 1st Insurance Co
... S IBEIEN=0
... S IBEIEN=$O(^TMP($J,"IBCNESI1",IBDT,IBDFN,IBRIEN,"INS",IBEIEN))
... S LINEVAR=$$SETFLD^VALM1($G(^TMP($J,"IBCNESI2",IBRIEN,"INS",IBEIEN,"EMFLAG")),LINEVAR,"EMFLAG")
... S IBDATA=$E($G(^TMP($J,"IBCNESI2",IBRIEN,"INS",IBEIEN,"NAME")),1,31)
... I ^TMP($J,"IBCNESI2",IBRIEN,"INS",IBEIEN,"ENT ID CD")]"" S IBDATA=IBDATA_" ("_$E(^TMP($J,"IBCNESI2",IBRIEN,"INS",IBEIEN,"ENT ID CD"),1)_")"
... S LINEVAR=$$SETFLD^VALM1(IBDATA,LINEVAR,"INSCO")
... D SET(LINEVAR,IBLN,IBRIEN)
... F S IBEIEN=$O(^TMP($J,"IBCNESI2",IBRIEN,"INS",IBEIEN)) Q:'IBEIEN D
.... S LINEVAR=""
.... S LINEVAR=$$SETFLD^VALM1($G(^TMP($J,"IBCNESI2",IBRIEN,"INS",IBEIEN,"EMFLAG")),LINEVAR,"EMFLAG")
.... S IBDATA=$E($G(^TMP($J,"IBCNESI2",IBRIEN,"INS",IBEIEN,"NAME")),1,31)
.... I ^TMP($J,"IBCNESI2",IBRIEN,"INS",IBEIEN,"ENT ID CD")]"" S IBDATA=IBDATA_" ("_$E(^TMP($J,"IBCNESI2",IBRIEN,"INS",IBEIEN,"ENT ID CD"),1)_")"
.... S LINEVAR=$$SETFLD^VALM1(IBDATA,LINEVAR,"INSCO")
.... D SET(LINEVAR,IBLN,IBRIEN)
I VALMCNT=0 D SET("",IBLN+1),SET("* * * No Worklist Entries to Display * * *",IBLN+1),SET("Review Status is 'Complete' for all entries within given Date Range",IBLN+1)
Q
;
SET(X,CNT,IBIEN) ;set up list manager screen array
S VALMCNT=VALMCNT+1
S @VALMAR@(VALMCNT,0)=X
S @VALMAR@("IDX",VALMCNT,CNT)=""
I $G(IBIEN),$G(@VALMAR@(CNT))="" S @VALMAR@(CNT)=VALMCNT_U_IBIEN
Q
;
SEL(IBDA,ONE) ; Select entry(s) from list
; IBDA = array returned if selections made
; IBDA(n)=ien of entry selected (file 365)
; ONE = if set to 1, only one selection can be made at a time
N VALMY,VALMBG,VALMLST
I $D(@VALMAR) D
. S VALMBG=$O(@VALMAR@("IDX","")),VALMLST=$O(@VALMAR@("IDX",""),-1)
. K IBDA
. D FULL^VALM1
. ;D EN^VALM2("",$S('$G(ONE):"",1:"S")) ; WCJ
. D EN^VALM2($G(XQORNOD(0)),$S('$G(ONE):"",1:"S")) ;WCJ
. S IBDA=0 F S IBDA=$O(VALMY(IBDA)) Q:'IBDA S IBDA(IBDA)=$P($G(@VALMAR@(+IBDA)),U,2,6)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCNESI1 9590 printed Sep 23, 2025@19:51:41 Page 2
IBCNESI1 ;ALB/TAZ - MEDICARE POTENTIAL COB Patient Selection ;15 Jan 13
+1 ;;2.0;INTEGRATED BILLING;**497**;21-MAR-94;Build 120
+2 ;;Per VHA Directive 2004-038, this routine should not be modified.
+3 ;
+4 ;Only enter at labels.
QUIT
+5 ;
LIST ; Entry Point from IBCNESI
+1 ; IBSDT - Start Date
+2 ; IBEDT - End Date
+3 ; IBSORT - Sort Direction
+4 ; IBREP - Report or Screen
+5 ; IBCOMP -
+6 ; 1 = include completed entries only
+7 ; 2 = include completed entries only with comments
+8 ; 3 = exclude completed entries
+9 ; 4 = exclude completed entries with comments
+10 ;
+11 NEW IBDT,IBDT1,IBPYR,IBMPYR,IBDFN,IBRIEN,IBRVIEN,IBEIEN,IBDATA,IENS,IBSEQ,IBCIEN,IBEIDCD,IBRVST,IBELIG,IBNOCMT,IBCNT
+12 KILL ^TMP($JOB,"IBCNESI1"),^TMP($JOB,"IBCNESI2"),^TMP("IBCNESI1",$JOB),^UTILITY("VADM",$JOB)
+13 ; get Medicare payer ien from IB site parameters
SET IBPYR=$PIECE($GET(^IBE(350.9,1,51)),U,25)
+14 SET IBDT=IBSDT-.1
SET IBCNT=0
+15 DO BLDTMP
+16 IF IBREP="R"
DO EN^IBCNERPI
+17 QUIT
+18 ;
BLDTMP ; construct the temporary global array according to filter and sort criteria selected by user
+1 FOR
SET IBDT=$ORDER(^IBCN(365,"AD",IBDT))
if 'IBDT!(IBDT>(IBEDT+1))
QUIT
Begin DoDot:1
+2 SET IBDFN=0
+3 FOR
SET IBDFN=$ORDER(^IBCN(365,"AD",IBDT,IBPYR,IBDFN))
if 'IBDFN
QUIT
Begin DoDot:2
+4 SET IBRIEN=0
+5 FOR
SET IBRIEN=$ORDER(^IBCN(365,"AD",IBDT,IBPYR,IBDFN,IBRIEN))
if 'IBRIEN
QUIT
Begin DoDot:3
+6 ; Transmission Status must be "Response Received"
+7 IF $$GET1^DIQ(365,IBRIEN_",",.06,"I")'=$ORDER(^IBE(365.14,"B","Response Received",""))
QUIT
+8 ; Get Response Review Status and check if there are comments. Include/exclude entries according to the report type.
+9 SET IBRVIEN=$ORDER(^IBCN(365.2,"B",IBRIEN,""))
SET IBRVST=+$$GET1^DIQ(365.2,IBRVIEN_",",.02,"I")
+10 ; 1 - don't print comments, 0 - print comments
SET IBNOCMT=IBCOMP#2
+11 ; type = 1 or 2, status is not "review complete"
IF "^1^2^"[(U_IBCOMP_U)
IF IBRVST'=2
QUIT
+12 ; type = 3 or 4, status is "review complete"
IF "^3^4^"[(U_IBCOMP_U)
IF IBRVST=2
QUIT
+13 ; Get eligibility Data and set up COB nodes
+14 SET IBDT1=(IBDT\1)*IBSORT
+15 SET IBEIEN=0
+16 FOR
SET IBEIEN=$ORDER(^IBCN(365,IBRIEN,2,IBEIEN))
if 'IBEIEN
QUIT
Begin DoDot:4
+17 ;Get Eligibility Code. We want R codes only.
+18 SET IENS=IBEIEN_","_IBRIEN_","
+19 SET IBELIG=$$GET1^DIQ(365.02,IENS,.02)
IF IBELIG'="R"
QUIT
+20 ;I ",PR,PRP,SEP,TTP,"'[(","_IBEIDCD_",") Q
SET IBEIDCD=$$GET1^DIQ(365.02,IENS,3.01)
+21 SET IBDATA=$$GET1^DIQ(365.02,IENS,3.03)
SET ^TMP($JOB,"IBCNESI1",IBDT1,IBDFN,IBRIEN,"INS",IBEIEN,"NAME")=IBDATA
+22 SET ^TMP($JOB,"IBCNESI1",IBDT1,IBDFN,IBRIEN,"INS",IBEIEN,"ENT ID CD")=$SELECT(",PRP,SEP,TTP,"[(","_IBEIDCD_","):IBEIDCD,1:"")
+23 SET ^TMP($JOB,"IBCNESI1",IBDT1,IBDFN,IBRIEN,"INS",IBEIEN,"EMFLAG")=$$MATCH(IBDFN,IBDATA)
+24 SET IBDATA=$$GET1^DIQ(365.02,IENS,3.04)
IF IBDATA'=""
SET ^TMP($JOB,"IBCNESI1",IBDT1,IBDFN,IBRIEN,"INS",IBEIEN,"ID")=IBDATA
+25 SET IBDATA=$$GET1^DIQ(365.02,IENS,3.05,"I")
IF IBDATA'=""
SET ^TMP($JOB,"IBCNESI1",IBDT1,IBDFN,IBRIEN,"INS",IBEIEN,"ID QUAL")=$PIECE(^IBE(365.023,IBDATA,0),U,2)
+26 SET IBDATA=$$GET1^DIQ(365.02,IENS,4.01)
IF IBDATA'=""
SET ^TMP($JOB,"IBCNESI1",IBDT1,IBDFN,IBRIEN,"INS",IBEIEN,"ADDRESS 1")=IBDATA
+27 SET IBDATA=$$GET1^DIQ(365.02,IENS,4.02)
IF IBDATA'=""
SET ^TMP($JOB,"IBCNESI1",IBDT1,IBDFN,IBRIEN,"INS",IBEIEN,"ADDRESS 2")=IBDATA
+28 SET IBDATA=$$GET1^DIQ(365.02,IENS,4.03)
IF IBDATA'=""
SET ^TMP($JOB,"IBCNESI1",IBDT1,IBDFN,IBRIEN,"INS",IBEIEN,"CITY")=IBDATA
+29 SET IBDATA=$$GET1^DIQ(365.02,IENS,4.04,"I")
IF IBDATA'=""
SET ^TMP($JOB,"IBCNESI1",IBDT1,IBDFN,IBRIEN,"INS",IBEIEN,"STATE")=$$GET1^DIQ(5,IBDATA_",",1)
+30 SET IBDATA=$$GET1^DIQ(365.02,IENS,4.05)
IF IBDATA'=""
SET ^TMP($JOB,"IBCNESI1",IBDT1,IBDFN,IBRIEN,"INS",IBEIEN,"ZIP")=IBDATA
+31 SET IBCIEN=0
+32 ; display Contact Information
+33 FOR
SET IBCIEN=$ORDER(^IBCN(365,IBRIEN,2,IBEIEN,6,IBCIEN))
if 'IBCIEN
QUIT
Begin DoDot:5
+34 SET IENS=IBCIEN_","_IBEIEN_","_IBRIEN_","
+35 ;Phone and Web only
SET IBDATA=$$GET1^DIQ(365.26,IENS,.04)
IF ",UR,TE,"'[(","_IBDATA_",")
QUIT
+36 SET IBSEQ=$$GET1^DIQ(365.26,IENS,.01)
+37 SET ^TMP($JOB,"IBCNESI1",IBDT1,IBDFN,IBRIEN,"INS",IBEIEN,IBDATA,IBSEQ)=$$GET1^DIQ(365.26,IENS,1)
End DoDot:5
End DoDot:4
+38 ;If COB data found set up Patient Info
+39 IF $DATA(^TMP($JOB,"IBCNESI1",IBDT1,IBDFN,IBRIEN))
Begin DoDot:4
+40 NEW VAHOW,DFN,VADM
+41 SET VAHOW=2
SET DFN=IBDFN
DO DEM^VADPT
+42 SET ^TMP($JOB,"IBCNESI1",IBDT1,IBDFN,IBRIEN,"PATIENT NAME")=$PIECE($GET(^UTILITY("VADM",$JOB,1)),U)
+43 SET ^TMP($JOB,"IBCNESI1",IBDT1,IBDFN,IBRIEN,"DOB")=$PIECE($GET(^UTILITY("VADM",$JOB,3)),U)
+44 SET ^TMP($JOB,"IBCNESI1",IBDT1,IBDFN,IBRIEN,"SSN")=$EXTRACT($PIECE($GET(^UTILITY("VADM",$JOB,2)),U),6,10)
+45 SET ^TMP($JOB,"IBCNESI1",IBDT1,IBDFN,IBRIEN,"REV IEN")=+$GET(IBRVIEN)
+46 ;KML need to have capability of accessing the REV STATUS subscript when REVIEW STATUS is updated by user
+47 SET ^TMP($JOB,"IBCNESI1",IBDT1,IBDFN,IBRIEN,"REV STATUS")=+$GET(IBRVST)_U_IBDT1_U_IBDFN
+48 SET ^TMP($JOB,"IBCNESI1",IBDT1,IBDFN,IBRIEN,"NO CMNT")=+$GET(IBNOCMT)
+49 KILL ^UTILITY("VADM",$JOB)
+50 SET IBCNT=IBCNT+1
IF '$DATA(ZTQUEUED)
IF '(IBCNT#15)
WRITE ". "
End DoDot:4
+51 MERGE ^TMP($JOB,"IBCNESI2",IBRIEN)=^TMP($JOB,"IBCNESI1",IBDT1,IBDFN,IBRIEN)
End DoDot:3
End DoDot:2
End DoDot:1
+52 IF IBREP="S"
DO EN^VALM("IBCNE MEDICARE COB LIST")
+53 QUIT
+54 ;
MATCH(IBDFN,INSCONM) ;Match Insurance Companies with Insurance Type subfile.
+1 NEW EXPDT,MATCH,NAME,IENS,IBITYP
+2 SET MATCH=0
+3 SET IBITYP=0
+4 FOR
SET IBITYP=$ORDER(^DPT(IBDFN,.312,IBITYP))
if 'IBITYP
QUIT
Begin DoDot:1
+5 SET IENS=IBITYP_","_IBDFN_","
+6 ;Only allow current Insurance Type entries
SET EXPDT=$$GET1^DIQ(2.312,IENS,.03)
IF EXPDT&(DT>(EXPDT-1))
QUIT
+7 SET NAME=$$GET1^DIQ(2.312,IENS,.01)
+8 ;Names must be an exact match
IF NAME=$EXTRACT(INSCONM,1,30)
SET MATCH=1
End DoDot:1
IF MATCH
QUIT
MATCHQ ;
+1 QUIT $SELECT(MATCH:"*",1:"")
+2 ;
HDR ; -- header code
+1 SET VALMHDR(1)=""
+2 SET VALMHDR(2)="Sorted in "_$SELECT((IBSORT<0):"Reverse ",1:"")_"Chronological Order."
+3 SET VALM("TITLE")="Medicare Potential COB List"
SET VALMSG="*Exact Match"
+4 QUIT
+5 ;
INIT ; -- init variables and list array
+1 DO BLDSCRN
+2 QUIT
+3 ;
HELP ; -- help code
+1 DO FULL^VALM1
+2 SET VALMBCK="R"
+3 WRITE @IOF
+4 WRITE !,"Status of entries displayed:"
+5 WRITE !," Y - Entry has been reviewed but is not yet complete"
+6 WRITE !," N - Entry has not been reviewed"
+7 WRITE !
+8 WRITE !,"* Denotes that the Insurance Company in the Response Record"
+9 WRITE !," matches an Insurance Company in the Insurance Type "
+10 WRITE !," sub-file of the Patient File."
+11 DO PAUSE^VALM1
+12 QUIT
+13 ;
EXIT ; -- exit code
+1 KILL ^TMP($JOB,"IBCNESI1"),^TMP($JOB,"IBCNESI2"),^TMP("IBCNESI1",$JOB),^UTILITY("VADM",$JOB)
+2 QUIT
+3 ;
EXPND ; -- expand code
+1 NEW DA,DD,DIC,DIK,DLAYGO,X,Y,IBDA,IBIEN
+2 DO SEL(.IBDA,1)
if $ORDER(IBDA(0))
SET IBRIEN=+IBDA($ORDER(IBDA(0)))
IF '$GET(IBRIEN)
GOTO EXPNDQ
+3 DO EN^IBCNESI2(IBRIEN)
EXPNDQ ;
+1 DO BLDSCRN
+2 SET VALMBCK="R"
+3 QUIT
+4 ;
BLDSCRN ;build screen of worklist entries
+1 NEW IBLN,IBRVSTAT,LINEVAR,DISPDATE
+2 KILL @VALMAR
+3 SET IBDT=""
SET (IBLN,VALMCNT)=0
+4 FOR
SET IBDT=$ORDER(^TMP($JOB,"IBCNESI1",IBDT))
if 'IBDT
QUIT
Begin DoDot:1
+5 SET DISPDATE=1
+6 SET IBDFN=""
+7 FOR
SET IBDFN=$ORDER(^TMP($JOB,"IBCNESI1",IBDT,IBDFN))
if 'IBDFN
QUIT
Begin DoDot:2
+8 SET IBRIEN=""
+9 FOR
SET IBRIEN=$ORDER(^TMP($JOB,"IBCNESI1",IBDT,IBDFN,IBRIEN))
if 'IBRIEN
QUIT
Begin DoDot:3
+10 SET IBRVSTAT=$PIECE($GET(^TMP($JOB,"IBCNESI1",IBDT,IBDFN,IBRIEN,"REV STATUS")),U)
+11 ;Do not include completes on the screen
IF IBRVSTAT=2
QUIT
+12 ;Only display the date if there are incomplete entries on that date.
+13 IF DISPDATE
SET LINEVAR=""
SET LINEVAR=$$SETSTR^VALM1($$FMTE^XLFDT((IBDT*IBSORT),"2Z"),LINEVAR,3,11)
DO SET(LINEVAR,IBLN+1)
SET DISPDATE=0
+14 SET LINEVAR=""
SET IBLN=IBLN+1
+15 SET LINEVAR=$$SETFLD^VALM1($JUSTIFY(IBLN,3),LINEVAR,"COUNTER")
+16 SET LINEVAR=$$SETFLD^VALM1($JUSTIFY(" ",7)_$GET(^TMP($JOB,"IBCNESI2",IBRIEN,"PATIENT NAME")),LINEVAR,"PATIENT")
+17 SET LINEVAR=$$SETFLD^VALM1($GET(^TMP($JOB,"IBCNESI2",IBRIEN,"SSN")),LINEVAR,"SSN")
+18 SET LINEVAR=$$SETFLD^VALM1($$FMTE^XLFDT($GET(^TMP($JOB,"IBCNESI2",IBRIEN,"DOB")),"2Z"),LINEVAR,"DOB")
+19 SET LINEVAR=$$SETFLD^VALM1($JUSTIFY($SELECT(IBRVSTAT:"Y",1:"N"),2),LINEVAR,"STATUS")
+20 ; Get 1st Insurance Co
+21 SET IBEIEN=0
+22 SET IBEIEN=$ORDER(^TMP($JOB,"IBCNESI1",IBDT,IBDFN,IBRIEN,"INS",IBEIEN))
+23 SET LINEVAR=$$SETFLD^VALM1($GET(^TMP($JOB,"IBCNESI2",IBRIEN,"INS",IBEIEN,"EMFLAG")),LINEVAR,"EMFLAG")
+24 SET IBDATA=$EXTRACT($GET(^TMP($JOB,"IBCNESI2",IBRIEN,"INS",IBEIEN,"NAME")),1,31)
+25 IF ^TMP($JOB,"IBCNESI2",IBRIEN,"INS",IBEIEN,"ENT ID CD")]""
SET IBDATA=IBDATA_" ("_$EXTRACT(^TMP($JOB,"IBCNESI2",IBRIEN,"INS",IBEIEN,"ENT ID CD"),1)_")"
+26 SET LINEVAR=$$SETFLD^VALM1(IBDATA,LINEVAR,"INSCO")
+27 DO SET(LINEVAR,IBLN,IBRIEN)
+28 FOR
SET IBEIEN=$ORDER(^TMP($JOB,"IBCNESI2",IBRIEN,"INS",IBEIEN))
if 'IBEIEN
QUIT
Begin DoDot:4
+29 SET LINEVAR=""
+30 SET LINEVAR=$$SETFLD^VALM1($GET(^TMP($JOB,"IBCNESI2",IBRIEN,"INS",IBEIEN,"EMFLAG")),LINEVAR,"EMFLAG")
+31 SET IBDATA=$EXTRACT($GET(^TMP($JOB,"IBCNESI2",IBRIEN,"INS",IBEIEN,"NAME")),1,31)
+32 IF ^TMP($JOB,"IBCNESI2",IBRIEN,"INS",IBEIEN,"ENT ID CD")]""
SET IBDATA=IBDATA_" ("_$EXTRACT(^TMP($JOB,"IBCNESI2",IBRIEN,"INS",IBEIEN,"ENT ID CD"),1)_")"
+33 SET LINEVAR=$$SETFLD^VALM1(IBDATA,LINEVAR,"INSCO")
+34 DO SET(LINEVAR,IBLN,IBRIEN)
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+35 IF VALMCNT=0
DO SET("",IBLN+1)
DO SET("* * * No Worklist Entries to Display * * *",IBLN+1)
DO SET("Review Status is 'Complete' for all entries within given Date Range",IBLN+1)
+36 QUIT
+37 ;
SET(X,CNT,IBIEN) ;set up list manager screen array
+1 SET VALMCNT=VALMCNT+1
+2 SET @VALMAR@(VALMCNT,0)=X
+3 SET @VALMAR@("IDX",VALMCNT,CNT)=""
+4 IF $GET(IBIEN)
IF $GET(@VALMAR@(CNT))=""
SET @VALMAR@(CNT)=VALMCNT_U_IBIEN
+5 QUIT
+6 ;
SEL(IBDA,ONE) ; Select entry(s) from list
+1 ; IBDA = array returned if selections made
+2 ; IBDA(n)=ien of entry selected (file 365)
+3 ; ONE = if set to 1, only one selection can be made at a time
+4 NEW VALMY,VALMBG,VALMLST
+5 IF $DATA(@VALMAR)
Begin DoDot:1
+6 SET VALMBG=$ORDER(@VALMAR@("IDX",""))
SET VALMLST=$ORDER(@VALMAR@("IDX",""),-1)
+7 KILL IBDA
+8 DO FULL^VALM1
+9 ;D EN^VALM2("",$S('$G(ONE):"",1:"S")) ; WCJ
+10 ;WCJ
DO EN^VALM2($GET(XQORNOD(0)),$SELECT('$GET(ONE):"",1:"S"))
+11 SET IBDA=0
FOR
SET IBDA=$ORDER(VALMY(IBDA))
if 'IBDA
QUIT
SET IBDA(IBDA)=$PIECE($GET(@VALMAR@(+IBDA)),U,2,6)
End DoDot:1
+12 QUIT
