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

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

initial load of WorldVistAEHR
File size: 7.0 KB
Line 
1IBCNRP5 ;BHAM ISC/CMW - Group Plan Status Report ;01-NOV-2004
2 ;;2.0;INTEGRATED BILLING;**276**;21-MAR-94
3 ;;Per VHA Directive 10-93-142, this routine should not be modified.
4 ;
5EN ;
6 ; Initialize variables
7 N STOP,IBCNRRTN,IBCNRSPC,RESORT,IBCNTYP,IBSEL
8 D:'$D(IOF) HOME^%ZIS
9 ;
10 S STOP=0,IBPXT=$G(IBPXT)
11 W @IOF
12 W !,"ePHARM GROUP PLAN STATUS REPORT",!
13 W !,"NCPDP process requires that the users match Group Plans to Pharmacy Plans."
14 W !,"This report will assist users in matching Group Insurance Plans to Pharmacy"
15 W !," Plans by searching through GIPF file for Group Plans that "
16 W !," are linked to an Insurance with active Pharmacy Plan coverage."
17 ;
18 ; Prompts
19 ; lock global
20 S IBCNRRPT=1
21 N IBCNRDEV S IBCNRDEV=1
22 L +^XTMP("IBCNRP5"):5 I '$T W !!,"Sorry, Status Report in use." H 2 G EXIT
23 ;Check for prior compile
24P10 D RESORT(.RESORT) I STOP G EXIT
25 I $G(RESORT) G P30
26 K ^XTMP("IBCNRP5")
27 ; compile valid insurance file
28P20 D GIPF
29 ; select insurance company
30P30 D INS I $G(IBSEL)="" G EXIT
31 D TYPE I $G(IBCNTYP)="" G EXIT
32 ; perform sort/selection
33P40 D INSEL
34 I '$D(^TMP("IBCNRP5")) G EXIT
35 ; print selection
36P50 D PRINT^IBCNRP5P
37 ;
38EXIT ; unlock global
39 L -^XTMP("IBCNRP5")
40 K IBPXT
41 K IBCNSP,IBCPOL,IBIND,IBMULT,IBSEL,IBW,IBALR,IBGRP,IBCNGP
42 K IBCNRRPT,IBCNTYP,IBCNRDEV,ZTDESC,ZTSTOP
43 K IBCNRP,IBCNRI,IBCNRGP
44 K IBICPT,IBICF,IBICL,IBIC,IBINA,IBIEN,INIEN
45 K ^TMP("IBCNRP5",$J)
46 Q
47 ;
48RESORT(RESORT) ; check for prior compile
49 NEW DIR,BDT,EDT,RDT,HDR,IBDT,X,Y,DIRUT
50 I '$D(^XTMP("IBCNRP5")) Q
51 S RDT=$P($G(^XTMP("IBCNRP5",0)),U,2)
52 S RESORT=0
53 S HDR=$$FMTE^XLFDT(RDT,"5Z")
54 W !!,"Current Insurance company list compiled on: ",HDR,!
55 S DIR(0)="Y"
56 S DIR("A")="Do you want to use the existing compiled file"
57 S DIR("B")="YES"
58 S DIR("?",1)=" Enter YES to use the existing compiled file."
59 S DIR("?")=" Enter NO to DELETE existing file and recompile,"
60 D ^DIR K DIR
61 I $D(DIRUT) S STOP=1 G RESRTX
62 S RESORT=Y
63 S IBCNRSPC("RESORT")=Y
64 ;
65RESRTX ;RESORT EXIT
66 Q
67 ;
68GIPF ; compiler valid insurance
69 W !,"*** COMPILING ......"
70 N GST1,GP0,GP6,IBCOV,LIM,IBCVRD,IBIEN
71 N GPIEN,GPNAM,GPNUM,IBINA
72 S GST1=1,(GPIEN,INIEN)=""
73 S ^XTMP("IBCNRP5",0)=($$NOW^XLFDT+30)_"^"_$$NOW^XLFDT_"^"_"Group Plan Status Report"
74 F S INIEN=$O(^IBA(355.3,"B",INIEN)) Q:INIEN="" D
75 . S IBINA=$P($G(^DIC(36,+INIEN,0)),U)
76 . ; company does not reimburse
77 . I $P($G(^DIC(36,+INIEN,0)),U,2)="N" Q
78 . ; company is inactive
79 . I $P($G(^DIC(36,INIEN,0)),U,5) Q
80 . ;
81 . F S GPIEN=$O(^IBA(355.3,"B",INIEN,GPIEN)) Q:GPIEN="" D
82 .. ;chk for active group
83 .. S GP0=$G(^IBA(355.3,GPIEN,0)),GP6=$G(^IBA(355.3,GPIEN,6))
84 .. I $P(GP0,U,11)=1 Q
85 .. ;
86 .. ;chk for pharm plan coverage
87 .. S IBCOV=$O(^IBE(355.31,"B","PHARMACY",""))
88 .. S LIM="",IBCVRD=0
89 .. F S LIM=$O(^IBA(355.32,"B",GPIEN,LIM)) Q:LIM="" D
90 ... I $P(^IBA(355.32,LIM,0),U,2)'=IBCOV Q
91 ... ;chk covered status
92 ... S IBCVRD=$P(^IBA(355.32,LIM,0),U,4)
93 ... I IBCVRD=0 Q
94 ... ;set valid insurance/group array
95 ... S ^XTMP("IBCNRP5",IBINA,INIEN,GPIEN)=""
96 Q
97 ;
98INS ;
99 S IBSEL=""
100 W !,"Run Report "
101 W " for (S)PECIFIC insurance companies or a (R)ANGE: RANGE// "
102 R X:DTIME Q:'$T!(X["^")
103 S:X="" X="R" S X=$E(X)
104 I "RSrs"'[X W !,"Enter <CR> for Range; 'S' for specific insurance; '^' to quit." G INS
105 W " ",$S("Ss"[X:"SPECIFIC",1:"RANGE") G:"Rr"[X INSO1
106INSO S DIC="^DIC(36,",DIC(0)="AEQMZ",DIC("S")="I '$G(^(5))"
107 S DIC("A")=" Select "_$S($G(IBICPT):"another ",1:"")_"INSURANCE CO.: "
108 D ^DIC K DIC I Y'>0 G INS:'$G(IBICPT) S IBSEL=1 Q
109 I $D(IBICPT(+Y)) D G INSO
110 .W !!?3,"Already selected. Choose another insurance company.",!,*7
111 S IBICPT(+Y)="",IBICPT=$G(IBICPT)+1 G INSO
112 ;
113INSO1 W !?3,"Start with INSURANCE COMPANY: FIRST// " R X:DTIME
114 G:'$T!(X["^") INS
115 I $E(X)="?" W !,"Enter value up to 40 char; <CR> to start with 'first' value; '^' to quit." G INSO1
116 S IBICF=X
117INSO2 W !?8,"Go to INSURANCE COMPANY: LAST// " R X:DTIME
118 G:'$T!(X["^") INSO1
119 I $E(X)="?" W !,"Enter value up to 40 char; <CR> to go to 'last' value; '^' to quit." G INSO1
120 I X="" S IBICL="zzzzz" S:IBICF="" IBIC="ALL" S IBSEL=1 Q
121 I IBICF]X D G INSO2
122 .W *7,!!?3,"The LAST value must follow the FIRST.",!
123 S IBICL=X,IBSEL=1
124 Q
125 ;
126TYPE ; Prompt to allow users to inquire for All group plans, or Matched group plans
127 N DIR,X,Y,DIRUT
128 S IBCNTYP="A"
129 S DIR(0)="S^A:All Group Plans;M:Matched Group Plans"
130 S DIR("A")=" Select the type of Group Plans you want to see for Insurance selected."
131 S DIR("B")="A"
132 S DIR("?",1)=" A - All Group Plans"
133 S DIR("?",2)=" M - Matched Group Plans"
134 D ^DIR K DIR
135 I $D(DIRUT) G TYPEX
136 S IBCNTYP=Y
137TYPEX Q
138 ;
139INSEL ; - Perform selection for insurance company.
140 S VALMCNT=0,VALMBG=1,IBCNGP=0
141 K ^TMP("IBCNRP5",$J)
142 ; check for specific insurance companies
143 I $G(IBICPT) D Q
144 . S (IBINA,IBIEN)=""
145 . F S IBIEN=$O(IBICPT(IBIEN)) Q:IBIEN="" D
146 .. S IBINA=$P($G(^DIC(36,+IBIEN,0)),U)
147 .. I '$D(^XTMP("IBCNRP5",IBINA,IBIEN)) D Q
148 ... W *7,!?3,"**NO pharmacy data found for "
149 ... W $P(^DIC(36,IBIEN,0),U)_" "_$P(^DIC(36,IBIEN,.11),U),! R X:2
150 .. D INIT
151 ;
152 ; check for range of insurance companies
153 I '$D(IBICL) Q
154 S IBIEN=0,IBINA=""
155 F S IBINA=$O(^XTMP("IBCNRP5",IBINA)) Q:IBINA="" D
156 . F S IBIEN=$O(^XTMP("IBCNRP5",IBINA,IBIEN)) Q:IBIEN="" D
157 ..; for selection "ALL"
158 .. I $G(IBIC)="ALL" D INIT Q
159 .. ;
160 .. ;check for match within first/last range
161 .. I (IBICF]IBINA)!(IBINA]IBICL) Q
162 .. D INIT
163 Q
164 ;
165INIT ; -- init variables and create list array or report array
166 N IBGP0,IBCPOLD,X,IBCPD6,IBCNRPP,IBCOV,IBCVRD,LIM
167 F S IBCNGP=$O(^XTMP("IBCNRP5",IBINA,IBIEN,IBCNGP)) Q:'IBCNGP D
168 . I '$D(^IBA(355.3,+IBCNGP,0)) Q
169 . ; if we want all plans, let it pass
170 . I IBCNTYP="A" D Q
171 . . D SETPLAN(IBCNGP)
172 . ; if we want Matched plans, check for existence of Plan ID
173 . I IBCNTYP="M" D Q
174 . . I $P($G(^IBA(355.3,IBCNGP,6)),U)'="" D SETPLAN(IBCNGP)
175 I VALMCNT=0 D
176 . S ^TMP("IBCNRP5",$J,"DSPDATA",1)=IBIEN
177 . S ^TMP("IBCNRP5",$J,"DSPDATA",2)="No data for this Insurance"
178 Q
179 ;
180SETPLAN(IBCNGP) ;
181 ; create text
182 N IBGPZ,I,IBPLN,IBPLNA,LINE
183 S VALMCNT=VALMCNT+1,$P(LINE,"-",80)=""
184 S IBGPZ=^IBA(355.3,+IBCNGP,0)
185 ; Group Name, Group #, Group Type, Plan ID, Plan Status
186 S X=$$FO^IBCNEUT1($P(IBGPZ,U,3),18)
187 S X=X_" "_$$FO^IBCNEUT1($P(IBGPZ,U,4),17)
188 S X=X_" "_$$FO^IBCNEUT1($$EXPAND^IBTRE(355.3,.09,$P(IBGPZ,U,9)),13)
189 S IBPLN=$P($G(^IBA(355.3,+IBCNGP,6)),U)
190 ; check for plan
191 I IBPLN="" D Q
192 . S ^TMP("IBCNRP5",$J,"DSPDATA",VALMCNT)=IBIEN_"^"_X
193 . S VALMCNT=VALMCNT+1,^TMP("IBCNRP5",$J,"DSPDATA",VALMCNT)=IBIEN_"^"_"No Plan Found."
194 . S VALMCNT=VALMCNT+1,^TMP("IBCNRP5",$J,"DSPDATA",VALMCNT)=IBIEN_"^"_LINE
195 ; check plan status information
196 S IBPLNA=$P($G(^IBCNR(366.03,IBPLN,0)),U)
197 S X=X_" "_$$FO^IBCNEUT1(IBPLNA,13)
198 ;
199 N ARRAY D STCHK^IBCNRU1(IBPLN,.ARRAY)
200 S X=X_" "_$$FO^IBCNEUT1($S($G(ARRAY(1))="I":"INACTIVE",1:"ACTIVE"),8)
201 S ^TMP("IBCNRP5",$J,"DSPDATA",VALMCNT)=IBIEN_"^"_X
202 I $G(ARRAY(6)) D
203 . N STATAR
204 . D STATAR^IBCNRU1(.STATAR)
205 . F I=1:1:$L(ARRAY(6),",") D
206 .. S VALMCNT=VALMCNT+1
207 .. S ^TMP("IBCNRP5",$J,"DSPDATA",VALMCNT)=IBIEN_"^"_" "_$G(STATAR($P(ARRAY(6),",",I)))
208 . S VALMCNT=VALMCNT+1,^TMP("IBCNRP5",$J,"DSPDATA",VALMCNT)=IBIEN_"^"_LINE
209 ;
210 Q
Note: See TracBrowser for help on using the repository browser.