IBCNEPM ;DAOU/ESG - PAYER MAINTENANCE PAYER LIST SCREEN ;22-JAN-2003
;;2.0;INTEGRATED BILLING;**184,601,621**;21-MAR-94;Build 14
;;Per VA Directive 6402, this routine should not be modified.
;
Q
;
HDR ; -- header code
S VALMHDR(1)="Payers with potential matches to active insurance companies."
Q
;
INIT ; -- init variables and list array
;
;Create scratch global of payer w/ potential matches missing
KILL ^TMP("IBCNEPM",$J)
NEW INS,DATA,PROFID,INSTID,IEN,APP,ACTIVE,PAYER
;
; First build a scratch global cross reference with all existing
; professional and institutional EDI ID numbers in file 36.
S INS=0
F S INS=$O(^DIC(36,INS)) Q:'INS D
. I '$$ACTIVE^IBCNEUT4(INS) Q ; inactive ins co
. S DATA=$G(^DIC(36,INS,3))
. I $P(DATA,U,10)'="" Q ; already linked to a payer
. S PROFID=$P(DATA,U,2),INSTID=$P(DATA,U,4)
. I PROFID'="" S ^TMP("IBCNEPM",$J,"P",PROFID,INS)=""
. I INSTID'="" S ^TMP("IBCNEPM",$J,"I",INSTID,INS)=""
. Q
;
; Next loop through all payers. Count up the number of insurance
; companies that have matching EDI ID numbers but no payer links.
; These are possible payer-insurance company links that have not yet
; been made.
;
S IEN=0
F S IEN=$O(^IBE(365.12,IEN)) Q:'IEN D
. I IEN=$$GET1^DIQ(350.9,"1,","MBI PAYER","I") Q ;IB*2*601/DM
. I IEN=$$GET1^DIQ(350.9,"1,","EICD PAYER","I") Q ;IB*2.0*621/DM
. S DATA=$G(^IBE(365.12,IEN,0))
. ;
. I '$$ACTAPP^IBCNEUT5(IEN) Q ; no active payer applications
. ;
. ; must have at least 1 nationally active payer application
. S APP=0,ACTIVE=0
. F S APP=$O(^IBE(365.12,IEN,1,APP)) Q:'APP!(ACTIVE) D
.. I $P($G(^IBE(365.12,IEN,1,APP,0)),U,2)=1 S ACTIVE=1
. Q:'ACTIVE ; no nationally active payer application found
. ;
. S PAYER=$P(DATA,U),PROFID=$P(DATA,U,5),INSTID=$P(DATA,U,6)
. ;
. ; Look at the payer's professional ID and see how many unique
. ; insurance companies also have this professional ID
. I PROFID'="",$D(^TMP("IBCNEPM",$J,"P",PROFID)) D
.. S INS="" F S INS=$O(^TMP("IBCNEPM",$J,"P",PROFID,INS)) Q:'INS D
... S ^TMP("IBCNEPM",$J,"INS",INS,IEN)=PAYER
... I $D(^TMP("IBCNEPM",$J,"PYR",PAYER,IEN,INS)) Q
... S ^TMP("IBCNEPM",$J,"PYR",PAYER,IEN,INS)=""
... S ^TMP("IBCNEPM",$J,"PYR",PAYER,IEN)=$G(^TMP("IBCNEPM",$J,"PYR",PAYER,IEN))+1 ; increment tot
. ;
. ; Look at the payer's institutional ID and see how many unique
. ; insurance companies also have this institutional ID
. I INSTID'="",$D(^TMP("IBCNEPM",$J,"I",INSTID)) D
.. S INS="" F S INS=$O(^TMP("IBCNEPM",$J,"I",INSTID,INS)) Q:'INS D
... S ^TMP("IBCNEPM",$J,"INS",INS,IEN)=PAYER
... I $D(^TMP("IBCNEPM",$J,"PYR",PAYER,IEN,INS)) Q
... S ^TMP("IBCNEPM",$J,"PYR",PAYER,IEN,INS)=""
... S ^TMP("IBCNEPM",$J,"PYR",PAYER,IEN)=$G(^TMP("IBCNEPM",$J,"PYR",PAYER,IEN))+1 ; increment tot
;
D BUILD
;
INITX ;
Q
;
BUILD ; This procedure builds the ListMan display global based on the
; "PYR" area of the scratch global.
;
NEW LINE,PAYER,IEN,STRING,LINKS
KILL ^TMP("IBCNEPM",$J,1)
S LINE=0,(PAYER,IEN)=""
F S PAYER=$O(^TMP("IBCNEPM",$J,"PYR",PAYER)) Q:PAYER="" D
. F S IEN=$O(^TMP("IBCNEPM",$J,"PYR",PAYER,IEN)) Q:IEN="" D
.. S STRING="",LINE=LINE+1
.. S ^TMP("IBCNEPM",$J,"IDX",LINE,IEN)=PAYER
.. S LINKS=^TMP("IBCNEPM",$J,"PYR",PAYER,IEN)
.. S STRING=$$SETFLD^VALM1(LINE,STRING,"LINE")
.. S STRING=$$SETFLD^VALM1(PAYER,STRING,"PAYER")
.. S STRING=$$SETFLD^VALM1(LINKS,STRING,"LINKS")
.. D SET^VALM10(LINE,STRING)
;
S VALMCNT=LINE
I VALMCNT=0 S VALMSG=" No Active Payers with potential missing links."
BUILDX ;
Q
;
;
HELP ; -- help code
N X S X="?" D DISP^XQORM1 W !!
Q
;
EXIT ; -- exit code
Q
;
EXPND ; -- expand code
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCNEPM 3785 printed Apr 09, 2024@21:09:31 Page 2
IBCNEPM ;DAOU/ESG - PAYER MAINTENANCE PAYER LIST SCREEN ;22-JAN-2003
+1 ;;2.0;INTEGRATED BILLING;**184,601,621**;21-MAR-94;Build 14
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;
+4 QUIT
+5 ;
HDR ; -- header code
+1 SET VALMHDR(1)="Payers with potential matches to active insurance companies."
+2 QUIT
+3 ;
INIT ; -- init variables and list array
+1 ;
+2 ;Create scratch global of payer w/ potential matches missing
+3 KILL ^TMP("IBCNEPM",$JOB)
+4 NEW INS,DATA,PROFID,INSTID,IEN,APP,ACTIVE,PAYER
+5 ;
+6 ; First build a scratch global cross reference with all existing
+7 ; professional and institutional EDI ID numbers in file 36.
+8 SET INS=0
+9 FOR
SET INS=$ORDER(^DIC(36,INS))
if 'INS
QUIT
Begin DoDot:1
+10 ; inactive ins co
IF '$$ACTIVE^IBCNEUT4(INS)
QUIT
+11 SET DATA=$GET(^DIC(36,INS,3))
+12 ; already linked to a payer
IF $PIECE(DATA,U,10)'=""
QUIT
+13 SET PROFID=$PIECE(DATA,U,2)
SET INSTID=$PIECE(DATA,U,4)
+14 IF PROFID'=""
SET ^TMP("IBCNEPM",$JOB,"P",PROFID,INS)=""
+15 IF INSTID'=""
SET ^TMP("IBCNEPM",$JOB,"I",INSTID,INS)=""
+16 QUIT
End DoDot:1
+17 ;
+18 ; Next loop through all payers. Count up the number of insurance
+19 ; companies that have matching EDI ID numbers but no payer links.
+20 ; These are possible payer-insurance company links that have not yet
+21 ; been made.
+22 ;
+23 SET IEN=0
+24 FOR
SET IEN=$ORDER(^IBE(365.12,IEN))
if 'IEN
QUIT
Begin DoDot:1
+25 ;IB*2*601/DM
IF IEN=$$GET1^DIQ(350.9,"1,","MBI PAYER","I")
QUIT
+26 ;IB*2.0*621/DM
IF IEN=$$GET1^DIQ(350.9,"1,","EICD PAYER","I")
QUIT
+27 SET DATA=$GET(^IBE(365.12,IEN,0))
+28 ;
+29 ; no active payer applications
IF '$$ACTAPP^IBCNEUT5(IEN)
QUIT
+30 ;
+31 ; must have at least 1 nationally active payer application
+32 SET APP=0
SET ACTIVE=0
+33 FOR
SET APP=$ORDER(^IBE(365.12,IEN,1,APP))
if 'APP!(ACTIVE)
QUIT
Begin DoDot:2
+34 IF $PIECE($GET(^IBE(365.12,IEN,1,APP,0)),U,2)=1
SET ACTIVE=1
End DoDot:2
+35 ; no nationally active payer application found
if 'ACTIVE
QUIT
+36 ;
+37 SET PAYER=$PIECE(DATA,U)
SET PROFID=$PIECE(DATA,U,5)
SET INSTID=$PIECE(DATA,U,6)
+38 ;
+39 ; Look at the payer's professional ID and see how many unique
+40 ; insurance companies also have this professional ID
+41 IF PROFID'=""
IF $DATA(^TMP("IBCNEPM",$JOB,"P",PROFID))
Begin DoDot:2
+42 SET INS=""
FOR
SET INS=$ORDER(^TMP("IBCNEPM",$JOB,"P",PROFID,INS))
if 'INS
QUIT
Begin DoDot:3
+43 SET ^TMP("IBCNEPM",$JOB,"INS",INS,IEN)=PAYER
+44 IF $DATA(^TMP("IBCNEPM",$JOB,"PYR",PAYER,IEN,INS))
QUIT
+45 SET ^TMP("IBCNEPM",$JOB,"PYR",PAYER,IEN,INS)=""
+46 ; increment tot
SET ^TMP("IBCNEPM",$JOB,"PYR",PAYER,IEN)=$GET(^TMP("IBCNEPM",$JOB,"PYR",PAYER,IEN))+1
End DoDot:3
End DoDot:2
+47 ;
+48 ; Look at the payer's institutional ID and see how many unique
+49 ; insurance companies also have this institutional ID
+50 IF INSTID'=""
IF $DATA(^TMP("IBCNEPM",$JOB,"I",INSTID))
Begin DoDot:2
+51 SET INS=""
FOR
SET INS=$ORDER(^TMP("IBCNEPM",$JOB,"I",INSTID,INS))
if 'INS
QUIT
Begin DoDot:3
+52 SET ^TMP("IBCNEPM",$JOB,"INS",INS,IEN)=PAYER
+53 IF $DATA(^TMP("IBCNEPM",$JOB,"PYR",PAYER,IEN,INS))
QUIT
+54 SET ^TMP("IBCNEPM",$JOB,"PYR",PAYER,IEN,INS)=""
+55 ; increment tot
SET ^TMP("IBCNEPM",$JOB,"PYR",PAYER,IEN)=$GET(^TMP("IBCNEPM",$JOB,"PYR",PAYER,IEN))+1
End DoDot:3
End DoDot:2
End DoDot:1
+56 ;
+57 DO BUILD
+58 ;
INITX ;
+1 QUIT
+2 ;
BUILD ; This procedure builds the ListMan display global based on the
+1 ; "PYR" area of the scratch global.
+2 ;
+3 NEW LINE,PAYER,IEN,STRING,LINKS
+4 KILL ^TMP("IBCNEPM",$JOB,1)
+5 SET LINE=0
SET (PAYER,IEN)=""
+6 FOR
SET PAYER=$ORDER(^TMP("IBCNEPM",$JOB,"PYR",PAYER))
if PAYER=""
QUIT
Begin DoDot:1
+7 FOR
SET IEN=$ORDER(^TMP("IBCNEPM",$JOB,"PYR",PAYER,IEN))
if IEN=""
QUIT
Begin DoDot:2
+8 SET STRING=""
SET LINE=LINE+1
+9 SET ^TMP("IBCNEPM",$JOB,"IDX",LINE,IEN)=PAYER
+10 SET LINKS=^TMP("IBCNEPM",$JOB,"PYR",PAYER,IEN)
+11 SET STRING=$$SETFLD^VALM1(LINE,STRING,"LINE")
+12 SET STRING=$$SETFLD^VALM1(PAYER,STRING,"PAYER")
+13 SET STRING=$$SETFLD^VALM1(LINKS,STRING,"LINKS")
+14 DO SET^VALM10(LINE,STRING)
End DoDot:2
End DoDot:1
+15 ;
+16 SET VALMCNT=LINE
+17 IF VALMCNT=0
SET VALMSG=" No Active Payers with potential missing links."
BUILDX ;
+1 QUIT
+2 ;
+3 ;
HELP ; -- help code
+1 NEW X
SET X="?"
DO DISP^XQORM1
WRITE !!
+2 QUIT
+3 ;
EXIT ; -- exit code
+1 QUIT
+2 ;
EXPND ; -- expand code
+1 QUIT
+2 ;
