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
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HECXDEPT 4540 printed Jun 11, 2024@21:38:22 Page 2
ECXDEPT ;ALB/GRR - Department lookup for extracts;June 11, 2002 ; 9/26/06 3:39pm
+1 ;;3.0;DSS EXTRACTS;**46,92**;Dec 22, 1997;Build 30
+2 ;Only the Division Logic is implemented and used in this release
+3 ;
+4 ;Input: X=Division
+5 ;Output: Y=Department
+6 ;
DEN(X) ;DENTAL DEPARTMENT LOOKUP
+1 ;format key (Feeder system_Feeder location_Feeder key)
+2 NEW ECXFS,ECXFL,ECXFK
+3 SET ECXFS="DEN"
+4 ;feeder location is division
SET ECXFL=X
+5 ;always null for dental
SET ECXFK=""
+6 NEW ECXKEY
SET ECXKEY=ECXFS_ECXFL_ECXFK
+7 NEW Y
+8 SET Y=$$GETDEPT(ECXKEY)
+9 IF Y="XXXX"!(Y="INAC")
DO MESBUL(X,ECXFS,ECXFL,ECXFK,Y)
+10 QUIT Y
+11 ;
IVP(X) ;IVP DEPARTMENT LOOKUP
+1 ;format key (Feeder system_Feeder location_Feeder key)
+2 NEW ECXFS,ECXFL,ECXFK
+3 ;feeder system is pharmacy
SET ECXFS="IVP"
+4 ;feeder location is IVP_division
SET ECXFL="IVP"_X
+5 ;feeder key always null for IVP
SET ECXFK=""
+6 NEW ECXKEY
SET ECXKEY=ECXFS_ECXFL_ECXFK
+7 NEW Y
+8 SET Y=$$GETDEPT(ECXKEY)
+9 IF Y="XXXX"!(Y="INAC")
DO MESBUL(X,ECXFS,ECXFL,ECXFK,Y)
+10 QUIT Y
+11 ;
RAD(X,X1,X2,X3) ;RAD DEPARTMENT LOOKUP
+1 ;Input X=division
+2 ; X1=Imaging type
+3 ; X2=CPT Code and any modifiers
+4 ; X3=Procedure
+5 ;Output Y=Department
+6 ;format key (Feeder system_Feeder location_Feeder key)
+7 NEW ECXFS,ECXFL,ECXFK
+8 ;feeder system is radiology
SET ECXFS="RAD"
+9 ;feeder location is division_"-"_imaging type
SET ECXFL=X_"-"_X1
+10 IF X2=""&(X3=468)
SET ECXFK=777777
GOTO FORMAT
+11 IF X2=""&(X3]"")
SET ECXFK=X3
GOTO FORMAT
+12 SET ECXFK=$EXTRACT(X2,1,5)
+13 ;look for modifier 26 or TC
NEW J
FOR J=8,10,12,14,16
if $EXTRACT(X2,J,J+1)=""
QUIT
IF $EXTRACT(X2,J,J+1)=26!($EXTRACT(X2,J,J+1)="TC")
SET ECXFK=ECXFK_"."_$EXTRACT(X2,J,J+1)
QUIT
FORMAT NEW ECXKEY
SET ECXKEY=ECXFS_ECXFL_ECXFK
+1 NEW Y
+2 SET Y=$$GETDEPT(ECXKEY)
+3 IF Y="XXXX"!(Y="INAC")
DO MESBUL(X,ECXFS,ECXFL,ECXFK,Y)
+4 QUIT Y
+5 ;
UDP(X) ;UDP DEPARTMENT LOOKUP
+1 ;format key (Feeder system_Feeder location_Feeder key)
+2 NEW ECXFS,ECXFL,ECXFK
+3 ;feeder system is pharmacy
SET ECXFS="UDP"
+4 ;feeder location is UDP_division
SET ECXFL="UDP"_X
+5 ;feeder key always null for UDP
SET ECXFK=""
+6 NEW ECXKEY
SET ECXKEY=ECXFS_ECXFL_ECXFK
+7 NEW Y
+8 SET Y=$$GETDEPT(ECXKEY)
+9 IF Y="XXXX"!(Y="INAC")
DO MESBUL(X,ECXFS,ECXFL,ECXFK,Y)
+10 QUIT Y
+11 ;
MTL(X,X1,X2) ;MTL DEPARTMENT LOOKUP
+1 ;X=DIVISION, X1=NAME OF TEST,X2=STATION NUMBER
+2 ;format key (Feeder System_Feeder location_Feeder key)
+3 NEW ECXFS,ECXFL,ECXFK
+4 ;feeder system for MTL
SET ECXFS="MTL"
+5 ;feeder key always null for MTL
SET ECXFK=""
+6 ;p-@@@ line added
IF X1'="ASI"&(X1'="GAF")
SET ECXFL=X_"PSOTSTLAB"
+7 IF '$TEST
SET ECXFL=X_X1
+8 SET ECXKEY=ECXFS_ECXFL_ECXFK
+9 NEW Y
+10 SET Y=$$GETDEPT(ECXKEY)
+11 IF Y="XXXX"!(Y="INAC")
DO MESBUL(X2,ECXFS,ECXFL,ECXFK,Y)
+12 QUIT Y
+13 ;
PRE(X,X1,X2) ;PRE DEPARTMENT LOOKUP
+1 ;Input X=Division
+2 ; X1=Whether mail or not
+3 ; X2=STATION NUMBER
+4 NEW ECXFS,ECXFL,ECXFK
+5 ;feeder system for PRE
SET ECXFS="PRE"
+6 ;feeder key always null for PRE
SET ECXFK=""
+7 IF X1=2
SET ECXFL="CMOPDSU"_X
+8 IF '$TEST
SET ECXFL="PRE"_X
+9 SET ECXKEY=ECXFS_ECXFL_ECXFK
+10 NEW Y
+11 SET Y=$$GETDEPT(ECXKEY)
+12 IF Y="XXXX"!(Y="INAC")
DO MESBUL(X2,ECXFS,ECXFL,ECXFK,Y)
+13 QUIT Y
+14 ;
GETDEPT(X) ;LOOKUP DEPARTMENT
+1 ;Input: X=lookup key
+2 ;Output Y=Department
+3 ;Look for key in AA crossreference
+4 NEW Y,ECXIEN
SET Y="XXXX"
+5 IF $DATA(^ECX(727.6,"AA",X))
Begin DoDot:1
+6 ;Get ien of department
+7 SET ECXIEN=$ORDER(^ECX(727.6,"AA",X,0))
+8 ;Get department
+9 SET Y=$SELECT($PIECE(^ECX(727.6,ECXIEN,0),"^",6)]"":"INAC",1:$PIECE(^ECX(727.6,ECXIEN,0),"^"))
End DoDot:1
+10 QUIT Y
+11 ;
GETDIV(X) ;GET PRODUCTION DIVISION
+1 ;Input X=ien medical center division, file #40.8
+2 ;Output Y=division number 3-6 characters
+3 NEW Y
SET Y=""
+4 if X=""
QUIT Y
+5 ;Get institution file pointer
SET Y=$$GET1^DIQ(40.8,X,.07,"I")
+6 ;Get station number
QUIT $SELECT(Y="":"",1:$$RADDIV(Y))
+7 ;
PREDIV(X) ;GET PRODUCTION DIVISION FOR PRE
+1 ;Input X=ien Outpatient Site file (#59)
+2 ;Output Y=division number 3-6 characters
+3 NEW Y,IN
SET Y=""
+4 KILL ^TMP($JOB,"ECXDIV")
+5 if X=""
QUIT Y
+6 DO PSS^PSO59(X,"","ECXDIV")
+7 ;Get related inst number
SET IN=$PIECE($GET(^TMP($JOB,"ECXDIV",X,100)),U,1)
+8 SET Y=$$RADDIV(IN)
+9 KILL ^TMP($JOB,"ECXDIV")
+10 QUIT Y
+11 ;
RADDIV(X) ;GET PRODUCTION DIVISION FOR RAD
+1 ;Input X=ien of Institution file
+2 ;Output Y=division number 3-6 characters
+3 NEW Y
SET Y=""
+4 if X=""
QUIT Y
+5 ;Get station number
SET Y=$PIECE($GET(^DIC(4,X,99)),"^",1)
+6 QUIT Y
+7 ;
MESBUL(ECXSN,ECXFS,ECXFL,ECXFK,ECXDEPT) ;SEND BULLETIN FOR TABLE LOOKUP ERROR
+1 ;
+2 NEW XMY,XMDUZ,XMDT,XMZ,XMB,XMCHAN,XMSUB
+3 SET XMCHAN=1
+4 SET XMSUB="A DSS Department Error was found for Station Number: "
+5 SET XMDUZ="ECX Department Extract Application"
+6 SET XMB="ECX DSS DEPARTMENT TABLE ERROR"
+7 SET XMB(1)=ECXSN
+8 SET XMB(2)=ECXFS
+9 SET XMB(3)=ECXFL
+10 SET XMB(4)=ECXFK
+11 SET XMB(5)=ECXDEPT
+12 SET XMDT=$$NOW^XLFDT
+13 DO ^XMB
+14 QUIT
+15 ;
