source: FOIAVistA/tag/r/SCHEDULING-SD-SC/SCRPW40.m@ 1540

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

initial load of FOIAVistA 6/30/08 version
File size: 9.0 KB
Line 
1SCRPW40 ;RENO/KEITH - Diagnosis/Procedure Frequency Report ;06/22/99
2 ;;5.3;Scheduling;**144,180**;AUG 13, 1993
3 ;06/22/99 ACS - Added CPT modifiers to the report
4 ;06/22/99 ACS - Added CPT modifier API calls
5 ;
6 N SDDIV,SD,%DT,X,Y,DIR,SDX,LINEFLAG
7 D TITL^SCRPW50("Outpatient Diagnosis/Procedure Frequncy Report")
8 I '$$DIVA^SCRPW17(.SDDIV) S SDOUT=1 G EXIT
9 D SUBT^SCRPW50("**** Date Range Selection ****")
10 W ! S %DT="AEPX",%DT(0)=2961001,%DT("A")="Beginning date: " D ^%DT I Y<1 S SDOUT=1 G EXIT
11 S SD("BDT")=Y
12EDT S %DT("A")=" Ending date: " W ! D ^%DT I Y<1 S SDOUT=1 G EXIT
13 I Y<SD("BDT") W !!,$C(7),"End date cannot be before begin date!",! G EDT
14 S SD("EDT")=Y_.999999
15 D SUBT^SCRPW50("**** Report Format Selection ****")
16 K DIR S DIR(0)="S^D:DIAGNOSIS FREQUENCY;P:PROCEDURE FREQUENCY;B:BOTH DIAGNOSIS AND PROCEDURE",DIR("A")="Specify the type of report to print",DIR("?")="This determines the type of lists returned by the report."
17 D ^DIR I $D(DTOUT)!$D(DUOUT) S SDOUT=1 G EXIT
18 S SD("TYPE")=Y
19 K DIR S DIR(0)="N^1:99999:0",DIR("A")="Limit list to most frequent",DIR("B")=50,DIR("?")="Enter the quantity of the most frequent items to list."
20 W ! D ^DIR I $D(DTOUT)!$D(DUOUT) S SDOUT=1 G EXIT
21 S SD("FREQ")=Y
22 W ! N ZTSAVE S ZTSAVE("SDDIV")="",ZTSAVE("SDDIV(")="",ZTSAVE("SD(")="" D EN^XUTMDEVQ("START^SCRPW40","Outpatient Diagnosis/Procedure Frequency Report",.ZTSAVE) S SDOUT=1 G EXIT
23 ;
24START ;Print report
25 S (SDOUT,SDSTOP)=0 K ^TMP("SCRPW",$J) S SDI=$O(SDDIV("")),SDI=$O(SDDIV(SDI)) S:$P(SDDIV,U,2)="ALL DIVISIONS" SDI=1 S SDDIV("MULT")=SDI
26 S SDT=SD("BDT") F S SDT=$O(^SCE("B",SDT)) Q:'SDT!(SDT>SD("EDT"))!SDOUT S SDOE=0 F S SDOE=$O(^SCE("B",SDT,SDOE)) Q:'SDOE!SDOUT S SDOE0=$$GETOE^SDOE(SDOE) I '$P(SDOE0,U,6),$P(SDOE0,U,2),$P(SDOE0,U,4),$$DIV() D EVAL
27 G:SDOUT EXIT S SDIV="" F S SDIV=$O(^TMP("SCRPW",$J,SDIV)) Q:SDIV="" D ORD
28 D STOP G:SDOUT EXIT D NOW^%DTC S Y=% X ^DD("DD") S SDPNOW=$P(Y,":",1,2),SDPAGE=1,SDLINE="",$P(SDLINE,"-",(IOM+1))="",SDFF=0
29 S Y=SD("BDT") X ^DD("DD") S SDPBDT=Y,Y=$P(SD("EDT"),".") X ^DD("DD") S SDPEDT=Y,SDT(1)="<*> OUTPATIENT "_$S(SD("TYPE")="D":"DIAGNOSIS",SD("TYPE")="P":"PROCEDURE",1:"DIAGNOSIS/PROCEDURE")_" FREQUENCY REPORT <*>"
30 S SDT(2)="For the "_SD("FREQ")_" most frequent "_$S(SD("TYPE")="D":"diagnoses",SD("TYPE")="P":"procedures",1:"diagnoses and procedures")
31 S SDIV="" F S SDIV=$O(SDDIV(SDIV)) Q:'SDIV S SDIV(SDDIV(SDIV))=SDIV
32 I 'SDDIV,$P(SDDIV,U,2)'="ALL DIVISIONS" S SDIV($P(SDDIV,U,2))=$$PRIM^VASITE()
33 I $P(SDDIV,U,2)="ALL DIVISIONS" S SDI=0 F S SDI=$O(^TMP("SCRPW",$J,SDI)) Q:'SDI S SDX=$P($G(^DG(40.8,SDI,0)),U) S:$L(SDX) SDIV(SDX)=SDI
34 D:$E(IOST)="C" DISP0^SCRPW23 I '$O(^TMP("SCRPW",$J,0)) S SDIV=0 D DHDR(2,.SDT) D HDR Q:SDOUT S SDX="No activity found within selected report parameters!" W !!?(IOM-$L(SDX)\2),SDX G EXIT
35 S SDIVN="" F S SDIVN=$O(SDIV(SDIVN)) Q:SDIVN=""!SDOUT S SDIV=SDIV(SDIVN) D DPRT(.SDIV)
36 S SDI=0,SDI=$O(^TMP("SCRPW",$J,SDI)),SDDIV("MULT")=$O(^TMP("SCRPW",$J,SDI))
37 G:SDOUT EXIT I SDDIV("MULT") S SDIV=0 D DPRT(.SDIV)
38 ;
39EXIT I $E(IOST)="C",'$G(SDOUT) N DIR S DIR(0)="E" D ^DIR
40 K %,%DT,C,DIR,DIVN,DTOUT,DUOUT,SD,SDCT,SDDIV,SDDX,SDDX0,SDDXC,SDDXN,SDFF,SDI,SDII,SDIV,SDIVN,SDLINE,SDLIST,SDOE,SDOE0
41 K SDX,SDORD,SDOUT,SDPAGE,SDPBDT,SDPEDT,SDPNOW,SDPR,SDPR0,SDPRC,SDPRN,SDPROC,SDPS,SDQT,SDSTOP,SDT,SDTOT,X,Y D END^SCRPW50 Q
42 ;
43DIV() ;Check division
44 Q:'SDDIV 1 Q $D(SDDIV(+$P(SDOE0,U,11)))
45 ;
46STOP ;Check for stop task request
47 S:$D(ZTQUEUED) (SDOUT,ZTSTOP)=$S($$S^%ZTLOAD:1,1:0) Q
48 ;
49EVAL ;Evaluate encounter
50 S SDSTOP=SDSTOP+1 D:SDSTOP#3000=0 STOP Q:SDOUT
51 S SDIV=+$P(SDOE0,U,11) D:"DB"[SD("TYPE") DX D:"PB"[SD("TYPE") PROC Q
52 ;
53DX ;Get diagnoses
54 N SDLIST,SDI D GETDX^SDOE(SDOE,"SDLIST")
55 S SDI=0 F S SDI=$O(SDLIST(SDI)) Q:'SDI D DX1(SDIV) D:SDDIV("MULT") DX1(0)
56 Q
57 ;
58DX1(SDIV) S SDDX=+SDLIST(SDI),SDPS=$S($P(SDLIST(SDI),U,12)="P":"PRI",1:"SEC")
59 F SDPS=SDPS,"QTY" S ^TMP("SCRPW",$J,SDIV,"DX",1,SDDX,SDPS)=$G(^TMP("SCRPW",$J,SDIV,"DX",1,SDDX,SDPS))+1
60 Q
61 ;
62PROC ;Get procedures
63 N SDLIST,SDI D GETCPT^SDOE(SDOE,"SDLIST")
64 S SDI=0 F S SDI=$O(SDLIST(SDI)) Q:'SDI D PROC1(SDIV) D:SDDIV("MULT") PROC1(0)
65 Q
66 ;
67PROC1(SDIV) S SDPROC=+SDLIST(SDI),SDQT=$P(SDLIST(SDI),U,16) S:'SDQT SDQT=1
68 S ^TMP("SCRPW",$J,SDIV,"PROC",1,SDPROC,"ENC")=$G(^TMP("SCRPW",$J,SDIV,"PROC",1,SDPROC,"ENC"))+1
69 S ^TMP("SCRPW",$J,SDIV,"PROC",1,SDPROC,"QTY")=$G(^TMP("SCRPW",$J,SDIV,"PROC",1,SDPROC,"QTY"))+SDQT
70 ;
71 ;set encounter and modifier quantity
72 N SDMOD,SDMODN
73 S SDMODN=0
74 F S SDMODN=$O(SDLIST(SDI,1,SDMODN)) Q:SDMODN="" D
75 . S SDMOD=$G(SDLIST(SDI,1,SDMODN,0))
76 . Q:SDMOD=""
77 . S ^TMP("SCRPW",$J,SDIV,"PROC",1,SDPROC,SDMOD,"ENC")=+1
78 . S ^TMP("SCRPW",$J,SDIV,"PROC",1,SDPROC,SDMOD,"QTY")=+SDQT
79 . Q
80 Q
81 ;
82ORD ;Determine list order
83 S SDI="" F S SDI=$O(^TMP("SCRPW",$J,SDIV,SDI)) Q:SDI="" S SDII=0 F S SDII=$O(^TMP("SCRPW",$J,SDIV,SDI,1,SDII)) Q:'SDII S ^TMP("SCRPW",$J,SDIV,SDI,2,$$ORDV(),SDII)=""
84 Q
85 ;
86ORDV() Q ^TMP("SCRPW",$J,SDIV,SDI,1,SDII,"QTY")
87 ;
88DPRT(SDIV) ;Print report for a division
89 ;Required input: SDIV=division ifn (or '0' for summary)
90 S C=(IOM-80\2) D DHDR(3,.SDT) I '$D(^TMP("SCRPW",$J,SDIV)) S SDPAGE=1 D HDR Q:SDOUT S SDX="No activity found for this date range!" W !!?(IOM-$L(SDX)\2),SDX Q
91 I $D(^TMP("SCRPW",$J,SDIV,"DX")) D DXPRT Q:SDOUT
92 I $D(^TMP("SCRPW",$J,SDIV,"PROC")) D PRPRT
93 Q
94 ;
95DXPRT ;Print diagnosis list
96 N SDTOT S SDPAGE=1 D HDR Q:SDOUT D DXHD S (SDCT,SDORD)="" F S SDORD=$O(^TMP("SCRPW",$J,SDIV,"DX",2,SDORD),-1) Q:SDORD=""!SDOUT!(SDCT>(SD("FREQ")-1)) D DXP1
97 Q:SDOUT D:$Y>(IOSL-4) HDR,DXHD Q:SDOUT
98 W !?(C),$E(SDLINE,1,7),?(C+9),$E(SDLINE,1,35),?(C+46),$E(SDLINE,1,10),?(C+58),$E(SDLINE,1,10),?(C+70),$E(SDLINE,1,10)
99 W !?(C),"TOTAL:",?(C+46),$J(SDTOT("PRI"),9,0),?(C+58),$J(SDTOT("SEC"),9,0),?(C+70),$J(SDTOT("QTY"),9,0)
100 Q
101 ;
102DXP1 S SDI=0 F S SDI=$O(^TMP("SCRPW",$J,SDIV,"DX",2,SDORD,SDI)) Q:'SDI!SDOUT!(SDCT>(SD("FREQ")-1)) S SDDX0=$G(^ICD9(SDI,0)) I $L(SDDX0) S SDDXC=$P(SDDX0,U),SDDXN=$P(SDDX0,U,3) D DXP2
103 Q
104 ;
105DXP2 F SDII="PRI","SEC","QTY" S SDDX(SDII)=+$G(^TMP("SCRPW",$J,SDIV,"DX",1,SDI,SDII))
106 D:$Y>(IOSL-4) HDR,DXHD Q:SDOUT S SDCT=SDCT+1 W !?(C),SDDXC,?(C+9),$E(SDDXN,1,35),?(C+46),$J(SDDX("PRI"),9,0),?(C+58),$J(SDDX("SEC"),9,0),?(C+70),$J(SDDX("QTY"),9,0)
107 F SDII="PRI","SEC","QTY" S SDTOT(SDII)=$G(SDTOT(SDII))+SDDX(SDII)
108 Q
109 ;
110PRPRT N SDTOT S C=(IOM-62\2),SDPAGE=1 D HDR Q:SDOUT D PRHD S (SDCT,SDORD)="" F S SDORD=$O(^TMP("SCRPW",$J,SDIV,"PROC",2,SDORD),-1) Q:SDORD=""!SDOUT!(SDCT>(SD("FREQ")-1)) D PRP1
111 Q:SDOUT D:$Y>(IOSL-4) HDR,PRHD Q:SDOUT
112 W !?(C),$E(SDLINE,1,6),?(C+8),$E(SDLINE,1,28),?(C+38),$E(SDLINE,1,10),?(C+50),$E(SDLINE,1,10),!?(C),"PROCEDURE TOTAL:",?(C+38),$J(SDTOT("ENC"),9,0),?(C+50),$J(SDTOT("QTY"),9,0)
113 Q
114 ;
115PRP1 ;S SDI=0 F S SDI=$O(^TMP("SCRPW",$J,SDIV,"PROC",2,SDORD,SDI)) Q:'SDI!SDOUT!(SDCT>(SD("FREQ")-1)) S SDPR0=$G(^ICPT(SDI,0)) I $L(SDPR0) S SDPRC=$P(SDPR0,U),SDPRN=$P(SDPR0,U,2) D PRP2
116 N CPTINFO
117 S SDI=0 F S SDI=$O(^TMP("SCRPW",$J,SDIV,"PROC",2,SDORD,SDI)) Q:'SDI!SDOUT!(SDCT>(SD("FREQ")-1)) D
118 . S CPTINFO=$$CPT^ICPTCOD(SDI,,1)
119 . Q:CPTINFO'>0
120 . S SDPRC=$P(CPTINFO,U,2)
121 . S SDPRN=$P(CPTINFO,U,3)
122 . D PRP2
123 . Q
124 Q
125 ;
126PRP2 F SDII="ENC","QTY" S SDPR(SDII)=+$G(^TMP("SCRPW",$J,SDIV,"PROC",1,SDI,SDII))
127 D:$Y>(IOSL-4) HDR,PRHD Q:SDOUT S SDCT=SDCT+1
128 ; skip a line in the report if printing next cpt code on same page
129 I LINEFLAG W !
130 W !?(C),SDPRC,?(C+8),SDPRN,?(C+38),$J(SDPR("ENC"),9,0),?(C+50),$J(SDPR("QTY"),9,0)
131 S LINEFLAG=1
132 F SDII="ENC","QTY" S SDTOT(SDII)=$G(SDTOT(SDII))+SDPR(SDII)
133 ;
134 ;rank and print the modifiers
135 D START^SCRPW401($NA(^TMP("SCRPW",$J,SDIV,"PROC",1,SDI)))
136 Q
137 ;
138PRHD ;Print procedure subheader
139 S LINEFLAG=0 Q:SDOUT W !!?(C),"CODE",!?(C),"NUMBER",?(C+8),"PROCEDURE/MODIFIER",?(C+38),"ENCOUNTERS",?(C+52),"QUANTITY",!?(C),$E(SDLINE,1,6),?(C+8),$E(SDLINE,1,28),?(C+38),$E(SDLINE,1,10),?(C+50),$E(SDLINE,1,10)
140 Q
141 ;
142DXHD ;Print diagnosis subheader
143 Q:SDOUT W !!?(C),"CODE",?(C+49),"PRIMARY",?(C+59),"SECONDARY",?(C+75),"TOTAL",!?(C),"NUMBER",?(C+9),"DIAGNOSIS",?(C+47),"DIAGNOSIS",?(C+59),"DIAGNOSIS",?(C+71),"FREQUENCY"
144 W !?(C),$E(SDLINE,1,7),?(C+9),$E(SDLINE,1,35),?(C+46),$E(SDLINE,1,10),?(C+58),$E(SDLINE,1,10),?(C+70),$E(SDLINE,1,10) Q
145 ;
146HDR ;Print report header
147 I $E(IOST)="C",SDFF N DIR S DIR(0)="E" W ! D ^DIR S SDOUT=Y'=1 Q:SDOUT
148 D STOP Q:SDOUT
149 I SDFF!($E(IOST)="C") W $$XY^SCRPW50(IOF,1,0)
150 I $X W $$XY^SCRPW50("",0,0)
151 N SDI W SDLINE S SDI=0 F S SDI=$O(SDT(SDI)) Q:'SDI W !?(IOM-$L(SDT(SDI))\2),SDT(SDI)
152 W !,SDLINE,!,"For date range: ",SDPBDT," to ",SDPEDT,!,"Date printed: ",SDPNOW,?(IOM-6-$L(SDPAGE)),"Page: ",SDPAGE,!,SDLINE S SDPAGE=SDPAGE+1,SDFF=1 Q
153 ;
154DHDR(SDI,SDT) ;Set up division subheaders
155 ;Required input: SDI=array number to start with
156 ;Required input: SDT=array to store subheaders in (pass by reference)
157 S SDT(SDI)=$S('SDIV:"Summary for "_$P(SDDIV,U,2),SDDIV!($P(SDDIV,U,2)="ALL DIVISIONS"):"For division: "_SDIVN,1:"For facility: "_SDIVN)
158 I 'SDIV,$P(SDDIV,U,2)="SELECTED DIVISIONS" N SDIVN S SDIVN="" D Q
159 .F S SDIVN=$O(SDIV(SDIVN)) Q:SDIVN="" S SDI=SDI+1,SDT(SDI)="Division: "_SDIVN
160 .Q
161 I 'SDIV,$P(SDDIV,U,2)="ALL DIVISIONS" D
162 .N SDIV S SDIV=0 F S SDIV=$O(^TMP("SCRPW",$J,SDIV)) Q:'SDIV S SDI=SDI+1,SDT(SDI)="Division: "_$P($G(^DG(40.8,SDIV,0)),U)
163 .Q
164 Q
Note: See TracBrowser for help on using the repository browser.