source: FOIAVistA/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCOMD1.m@ 1757

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

initial load of FOIAVistA 6/30/08 version

File size: 4.3 KB
Line 
1IBCOMD1 ;ALB/CMS - GENERATE INSURANCE COMPANY LISTINGS ; 03-AUG-98
2 ;;2.0;INTEGRATED BILLING;**103**;21-MAR-94
3 Q
4 ;
5BEG ; Queued entry point.
6 ; Input variables:
7 ;
8 ; IBCASE(n) = x ^ y ^ z (Optional), where
9 ; n = 1-4 (1:Name, 2:Street, 3:City, 4:State)
10 ; x = C (Contains), or R (RANGE)
11 ; y = Pointer to the STATE (#5) file, if n=4
12 ; The 'Contains' value, if x = C
13 ; The 'Start From' value, if x = R
14 ; z = The 'Go To' value, if x = R
15 ;
16 ; IBFLD(n) = x (Required), where
17 ; n = 1-4 (1:Name, 2:Street, 3:City, 4:State)
18 ; x = NAME (n=1), STREET (n=2), CITY (n=3), STATE (n=4)
19 ;
20 ; IBAIB - Required. Include Active Insurance
21 ; 1= Active Ins. 2= Inactive Ins. 3= Both
22 ;
23 N IBDA,IBDA0,IBDA11,IBDA13,IBI,IBPAGE,IBTMP,IBX,X,Y,IBJ,IBNOT
24 K ^TMP("IBCOMD",$J) S IBPAGE=0
25 ;
26 ; - must look at all entries in file #36
27 S IBDA=0 F S IBDA=$O(^DIC(36,IBDA)) Q:'IBDA S IBDA0=$G(^(IBDA,0)) D
28 .;
29 .; - screen out active/inactive companies
30 .I IBAIB=1,$P(IBDA0,U,5) Q
31 .I IBAIB=2,'$P(IBDA0,U,5) Q
32 .;
33 .S IBDA11=$G(^DIC(36,IBDA,.11)),IBDA13=$G(^(.13))
34 .;
35 .; - screen out entries based on user-selected field screens
36 .S (IBJ,IBNOT)=0 F S IBJ=$O(IBCASE(IBJ)) Q:'IBJ D Q:IBNOT
37 ..N IBD,VAL S IBD=IBCASE(IBJ)
38 ..;
39 ..; - check state first
40 ..I IBJ=4 S:$P(IBDA11,"^",5)'=$P(IBD,"^",2) IBNOT=1 Q
41 ..;
42 ..; - find the field value to be evaluated
43 ..S VAL=$S(IBJ=1:$P(IBDA0,"^"),1:$P(IBDA11,"^",$S(IBJ=2:1,1:4)))
44 ..;
45 ..; - check 'contains' values
46 ..I $P(IBD,"^")="C" S:VAL'[$P(IBD,"^",2) IBNOT=1 Q
47 ..;
48 ..; - check 'range' values
49 ..I VAL="" S IBNOT=1 Q ; VAL must have a value in a range
50 ..I $P(IBD,"^",2)]VAL S IBNOT=1 Q ; VAL doesn't follow Start value
51 ..I VAL]$P(IBD,"^",3) S IBNOT=1 ; VAL follows the Go To value
52 .;
53 .Q:IBNOT ; entry does not meet criteria
54 .;
55 .;
56 .; - set entry in global
57 .S IBTMP=$P(IBDA0,U,1)_U
58 .S IBX=$P(IBDA0,U,2) S $P(IBTMP,U,2)=$S(IBX]"":$E($$EXPAND^IBTRE(36,1,IBX),1,20),1:"")_U
59 .F IBX=1:1:6 S IBTMP=IBTMP_$P(IBDA11,U,IBX)_U
60 .S IBX=$P(IBTMP,U,7) S $P(IBTMP,U,7)=$S(IBX]"":$$STATE^IBCF2(IBX),1:"")_U
61 .S $P(IBTMP,U,9)=$P(IBDA13,U,1)
62 .S ^TMP("IBCOMD",$J,+$P(IBDA0,U,5),$S($P(IBDA0,U,1)]"":$P(IBDA0,U,1),1:"ZZZZ"),+IBDA)=IBTMP
63 ;
64 I '$D(^TMP("IBCOMD",$J)) D HD W !!,"** NO RECORDS FOUND **" G QUEQ
65 D WRT
66 ;
67 ; Exit clean-UP
68QUEQ K IBAIB,IBCASE,IBFLD,IBQUIT,^TMP("IBCOMD",$J)
69 I $D(ZTQUEUED) S ZTREQ="@" Q
70 W ! D ^%ZISC
71 Q
72 ;
73 ;
74HD ; Write Heading
75 S IBPAGE=IBPAGE+1
76 W @IOF,"Generate Insurance Company Listings",?50,$$FMTE^XLFDT($$NOW^XLFDT,"Z"),?70," Page ",IBPAGE
77 W !,"List of ",$S(IBAIB=1:"Active",IBAIB=2:"Inactive",1:"All")," Insurance Companies"
78 ;
79 ; - display definition of screens
80 I $D(IBCASE) W ", where" D
81 .N I,H
82 .S (H,I)=0 F S I=$O(IBCASE(I)) Q:'I D
83 ..W ! I H W ?3,"and"
84 ..S H=1 W ?8,IBFLD(I)," "
85 ..W $S(I=4:"Equals ",$P(IBCASE(I),"^")="C":"Contains ",1:"Between ")
86 ..W $S(I=4:$P($G(^DIC(5,+$P(IBCASE(I),"^",2),0)),"^"),$P(IBCASE(I),"^",2)="":"'FIRST'",1:$P(IBCASE(I),"^",2))
87 ..I $P(IBCASE(I),"^")="R" W " and ",$S($P(IBCASE(I),"^",3)="zzzzzz":"'LAST'",1:$P(IBCASE(I),"^",3))
88 ;
89 W !,"Insurance Name/Address",?33,"Reimburse?",?56,"Phone Number"
90 W ! F IBX=1:1:79 W "="
91 Q
92 ;
93WRT ; Write data lines
94 N IBA,IBNA,IBOFF,X,Y S IBQUIT=0
95 S IBA="" F S IBA=$O(^TMP("IBCOMD",$J,IBA)) Q:(IBA="")!(IBQUIT=1) D
96 .I IBPAGE D ASK I IBQUIT=1 Q
97 .D HD W !,$S(IBA=1:"Inactive Companies",1:"Active Companies"),!
98 .S IBNA="" F S IBNA=$O(^TMP("IBCOMD",$J,IBA,IBNA)) Q:(IBNA="")!(IBQUIT=1) D
99 ..S IBDA="" F S IBDA=$O(^TMP("IBCOMD",$J,IBA,IBNA,IBDA)) Q:('IBDA)!(IBQUIT=1) D
100 ...S IBTMP=^TMP("IBCOMD",$J,IBA,IBNA,IBDA)
101 ...S IBOFF=$S($P(IBTMP,U,4)]""!($P(IBTMP,U,5)]""):7,1:6)
102 ...I ($Y+IBOFF)>IOSL D I IBQUIT=1 Q
103 ....D ASK I IBQUIT=1 Q
104 ....D HD
105 ...S IBTMP=^TMP("IBCOMD",$J,IBA,IBNA,IBDA)
106 ...W !!,$P(IBTMP,U,1),?33,$P(IBTMP,U,2),?56,$P(IBTMP,U,9)
107 ...I $P(IBTMP,U,3)]"" W !,$P(IBTMP,U,3)
108 ...I $P(IBTMP,U,4)]""!($P(IBTMP,U,5)]"") W !,$P(IBTMP,U,4) W:$P(IBTMP,U,4)]""&($P(IBTMP,U,5)]"") ", " W $P(IBTMP,U,5)
109 ...W !,$P(IBTMP,U,6) W:$P(IBTMP,U,6)]""&($P(IBTMP,U,7)]"") ", " W $P(IBTMP,U,7)," ",$P(IBTMP,U,8)
110 Q
111 ;
112ASK ; Ask to Continue with display
113 ; Returns IBQUIT=1 if user Timed out or entered ^
114 I $E(IOST,1,2)'["C-" Q
115 N DIR,DIROUT,DIRUT,DTOUT,DUOUT,IBI,X,Y
116 F IBI=1:1:(IOSL-3) Q:$Y>(IOSL-3) W !
117 S DIR(0)="E" D ^DIR
118 I ($D(DIRUT))!($D(DUOUT)) S IBQUIT=1
119 Q
Note: See TracBrowser for help on using the repository browser.