MAGDHLSV ;WOIFO/MLH - IHE-based ADT interface for PACS - PV1 segment ; 08 Jul 2013 11:24 AM
;;3.0;IMAGING;**49,141,138**;Mar 19, 2002;Build 5380;Sep 03, 2013
;; Per VHA Directive 2004-038, this routine should not be modified.
;; +---------------------------------------------------------------+
;; | Property of the US Government. |
;; | No permission to copy or redistribute this software is given. |
;; | Use of unreleased versions of this software requires the user |
;; | to execute a written test agreement with the VistA Imaging |
;; | Development Office of the Department of Veterans Affairs, |
;; | telephone (301) 734-0100. |
;; | The Food and Drug Administration classifies this software as |
;; | a medical device. As such, it may not be changed in any way. |
;; | Modifications to this software may result in an adulterated |
;; | medical device under 21CFR820, the use of which is considered |
;; | to be a violation of US Federal Statutes. |
;; +---------------------------------------------------------------+
;;
Q
;
PV1 ; GOTO entry point from MAGDHLS - patient visit - NOT FOR DIRECT ENTRY
; input: XDFN internal entry number of the patient on global ^DPT/^RADPT
; XEVN event type of this message
; XEVNDT event date/time (FileMan format)
; XYMSG name of array to which to add message elts
; output: @XYMSG input array plus new subtree containing PV1 elts
; function return 0 (success) always
;
N SEGIX ; --- segment index on array @XYMSG
N MAGNME ; -- array for HL7-formatted name lookup info
N I ; ------- loop index for $Piece calls
N BDT ; ----- beginning date for call to EN1^RAO7PC1
N EDT ; ----- ending date for call to EN1^RAO7PC1
N EXN ; ----- max # of exams for call to EN1^RAO7PC1
N DTCS ; ---- date/case index from RAO7PC1 lookup
N RVDT ; ---- reverse date time entry on global ^RADPT
N CSIX ; ---- case number index under RVDT on global ^RADPT
N VAIP ; ---- patient data array from call to IN5^VADPT
N RAXSET ; -- exam set data from ^RADPT
N RAXWRD ; -- exam ward (entry in File 42)
N RASCIX ; -- ward location service/section index (entry in File 44)
N RASVC ; --- service/section name from File 44
N RAORIX ; -- order index on ^RAO(75.1)
N RAORDR ; -- order data from ^RAO(75.1)
N ERPTSS ; -- element repetition subscript
N RAXPRT ; -- transport mode from RAORDR
N VAIN ; ---- inpatient data array from call to INP^VADPT
N RESULT ; -- return array from entry point PTSEG^DGSEC4
N VISNO ; --- visit number
N DFN ; ----- temporary value for ^VADPT call
;
; set up the PV1 segment
S SEGIX=$O(@XYMSG@(" "),-1)+1 ; segment index
S @XYMSG@(SEGIX,0)="PV1"
I '$D(XDFN) S @XYMSG@(SEGIX,2,1,1,1)="N" Q 0 ; no DFN, can't get IP/OP info
S DFN=XDFN D IN5^VADPT ; supported PIMS call - get IP info if any into VAIP()
D @$S($G(VAIP(13)):"IN",1:"OUT") ;inpatient/outpatient
D ; insert admit date/time from current status date @ 0000H
. N VAINDT ; -- date/time of status
. S VAINDT=XEVNDT\1 D INP^VADPT ; inpt info into VAIN()
. S:VAIN(7) @XYMSG@(SEGIX,44,1,1,1)=$$FMTHL7^XLFDT($P(VAIN(7),"^",1))
. Q
; IA #3646: employee flag
S:$$EMPL^DGSEC4(XDFN)=1 @XYMSG@(SEGIX,16,1,1,1)="E"
; IA #767: sensitive flag
S:$P($G(^DGSL(38.1,XDFN,0)),"^",2)=1 @XYMSG@(SEGIX,16,1,1,1)=$G(@XYMSG@(SEGIX,16,1,1,1))_"S"
; insert visit number <- admission number (IP) or date (OP)
S VISNO=$S($G(VAIN(1))'="":"I"_VAIN(1),1:"O"_($$HTFM^XLFDT($H,1)+17000000))
S @XYMSG@(SEGIX,19,1,1,1)=VISNO
S:XEVN="A11" @XYMSG@(SEGIX,2,1,1,1)="N" ; cancel an admit - IP/OP doesn't apply in PV1-2
Q 0
;
IN ; SUBROUTINE - patient is now an inpatient
;
N ROOMBED ; --- patient's room and bed
N ATTPHYIX ; -- patient's attending physician index on NEW PERSON (#200)
N ATTPHY ; ---- patient's attending physician information
N ADMPHYIX ; -- patient's admitting physician index on NEW PERSON
N ADMPHY ; ---- patient's admitting physician information
N RADSVCIX ; -- patient's service/section associated with Rad order - index
N SVC ; ------- service/section name
N TMP ; ------- scratch variable
N WARDREC ; --- ward record from VAIP(5)
N WARDIX ; ---- ward index on WARD LOCATION File (#44)
N WARDNAM ; --- name of ward
;
; fetch information
S ROOMBED=$P($G(VAIP(6)),U,2) ; patient's room and bed
S ATTPHYIX=+$G(VAIP(18)),ATTPHY="" ; attending physician
I ATTPHYIX D
. S MAGNME("FILE")=200,MAGNME("IENS")=ATTPHYIX,MAGNME("FIELD")=.01
. S ATTPHY=ATTPHYIX_U_$$HLNAME^XLFNAME(.MAGNME,"S",U)
. Q
S ADMPHYIX=+$G(VAIP(13,5)),ADMPHY="" ; admitting physician
I ADMPHYIX D
. S MAGNME("FILE")=200,MAGNME("IENS")=ADMPHYIX,MAGNME("FIELD")=.01
. S ADMPHY=ADMPHYIX_U_$$HLNAME^XLFNAME(.MAGNME,"S",U)
. Q
; populate message array
S @XYMSG@(SEGIX,2,1,1,1)="I" ; patient class
S WARDREC=$G(VAIP(5)),WARDIX=$P(WARDREC,U,1),WARDNAM=$P(WARDREC,U,2)
S @XYMSG@(SEGIX,3,1,1,1)=WARDNAM ; patient location - ward
S @XYMSG@(SEGIX,3,1,2,1)=$P(ROOMBED,"-",1) ; patient location - room
S @XYMSG@(SEGIX,3,1,3,1)=$P(ROOMBED,"-",2) ; patient location - bed
S:WARDNAM'="" @XYMSG@(SEGIX,3,1,4,1)=$$FACILIX(WARDIX,"W") ; pt loc - facility
I XEVN="A02" D ; transfer -> get previous location
. S TMP=$G(VAIP(15)) Q:'TMP K VAIP
. S VAIP("E")=TMP D IN5^VADPT
. S ROOMBED=$P($G(VAIP(6)),U,2) ; previous room and bed
. S WARDREC=$G(VAIP(5)),WARDIX=$P(WARDREC,U,1),WARDNAM=$P(WARDREC,U,2)
. S @XYMSG@(SEGIX,6,1,1,1)=WARDNAM ; previous location - ward
. S @XYMSG@(SEGIX,6,1,2,1)=$P(ROOMBED,"-",1) ; previous location - room
. S @XYMSG@(SEGIX,6,1,3,1)=$P(ROOMBED,"-",2) ; previous location - bed
. S:WARDNAM'="" @XYMSG@(SEGIX,6,1,4,1)=$$FACILIX(WARDIX,"W") ; prev loc - facility
. Q
F I=1:1:$L(ATTPHY,U) S @XYMSG@(SEGIX,7,1,I,1)=$P(ATTPHY,U,I) ; attending physician
S @XYMSG@(SEGIX,10,1,1,1)=$P(VAIP(8),"^",2) ; hospital service <- treating specialty
F I=1:1:$L(ADMPHY,U) S @XYMSG@(SEGIX,8,1,I,1)=$P(ADMPHY,U,I) ; referring = admitting physician
F I=1:1:$L(ADMPHY,U) S @XYMSG@(SEGIX,17,1,I,1)=$P(ADMPHY,U,I) ; admitting physician
Q
;
OUT ; SUBROUTINE - patient is now an outpatient
N CLINICIX ; -- outpatient clinic index on HOSPITAL LOCATION
N CLINIC ; ---- outpatient clinic
;
S @XYMSG@(SEGIX,2,1,1,1)="O" ; patient class
S:XEVN="A03" @XYMSG@(SEGIX,45,1,1,1)=$$FMTHL7^XLFDT(XEVNDT) ; discharge date/time
; insert admit date/time as appropriate
;
I $G(RADFN) D ; outpatient radiology order
. I $G(RADTI),$G(RACNI) D
. . N SUBSCRIPT ; -- working variable
. . S SUBSCRIPT=RACNI_","_RADTI_","_RADFN
. . S CLINICIX=$$GET1^DIQ(70.03,SUBSCRIPT,8,"I")
. . Q
. Q
E I $G(GMRCIEN) D ; outpatient consult/procedure order
. S CLINICIX=$$GET1^DIQ(123,GMRCIEN,.04,"I")
. Q
;
I $G(CLINICIX) D ; outpatient clinic goes on PV1-11 Temporary Location
. S CLINIC=$$GET1^DIQ(44,CLINICIX,.01)
. S @XYMSG@(SEGIX,11,1,1,1)=CLINIC ; patient location - clinic
. S:CLINIC'="" @XYMSG@(SEGIX,11,1,4,1)=$$FACILIX(CLINICIX,"C") ; pt loc - facility
. Q
;
Q
;
FACILIX(LOCATIONIX,LOCTYPE) ; FUNCTION - return the facility associated with a ward
; or clinic, if any, otherwise return user's default facility
;
; input: LOCATIONIX = IEN of the ward in WARD LOCATION File (#42), or
; LOCATIONIX = IEN of the clinic in HOSPITAL LOCATION File (#44)
; LOCTYPE = "W" for Ward (#42) or "C" for Clinic (#44)
;
; function return: <facility code>_"_"_<facility name>
;
N DA,DIC,DIQ,DR,X ; FileMan work variables
N HOSPLOCIX ; -- IEN of hospital location in HOSPITAL LOCATION File (#44)
N FACILIX ; ---- IEN of facility on INSTITUTION File (#4)
N FACILNAM ; --- name of facility on INSTITUTION File (#4)
N MAGLOC ; ----- work array for FileMan search results
;
D:$G(LOCATIONIX)
. Q:LOCATIONIX'=+LOCATIONIX
. I $G(LOCTYPE)="C" S HOSPLOCIX=LOCATIONIX ; hospital location passed as LOCATIONIX
. E S HOSPLOCIX=$P($G(^DIC(42,LOCATIONIX,44)),U,1) ; look up hospital location - ICR 10039
. Q:HOSPLOCIX'>0 Q:'$D(^SC(HOSPLOCIX)) ; hospital location not on file
. S FACILIX=$P($G(^SC(HOSPLOCIX,0)),"^",4) ; look up facility - ICR 10040
. Q
S:'$G(FACILIX) FACILIX=$G(DUZ(2))
D:FACILIX ; get facility name - ICR 10090
. S DIC=4,DR=.01,DA=FACILIX,DIQ="MAGLOC",DIQ(0)="E"
. D EN^DIQ1 S FACILNAM=$G(MAGLOC(4,FACILIX,.01,"E"))
. Q
Q $S(FACILIX:FACILIX_"_"_$G(FACILNAM),1:"")
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HMAGDHLSV 8592 printed Dec 13, 2024@02:00:01 Page 2
MAGDHLSV ;WOIFO/MLH - IHE-based ADT interface for PACS - PV1 segment ; 08 Jul 2013 11:24 AM
+1 ;;3.0;IMAGING;**49,141,138**;Mar 19, 2002;Build 5380;Sep 03, 2013
+2 ;; Per VHA Directive 2004-038, this routine should not be modified.
+3 ;; +---------------------------------------------------------------+
+4 ;; | Property of the US Government. |
+5 ;; | No permission to copy or redistribute this software is given. |
+6 ;; | Use of unreleased versions of this software requires the user |
+7 ;; | to execute a written test agreement with the VistA Imaging |
+8 ;; | Development Office of the Department of Veterans Affairs, |
+9 ;; | telephone (301) 734-0100. |
+10 ;; | The Food and Drug Administration classifies this software as |
+11 ;; | a medical device. As such, it may not be changed in any way. |
+12 ;; | Modifications to this software may result in an adulterated |
+13 ;; | medical device under 21CFR820, the use of which is considered |
+14 ;; | to be a violation of US Federal Statutes. |
+15 ;; +---------------------------------------------------------------+
+16 ;;
+17 QUIT
+18 ;
PV1 ; GOTO entry point from MAGDHLS - patient visit - NOT FOR DIRECT ENTRY
+1 ; input: XDFN internal entry number of the patient on global ^DPT/^RADPT
+2 ; XEVN event type of this message
+3 ; XEVNDT event date/time (FileMan format)
+4 ; XYMSG name of array to which to add message elts
+5 ; output: @XYMSG input array plus new subtree containing PV1 elts
+6 ; function return 0 (success) always
+7 ;
+8 ; --- segment index on array @XYMSG
NEW SEGIX
+9 ; -- array for HL7-formatted name lookup info
NEW MAGNME
+10 ; ------- loop index for $Piece calls
NEW I
+11 ; ----- beginning date for call to EN1^RAO7PC1
NEW BDT
+12 ; ----- ending date for call to EN1^RAO7PC1
NEW EDT
+13 ; ----- max # of exams for call to EN1^RAO7PC1
NEW EXN
+14 ; ---- date/case index from RAO7PC1 lookup
NEW DTCS
+15 ; ---- reverse date time entry on global ^RADPT
NEW RVDT
+16 ; ---- case number index under RVDT on global ^RADPT
NEW CSIX
+17 ; ---- patient data array from call to IN5^VADPT
NEW VAIP
+18 ; -- exam set data from ^RADPT
NEW RAXSET
+19 ; -- exam ward (entry in File 42)
NEW RAXWRD
+20 ; -- ward location service/section index (entry in File 44)
NEW RASCIX
+21 ; --- service/section name from File 44
NEW RASVC
+22 ; -- order index on ^RAO(75.1)
NEW RAORIX
+23 ; -- order data from ^RAO(75.1)
NEW RAORDR
+24 ; -- element repetition subscript
NEW ERPTSS
+25 ; -- transport mode from RAORDR
NEW RAXPRT
+26 ; ---- inpatient data array from call to INP^VADPT
NEW VAIN
+27 ; -- return array from entry point PTSEG^DGSEC4
NEW RESULT
+28 ; --- visit number
NEW VISNO
+29 ; ----- temporary value for ^VADPT call
NEW DFN
+30 ;
+31 ; set up the PV1 segment
+32 ; segment index
SET SEGIX=$ORDER(@XYMSG@(" "),-1)+1
+33 SET @XYMSG@(SEGIX,0)="PV1"
+34 ; no DFN, can't get IP/OP info
IF '$DATA(XDFN)
SET @XYMSG@(SEGIX,2,1,1,1)="N"
QUIT 0
+35 ; supported PIMS call - get IP info if any into VAIP()
SET DFN=XDFN
DO IN5^VADPT
+36 ;inpatient/outpatient
DO @$SELECT($GET(VAIP(13)):"IN",1:"OUT")
+37 ; insert admit date/time from current status date @ 0000H
Begin DoDot:1
+38 ; -- date/time of status
NEW VAINDT
+39 ; inpt info into VAIN()
SET VAINDT=XEVNDT\1
DO INP^VADPT
+40 if VAIN(7)
SET @XYMSG@(SEGIX,44,1,1,1)=$$FMTHL7^XLFDT($PIECE(VAIN(7),"^",1))
+41 QUIT
End DoDot:1
+42 ; IA #3646: employee flag
+43 if $$EMPL^DGSEC4(XDFN)=1
SET @XYMSG@(SEGIX,16,1,1,1)="E"
+44 ; IA #767: sensitive flag
+45 if $PIECE($GET(^DGSL(38.1,XDFN,0)),"^",2)=1
SET @XYMSG@(SEGIX,16,1,1,1)=$GET(@XYMSG@(SEGIX,16,1,1,1))_"S"
+46 ; insert visit number <- admission number (IP) or date (OP)
+47 SET VISNO=$SELECT($GET(VAIN(1))'="":"I"_VAIN(1),1:"O"_($$HTFM^XLFDT($HOROLOG,1)+17000000))
+48 SET @XYMSG@(SEGIX,19,1,1,1)=VISNO
+49 ; cancel an admit - IP/OP doesn't apply in PV1-2
if XEVN="A11"
SET @XYMSG@(SEGIX,2,1,1,1)="N"
+50 QUIT 0
+51 ;
IN ; SUBROUTINE - patient is now an inpatient
+1 ;
+2 ; --- patient's room and bed
NEW ROOMBED
+3 ; -- patient's attending physician index on NEW PERSON (#200)
NEW ATTPHYIX
+4 ; ---- patient's attending physician information
NEW ATTPHY
+5 ; -- patient's admitting physician index on NEW PERSON
NEW ADMPHYIX
+6 ; ---- patient's admitting physician information
NEW ADMPHY
+7 ; -- patient's service/section associated with Rad order - index
NEW RADSVCIX
+8 ; ------- service/section name
NEW SVC
+9 ; ------- scratch variable
NEW TMP
+10 ; --- ward record from VAIP(5)
NEW WARDREC
+11 ; ---- ward index on WARD LOCATION File (#44)
NEW WARDIX
+12 ; --- name of ward
NEW WARDNAM
+13 ;
+14 ; fetch information
+15 ; patient's room and bed
SET ROOMBED=$PIECE($GET(VAIP(6)),U,2)
+16 ; attending physician
SET ATTPHYIX=+$GET(VAIP(18))
SET ATTPHY=""
+17 IF ATTPHYIX
Begin DoDot:1
+18 SET MAGNME("FILE")=200
SET MAGNME("IENS")=ATTPHYIX
SET MAGNME("FIELD")=.01
+19 SET ATTPHY=ATTPHYIX_U_$$HLNAME^XLFNAME(.MAGNME,"S",U)
+20 QUIT
End DoDot:1
+21 ; admitting physician
SET ADMPHYIX=+$GET(VAIP(13,5))
SET ADMPHY=""
+22 IF ADMPHYIX
Begin DoDot:1
+23 SET MAGNME("FILE")=200
SET MAGNME("IENS")=ADMPHYIX
SET MAGNME("FIELD")=.01
+24 SET ADMPHY=ADMPHYIX_U_$$HLNAME^XLFNAME(.MAGNME,"S",U)
+25 QUIT
End DoDot:1
+26 ; populate message array
+27 ; patient class
SET @XYMSG@(SEGIX,2,1,1,1)="I"
+28 SET WARDREC=$GET(VAIP(5))
SET WARDIX=$PIECE(WARDREC,U,1)
SET WARDNAM=$PIECE(WARDREC,U,2)
+29 ; patient location - ward
SET @XYMSG@(SEGIX,3,1,1,1)=WARDNAM
+30 ; patient location - room
SET @XYMSG@(SEGIX,3,1,2,1)=$PIECE(ROOMBED,"-",1)
+31 ; patient location - bed
SET @XYMSG@(SEGIX,3,1,3,1)=$PIECE(ROOMBED,"-",2)
+32 ; pt loc - facility
if WARDNAM'=""
SET @XYMSG@(SEGIX,3,1,4,1)=$$FACILIX(WARDIX,"W")
+33 ; transfer -> get previous location
IF XEVN="A02"
Begin DoDot:1
+34 SET TMP=$GET(VAIP(15))
if 'TMP
QUIT
KILL VAIP
+35 SET VAIP("E")=TMP
DO IN5^VADPT
+36 ; previous room and bed
SET ROOMBED=$PIECE($GET(VAIP(6)),U,2)
+37 SET WARDREC=$GET(VAIP(5))
SET WARDIX=$PIECE(WARDREC,U,1)
SET WARDNAM=$PIECE(WARDREC,U,2)
+38 ; previous location - ward
SET @XYMSG@(SEGIX,6,1,1,1)=WARDNAM
+39 ; previous location - room
SET @XYMSG@(SEGIX,6,1,2,1)=$PIECE(ROOMBED,"-",1)
+40 ; previous location - bed
SET @XYMSG@(SEGIX,6,1,3,1)=$PIECE(ROOMBED,"-",2)
+41 ; prev loc - facility
if WARDNAM'=""
SET @XYMSG@(SEGIX,6,1,4,1)=$$FACILIX(WARDIX,"W")
+42 QUIT
End DoDot:1
+43 ; attending physician
FOR I=1:1:$LENGTH(ATTPHY,U)
SET @XYMSG@(SEGIX,7,1,I,1)=$PIECE(ATTPHY,U,I)
+44 ; hospital service <- treating specialty
SET @XYMSG@(SEGIX,10,1,1,1)=$PIECE(VAIP(8),"^",2)
+45 ; referring = admitting physician
FOR I=1:1:$LENGTH(ADMPHY,U)
SET @XYMSG@(SEGIX,8,1,I,1)=$PIECE(ADMPHY,U,I)
+46 ; admitting physician
FOR I=1:1:$LENGTH(ADMPHY,U)
SET @XYMSG@(SEGIX,17,1,I,1)=$PIECE(ADMPHY,U,I)
+47 QUIT
+48 ;
OUT ; SUBROUTINE - patient is now an outpatient
+1 ; -- outpatient clinic index on HOSPITAL LOCATION
NEW CLINICIX
+2 ; ---- outpatient clinic
NEW CLINIC
+3 ;
+4 ; patient class
SET @XYMSG@(SEGIX,2,1,1,1)="O"
+5 ; discharge date/time
if XEVN="A03"
SET @XYMSG@(SEGIX,45,1,1,1)=$$FMTHL7^XLFDT(XEVNDT)
+6 ; insert admit date/time as appropriate
+7 ;
+8 ; outpatient radiology order
IF $GET(RADFN)
Begin DoDot:1
+9 IF $GET(RADTI)
IF $GET(RACNI)
Begin DoDot:2
+10 ; -- working variable
NEW SUBSCRIPT
+11 SET SUBSCRIPT=RACNI_","_RADTI_","_RADFN
+12 SET CLINICIX=$$GET1^DIQ(70.03,SUBSCRIPT,8,"I")
+13 QUIT
End DoDot:2
+14 QUIT
End DoDot:1
+15 ; outpatient consult/procedure order
IF '$TEST
IF $GET(GMRCIEN)
Begin DoDot:1
+16 SET CLINICIX=$$GET1^DIQ(123,GMRCIEN,.04,"I")
+17 QUIT
End DoDot:1
+18 ;
+19 ; outpatient clinic goes on PV1-11 Temporary Location
IF $GET(CLINICIX)
Begin DoDot:1
+20 SET CLINIC=$$GET1^DIQ(44,CLINICIX,.01)
+21 ; patient location - clinic
SET @XYMSG@(SEGIX,11,1,1,1)=CLINIC
+22 ; pt loc - facility
if CLINIC'=""
SET @XYMSG@(SEGIX,11,1,4,1)=$$FACILIX(CLINICIX,"C")
+23 QUIT
End DoDot:1
+24 ;
+25 QUIT
+26 ;
FACILIX(LOCATIONIX,LOCTYPE) ; FUNCTION - return the facility associated with a ward
+1 ; or clinic, if any, otherwise return user's default facility
+2 ;
+3 ; input: LOCATIONIX = IEN of the ward in WARD LOCATION File (#42), or
+4 ; LOCATIONIX = IEN of the clinic in HOSPITAL LOCATION File (#44)
+5 ; LOCTYPE = "W" for Ward (#42) or "C" for Clinic (#44)
+6 ;
+7 ; function return: <facility code>_"_"_<facility name>
+8 ;
+9 ; FileMan work variables
NEW DA,DIC,DIQ,DR,X
+10 ; -- IEN of hospital location in HOSPITAL LOCATION File (#44)
NEW HOSPLOCIX
+11 ; ---- IEN of facility on INSTITUTION File (#4)
NEW FACILIX
+12 ; --- name of facility on INSTITUTION File (#4)
NEW FACILNAM
+13 ; ----- work array for FileMan search results
NEW MAGLOC
+14 ;
+15 if $GET(LOCATIONIX)
Begin DoDot:1
+16 if LOCATIONIX'=+LOCATIONIX
QUIT
+17 ; hospital location passed as LOCATIONIX
IF $GET(LOCTYPE)="C"
SET HOSPLOCIX=LOCATIONIX
+18 ; look up hospital location - ICR 10039
IF '$TEST
SET HOSPLOCIX=$PIECE($GET(^DIC(42,LOCATIONIX,44)),U,1)
+19 ; hospital location not on file
if HOSPLOCIX'>0
QUIT
if '$DATA(^SC(HOSPLOCIX))
QUIT
+20 ; look up facility - ICR 10040
SET FACILIX=$PIECE($GET(^SC(HOSPLOCIX,0)),"^",4)
+21 QUIT
End DoDot:1
+22 if '$GET(FACILIX)
SET FACILIX=$GET(DUZ(2))
+23 ; get facility name - ICR 10090
if FACILIX
Begin DoDot:1
+24 SET DIC=4
SET DR=.01
SET DA=FACILIX
SET DIQ="MAGLOC"
SET DIQ(0)="E"
+25 DO EN^DIQ1
SET FACILNAM=$GET(MAGLOC(4,FACILIX,.01,"E"))
+26 QUIT
End DoDot:1
+27 QUIT $SELECT(FACILIX:FACILIX_"_"_$GET(FACILNAM),1:"")
