- 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 Jan 18, 2025@02:53:37 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 ;