source: FOIAVistA/trunk/r/SCHEDULING-SD-SC/SCRPW46.m@ 1397

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

initial load of FOIAVistA 6/30/08 version
File size: 9.6 KB
Line 
1SCRPW46 ;RENO/KEITH/MLR - Outpatient Diagnosis/Procedure Search (cont.) ; 9/27/00 10:29am
2 ;;5.3;Scheduling;**144,180,199,295,324,351**;AUG 13, 1993
3 ; *199*
4 ; - Creation of Division subscript in ^TMP after DFN to capture,
5 ; display, & count multi-divisional patients in Summary Section.
6 ; - Filtering out on Sub-header those Division names not having
7 ; patients meeting search criteria.
8 ;
9PDIS ;Parameter display
10 D SUBT^SCRPW50("**** Report Parameters Selected ****")
11 W ! D PD1^SCRPW47(0) S SDOUT=0
12 ;
13PDIS1 K DIR
14 S DIR(0)="S^C:CONTINUE;R:RE-DISPLAY PARAMETERS;P:PRINT PARAMETERS;Q:QUIT"
15 S DIR("A")="Select report action"
16 S DIR("B")="CONTINUE"
17 D ^DIR I $D(DTOUT)!$D(DUOUT) S SDOUT=1 Q
18 Q:Y="C" G:Y="R" PDIS I Y="Q" S SDOUT=1 Q
19 N ZTSAVE
20 F SDI="SDDIV","SDDIV(","SD(","SDPAR(","SDCRI(","SDFMT","SDAPF(" S ZTSAVE(SDI)=""
21 W ! D EN^XUTMDEVQ("PPRT^SCRPW46","Print Report Parameters",.ZTSAVE)
22 G PDIS1
23 ;
24PPRT ;Print report parameters
25 D:$E(IOST)="C" DISP0^SCRPW23
26 S SDTIT(1)="<*> OUTPATIENT DIAGNOSTIC/PROCEDURE CODE SEARCH <*>"
27 S SDTIT(2)="Report Search Parameters" D HINI,HDR
28 D:'SDOUT PD1^SCRPW47(0) I $E(IOST)="P",$D(ZTQUEUED) G EXIT^SCRPW47
29 Q ;PPRT
30 ;
31STOP ;Check for stop task request
32 S:$D(ZTQUEUED) (SDOUT,ZTSTOP)=$S($$S^%ZTLOAD:1,1:0) Q
33 ;
34HINI ;Initialize header variables
35 S SDLINE="",$P(SDLINE,"-",(IOM+1))=""
36 D NOW^%DTC S Y=% X ^DD("DD") S SDPNOW=$P(Y,":",1,2),SDPAGE=1,SDFF=0 Q
37 ;
38HDR ;Print report header
39 I $E(IOST)="C",SDFF N DIR S DIR(0)="E" W ! D ^DIR S SDOUT=Y'=1 Q:SDOUT
40 D STOP Q:SDOUT
41 I SDFF!('SDFF&($E(IOST)="C")) W $$XY^SCRPW50(IOF,1,0)
42 I $X W $$XY^SCRPW50("",0,0)
43 N SDI W SDLINE S SDI=0
44 F S SDI=$O(SDTIT(SDI)) Q:'SDI W !?(IOM-$L(SDTIT(SDI))\2),SDTIT(SDI)
45 W !,SDLINE,!,"For date range: ",SD("PBDT")," to ",SD("PEDT")
46 W !,"Date printed: ",SDPNOW,?(IOM-6-$L(SDPAGE)),"Page: ",SDPAGE
47 W !,SDLINE S SDPAGE=SDPAGE+1,SDFF=1
48 Q ;HDR
49 ;
50DHDR(SDIV,SDI,SDTIT) ;Set up division subheaders
51 ;Required input: SDIV=division ifn or '0' for summary
52 ;Required input: SDI=array number to start with
53 ;Required input: SDTIT=array to store subheaders in (pass by reference)
54 D ;
55 . I 'SDIV S SDTIT(SDI)="Summary for "_$P(SDDIV,U,2) Q
56 . I SDDIV,($P(SDDIV,U,2)="ALL DIVISIONS") S SDTIT(SDI)="For division: "_SDIVN_" "_SDIVL(SDIVN) Q ; SD*5.3*324
57 . S SDTIT(SDI)="For facility: "_SDIVN Q
58 ;S SDTIT(SDI)=$S('SDIV:"Summary for "_$P(SDDIV,U,2),SDDIV!($P(SDDIV,U,2)="ALL DIVISIONS"):"For division: "_SDIVN_" "_SDIVL(SDIVN),1:"For facility: "_SDIVN)
59 ;
60 I 'SDIV,$P(SDDIV,U,2)="SELECTED DIVISIONS" N SDIVN S SDIVN="" D Q
61 .F S SDIVN=$O(SDDIV(SDIVN)) Q:SDIVN="" S SDI=SDI+1,SDTIT(SDI)="Division: "_SDDIV(SDIVN)
62 .Q
63 ;
64 I 'SDIV,$P(SDDIV,U,2)="ALL DIVISIONS" D
65 .N SDIV S SDIV=0 F S SDIV=$O(^TMP("SCRPW",$J,SDIV)) Q:'SDIV D
66 .. Q:'$D(^TMP("SCRPW",$J,SDIV,2))
67 .. S SDI=SDI+1
68 .. S SDTIT(SDI)="Division: "_$P($G(^DG(40.8,SDIV,0)),U)_" "_SDIV
69 .Q
70 Q
71 ;
72START ;Print report
73 K ^TMP("SCRPW",$J) S (SDOUT,SDSTOP)=0,SDMD="",SDMD=$O(SDDIV(SDMD)),SDMD=$O(SDDIV(SDMD)) S:$P(SDDIV,U,2)="ALL DIVISIONS" SDMD=1
74 ;Iterate through list of patient encounters
75 S DFN=0 F S DFN=$O(^SCE("ADFN",DFN)) Q:'DFN K SDPDIV S SDSTOP=SDSTOP+1 D:SDSTOP#100=0 STOP Q:SDOUT D
76 .S SDT=SD("BDT") F S SDT=$O(^SCE("ADFN",DFN,SDT)) Q:'SDT!SDOUT!(SDT>SD("EDT")) D
77 ..S SDOE=0 F S SDOE=$O(^SCE("ADFN",DFN,SDT,SDOE)) Q:'SDOE!SDOUT D
78 ...S SDOE0=$$GETOE^SDOE(SDOE) S SDIV=$P(SDOE0,"^",11) Q:'SDIV!$P(SDOE0,"^",6)!'$$DIV() S SDPDIV(SDIV)=""
79 ...;Build initial patient diagnosis/procedure lists
80 ...I $D(SD("LIST","D")) K SDLIST D GETDX^SDOE(SDOE,"SDLIST") S SDI=0 F S SDI=$O(SDLIST(SDI)) Q:'SDI D
81 ....S SDDX=$P(SDLIST(SDI),"^") S:SDDX ^TMP("SCRPW",$J,0,0,DFN,SDIV,"DX",SDDX)=""
82 ....Q
83 ...I $D(SD("LIST","P")) K SDLIST D GETCPT^SDOE(SDOE,"SDLIST") S SDI=0 F S SDI=$O(SDLIST(SDI)) Q:'SDI D
84 ....S SDCPT=$P(SDLIST(SDI),"^") S:SDCPT ^TMP("SCRPW",$J,0,0,DFN,SDIV,"CPT",SDCPT)=""
85 ....;Loop through modifiers and add to CPT array
86 .... N SDMODN,SDMOD ; SDMODN=modifier node, SDMOD=mod pointer
87 .... S SDMODN=0
88 .... F S SDMODN=+$O(SDLIST(SDI,1,SDMODN)) Q:'SDMODN D
89 ..... S SDMOD=$P(SDLIST(SDI,1,SDMODN,0),"^",1)
90 ..... S:SDMOD ^TMP("SCRPW",$J,0,0,DFN,SDIV,"CPT",SDCPT,SDMOD)=""
91 ..... Q
92 .... Q
93 ...S:$P(SDFMT,"^")="E" ^TMP("SCRPW",$J,SDIV,1,DFN,SDIV,"ACT",SDT,SDOE)=SDOE0
94 ...S:$P(SDFMT,"^")="V" ^TMP("SCRPW",$J,SDIV,1,DFN,SDIV,"ACT",$P(SDT,"."))=""
95 ...S:$P(SDFMT,"^")="P" ^TMP("SCRPW",$J,SDIV,1,DFN,SDIV,"ACT")=""
96 ...Q
97 ..Q
98 .I '$D(^TMP("SCRPW",$J,0,0,DFN)) D Q
99 ..N SDIV S SDIV="" F S SDIV=$O(SDPDIV(SDIV)) Q:SDIV="" K ^TMP("SCRPW",$J,SDIV,1,DFN)
100 ..Q
101 .;Build text lists for Diagnosis ranges if necessary
102 .I $D(SD("LIST","D","R")) D
103 .. N SDIV S SDIV="" F S SDIV=$O(SDPDIV(SDIV)) Q:'SDIV D
104 ... S SDI=0 F S SDI=$O(^TMP("SCRPW",$J,0,0,DFN,SDIV,"DX",SDI)) Q:'SDI D
105 ....S SDX=$$ICDDX^ICDCODE(SDI,+SDOE0),SDX=$P(SDX,"^",2)_" "_$P(SDX,"^",4)
106 .... S:$L(SDX)>1 ^TMP("SCRPW",$J,0,0,DFN,SDIV,"DXR",SDX)=SDI
107 .;Building text list for Procedure ranges
108 .I $D(SD("LIST","P","R")) S SDI=0 F S SDI=$O(^TMP("SCRPW",$J,0,0,DFN,SDIV,"CPT",SDI)) Q:'SDI D
109 ..; SDI=CPT pointer, SDI2=mod ptr, SDX=CPT+desc, SDX2=mod+desc
110 ..; get CPT and description and build array entry
111 .. N CPTINFO,CPTCODE,CPTTEXT
112 .. S CPTINFO=$$CPT^ICPTCOD(SDI,+SDOE0,1)
113 .. Q:CPTINFO'>0
114 .. S CPTCODE=$P(CPTINFO,"^",2)
115 .. S CPTTEXT=$P(CPTINFO,"^",3)
116 .. S SDX=CPTCODE_" "_CPTTEXT
117 .. S:$L(SDX)>1 ^TMP("SCRPW",$J,0,0,DFN,SDIV,"CPTR",SDX)=SDI
118 ..;
119 ..; loop through mods in CPT array and call API to get mod code/desc
120 .. S SDI2="" F S SDI2=$O(^TMP("SCRPW",$J,0,0,DFN,SDIV,"CPT",SDI,SDI2)) Q:'SDI2 D
121 ... N MODINFO,MODCODE,MODTEXT
122 ... S MODINFO=$$MOD^ICPTMOD(SDI2,"I",+SDOE0,1)
123 ... Q:MODINFO'>0
124 ... S MODCODE=$P(MODINFO,"^",2)
125 ... S MODTEXT=$P(MODINFO,"^",3)
126 ... S SDX2=MODCODE_" "_MODTEXT
127 ... ; add mod code/desc to array
128 ... S:$L(SDX2)>1 ^TMP("SCRPW",$J,0,0,DFN,SDIV,"CPTR",SDX,SDX2)=SDI2
129 ... Q
130 ..Q
131 .;Iterate through criteria combine logic
132 .;Loop through secondary Division (SDIV) for multiple division episodes
133 . N SDIV S SDIV="" F S SDIV=$O(SDPDIV(SDIV)) Q:SDIV="" D
134 .. S SDCRI="" F S SDCRI=$O(SDCRI(SDCRI)) Q:SDCRI="" D
135 ... S SDCL=$TR($TR(SDCRI,"'",""),"&","") F SDI=1:1:$L(SDCL) S SDC=$E(SDCL,SDI) D:'$D(^TMP("SCRPW",$J,0,0,DFN,SDIV,"CRI",SDC))
136 ....;Build list of true items for each criteria element
137 .... S SDZ=$P(SDPAR(SDC),"^")
138 .... I SDZ="DL" S SDI=0 F S SDI=$O(^TMP("SCRPW",$J,0,0,DFN,SDIV,"DX",SDI)) Q:'SDI D
139 ..... S:$D(SDPAR(SDC,SDI)) ^TMP("SCRPW",$J,0,0,DFN,SDIV,"CRI",SDC,SDI)=""
140 ..... Q
141 .... I SDZ="DR" S SDR1="",SDR1=$O(SDPAR(SDC,SDR1)),SDR2=$O(SDPAR(SDC,SDR1)),SDI="" D
142 ..... F S SDI=$O(^TMP("SCRPW",$J,0,0,DFN,SDIV,"DXR",SDI)) Q:SDI="" D
143 ...... I SDR1']SDI,SDI']SDR2 S ^TMP("SCRPW",$J,0,0,DFN,SDIV,"CRI",SDC,SDI)="" Q
144 ..... Q
145 .... I SDZ="PL" S SDI=0 F S SDI=$O(^TMP("SCRPW",$J,0,0,DFN,SDIV,"CPT",SDI)) Q:'SDI D
146 ..... I $D(SDPAR(SDC,SDI)) M ^TMP("SCRPW",$J,0,0,DFN,SDIV,"CRI",SDC,SDI)=^TMP("SCRPW",$J,0,0,DFN,SDIV,"CPT",SDI)
147 ..... Q
148 .... I SDZ="PR" S SDR1="",SDR1=$O(SDPAR(SDC,SDR1)),SDR2=$O(SDPAR(SDC,SDR1)),SDI="" D
149 ..... F S SDI=$O(^TMP("SCRPW",$J,0,0,DFN,SDIV,"CPTR",SDI)) Q:SDI="" D
150 ...... I SDR1']SDI,SDI']SDR2 M ^TMP("SCRPW",$J,0,0,DFN,SDIV,"CRI",SDC,SDI)=^TMP("SCRPW",$J,0,0,DFN,SDIV,"CPTR",SDI)
151 ......Q
152 .....Q
153 ....S ^TMP("SCRPW",$J,0,0,DFN,SDIV,"CRI",SDC)=($D(^TMP("SCRPW",$J,0,0,DFN,SDIV,"CRI",SDC))>0)_U_SDZ
154 .... Q
155 ...;Apply criteria combine logic
156 ...N A,B,C,D,E,F,G,H,I,J,K,L,M,N,O,P,Q,R,S,T,U,V,W,X,Y,Z
157 ...F SDI=1:1:$L(SDCL) S SDC=$E(SDCL,SDI),@SDC=$P(^TMP("SCRPW",$J,0,0,DFN,SDIV,"CRI",SDC),"^")
158 ...;If combine logic is "true", move items to final list
159 ...I @SDCRI F SDI=1:1:$L(SDCL) S SDC=$E(SDCL,SDI),SDX=^TMP("SCRPW",$J,0,0,DFN,SDIV,"CRI",SDC) D
160 ....I SDX M ^TMP("SCRPW",$J,0,1,DFN,SDIV,$P(SDX,"^",2))=^TMP("SCRPW",$J,0,0,DFN,SDIV,"CRI",SDC)
161 ....Q
162 ...Q
163 .I '$D(^TMP("SCRPW",$J,0,1,DFN)) D Q
164 ..S SDIV="" F S SDIV=$O(SDPDIV(SDIV)) Q:SDIV="" K ^TMP("SCRPW",$J,SDIV,1,DFN)
165 ..Q
166 .;Move item ifn lists to text lists
167 .N SDIV S SDIV="" F S SDIV=$O(SDPDIV(SDIV)) Q:SDIV="" D
168 .. S SDI=0 F S SDI=$O(^TMP("SCRPW",$J,0,1,DFN,SDIV,"DL",SDI)) Q:'SDI D
169 ... S SDX=$$ICDDX^ICDCODE(SDI,+SDOE0),SDX=$P(SDX,"^",2)_" "_$P(SDX,"^",4) S:$L(SDX)>1 ^TMP("SCRPW",$J,0,1,DFN,SDIV,"DR",SDX)=$G(SDT)
170 ... Q
171 .N SDIV S SDIV="" F S SDIV=$O(SDPDIV(SDIV)) Q:SDIV="" D
172 .. S SDI=0 F S SDI=$O(^TMP("SCRPW",$J,0,1,DFN,SDIV,"PL",SDI)) Q:'SDI D
173 ... N CPTINFO,CPTCODE,CPTTEXT
174 ... S CPTINFO=$$CPT^ICPTCOD(SDI,+SDOE0,1)
175 ... Q:CPTINFO'>0
176 ... S CPTCODE=$P(CPTINFO,"^",2)
177 ... S CPTTEXT=$P(CPTINFO,"^",3)
178 ... S SDX=CPTCODE_" "_CPTTEXT
179 ... S:$L(SDX)>1 ^TMP("SCRPW",$J,0,1,DFN,SDIV,"PR",SDX)=""
180 ... ;
181 ... ;loop through mods in CPT array and call API to get mod code/desc
182 ... S SDI2=""
183 ... F S SDI2=$O(^TMP("SCRPW",$J,0,1,DFN,SDIV,"PL",SDI,SDI2)) Q:'SDI2 D
184 .... N MODINFO,MODCODE,MODTEXT
185 .... S MODINFO=$$MOD^ICPTMOD(SDI2,"I",+SDOE0,1)
186 .... Q:MODINFO'>0
187 .... S MODCODE=$P(MODINFO,"^",2)
188 .... S MODTEXT=$P(MODINFO,"^",3)
189 .... S SDX2=MODCODE_" "_MODTEXT
190 .... ; add mod code/desc to array
191 .... S:$L(SDX2)>1 ^TMP("SCRPW",$J,0,1,DFN,SDIV,"PR",SDX,SDX2)=""
192 .... Q
193 ...Q
194 . ; delete procedure list array
195 . N SDIV S SDIV="" F S SDIV=$O(SDPDIV(SDIV)) Q:SDIV="" D
196 ..;Merge activity list
197 .. M ^TMP("SCRPW",$J,SDIV,1,DFN,SDIV,"ACT")=^TMP("SCRPW",$J,SDIV,0,DFN,SDIV,"ACT")
198 ..;Kill scratch list, merge to summary global if multidivisional
199 ..I SDMD,SDFMT'="P" M ^TMP("SCRPW",$J,0,1,DFN,SDIV,"ACT")=^TMP("SCRPW",$J,SDIV,1,DFN,SDIV,"ACT")
200 ..;Delete scratch levels and arrays after merge
201 .. K ^TMP("SCRPW",$J,0,1,DFN,"DL")
202 .. K ^TMP("SCRPW",$J,0,1,DFN,"PL")
203 ..Q
204 .Q
205 ;Delete 0,0 scratch level prior to printing
206 K ^TMP("SCRPW",$J,0,0)
207 G:SDOUT EXIT^SCRPW47 G ^SCRPW47
208 ;
209DIV() ;Check division
210 Q:'SDDIV 1 Q $D(SDDIV(+SDIV))
Note: See TracBrowser for help on using the repository browser.