source: FOIAVistA/trunk/r/CONSULT_REQUEST_TRACKING-GMRC-GMRS-GMRT/GMRCPSL3.m@ 1688

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

initial load of FOIAVistA 6/30/08 version
File size: 9.0 KB
Line 
1GMRCPSL3 ;SLC/MA - Special Consult Reports;9/21/01 05:25 ;1/17/02 18:19
2 ;;3.0;CONSULT/REQUEST TRACKING;**23,22**;DEC 27, 1997
3 ; This routine is called by GMRCPSL2 to generate reports or
4 ; date output.
5 ; DBIA 10035 call DIQ=2 ;PATIENT FILE
6 ; DBIA 10040 call DIQ=44 ;LOCATION FILE
7 ; DBIA 10060 call DIQ=200 ;NEW PERSON FILE
8 ; GMRCDT1 = Start date
9 ; GMRCDT2 = Stop date
10 ; GMRCBRK = Print page break between sub-totals <Y-N>
11 ; TOTCNTR = Count for total records
12 ; DISPLINE = ^GMR(123,,0) + FORMATED 12 NODE
13REPORT32(SUBTOT,TOTCNTR,GMRCSRCH,GMRCBRK) ; Read ^TMP("GMRCRPT",$J) and format report
14 ; The ^TMP global can be in any order but it will always have 3
15 ; sorting parameters (PROVIDER,DATE,IEN) or (PT LOCATION,DATE,IEN)
16 ; or (PROCEDURE TYPE,DATE,IEN)
17 ; RPTTITL = Used to vary report title
18 ; SRTCOMP = Used to tell when to print subtotals
19 ; SUBTOT = Used to count subtotals
20 N RPTTITL,SRTCOMP,GMRCQUIT
21 U IO
22 N IEN,SRT1,SRT2,SRT3,DISPLINE,LINECNT,PAGE,RPTTITL,SUBCOMP,GMRCFRST
23 S RPTTITL=$$RPTT(GMRCSRCH)
24 S (LINECNT,PAGE,SUBTOT,GMRCQUIT)=0,GMRCFRST=1
25 S SRT1="",SRTCOMP=""
26 ; Sorted by GMRCSRCH & date. First sort compare is just to watch
27 ; for GMRCSRCH change to print sub-totals.
28 F S SRT1=$O(^TMP("GMRCRPT",$J,SRT1)) Q:'$L(SRT1) Q:GMRCQUIT D
29 . I SRTCOMP="" S SRTCOMP=SRT1
30 . I SRTCOMP'=SRT1 D
31 . . W !!,"SUB TOTAL= ",SUBTOT,!
32 . . S LINECNT=LINECNT+3
33 . . S SUBTOT=0
34 . . I GMRCBRK D PAGEBK32
35 . S SRT2=0
36 . F S SRT2=$O(^TMP("GMRCRPT",$J,SRT1,SRT2)) Q:'SRT2 Q:GMRCQUIT D
37 . . S SRT3=0
38 . . F S SRT3=$O(^TMP("GMRCRPT",$J,SRT1,SRT2,SRT3)) Q:'SRT3 Q:GMRCQUIT D
39 . . . S DISPLINE=^TMP("GMRCRPT",$J,SRT1,SRT2,SRT3)
40 . . . I GMRCFRST D PAGEBK32 ; Kick out first page header
41 . . . I LINECNT>IOSL D PAGEBK32
42 . . . I GMRCQUIT Q
43 . . . ;
44 . . . ; Start writing the print line
45 . . . W !,$P(DISPLINE,"|",1) ;IEN
46 . . . W ?11,$$FMTE^XLFDT($P(DISPLINE,"^",7),"D") ;REQ DAT
47 . . . ; If Provider not NULL, If IFC record Provider will be NULL
48 . . . I GMRCSRCH=1 D
49 . . . . I +$P(DISPLINE,"^",14) D
50 . . . . . W ?25,$E($$GET1^DIQ(200,$P(DISPLINE,"^",14),.01),1,20) ;PROVIDER
51 . . . . ; Provider Null and REMOTE ORDERING PROVIDER not, must be an IFC record
52 . . . . I '+$P(DISPLINE,"^",14),$P(DISPLINE,"^",24)'="" D
53 . . . . . W ?25,$E($P(DISPLINE,"^",24),1,40)
54 . . . . W ?48,$E($$GET1^DIQ(123.5,$P(DISPLINE,"^",5),.01),1,40) ;TO SERVICE
55 . . . I GMRCSRCH=2 D
56 . . . . ; Location not null, if null then it is a IFC record
57 . . . . I +$P(DISPLINE,"^",4) D
58 . . . . . W ?25,$E($$GET1^DIQ(44,$P(DISPLINE,"^",4),.01),1,22)
59 . . . . ; Location null and Ordering Facility not, IFC record
60 . . . . I '+$P(DISPLINE,"^",4),+$P(DISPLINE,"^",21) D
61 . . . . . W ?25,$E($$GET1^DIQ(4,$P(DISPLINE,"^",21),.01),1,22)
62 . . . . ; Location null, Ordering Facility null, Routing Facility not
63 . . . . ; meaning this is an IFC record
64 . . . . I '+$P(DISPLINE,"^",4),'+$P(DISPLINE,"^",21),+$P(DISPLINE,"^",23) D
65 . . . . . W ?25,$E($$GET1^DIQ(4,$P(DISPLINE,"^",23),.01),1,22)
66 . . . . W ?48,$E($$GET1^DIQ(123.5,$P(DISPLINE,"^",5),.01),1,40) ;TO SERVICE
67 . . . I GMRCSRCH=3 D
68 . . . . W ?25,$E($$GET1^DIQ(123.3,$P($P(DISPLINE,"^",8),";",1),.01),1,20) ;PROCEDURE
69 . . . . W ?48,$E($$GET1^DIQ(123.5,$P(DISPLINE,"^",5),.01),1,40) ;TO SERVICE
70 . . . W ?89,$E($$GET1^DIQ(2,$P(DISPLINE,"^",2),.01),1,20) ;PATIENT
71 . . . W ?121,$E($$GET1^DIQ(2,$P(DISPLINE,"^",2),.09),6,9) ;SSN
72 . . . W ?129,$$GET1^DIQ(100.01,$P(DISPLINE,"^",12),.1) ;STATUS
73 . . . S LINECNT=LINECNT+1,TOTCNTR=TOTCNTR+1,SUBTOT=SUBTOT+1
74 Q
75 ;
76REPORT80(SUBTOT,TOTCNTR,GMRCSRCH,GMRCBRK) ; Read ^TMP("GMRCRPT",$J) and format report
77 ; The ^TMP global can be in any order but it will always have 3
78 ; sorting parameters (PROVIDER,DATE,IEN) or (PT LOCATION,DATE,IEN)
79 ; or (PROCEDURE TYPE,DATE,IEN)
80 ; RPTTITL = Used to vary report title
81 ; SRTCOMP = Used to tell when to print subtotals
82 ; SUBTOT = Used to count subtotals
83 ; GMRCFRST= Set to one to get first report headers to print
84 N RPTTITL,SRTCOMP,GMRCQUIT
85 U IO
86 N IEN,SRT1,SRT2,SRT3,DISPLINE,LINECNT,PAGE,RPTTITL,SUBCOMP,GMRCFRST
87 S RPTTITL=$$RPTT(GMRCSRCH)
88 S (LINECNT,PAGE,SUBTOT,GMRCQUIT)=0,GMRCFRST=1
89 S SRT1="",SRTCOMP=""
90 ; Sorted by GMRCSRCH & date. First sort compare is just to watch
91 ; for GMRCSRCH change to print sub-totals.
92 F S SRT1=$O(^TMP("GMRCRPT",$J,SRT1)) Q:'$L(SRT1) Q:GMRCQUIT D
93 . I SRTCOMP="" S SRTCOMP=SRT1
94 . I SRTCOMP'=SRT1 D
95 . . I (LINECNT+3)>IOSL D PAGEBK80
96 . . W !!,"SUB TOTAL= ",SUBTOT,!
97 . . S LINECNT=LINECNT+3
98 . . S SUBTOT=0
99 . . I GMRCBRK D PAGEBK80
100 . S SRT2=0
101 . F S SRT2=$O(^TMP("GMRCRPT",$J,SRT1,SRT2)) Q:'SRT2 Q:GMRCQUIT D
102 . . S SRT3=0
103 . . F S SRT3=$O(^TMP("GMRCRPT",$J,SRT1,SRT2,SRT3)) Q:'SRT3 Q:GMRCQUIT D
104 . . . S DISPLINE=^TMP("GMRCRPT",$J,SRT1,SRT2,SRT3)
105 . . . I GMRCFRST=1 D PAGEBK80 ; Kick out first page header
106 . . . I LINECNT>IOSL D PAGEBK80
107 . . . I GMRCQUIT Q
108 . . . ;
109 . . . ; STARTING WRITING THE PRINT LINE
110 . . . ;
111 . . . W !,$P(DISPLINE,"|",1) ;IEN
112 . . . W ?9,$P($$FMTE^XLFDT($P(DISPLINE,"^",7),2),"@",1) ;REQ DATE
113 . . . I GMRCSRCH=1 D
114 . . . . ; Provider not null, If null then it is an IFC record
115 . . . . I +$P(DISPLINE,"^",14) D
116 . . . . . W ?18,$E($$GET1^DIQ(200,$P(DISPLINE,"^",14),.01),1,16) ;PROVIDER
117 . . . . ; Provider null and REMOTE ORDERING PROVIDER not, this is an IFC record
118 . . . . I '+$P(DISPLINE,"^",14),$P(DISPLINE,"^",24)'="" D
119 . . . . . W ?18,$E($P(DISPLINE,"^",24),1,16)
120 . . . ; Location not null, If null then it is an IFC record
121 . . . I GMRCSRCH=2,+$P(DISPLINE,"^",4) D
122 . . . . W ?18,$E($$GET1^DIQ(44,$P(DISPLINE,"^",4),.01),1,16) ;LOCATION
123 . . . . ; Location null meaning IFC record. Use Ordering Facility
124 . . . I GMRCSRCH=2,$P(DISPLINE,"^",4)="",+$P(DISPLINE,"^",21) D
125 . . . . W ?18,$E($$GET1^DIQ(4,$P(DISPLINE,"^",21),.01),1,16) ;ORD FACILITY
126 . . . ; Location null, Ordering Facility null, use Routing Facilty
127 . . . ; Still an IFC record
128 . . . I GMRCSRCH=2,$P(DISPLINE,"^",4)="",'$P(DISPLINE,"^",21) D
129 . . . . I +$P(DISPLINE,"^",23) D
130 . . . . . W ?18,$E($$GET1^DIQ(4,$P(DISPLINE,"^",23),.01),1,16) ;ROUTIN FACILITY
131 . . . I GMRCSRCH=3 D
132 . . . . W ?18,$E($$GET1^DIQ(123.3,$P($P(DISPLINE,"^",8),";",1),.01),1,16) ; PROCEDURE
133 . . . W ?35,$E($$GET1^DIQ(2,$P(DISPLINE,"^",2),.01),1,20) ;PATIENT
134 . . . W ?56,$E($$GET1^DIQ(2,$P(DISPLINE,"^",2),.09),6,9) ;SSN
135 . . . W ?61,$E($$GET1^DIQ(123.5,$P(DISPLINE,"^",5),.01),1,15) ;TO SERVICE
136 . . . W ?77,$$GET1^DIQ(100.01,$P(DISPLINE,"^",12),.1) ;STATUS
137 . . . S LINECNT=LINECNT+1,TOTCNTR=TOTCNTR+1,SUBTOT=SUBTOT+1
138 Q
139PAGEBK32 ;
140 S GMRCFRST=0
141 K DIR
142 I ($E(IOST)="C")&(IO=IO(0))&(PAGE>0) D
143 .S DIR(0)="E"
144 .W !
145 .D ^DIR K DIR
146 I $D(DUOUT)!($D(DTOUT))!($D(DIROUT)) S GMRCQUIT=1 Q
147 W:$D(IOF) @IOF
148 S PAGE=PAGE+1
149 I $E(IOST)="C",IO=IO(0) W @IOF
150 E W !
151 N TEMPDATE,TEXTLEN,LINE
152 S TEMPDATE=$$NOW^XLFDT,TEMPDATE=$$FMTE^XLFDT(TEMPDATE,"P")
153 S TEMPDATE=TEMPDATE_" Page "_PAGE
154 I GMRCSRCH=1,GMRCBRK D
155 . W !,?6,"ORDERING PROVIDER: ",?26,SRT1
156 I GMRCSRCH=2,GMRCBRK D
157 . W !,?6,"LOCATION: ",?12,SRT1,?45
158 I GMRCSRCH=3,GMRCBRK D
159 . W !,?6,"PROCEDURE: ",?12,SRT1,?45
160 W !,"CONSULT LIST BY "_RPTTITL_", FOR SPECIFIED DATE(S)"
161 W ?97,TEMPDATE
162 I GMRCDT1>0 D
163 . W !,"FROM: ",$$FMTE^XLFDT(GMRCDT1,"D")," TO: ",$$FMTE^XLFDT(GMRCDT2-1,"D")
164 ELSE W !,"FROM: ALL"," TO: ALL"
165 W ?121,"LAST 4",?128,"CON"
166 W !!,"CONSULT #",?11,"REQUEST DATE"
167 I GMRCSRCH=1 W ?26,"ORDERING PROVIDER",?48,"TO SERVICE"
168 I GMRCSRCH=2 W ?26,"FROM LOCATION",?48,"TO SERVICE"
169 I GMRCSRCH=3 W ?26,"PROCEDURE",?48,"ASSOCIATED CONSULT SERVICE"
170 W ?89,"PATIENT NAME",?121,"SSN",?128,"STAT"
171 S LINE="",$P(LINE,"-",132)=""
172 W !,LINE
173 S LINECNT=$S(GMRCBRK=1:8,1:7)
174 S LINECNT=9
175 Q
176PAGEBK80 ;
177 S GMRCFRST=0
178 K DIR
179 I ($E(IOST)="C")&(IO=IO(0))&(PAGE>0) D
180 .S DIR(0)="E"
181 .W !
182 .D ^DIR K DIR
183 I $D(DUOUT)!($D(DTOUT))!($D(DIROUT)) S GMRCQUIT=1 Q
184 W:$D(IOF) @IOF
185 S PAGE=PAGE+1
186 I $E(IOST)="C",IO=IO(0) W @IOF
187 E W !
188 N TEMPDATE,TEXTLEN,LINE
189 S TEMPDATE=$$NOW^XLFDT,TEMPDATE=$$FMTE^XLFDT(TEMPDATE,"P")
190 S TEMPDATE=TEMPDATE_" Page "_PAGE
191 I GMRCSRCH=1,GMRCBRK D
192 . W !,?6,"ORDERING PROVIDER: ",?26,SRT1,?45,TEMPDATE
193 I GMRCSRCH=2,GMRCBRK D
194 . W !,?6,"LOCATION: ",?12,SRT1,?45,TEMPDATE
195 I GMRCSRCH=3,GMRCBRK D
196 . W !,?6,"PROCEDURE: ",?12,SRT1,?45,TEMPDATE
197 I 'GMRCBRK W !,?45,TEMPDATE
198 W !,"CONSULT LIST BY "_RPTTITL_", FOR SPECIFIED DATE(S)"
199 I GMRCDT1>0 D
200 . W !,"FROM: ",$$FMTE^XLFDT(GMRCDT1,"D")," TO: ",$$FMTE^XLFDT(GMRCDT2-1,"D")
201 ELSE W !,"FROM: ALL"," TO: ALL"
202 W !!,"CONSULT",?9,"REQ DATE"
203 I GMRCSRCH=1 W ?18,"ORDERING PROVIDER"
204 I GMRCSRCH=2 W ?18,"LOCATION"
205 I GMRCSRCH=3 W ?18,"PROCEDURE"
206 W ?37,"PATIENT NAME",?56,"SSN",?61,"TO SERVICE",?77,"ST"
207 S LINE="",$P(LINE,"-",80)=""
208 W !,LINE
209 S LINECNT=9
210 Q
211RPTT(GMRCSRCH) ; Title
212 S RPTTITL=$S(GMRCSRCH=1:"PROVIDER(S)",GMRCSRCH=2:"LOCATION(S)",1:"PROCEDURE(S)")
213 I GMRCSRCH'=3 D
214 . S RPTTITL=RPTTITL_" - "_$S(GMRCARRY(1)="ALL":"ALL ",1:"SELECTED ")_$S(GMRCARRY="L":"LOCAL",GMRCARRY="R":"REMOTE",1:"LOCAL & REMOTE")
215 Q RPTTITL
Note: See TracBrowser for help on using the repository browser.