Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: ECXDEPT

ECXDEPT.m

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