source: FOIAVistA/tag/r/EVENT_CAPTURE-EC--ECT--ECX/ECPROV3.m@ 628

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

initial load of FOIAVistA 6/30/08 version
File size: 6.0 KB
Line 
1ECPROV3 ;BIR/MAM,JPW-Event Capture Provider Summary (cont'd) ;7 May 96
2 ;;2.0; EVENT CAPTURE ;**5,8,18,29,47,56,63,72**;8 May 96
3 ; This routine is used when printing the report for
4 ; all ACCESSIBLE DSS Units
5 ;JAM/3/7/03, This routine now combines ECPROV3, ECPROV4 and ECPROV5
6 ;
7 S %H=$H D YX^%DTC S ECRDT=Y
8 I ECL D D LOC,PRINT Q
9 .I ECPRV=1 D UNIT Q
10 .I 'ECPRV S ECC=+$P(^ECD(ECD,0),U,11) Q
11 S ECL=0 D
12 .F I=0:0 S ECL=$O(^ECH("ADT",ECL)) Q:'ECL D
13 ..S ECLN=$P(^DIC(4,ECL,0),"^") I ECPRV D UNIT
14 ..I 'ECPRV S ECC=+$P(^ECD(ECD,0),U,11)
15 ..D LOC
16PRINT ;Changes below were made by VMP to correct NOIS ATG-1003-32545
17 S (ECLN,ECPN)=0,ECCN=""
18 F I=0:0 S ECLN=$O(^TMP($J,ECLN)) Q:ECLN=""!(ECOUT)!(ECLN["^") D
19 .I 'ECPRV D CATS Q
20 . S ECDN="" D NOUNIT F I=0:0 S ECDN=$O(^TMP($J,ECLN,ECDN)) Q:ECDN=""!(ECOUT) D CATS
21 K ECPNAM
22 Q
23CATS ; continue looping
24 I $O(^TMP($J,ECLN,ECDN,""))']"" D PAGE W !!!,?12,"NO PROCEDURES" S ECPG=1 Q
25 D PAGE Q:ECOUT S ECPG=1,ECUN=0 F I=0:0 S ECUN=$O(^TMP($J,ECLN,ECDN,ECUN)) Q:ECUN=""!(ECOUT) S ECINZ="^"_$O(^(ECUN,0)) D:$Y+7>IOSL PAGE Q:ECOUT D PRO
26 Q
27PRO I $Y+10>IOSL D PAGE I ECOUT Q
28 W !!,ECUN S ECCN=0 F I=0:0 S ECCN=$O(^TMP($J,ECINZ,ECCN)) D:ECCN="" TOTP Q:ECCN=""!(ECOUT) D MORE
29 Q
30MORE ;
31 ;ALB/ESD - Loop through to get procedure reason and print
32 W !,?3,ECCN S ECPN=0,(ECPRSN,ECPI)=""
33 F S ECPN=$O(^TMP($J,ECINZ,ECCN,ECPN)) Q:ECPN=""!(ECOUT) S ECUSER=1 D:$Y+7>IOSL PAGE Q:ECOUT K ECUSER F S ECPRSN=$O(^TMP($J,ECINZ,ECCN,ECPN,ECPRSN)) Q:ECPRSN=""!(ECOUT) DO
34 .S ECCPT=$S($P(ECPN,"~",3)="I":$P(ECPN,"~",2),1:$P($G(^EC(725,$P(ECPN,"~",2),0)),"^",5))
35 .I ECCPT'="" D
36 ..;Changes made by VMP to correct NOIS ATG-1003-32545
37 ..;use end date/date range to get CPT description; CTD project.
38 ..S ECPI=$$CPT^ICPTCOD(ECCPT,$P(ECED,".")),ECCPT=$P(ECPI,"^",2)
39 .S EC725="" I $P(ECPN,"~",3)="E" S EC725=$G(^EC(725,+$P(ECPN,"~",2),0))
40 .S ECPNAM=$S($P(ECPN,"~",3)="E":$P(EC725,"^",2)_" "_$P(EC725,"^"),$P(ECPN,"~",3)="I":$P(ECPI,"^",3),1:"UNKNOWN")
41 .S ECPSY=$P(ECPN,"~",4),ECPSYN=""
42 .I ECPSY'="" S ECPSYN=$P($G(^ECJ(ECPSY,"PRO")),"^",2)
43 .W !,?6,$J(ECCPT_" ",6),$E(ECPNAM,1,40)
44 .W:ECPSYN'="" " [",$E(ECPSYN,1,25),"]"
45 .W:$D(ECRY) ?70,ECPRSN
46 .W ?105,$J(^TMP($J,ECINZ,ECCN,ECPN,ECPRSN),6)
47 .;print CPT procedure modifiers
48 .S IEN=""
49 .F S IEN=$O(^TMP($J,ECINZ,ECCN,ECPN,ECPRSN,"MOD",IEN)) Q:IEN="" D I ECOUT Q
50 ..;used end date to get description,CTD project
51 ..S MODI=$$MOD^ICPTMOD(IEN,"I",$P(ECED,"."))
52 ..S MOD=$P(MODI,"^",2) I MOD="" K MODI Q
53 ..S MODESC=$P(MODI,"^",3) I MODESC="" S MODESC="UNKNOWN"
54 ..S MODAMT=^TMP($J,ECINZ,ECCN,ECPN,ECPRSN,"MOD",IEN)
55 ..W !?10,"- ",MOD," ",MODESC," (",MODAMT,")"
56 ..I ($Y+3)>IOSL D PAGE
57 .K MODESC,MOD,IEN,MODAMT,MODI,EC725
58 Q
59LOC S (ECDFN,ECOUT,^TMP($J,ECLN))=0
60 F I=0:0 S ECDFN=$O(^ECH("ADT",ECL,ECDFN)) Q:'ECDFN D
61 .I ECPRV D GECD Q
62 .D GMM
63 Q
64GECD S ECD=0 F I=0:0 S ECD=$O(^ECH("ADT",ECL,ECDFN,ECD)) Q:'ECD D GMM
65 Q
66GMM S MM=ECSD F I=0:0 S MM=$O(^ECH("ADT",ECL,ECDFN,ECD,MM)) Q:'MM!(MM>ECED) D LOC1
67 Q
68LOC1 S ECFN=0 F I=0:0 S ECFN=$O(^ECH("ADT",ECL,ECDFN,ECD,MM,ECFN)) Q:'ECFN D UTL
69 Q
70UTL ; set ^TMP($J,"ECPROV"
71 Q:'$D(^ECH(+ECFN,0))!(+$G(ECD)'=$P($G(^ECH(+ECFN,0)),"^",7))
72 S ECEC=^ECH(+ECFN,0),ECV=+$P(ECEC,"^",10),ECC=+$P(ECEC,"^",8)
73 ;S ECP=$P(ECEC,"^",9),ECU=+$P(ECEC,"^",11)
74 S ECP=$P(ECEC,"^",9),ECU=$$GETPPRV^ECPRVMUT(ECFN,.ECUN),ECUN=$S(ECU:"UNKNOWN",1:$P(ECUN,"^",2))
75 S ECCN=$S($P($G(^EC(726,ECC,0)),"^")]"":$P(^(0),"^"),1:"None")
76 Q:ECP']""
77 S ECD=+$P(ECEC,"^",7)
78 I ECPRV=1 Q:'$D(ECDU(ECD)) S ECDN=ECDU(ECD)
79 I ECPRV=2 S ECDN=$S($P($G(^ECD(ECD,0)),"^")]"":$P(^(0),"^"),1:"UNKNOWN")
80 ;S ECUN=$S($P($G(^VA(200,ECU,0)),"^")]"":$P(^(0),"^"),1:"UNKNOWN")
81 S ECPSY=+$O(^ECJ("AP",ECL,ECD,ECC,ECP,"")),ECPN=""
82 S ECFILE=$P(ECP,";",2),ECFILE=$S($E(ECFILE)="I":81,$E(ECFILE)="E":725,1:"UNKNOWN")
83 I ECFILE=81 S ECPN=$P($$CPT^ICPTCOD(+ECP,$P(ECED,".")),"^",3)
84 I ECFILE=725 S ECPN=$P($G(^EC(725,+ECP,0)),"^")
85 I ECFILE="UNKNOWN"!(ECPN="") S ECPN="UNKNOWN"
86 ;Changes made by VMP to correct NOIS SDC-1003-60397
87 S ECPN=$E(ECPN,1,5)_"~"_$P(ECP,";")_"~"_$E($P(ECP,";",2))_"~"_ECPSY
88 ;Get Procedure CPT modifiers
89 S ECMODF=0 K ECMOD
90 I $O(^ECH(+ECFN,"MOD",0))'="" S ECMODF=$$MOD^ECUTL(+ECFN,"I",.ECMOD)
91 ;
92 ;ALB/ESD - Get procedure reason from EC Patient file (#721) record
93 N ECLNK
94 S ECPRSN=""
95 S ECLNK=+$P(ECEC,"^",23)
96 I +ECLNK>0 DO
97 .S ECPRSN=$P($G(^ECL(ECLNK,0)),"^",1)
98 .S:+ECPRSN'>0 ECPRSN="REASON NOT DEFINED"
99 .S:+ECPRSN>0 ECPRSN=$P(^ECR(ECPRSN,0),"^",1)
100 S:+ECLNK'>0 ECPRSN="REASON NOT DEFINED"
101 I '$D(ECRY) S ECPRSN="REASON NOT DEFINED" ;group proc reason-not print
102 I '$D(^TMP($J,ECLN,ECDN,ECUN)) S ECINC=ECINC+1,ECINZ="^"_ECINC,^(ECUN)=0,^(ECUN,ECINC)=0
103 S ECINZ="^"_$O(^TMP($J,ECLN,ECDN,ECUN,0))
104 I '$D(^TMP($J,ECINZ,ECCN)) S ^TMP($J,ECINZ,ECCN)=0
105 ;
106 ;ALB/ESD - Add procedure reason to ^TMP array
107 I '$D(^TMP($J,ECINZ,ECCN,ECPN,ECPRSN)) S ^TMP($J,ECINZ,ECCN,ECPN,ECPRSN)=0
108 S ^TMP($J,ECLN)=^TMP($J,ECLN)+ECV
109 S ^TMP($J,ECLN,ECDN,ECUN)=^TMP($J,ECLN,ECDN,ECUN)+ECV
110 S ^TMP($J,ECINZ,ECCN)=^TMP($J,ECINZ,ECCN)+ECV
111 ;
112 ;ALB/ESD - Add procedure reason to ^TMP array
113 S ^TMP($J,ECINZ,ECCN,ECPN,ECPRSN)=^TMP($J,ECINZ,ECCN,ECPN,ECPRSN)+ECV
114 ;ALB/JAM - Add Procedure CPT modifier to ^TMP array
115 S MOD="" F S MOD=$O(ECMOD(MOD)) Q:MOD="" D
116 . S ^TMP($J,ECINZ,ECCN,ECPN,ECPRSN,"MOD",MOD)=$G(^TMP($J,ECINZ,ECCN,ECPN,ECPRSN,"MOD",MOD))+ECV
117 Q
118PAGE ; end of page
119 I $D(ECPG),$E(IOST,1,2)="C-" W !!,"Press <RET> to continue, or ^ to quit " R X:DTIME I '$T!(X="^") S ECOUT=1 Q
120HDR ; print heading
121 W:$Y @IOF W !!,?49,"EVENT CAPTURE PROVIDER SUMMARY",!,?49,"FROM "_$P(ECDATE,"^")_" TO "_$P(ECDATE,"^",2),!,?49,"Run Date : ",ECRDT
122 W !!?3,"Category",!,?6,"CPT Code",?20,"Description"
123 W:$D(ECRY) ?70,"Procedure Reason"
124 W ?105,"Volume",!,?10,"CPT Modifier (volume)",!
125 F LINE=1:1:132 W "-"
126 W !!,"Location: "_ECLN,! W:ECDN]"" "DSS Unit: "_ECDN
127 I ECPRV,$D(ECUSER) W !!,ECUN,!,ECCN
128 Q
129TOTP Q:ECOUT W !,?105,"------",!,"Total Procedures for "_ECUN,?105,$J(^TMP($J,ECLN,ECDN,ECUN),6)
130 Q
131UNIT ; set units
132 S CNT=0 F I=0:0 S CNT=$O(UNIT(CNT)) Q:'CNT S ECDU(+UNIT(CNT))=$P(UNIT(CNT),"^",2)
133 Q
134 ;
135NOUNIT ;Nothing there
136 I $O(^TMP($J,ECLN,ECDN))']"" D PAGE W !!!,?12,"NO PROCEDURES",! S ECPG=1
137 Q
Note: See TracBrowser for help on using the repository browser.