149 lines
4.3 KiB
Mathematica
149 lines
4.3 KiB
Mathematica
ECXDEPT ;ALB/GRR - Department lookup for extracts;June 11, 2002 ; 9/26/06 3:39pm
|
|
;;3.0;DSS EXTRACTS;**46,92**;Dec 22, 1997;Build 30
|
|
;Only the Division Logic is implemented and used in this release
|
|
;
|
|
;Input: X=Division
|
|
;Output: Y=Department
|
|
;
|
|
DEN(X) ;DENTAL DEPARTMENT LOOKUP
|
|
;format key (Feeder system_Feeder location_Feeder key)
|
|
N ECXFS,ECXFL,ECXFK
|
|
S ECXFS="DEN"
|
|
S ECXFL=X ;feeder location is division
|
|
S ECXFK="" ;always null for dental
|
|
N ECXKEY S ECXKEY=ECXFS_ECXFL_ECXFK
|
|
N Y
|
|
S Y=$$GETDEPT(ECXKEY)
|
|
I Y="XXXX"!(Y="INAC") D MESBUL(X,ECXFS,ECXFL,ECXFK,Y)
|
|
Q Y
|
|
;
|
|
IVP(X) ;IVP DEPARTMENT LOOKUP
|
|
;format key (Feeder system_Feeder location_Feeder key)
|
|
N ECXFS,ECXFL,ECXFK
|
|
S ECXFS="IVP" ;feeder system is pharmacy
|
|
S ECXFL="IVP"_X ;feeder location is IVP_division
|
|
S ECXFK="" ;feeder key always null for IVP
|
|
N ECXKEY S ECXKEY=ECXFS_ECXFL_ECXFK
|
|
N Y
|
|
S Y=$$GETDEPT(ECXKEY)
|
|
I Y="XXXX"!(Y="INAC") D MESBUL(X,ECXFS,ECXFL,ECXFK,Y)
|
|
Q Y
|
|
;
|
|
RAD(X,X1,X2,X3) ;RAD DEPARTMENT LOOKUP
|
|
;Input X=division
|
|
; X1=Imaging type
|
|
; X2=CPT Code and any modifiers
|
|
; X3=Procedure
|
|
;Output Y=Department
|
|
;format key (Feeder system_Feeder location_Feeder key)
|
|
N ECXFS,ECXFL,ECXFK
|
|
S ECXFS="RAD" ;feeder system is radiology
|
|
S ECXFL=X_"-"_X1 ;feeder location is division_"-"_imaging type
|
|
I X2=""&(X3=468) S ECXFK=777777 G FORMAT
|
|
I X2=""&(X3]"") S ECXFK=X3 G FORMAT
|
|
S ECXFK=$E(X2,1,5)
|
|
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
|
|
FORMAT N ECXKEY S ECXKEY=ECXFS_ECXFL_ECXFK
|
|
N Y
|
|
S Y=$$GETDEPT(ECXKEY)
|
|
I Y="XXXX"!(Y="INAC") D MESBUL(X,ECXFS,ECXFL,ECXFK,Y)
|
|
Q Y
|
|
;
|
|
UDP(X) ;UDP DEPARTMENT LOOKUP
|
|
;format key (Feeder system_Feeder location_Feeder key)
|
|
N ECXFS,ECXFL,ECXFK
|
|
S ECXFS="UDP" ;feeder system is pharmacy
|
|
S ECXFL="UDP"_X ;feeder location is UDP_division
|
|
S ECXFK="" ;feeder key always null for UDP
|
|
N ECXKEY S ECXKEY=ECXFS_ECXFL_ECXFK
|
|
N Y
|
|
S Y=$$GETDEPT(ECXKEY)
|
|
I Y="XXXX"!(Y="INAC") D MESBUL(X,ECXFS,ECXFL,ECXFK,Y)
|
|
Q Y
|
|
;
|
|
MTL(X,X1,X2) ;MTL DEPARTMENT LOOKUP
|
|
;X=DIVISION, X1=NAME OF TEST,X2=STATION NUMBER
|
|
;format key (Feeder System_Feeder location_Feeder key)
|
|
N ECXFS,ECXFL,ECXFK
|
|
S ECXFS="MTL" ;feeder system for MTL
|
|
S ECXFK="" ;feeder key always null for MTL
|
|
I X1'="ASI"&(X1'="GAF") S ECXFL=X_"PSOTSTLAB" ;p-@@@ line added
|
|
E S ECXFL=X_X1
|
|
S ECXKEY=ECXFS_ECXFL_ECXFK
|
|
N Y
|
|
S Y=$$GETDEPT(ECXKEY)
|
|
I Y="XXXX"!(Y="INAC") D MESBUL(X2,ECXFS,ECXFL,ECXFK,Y)
|
|
Q Y
|
|
;
|
|
PRE(X,X1,X2) ;PRE DEPARTMENT LOOKUP
|
|
;Input X=Division
|
|
; X1=Whether mail or not
|
|
; X2=STATION NUMBER
|
|
N ECXFS,ECXFL,ECXFK
|
|
S ECXFS="PRE" ;feeder system for PRE
|
|
S ECXFK="" ;feeder key always null for PRE
|
|
I X1=2 S ECXFL="CMOPDSU"_X
|
|
E S ECXFL="PRE"_X
|
|
S ECXKEY=ECXFS_ECXFL_ECXFK
|
|
N Y
|
|
S Y=$$GETDEPT(ECXKEY)
|
|
I Y="XXXX"!(Y="INAC") D MESBUL(X2,ECXFS,ECXFL,ECXFK,Y)
|
|
Q Y
|
|
;
|
|
GETDEPT(X) ;LOOKUP DEPARTMENT
|
|
;Input: X=lookup key
|
|
;Output Y=Department
|
|
;Look for key in AA crossreference
|
|
N Y,ECXIEN S Y="XXXX"
|
|
I $D(^ECX(727.6,"AA",X)) D
|
|
.;Get ien of department
|
|
.S ECXIEN=$O(^ECX(727.6,"AA",X,0))
|
|
.;Get department
|
|
.S Y=$S($P(^ECX(727.6,ECXIEN,0),"^",6)]"":"INAC",1:$P(^ECX(727.6,ECXIEN,0),"^"))
|
|
Q Y
|
|
;
|
|
GETDIV(X) ;GET PRODUCTION DIVISION
|
|
;Input X=ien medical center division, file #40.8
|
|
;Output Y=division number 3-6 characters
|
|
N Y S Y=""
|
|
Q:X="" Y
|
|
S Y=$$GET1^DIQ(40.8,X,.07,"I") ;Get institution file pointer
|
|
Q $S(Y="":"",1:$$RADDIV(Y)) ;Get station number
|
|
;
|
|
PREDIV(X) ;GET PRODUCTION DIVISION FOR PRE
|
|
;Input X=ien Outpatient Site file (#59)
|
|
;Output Y=division number 3-6 characters
|
|
N Y,IN S Y=""
|
|
K ^TMP($J,"ECXDIV")
|
|
Q:X="" Y
|
|
D PSS^PSO59(X,"","ECXDIV")
|
|
S IN=$P($G(^TMP($J,"ECXDIV",X,100)),U,1) ;Get related inst number
|
|
S Y=$$RADDIV(IN)
|
|
K ^TMP($J,"ECXDIV")
|
|
Q Y
|
|
;
|
|
RADDIV(X) ;GET PRODUCTION DIVISION FOR RAD
|
|
;Input X=ien of Institution file
|
|
;Output Y=division number 3-6 characters
|
|
N Y S Y=""
|
|
Q:X="" Y
|
|
S Y=$P($G(^DIC(4,X,99)),"^",1) ;Get station number
|
|
Q Y
|
|
;
|
|
MESBUL(ECXSN,ECXFS,ECXFL,ECXFK,ECXDEPT) ;SEND BULLETIN FOR TABLE LOOKUP ERROR
|
|
;
|
|
N XMY,XMDUZ,XMDT,XMZ,XMB,XMCHAN,XMSUB
|
|
S XMCHAN=1
|
|
S XMSUB="A DSS Department Error was found for Station Number: "
|
|
S XMDUZ="ECX Department Extract Application"
|
|
S XMB="ECX DSS DEPARTMENT TABLE ERROR"
|
|
S XMB(1)=ECXSN
|
|
S XMB(2)=ECXFS
|
|
S XMB(3)=ECXFL
|
|
S XMB(4)=ECXFK
|
|
S XMB(5)=ECXDEPT
|
|
S XMDT=$$NOW^XLFDT
|
|
D ^XMB
|
|
Q
|
|
;
|