source: WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCNEPM.m@ 767

Last change on this file since 767 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR

File size: 3.5 KB
Line 
1IBCNEPM ;DAOU/ESG - PAYER MAINTENANCE PAYER LIST SCREEN ;22-JAN-2003
2 ;;2.0;INTEGRATED BILLING;**184**;21-MAR-94
3 ;;Per VHA Directive 10-93-142, this routine should not be modified.
4 ;
5 Q
6 ;
7HDR ; -- header code
8 S VALMHDR(1)="Payers with potential matches to active insurance companies."
9 Q
10 ;
11INIT ; -- init variables and list array
12 ;
13 ;Create scratch global of payer w/ potential matches missing
14 KILL ^TMP("IBCNEPM",$J)
15 NEW INS,DATA,PROFID,INSTID,IEN,APP,ACTIVE,PAYER
16 ;
17 ; First build a scratch global cross reference with all existing
18 ; professional and institutional EDI ID numbers in file 36.
19 S INS=0
20 F S INS=$O(^DIC(36,INS)) Q:'INS D
21 . I '$$ACTIVE^IBCNEUT4(INS) Q ; inactive ins co
22 . S DATA=$G(^DIC(36,INS,3))
23 . I $P(DATA,U,10)'="" Q ; already linked to a payer
24 . S PROFID=$P(DATA,U,2),INSTID=$P(DATA,U,4)
25 . I PROFID'="" S ^TMP("IBCNEPM",$J,"P",PROFID,INS)=""
26 . I INSTID'="" S ^TMP("IBCNEPM",$J,"I",INSTID,INS)=""
27 . Q
28 ;
29 ; Next loop through all payers. Count up the number of insurance
30 ; companies that have matching EDI ID numbers but no payer links.
31 ; These are possible payer-insurance company links that have not yet
32 ; been made.
33 ;
34 S IEN=0
35 F S IEN=$O(^IBE(365.12,IEN)) Q:'IEN D
36 . S DATA=$G(^IBE(365.12,IEN,0))
37 . ;
38 . I '$$ACTAPP^IBCNEUT5(IEN) Q ; no active payer applications
39 . ;
40 . ; must have at least 1 nationally active payer application
41 . S APP=0,ACTIVE=0
42 . F S APP=$O(^IBE(365.12,IEN,1,APP)) Q:'APP!(ACTIVE) D
43 .. I $P($G(^IBE(365.12,IEN,1,APP,0)),U,2)=1 S ACTIVE=1
44 . Q:'ACTIVE ; no nationally active payer application found
45 . ;
46 . S PAYER=$P(DATA,U),PROFID=$P(DATA,U,5),INSTID=$P(DATA,U,6)
47 . ;
48 . ; Look at the payer's professional ID and see how many unique
49 . ; insurance companies also have this professional ID
50 . I PROFID'="",$D(^TMP("IBCNEPM",$J,"P",PROFID)) D
51 .. S INS="" F S INS=$O(^TMP("IBCNEPM",$J,"P",PROFID,INS)) Q:'INS D
52 ... S ^TMP("IBCNEPM",$J,"INS",INS,IEN)=PAYER
53 ... I $D(^TMP("IBCNEPM",$J,"PYR",PAYER,IEN,INS)) Q
54 ... S ^TMP("IBCNEPM",$J,"PYR",PAYER,IEN,INS)=""
55 ... S ^TMP("IBCNEPM",$J,"PYR",PAYER,IEN)=$G(^TMP("IBCNEPM",$J,"PYR",PAYER,IEN))+1 ; increment tot
56 . ;
57 . ; Look at the payer's institutional ID and see how many unique
58 . ; insurance companies also have this institutional ID
59 . I INSTID'="",$D(^TMP("IBCNEPM",$J,"I",INSTID)) D
60 .. S INS="" F S INS=$O(^TMP("IBCNEPM",$J,"I",INSTID,INS)) Q:'INS D
61 ... S ^TMP("IBCNEPM",$J,"INS",INS,IEN)=PAYER
62 ... I $D(^TMP("IBCNEPM",$J,"PYR",PAYER,IEN,INS)) Q
63 ... S ^TMP("IBCNEPM",$J,"PYR",PAYER,IEN,INS)=""
64 ... S ^TMP("IBCNEPM",$J,"PYR",PAYER,IEN)=$G(^TMP("IBCNEPM",$J,"PYR",PAYER,IEN))+1 ; increment tot
65 ;
66 D BUILD
67 ;
68INITX ;
69 Q
70 ;
71BUILD ; This procedure builds the ListMan display global based on the
72 ; "PYR" area of the scratch global.
73 ;
74 NEW LINE,PAYER,IEN,STRING,LINKS
75 KILL ^TMP("IBCNEPM",$J,1)
76 S LINE=0,(PAYER,IEN)=""
77 F S PAYER=$O(^TMP("IBCNEPM",$J,"PYR",PAYER)) Q:PAYER="" D
78 . F S IEN=$O(^TMP("IBCNEPM",$J,"PYR",PAYER,IEN)) Q:IEN="" D
79 .. S STRING="",LINE=LINE+1
80 .. S ^TMP("IBCNEPM",$J,"IDX",LINE,IEN)=PAYER
81 .. S LINKS=^TMP("IBCNEPM",$J,"PYR",PAYER,IEN)
82 .. S STRING=$$SETFLD^VALM1(LINE,STRING,"LINE")
83 .. S STRING=$$SETFLD^VALM1(PAYER,STRING,"PAYER")
84 .. S STRING=$$SETFLD^VALM1(LINKS,STRING,"LINKS")
85 .. D SET^VALM10(LINE,STRING)
86 ;
87 S VALMCNT=LINE
88 I VALMCNT=0 S VALMSG=" No Active Payers with potential missing links."
89BUILDX ;
90 Q
91 ;
92 ;
93HELP ; -- help code
94 N X S X="?" D DISP^XQORM1 W !!
95 Q
96 ;
97EXIT ; -- exit code
98 Q
99 ;
100EXPND ; -- expand code
101 Q
102 ;
Note: See TracBrowser for help on using the repository browser.