source: WorldVistAEHR/trunk/r/DSS_EXTRACTS-ECX/ECXDEPT.m@ 861

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

initial load of WorldVistAEHR
File size: 4.3 KB
Line 
1ECXDEPT ;ALB/GRR - Department lookup for extracts;June 11, 2002 ; 9/26/06 3:39pm
2 ;;3.0;DSS EXTRACTS;**46,92**;Dec 22, 1997;Build 30
3 ;Only the Division Logic is implemented and used in this release
4 ;
5 ;Input: X=Division
6 ;Output: Y=Department
7 ;
8DEN(X) ;DENTAL DEPARTMENT LOOKUP
9 ;format key (Feeder system_Feeder location_Feeder key)
10 N ECXFS,ECXFL,ECXFK
11 S ECXFS="DEN"
12 S ECXFL=X ;feeder location is division
13 S ECXFK="" ;always null for dental
14 N ECXKEY S ECXKEY=ECXFS_ECXFL_ECXFK
15 N Y
16 S Y=$$GETDEPT(ECXKEY)
17 I Y="XXXX"!(Y="INAC") D MESBUL(X,ECXFS,ECXFL,ECXFK,Y)
18 Q Y
19 ;
20IVP(X) ;IVP DEPARTMENT LOOKUP
21 ;format key (Feeder system_Feeder location_Feeder key)
22 N ECXFS,ECXFL,ECXFK
23 S ECXFS="IVP" ;feeder system is pharmacy
24 S ECXFL="IVP"_X ;feeder location is IVP_division
25 S ECXFK="" ;feeder key always null for IVP
26 N ECXKEY S ECXKEY=ECXFS_ECXFL_ECXFK
27 N Y
28 S Y=$$GETDEPT(ECXKEY)
29 I Y="XXXX"!(Y="INAC") D MESBUL(X,ECXFS,ECXFL,ECXFK,Y)
30 Q Y
31 ;
32RAD(X,X1,X2,X3) ;RAD DEPARTMENT LOOKUP
33 ;Input X=division
34 ; X1=Imaging type
35 ; X2=CPT Code and any modifiers
36 ; X3=Procedure
37 ;Output Y=Department
38 ;format key (Feeder system_Feeder location_Feeder key)
39 N ECXFS,ECXFL,ECXFK
40 S ECXFS="RAD" ;feeder system is radiology
41 S ECXFL=X_"-"_X1 ;feeder location is division_"-"_imaging type
42 I X2=""&(X3=468) S ECXFK=777777 G FORMAT
43 I X2=""&(X3]"") S ECXFK=X3 G FORMAT
44 S ECXFK=$E(X2,1,5)
45 N J F J=8,10,12,14,16 Q:$E(X2,J,J+1)="" I $E(X2,J,J+1)=26!($E(X2,J,J+1)="TC") S ECXFK=ECXFK_"."_$E(X2,J,J+1) Q ;look for modifier 26 or TC
46FORMAT N ECXKEY S ECXKEY=ECXFS_ECXFL_ECXFK
47 N Y
48 S Y=$$GETDEPT(ECXKEY)
49 I Y="XXXX"!(Y="INAC") D MESBUL(X,ECXFS,ECXFL,ECXFK,Y)
50 Q Y
51 ;
52UDP(X) ;UDP DEPARTMENT LOOKUP
53 ;format key (Feeder system_Feeder location_Feeder key)
54 N ECXFS,ECXFL,ECXFK
55 S ECXFS="UDP" ;feeder system is pharmacy
56 S ECXFL="UDP"_X ;feeder location is UDP_division
57 S ECXFK="" ;feeder key always null for UDP
58 N ECXKEY S ECXKEY=ECXFS_ECXFL_ECXFK
59 N Y
60 S Y=$$GETDEPT(ECXKEY)
61 I Y="XXXX"!(Y="INAC") D MESBUL(X,ECXFS,ECXFL,ECXFK,Y)
62 Q Y
63 ;
64MTL(X,X1,X2) ;MTL DEPARTMENT LOOKUP
65 ;X=DIVISION, X1=NAME OF TEST,X2=STATION NUMBER
66 ;format key (Feeder System_Feeder location_Feeder key)
67 N ECXFS,ECXFL,ECXFK
68 S ECXFS="MTL" ;feeder system for MTL
69 S ECXFK="" ;feeder key always null for MTL
70 I X1'="ASI"&(X1'="GAF") S ECXFL=X_"PSOTSTLAB" ;p-@@@ line added
71 E S ECXFL=X_X1
72 S ECXKEY=ECXFS_ECXFL_ECXFK
73 N Y
74 S Y=$$GETDEPT(ECXKEY)
75 I Y="XXXX"!(Y="INAC") D MESBUL(X2,ECXFS,ECXFL,ECXFK,Y)
76 Q Y
77 ;
78PRE(X,X1,X2) ;PRE DEPARTMENT LOOKUP
79 ;Input X=Division
80 ; X1=Whether mail or not
81 ; X2=STATION NUMBER
82 N ECXFS,ECXFL,ECXFK
83 S ECXFS="PRE" ;feeder system for PRE
84 S ECXFK="" ;feeder key always null for PRE
85 I X1=2 S ECXFL="CMOPDSU"_X
86 E S ECXFL="PRE"_X
87 S ECXKEY=ECXFS_ECXFL_ECXFK
88 N Y
89 S Y=$$GETDEPT(ECXKEY)
90 I Y="XXXX"!(Y="INAC") D MESBUL(X2,ECXFS,ECXFL,ECXFK,Y)
91 Q Y
92 ;
93GETDEPT(X) ;LOOKUP DEPARTMENT
94 ;Input: X=lookup key
95 ;Output Y=Department
96 ;Look for key in AA crossreference
97 N Y,ECXIEN S Y="XXXX"
98 I $D(^ECX(727.6,"AA",X)) D
99 .;Get ien of department
100 .S ECXIEN=$O(^ECX(727.6,"AA",X,0))
101 .;Get department
102 .S Y=$S($P(^ECX(727.6,ECXIEN,0),"^",6)]"":"INAC",1:$P(^ECX(727.6,ECXIEN,0),"^"))
103 Q Y
104 ;
105GETDIV(X) ;GET PRODUCTION DIVISION
106 ;Input X=ien medical center division, file #40.8
107 ;Output Y=division number 3-6 characters
108 N Y S Y=""
109 Q:X="" Y
110 S Y=$$GET1^DIQ(40.8,X,.07,"I") ;Get institution file pointer
111 Q $S(Y="":"",1:$$RADDIV(Y)) ;Get station number
112 ;
113PREDIV(X) ;GET PRODUCTION DIVISION FOR PRE
114 ;Input X=ien Outpatient Site file (#59)
115 ;Output Y=division number 3-6 characters
116 N Y,IN S Y=""
117 K ^TMP($J,"ECXDIV")
118 Q:X="" Y
119 D PSS^PSO59(X,"","ECXDIV")
120 S IN=$P($G(^TMP($J,"ECXDIV",X,100)),U,1) ;Get related inst number
121 S Y=$$RADDIV(IN)
122 K ^TMP($J,"ECXDIV")
123 Q Y
124 ;
125RADDIV(X) ;GET PRODUCTION DIVISION FOR RAD
126 ;Input X=ien of Institution file
127 ;Output Y=division number 3-6 characters
128 N Y S Y=""
129 Q:X="" Y
130 S Y=$P($G(^DIC(4,X,99)),"^",1) ;Get station number
131 Q Y
132 ;
133MESBUL(ECXSN,ECXFS,ECXFL,ECXFK,ECXDEPT) ;SEND BULLETIN FOR TABLE LOOKUP ERROR
134 ;
135 N XMY,XMDUZ,XMDT,XMZ,XMB,XMCHAN,XMSUB
136 S XMCHAN=1
137 S XMSUB="A DSS Department Error was found for Station Number: "
138 S XMDUZ="ECX Department Extract Application"
139 S XMB="ECX DSS DEPARTMENT TABLE ERROR"
140 S XMB(1)=ECXSN
141 S XMB(2)=ECXFS
142 S XMB(3)=ECXFL
143 S XMB(4)=ECXFK
144 S XMB(5)=ECXDEPT
145 S XMDT=$$NOW^XLFDT
146 D ^XMB
147 Q
148 ;
Note: See TracBrowser for help on using the repository browser.