BEDDADM ;GDIT/HS/BEE-BEDD Admit Utility Routine ; 08 Nov 2011 12:00 PM
;;2.0;BEDD DASHBOARD;**2,3**;Jun 04, 2014;Build 12
;
;GDIT/HS/BEE 05/10/2018;CR#10213 - BEDD*2.0*3 - Allow different hospital locations
;
Q
;
GCLINIC(DFN) ;Return the visit clinic
;
;GDIT/HS/BEE 05/10/2018;CR#10213 - BEDD*2.0*3 - Now returning ER OPTION CIEN
;NEW CL,VIEN,DEF
;
;S DEF=$$GET1^DIQ(40.7,"30,",1,"I")
;
;I +$G(DFN)=0 Q DEF
;
;Get the visit
;S VIEN=$$GET1^DIQ(9009081,DFN_",",1.1,"I") I '+VIEN Q DEF
;
;Get the clinic
;S CL=$$GET1^DIQ(9000010,VIEN_",",.08,"I") I '+CL Q DEF
;Q $$GET1^DIQ(40.7,CL_",",1,"I")
;
NEW VIEN
;
S VIEN=$$GET1^DIQ(9009081,+$G(DFN)_",",1.1,"I") I '+VIEN Q ""
Q $$VCLIN^BEDDUTL2(VIEN)
;
CLIN(CIEN) ;Return the clinic mnemonic
Q
ADATE(X) ;EP - Convert user entered admit date/time to correct format
;
NEW %DT,Y,%,NOW
;
;Get current date/time
D
. NEW X
. D NOW^%DTC
. S NOW=%
;
S X=$TR(X," ","@")
;
S:$E(X)="N" X="NOW"
S %DT="T" D ^%DT
S:Y=-1 Y=""
;
;Flag future date/time
I Y>NOW Q "-1"
;
;Return converted date/time
Q $$FMTE^BEDDUTIL(Y)
;
BLDVTYP(MYVTP) ;EP - Build Acuity MYVTP array
;
; Input:
; None
;
; Output:
; MYVTP array of ^AMER(3) VISIT TYPE entries
;
;Error Trap
NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BEDDADM D UNWIND^%ZTER" ; SAC 2006 2.2.3.3.2
;
NEW VTIEN,CNT,VIEN,VTYP
K MYTRG
S VTIEN=$O(^AMER(2,"B","VISIT TYPE","")) Q:VTIEN=""
S CNT=0,VIEN="" F S VIEN=$O(^AMER(3,"AC",VTIEN,VIEN)) Q:'VIEN D
. S VTYP=$$GET1^DIQ(9009083,VIEN_",",.01,"E") Q:VTYP=""
. S CNT=CNT+1
. S MYVTP(CNT)=VIEN_"^"_VTYP
Q
;
DEFVTYP() ;EP - Locate Default "UNSCHEDULED" visit type
Q $O(^AMER(3,"B","UNSCHEDULED",""))
;
BLDTFRM(MYTFRM) ;EP - Build Acuity MYTFRM array
;
; Input:
; None
;
; Output:
; MYTFRM array of ^AMER(3) VISIT TYPE entries
;
;Error Trap
NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BEDDADM D UNWIND^%ZTER" ; SAC 2006 2.2.3.3.2
;
NEW CNT,TIEN,TFRM
K MYTFRM
S CNT=0,TFRM="" F S TFRM=$O(^AMER(2.1,"B",TFRM)) Q:TFRM="" D
. S TIEN=$O(^AMER(2.1,"B",TFRM,"")) Q:TIEN=""
. S CNT=CNT+1
. S MYTFRM(CNT)=TIEN_"^"_TFRM
Q
;
BLDMTRN(MYMTRN) ;EP - Build MYMTRN array
;
; Input:
; None
;
; Output:
; MYMTRN array of ^AMER(3) TRANSFER DETAILS entries
;
;Error Trap
NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BEDDADM D UNWIND^%ZTER" ; SAC 2006 2.2.3.3.2
;
NEW MTIEN,CNT,MIEN,MTRN
K MYMTRN
S MTIEN=$O(^AMER(2,"B","TRANSFER DETAILS","")) Q:MTIEN=""
S CNT=0,MIEN="" F S MIEN=$O(^AMER(3,"AC",MTIEN,MIEN)) Q:'MIEN D
. S MTRN=$$GET1^DIQ(9009083,MIEN_",",.01,"E") Q:MTRN=""
. S CNT=CNT+1
. S MYMTRN(CNT)=MIEN_"^"_MTRN
Q
;
BLDTMOD(MYTMOD) ;EP - Build MYTMOD array
;
; Input:
; None
;
; Output:
; MYTMOD array of ^AMER(3) MODE OF TRANSPORT entries
;
;Error Trap
NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BEDDADM D UNWIND^%ZTER" ; SAC 2006 2.2.3.3.2
;
NEW MTIEN,CNT,MIEN,MTRN
K MYTMOD
S MTIEN=$O(^AMER(2,"B","MODE OF TRANSPORT","")) Q:MTIEN=""
S CNT=0,MIEN="" F S MIEN=$O(^AMER(3,"AC",MTIEN,MIEN)) Q:'MIEN D
. S MTRN=$$GET1^DIQ(9009083,MIEN_",",.01,"E") Q:MTRN=""
. S CNT=CNT+1
. S MYTMOD(CNT)=MIEN_"^"_MTRN
Q
;
BLDACMP(MYACMP) ;EP - Build MYACMP array
;
; Input:
; None
;
; Output:
; MYACMP array of ^AMER(3) Ambulance Company entries
;
;Error Trap
NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BEDDADM D UNWIND^%ZTER" ; SAC 2006 2.2.3.3.2
;
NEW MTIEN,CNT,MIEN,MCMP
K MYACMP
S MTIEN=$O(^AMER(2,"B","AMBULANCE COMPANY","")) Q:MTIEN=""
S CNT=0,MIEN="" F S MIEN=$O(^AMER(3,"AC",MTIEN,MIEN)) Q:'MIEN D
. S MCMP=$$GET1^DIQ(9009083,MIEN_",",.01,"E") Q:MCMP=""
. S CNT=CNT+1
. S MYACMP(CNT)=MIEN_"^"_MCMP
Q
;
DEFCLIN() ;EP - Return the default clinic
;
NEW CLIN
;
;GDIT/HS/BEE 07/10/2018;CR#10213 - BEDD*2.0*3 - Now use CIEN rather then code
;S CLIN=$$GET1^DIQ(9009082.5,DUZ(2)_",",.06,"I") I CLIN]"" D
;. S CLIN=$$GET1^DIQ(9009083,CLIN_",",5,"I")
S CLIN=$$GET1^DIQ(9009082.5,+$G(DUZ(2))_",",.06,"I")
;
;GDIT/HS/BEE 07/10/2018;CR#10213 - BEDD*2.0*3 - if none, pick first with 30
;If default not set, use first one pointing to 30
;S:CLIN="" CLIN=30
S:CLIN="" CLIN=$O(^AMER(3,"B",30,""))
;
Q CLIN
;
DEFMTRN() ;EP - Locate Default "PRIVATE VEHICLE TRANSFER" transport type
Q $O(^AMER(3,"B","PRIVATE VEHICLE TRANSFER",""))
;
DEFTMOD() ;EP - Locate Default "PRIVATE VEHICLE TRANSFER" trasnsport type
Q $O(^AMER(3,"B","PRIVATE VEHICLE/WALK IN",""))
;
SAVEADM(BEDD) ;Admit/update patient visit
;
NEW X,AMERUP,DFN,AMERTIME,AGCHART,AMERPCC,TRANSYN,TRNFRM,TRNMOD,TRNATT,PCMP
NEW VTYPE,AMEANS,ACOMP,ABILL,ANUMB,ACTION,BIEN,EXEC,CLINIC,ERR
;
;Update visit entries
S DFN=$G(BEDD("tPatientDFN")) I DFN="" Q "-1^Could not locate patient DFN"
;
;New visit
I +$G(BEDD("tNewVisit"))=0 S AMERPCC=$$NADM(.BEDD) I +AMERPCC=-1 Q AMERPCC
;
;Existing visit
I +$G(BEDD("tNewVisit"))=1 S AMERPCC=$$GET1^DIQ(9009081,DFN_",",1.1,"I")
;
;Admit Date/Time
S AMERTIME=$$DATE^BEDDUTIU($G(BEDD("tAdmitDtTm")))
S AMERUP(9009081,DFN_",",1)=AMERTIME
;
;Presenting complaint
S PCMP=$G(BEDD("tPCmp"))
S PCMP=$TR(PCMP,$C(10)," ") ;Convert linefeed to space
S AMERUP(9009081,DFN_",",23)=$S(PCMP]"":PCMP,1:"@")
S AMERUP(9000010,AMERPCC_",",1401)=$S(PCMP]"":PCMP,1:"@")
;
;Clinic
S CLINIC=$G(BEDD("tClinic"))
;GDIT/HS/BEE 05/10/2018;CR#10213 - BEDD*2.0*3 - Allow different hospital locations
S ERR=$$CKHLOC^AMERBSD(AMERPCC,CLINIC)
;
;Date of Birth
S AMERUP(9009081,DFN_",",.02)=$$GET1^DIQ(2,DFN_",",.03,"I")
;
;Chart
S AGCHART="00000"_$P($G(^AUPNPAT(DFN,41,DUZ(2),0)),U,2)
S AGCHART=$E(AGCHART,$L(AGCHART)-5,$L(AGCHART))
S AMERUP(9009081,DFN_",",.03)=$S(AGCHART="":"",1:AGCHART)
;
;Sex
S AMERUP(9009081,DFN_",",.05)=$$GET1^DIQ(2,DFN_",",".02","I")
;
;Visit Type
S VTYPE=$G(BEDD("tVisitType"))
S AMERUP(9009081,DFN_",",3)=$S(VTYPE="":"@",1:VTYPE)
;
;PCC Visit
S AMERUP(9009081,DFN_",",1.1)=AMERPCC
;
;Transfer YN
S TRANSYN=$G(BEDD("tTransferYN"))
S AMERUP(9009081,DFN_",",2.1)=$S(TRANSYN="":"@",1:TRANSYN)
;
;Transfer From
S TRNFRM=$G(BEDD("tTransferFrom"))
S AMERUP(9009081,DFN_",",2.2)=$S(TRNFRM="":"@",1:TRNFRM)
;
;Transfer Mode
S TRNMOD=$G(BEDD("tModeTransport"))
S AMERUP(9009081,DFN_",",2.3)=$S(TRNMOD="":"@",1:TRNMOD)
;
;Transfer Attendant
S TRNATT=$G(BEDD("tAttendantYN"))
S AMERUP(9009081,DFN_",",2.4)=$S(TRNATT="":"@",1:TRNATT)
;
;Data Enterer
S AMERUP(9009081,DFN_",",10)=DUZ
;
;Arrival Means
S AMEANS=$G(BEDD("tArrivalMeans"))
S AMERUP(9009081,DFN_",",6)=$S(AMEANS]"":AMEANS,1:"@")
;
;Ambulance Company
S ACOMP=$G(BEDD("tAmbulanceCompany"))
S AMERUP(9009081,DFN_",",15)=$S(ACOMP]"":ACOMP,1:"@")
;
;Ambulance Billing Number
S ABILL=$G(BEDD("tBillingNumber"))
S AMERUP(9009081,DFN_",",13)=$S(ABILL]"":ABILL,1:"@")
;
;Ambulance Number
S ANUMB=$G(BEDD("tAmbulanceNumber"))
S AMERUP(9009081,DFN_",",12)=$S(ANUMB]"":ANUMB,1:"@")
;
;Save the entry
D FILE^DIE("","AMERUP","ERROR")
;
;Admit to Dashboard if new
S BIEN=""
I +$G(BEDD("tNewVisit"))=0 S BIEN=$$NEW(DFN,AMERPCC) I BIEN=0 Q "-1^Could not admit to dashboard"
;
;Get BEDD ObjectID if existing
I +$G(BEDD("tNewVisit")) D
. NEW EXEC
. S EXEC="S BIEN=$O(^BEDD.EDVISITI(""ADIdx"",AMERPCC,""""))" X EXEC
;
;Create/update V EMERGENCY VISIT RECORD entry
D VER^AMERVER(DFN,AMERPCC)
;
;Log to BUSA
;
;New visit
I +$G(BEDD("tNewVisit"))=0 D LOG^BEDDUTIU(DUZ,"P","A","BEDDAdmit.csp","BEDD: Admitted patient to ER",DFN) I 1
E D LOG^BEDDUTIU(DUZ,"P","E","BEDDAdmit.csp","BEDD: Updated existing ER visit admission information",DFN)
;
Q BIEN
;
NADM(BEDD) ;Create new ER ADMISSION and VISIT records
;
NEW AMERDFN,DIC,X,Y,DINUM,AMERTIME,AMERPCC,ERR
;
;Create ER ADMISSION entry
S AMERDFN=$G(BEDD("tPatientDFN")) I AMERDFN="" Q "-1^No DFN found"
;
;Check to make sure we don't have an entry and create one if needed
S ERR="" I '$D(^AMERADM(AMERDFN)) D Q:ERR]"" ERR
. S DIC="^AMERADM(",DIC(0)="L",X=AMERDFN,DINUM=X
. K DD,DO
. D FILE^DICN K DIC I Y=-1 S ERR="-1^Could not create ER ADMISSION record"
;
;Get visit date/time
S AMERTIME=$$DATE^BEDDUTIU($G(BEDD("tAdmitDtTm")))
;
;Try to find a visit in the entry
S AMERPCC=$$GET1^DIQ(9009081,AMERDFN_",",1.1,"I") I +AMERPCC Q AMERPCC
;
;Create VISIT entry
S AMERPCC=$$VISIT^BEDDPCC(AMERDFN,AMERTIME,.BEDD)
;
Q AMERPCC
;
NEW(AMERDFN,VIEN) ; EP - Add New
;
NEW EXEC
;
;Lock global
S EXEC="L +^BEDD.EDVISIT(0):45" X EXEC I $T=0 Q 0
;
NEW EDOBJ,STATUS,ID
;
S ID=""
S EXEC="S EDOBJ=##CLASS(BEDD.EDVISIT).%New()" X EXEC
S EXEC="S EDOBJ.PtDFN=AMERDFN" X EXEC
S EXEC="S EDOBJ.VIEN=VIEN" X EXEC
S EXEC="S EDOBJ.DCFlag=0" X EXEC
S EXEC="S EDOBJ.PtStatV=1" X EXEC
S EXEC="S EDOBJ.DCDtH=""""" X EXEC
S EXEC="S STATUS=EDOBJ.%Save()" X EXEC I STATUS'=1 S ID=0 G XNEW
S EXEC="S ID=EDOBJ.%Id()" X EXEC
S EDOBJ=""
;
;Unlock global
XNEW S EXEC="L -^BEDD.EDVISIT(0)" X EXEC
Q ID
;
;Retrieve printer IEN
DVIEN(PRINTER) ;Return the IEN associated with the printer
;
I $G(PRINTER)="" Q ""
Q $O(^%ZIS(1,"B",PRINTER,""))
;
DVLIST(DVLIST) ;
;
NEW X,CNT,PRT,CNT,IEN
;
;Make sure initial variables are set
S X="S:$G(U)="""" U=""^""" X X
S X="S:$G(DT)="""" DT=$$DT^XLFDT" X X
;
S CNT=0
;
S PRT="" F S PRT=$O(^%ZIS(1,"B",PRT)) Q:PRT="" D
. Q:$E(PRT,1,4)="NULL"
. ;
. S IEN="" F S IEN=$O(^%ZIS(1,"B",PRT,IEN)) Q:'IEN D
.. ;
.. NEW XSTYPE,XTYPE,X0,XOSD,X
.. ;
.. ;Printers only
.. S XSTYPE=+$G(^%ZIS(1,IEN,"SUBTYPE"))
.. Q:$E($G(^%ZIS(2,XSTYPE,0)))'="P"
.. ;
.. ;Type
.. S XTYPE=$P($G(^%ZIS(1,IEN,"TYPE")),U)
.. Q:"^TRM^HG^CHAN^OTH^"'[(U_XTYPE_U)
.. ;
.. ;Queuing allowed
.. S X0=$G(^%ZIS(1,IEN,0))
.. Q:$P(X0,U,2)="0"!($P(X0,U,12)=2)
.. ;
.. ;Out of Service
.. S XOSD=+$G(^%ZIS(1,IEN,90))
.. I XOSD,XOSD'>DT Q ; Out of Service
.. ;
.. ;Printer
.. S X=$P(X0,U) Q:X=""
.. Q:$E(X,1,4)="NULL"
.. ;
.. S CNT=CNT+1,DVLIST(CNT)=IEN_U_X
;
Q
;
ERR ;
D ^%ZTER
Q
BEDDADM ;GDIT/HS/BEE-BEDD Admit Utility Routine ; 08 Nov 2011 12:00 PM
+1 ;;2.0;BEDD DASHBOARD;**2,3**;Jun 04, 2014;Build 12
+2 ;
+3 ;GDIT/HS/BEE 05/10/2018;CR#10213 - BEDD*2.0*3 - Allow different hospital locations
+4 ;
+5 QUIT
+6 ;
GCLINIC(DFN) ;Return the visit clinic
+1 ;
+2 ;GDIT/HS/BEE 05/10/2018;CR#10213 - BEDD*2.0*3 - Now returning ER OPTION CIEN
+3 ;NEW CL,VIEN,DEF
+4 ;
+5 ;S DEF=$$GET1^DIQ(40.7,"30,",1,"I")
+6 ;
+7 ;I +$G(DFN)=0 Q DEF
+8 ;
+9 ;Get the visit
+10 ;S VIEN=$$GET1^DIQ(9009081,DFN_",",1.1,"I") I '+VIEN Q DEF
+11 ;
+12 ;Get the clinic
+13 ;S CL=$$GET1^DIQ(9000010,VIEN_",",.08,"I") I '+CL Q DEF
+14 ;Q $$GET1^DIQ(40.7,CL_",",1,"I")
+15 ;
+16 NEW VIEN
+17 ;
+18 SET VIEN=$$GET1^DIQ(9009081,+$GET(DFN)_",",1.1,"I")
IF '+VIEN
QUIT ""
+19 QUIT $$VCLIN^BEDDUTL2(VIEN)
+20 ;
CLIN(CIEN) ;Return the clinic mnemonic
+1 QUIT
ADATE(X) ;EP - Convert user entered admit date/time to correct format
+1 ;
+2 NEW %DT,Y,%,NOW
+3 ;
+4 ;Get current date/time
+5 Begin DoDot:1
+6 NEW X
+7 DO NOW^%DTC
+8 SET NOW=%
End DoDot:1
+9 ;
+10 SET X=$TRANSLATE(X," ","@")
+11 ;
+12 IF $EXTRACT(X)="N"
SET X="NOW"
+13 SET %DT="T"
DO ^%DT
+14 IF Y=-1
SET Y=""
+15 ;
+16 ;Flag future date/time
+17 IF Y>NOW
QUIT "-1"
+18 ;
+19 ;Return converted date/time
+20 QUIT $$FMTE^BEDDUTIL(Y)
+21 ;
BLDVTYP(MYVTP) ;EP - Build Acuity MYVTP array
+1 ;
+2 ; Input:
+3 ; None
+4 ;
+5 ; Output:
+6 ; MYVTP array of ^AMER(3) VISIT TYPE entries
+7 ;
+8 ;Error Trap
+9 ; SAC 2006 2.2.3.3.2
NEW $ESTACK,$ETRAP
SET $ETRAP="D ERR^BEDDADM D UNWIND^%ZTER"
+10 ;
+11 NEW VTIEN,CNT,VIEN,VTYP
+12 KILL MYTRG
+13 SET VTIEN=$ORDER(^AMER(2,"B","VISIT TYPE",""))
IF VTIEN=""
QUIT
+14 SET CNT=0
SET VIEN=""
FOR
SET VIEN=$ORDER(^AMER(3,"AC",VTIEN,VIEN))
IF 'VIEN
QUIT
Begin DoDot:1
+15 SET VTYP=$$GET1^DIQ(9009083,VIEN_",",.01,"E")
IF VTYP=""
QUIT
+16 SET CNT=CNT+1
+17 SET MYVTP(CNT)=VIEN_"^"_VTYP
End DoDot:1
+18 QUIT
+19 ;
DEFVTYP() ;EP - Locate Default "UNSCHEDULED" visit type
+1 QUIT $ORDER(^AMER(3,"B","UNSCHEDULED",""))
+2 ;
BLDTFRM(MYTFRM) ;EP - Build Acuity MYTFRM array
+1 ;
+2 ; Input:
+3 ; None
+4 ;
+5 ; Output:
+6 ; MYTFRM array of ^AMER(3) VISIT TYPE entries
+7 ;
+8 ;Error Trap
+9 ; SAC 2006 2.2.3.3.2
NEW $ESTACK,$ETRAP
SET $ETRAP="D ERR^BEDDADM D UNWIND^%ZTER"
+10 ;
+11 NEW CNT,TIEN,TFRM
+12 KILL MYTFRM
+13 SET CNT=0
SET TFRM=""
FOR
SET TFRM=$ORDER(^AMER(2.1,"B",TFRM))
IF TFRM=""
QUIT
Begin DoDot:1
+14 SET TIEN=$ORDER(^AMER(2.1,"B",TFRM,""))
IF TIEN=""
QUIT
+15 SET CNT=CNT+1
+16 SET MYTFRM(CNT)=TIEN_"^"_TFRM
End DoDot:1
+17 QUIT
+18 ;
BLDMTRN(MYMTRN) ;EP - Build MYMTRN array
+1 ;
+2 ; Input:
+3 ; None
+4 ;
+5 ; Output:
+6 ; MYMTRN array of ^AMER(3) TRANSFER DETAILS entries
+7 ;
+8 ;Error Trap
+9 ; SAC 2006 2.2.3.3.2
NEW $ESTACK,$ETRAP
SET $ETRAP="D ERR^BEDDADM D UNWIND^%ZTER"
+10 ;
+11 NEW MTIEN,CNT,MIEN,MTRN
+12 KILL MYMTRN
+13 SET MTIEN=$ORDER(^AMER(2,"B","TRANSFER DETAILS",""))
IF MTIEN=""
QUIT
+14 SET CNT=0
SET MIEN=""
FOR
SET MIEN=$ORDER(^AMER(3,"AC",MTIEN,MIEN))
IF 'MIEN
QUIT
Begin DoDot:1
+15 SET MTRN=$$GET1^DIQ(9009083,MIEN_",",.01,"E")
IF MTRN=""
QUIT
+16 SET CNT=CNT+1
+17 SET MYMTRN(CNT)=MIEN_"^"_MTRN
End DoDot:1
+18 QUIT
+19 ;
BLDTMOD(MYTMOD) ;EP - Build MYTMOD array
+1 ;
+2 ; Input:
+3 ; None
+4 ;
+5 ; Output:
+6 ; MYTMOD array of ^AMER(3) MODE OF TRANSPORT entries
+7 ;
+8 ;Error Trap
+9 ; SAC 2006 2.2.3.3.2
NEW $ESTACK,$ETRAP
SET $ETRAP="D ERR^BEDDADM D UNWIND^%ZTER"
+10 ;
+11 NEW MTIEN,CNT,MIEN,MTRN
+12 KILL MYTMOD
+13 SET MTIEN=$ORDER(^AMER(2,"B","MODE OF TRANSPORT",""))
IF MTIEN=""
QUIT
+14 SET CNT=0
SET MIEN=""
FOR
SET MIEN=$ORDER(^AMER(3,"AC",MTIEN,MIEN))
IF 'MIEN
QUIT
Begin DoDot:1
+15 SET MTRN=$$GET1^DIQ(9009083,MIEN_",",.01,"E")
IF MTRN=""
QUIT
+16 SET CNT=CNT+1
+17 SET MYTMOD(CNT)=MIEN_"^"_MTRN
End DoDot:1
+18 QUIT
+19 ;
BLDACMP(MYACMP) ;EP - Build MYACMP array
+1 ;
+2 ; Input:
+3 ; None
+4 ;
+5 ; Output:
+6 ; MYACMP array of ^AMER(3) Ambulance Company entries
+7 ;
+8 ;Error Trap
+9 ; SAC 2006 2.2.3.3.2
NEW $ESTACK,$ETRAP
SET $ETRAP="D ERR^BEDDADM D UNWIND^%ZTER"
+10 ;
+11 NEW MTIEN,CNT,MIEN,MCMP
+12 KILL MYACMP
+13 SET MTIEN=$ORDER(^AMER(2,"B","AMBULANCE COMPANY",""))
IF MTIEN=""
QUIT
+14 SET CNT=0
SET MIEN=""
FOR
SET MIEN=$ORDER(^AMER(3,"AC",MTIEN,MIEN))
IF 'MIEN
QUIT
Begin DoDot:1
+15 SET MCMP=$$GET1^DIQ(9009083,MIEN_",",.01,"E")
IF MCMP=""
QUIT
+16 SET CNT=CNT+1
+17 SET MYACMP(CNT)=MIEN_"^"_MCMP
End DoDot:1
+18 QUIT
+19 ;
DEFCLIN() ;EP - Return the default clinic
+1 ;
+2 NEW CLIN
+3 ;
+4 ;GDIT/HS/BEE 07/10/2018;CR#10213 - BEDD*2.0*3 - Now use CIEN rather then code
+5 ;S CLIN=$$GET1^DIQ(9009082.5,DUZ(2)_",",.06,"I") I CLIN]"" D
+6 ;. S CLIN=$$GET1^DIQ(9009083,CLIN_",",5,"I")
+7 SET CLIN=$$GET1^DIQ(9009082.5,+$GET(DUZ(2))_",",.06,"I")
+8 ;
+9 ;GDIT/HS/BEE 07/10/2018;CR#10213 - BEDD*2.0*3 - if none, pick first with 30
+10 ;If default not set, use first one pointing to 30
+11 ;S:CLIN="" CLIN=30
+12 IF CLIN=""
SET CLIN=$ORDER(^AMER(3,"B",30,""))
+13 ;
+14 QUIT CLIN
+15 ;
DEFMTRN() ;EP - Locate Default "PRIVATE VEHICLE TRANSFER" transport type
+1 QUIT $ORDER(^AMER(3,"B","PRIVATE VEHICLE TRANSFER",""))
+2 ;
DEFTMOD() ;EP - Locate Default "PRIVATE VEHICLE TRANSFER" trasnsport type
+1 QUIT $ORDER(^AMER(3,"B","PRIVATE VEHICLE/WALK IN",""))
+2 ;
SAVEADM(BEDD) ;Admit/update patient visit
+1 ;
+2 NEW X,AMERUP,DFN,AMERTIME,AGCHART,AMERPCC,TRANSYN,TRNFRM,TRNMOD,TRNATT,PCMP
+3 NEW VTYPE,AMEANS,ACOMP,ABILL,ANUMB,ACTION,BIEN,EXEC,CLINIC,ERR
+4 ;
+5 ;Update visit entries
+6 SET DFN=$GET(BEDD("tPatientDFN"))
IF DFN=""
QUIT "-1^Could not locate patient DFN"
+7 ;
+8 ;New visit
+9 IF +$GET(BEDD("tNewVisit"))=0
SET AMERPCC=$$NADM(.BEDD)
IF +AMERPCC=-1
QUIT AMERPCC
+10 ;
+11 ;Existing visit
+12 IF +$GET(BEDD("tNewVisit"))=1
SET AMERPCC=$$GET1^DIQ(9009081,DFN_",",1.1,"I")
+13 ;
+14 ;Admit Date/Time
+15 SET AMERTIME=$$DATE^BEDDUTIU($GET(BEDD("tAdmitDtTm")))
+16 SET AMERUP(9009081,DFN_",",1)=AMERTIME
+17 ;
+18 ;Presenting complaint
+19 SET PCMP=$GET(BEDD("tPCmp"))
+20 ;Convert linefeed to space
SET PCMP=$TRANSLATE(PCMP,$CHAR(10)," ")
+21 SET AMERUP(9009081,DFN_",",23)=$SELECT(PCMP]"":PCMP,1:"@")
+22 SET AMERUP(9000010,AMERPCC_",",1401)=$SELECT(PCMP]"":PCMP,1:"@")
+23 ;
+24 ;Clinic
+25 SET CLINIC=$GET(BEDD("tClinic"))
+26 ;GDIT/HS/BEE 05/10/2018;CR#10213 - BEDD*2.0*3 - Allow different hospital locations
+27 SET ERR=$$CKHLOC^AMERBSD(AMERPCC,CLINIC)
+28 ;
+29 ;Date of Birth
+30 SET AMERUP(9009081,DFN_",",.02)=$$GET1^DIQ(2,DFN_",",.03,"I")
+31 ;
+32 ;Chart
+33 SET AGCHART="00000"_$PIECE($GET(^AUPNPAT(DFN,41,DUZ(2),0)),U,2)
+34 SET AGCHART=$EXTRACT(AGCHART,$LENGTH(AGCHART)-5,$LENGTH(AGCHART))
+35 SET AMERUP(9009081,DFN_",",.03)=$SELECT(AGCHART="":"",1:AGCHART)
+36 ;
+37 ;Sex
+38 SET AMERUP(9009081,DFN_",",.05)=$$GET1^DIQ(2,DFN_",",".02","I")
+39 ;
+40 ;Visit Type
+41 SET VTYPE=$GET(BEDD("tVisitType"))
+42 SET AMERUP(9009081,DFN_",",3)=$SELECT(VTYPE="":"@",1:VTYPE)
+43 ;
+44 ;PCC Visit
+45 SET AMERUP(9009081,DFN_",",1.1)=AMERPCC
+46 ;
+47 ;Transfer YN
+48 SET TRANSYN=$GET(BEDD("tTransferYN"))
+49 SET AMERUP(9009081,DFN_",",2.1)=$SELECT(TRANSYN="":"@",1:TRANSYN)
+50 ;
+51 ;Transfer From
+52 SET TRNFRM=$GET(BEDD("tTransferFrom"))
+53 SET AMERUP(9009081,DFN_",",2.2)=$SELECT(TRNFRM="":"@",1:TRNFRM)
+54 ;
+55 ;Transfer Mode
+56 SET TRNMOD=$GET(BEDD("tModeTransport"))
+57 SET AMERUP(9009081,DFN_",",2.3)=$SELECT(TRNMOD="":"@",1:TRNMOD)
+58 ;
+59 ;Transfer Attendant
+60 SET TRNATT=$GET(BEDD("tAttendantYN"))
+61 SET AMERUP(9009081,DFN_",",2.4)=$SELECT(TRNATT="":"@",1:TRNATT)
+62 ;
+63 ;Data Enterer
+64 SET AMERUP(9009081,DFN_",",10)=DUZ
+65 ;
+66 ;Arrival Means
+67 SET AMEANS=$GET(BEDD("tArrivalMeans"))
+68 SET AMERUP(9009081,DFN_",",6)=$SELECT(AMEANS]"":AMEANS,1:"@")
+69 ;
+70 ;Ambulance Company
+71 SET ACOMP=$GET(BEDD("tAmbulanceCompany"))
+72 SET AMERUP(9009081,DFN_",",15)=$SELECT(ACOMP]"":ACOMP,1:"@")
+73 ;
+74 ;Ambulance Billing Number
+75 SET ABILL=$GET(BEDD("tBillingNumber"))
+76 SET AMERUP(9009081,DFN_",",13)=$SELECT(ABILL]"":ABILL,1:"@")
+77 ;
+78 ;Ambulance Number
+79 SET ANUMB=$GET(BEDD("tAmbulanceNumber"))
+80 SET AMERUP(9009081,DFN_",",12)=$SELECT(ANUMB]"":ANUMB,1:"@")
+81 ;
+82 ;Save the entry
+83 DO FILE^DIE("","AMERUP","ERROR")
+84 ;
+85 ;Admit to Dashboard if new
+86 SET BIEN=""
+87 IF +$GET(BEDD("tNewVisit"))=0
SET BIEN=$$NEW(DFN,AMERPCC)
IF BIEN=0
QUIT "-1^Could not admit to dashboard"
+88 ;
+89 ;Get BEDD ObjectID if existing
+90 IF +$GET(BEDD("tNewVisit"))
Begin DoDot:1
+91 NEW EXEC
+92 SET EXEC="S BIEN=$O(^BEDD.EDVISITI(""ADIdx"",AMERPCC,""""))"
XECUTE EXEC
End DoDot:1
+93 ;
+94 ;Create/update V EMERGENCY VISIT RECORD entry
+95 DO VER^AMERVER(DFN,AMERPCC)
+96 ;
+97 ;Log to BUSA
+98 ;
+99 ;New visit
+100 IF +$GET(BEDD("tNewVisit"))=0
DO LOG^BEDDUTIU(DUZ,"P","A","BEDDAdmit.csp","BEDD: Admitted patient to ER",DFN)
IF 1
+101 IF '$TEST
DO LOG^BEDDUTIU(DUZ,"P","E","BEDDAdmit.csp","BEDD: Updated existing ER visit admission information",DFN)
+102 ;
+103 QUIT BIEN
+104 ;
NADM(BEDD) ;Create new ER ADMISSION and VISIT records
+1 ;
+2 NEW AMERDFN,DIC,X,Y,DINUM,AMERTIME,AMERPCC,ERR
+3 ;
+4 ;Create ER ADMISSION entry
+5 SET AMERDFN=$GET(BEDD("tPatientDFN"))
IF AMERDFN=""
QUIT "-1^No DFN found"
+6 ;
+7 ;Check to make sure we don't have an entry and create one if needed
+8 SET ERR=""
IF '$DATA(^AMERADM(AMERDFN))
Begin DoDot:1
+9 SET DIC="^AMERADM("
SET DIC(0)="L"
SET X=AMERDFN
SET DINUM=X
+10 KILL DD,DO
+11 DO FILE^DICN
KILL DIC
IF Y=-1
SET ERR="-1^Could not create ER ADMISSION record"
End DoDot:1
IF ERR]""
QUIT ERR
+12 ;
+13 ;Get visit date/time
+14 SET AMERTIME=$$DATE^BEDDUTIU($GET(BEDD("tAdmitDtTm")))
+15 ;
+16 ;Try to find a visit in the entry
+17 SET AMERPCC=$$GET1^DIQ(9009081,AMERDFN_",",1.1,"I")
IF +AMERPCC
QUIT AMERPCC
+18 ;
+19 ;Create VISIT entry
+20 SET AMERPCC=$$VISIT^BEDDPCC(AMERDFN,AMERTIME,.BEDD)
+21 ;
+22 QUIT AMERPCC
+23 ;
NEW(AMERDFN,VIEN) ; EP - Add New
+1 ;
+2 NEW EXEC
+3 ;
+4 ;Lock global
+5 SET EXEC="L +^BEDD.EDVISIT(0):45"
XECUTE EXEC
IF $TEST=0
QUIT 0
+6 ;
+7 NEW EDOBJ,STATUS,ID
+8 ;
+9 SET ID=""
+10 SET EXEC="S EDOBJ=##CLASS(BEDD.EDVISIT).%New()"
XECUTE EXEC
+11 SET EXEC="S EDOBJ.PtDFN=AMERDFN"
XECUTE EXEC
+12 SET EXEC="S EDOBJ.VIEN=VIEN"
XECUTE EXEC
+13 SET EXEC="S EDOBJ.DCFlag=0"
XECUTE EXEC
+14 SET EXEC="S EDOBJ.PtStatV=1"
XECUTE EXEC
+15 SET EXEC="S EDOBJ.DCDtH="""""
XECUTE EXEC
+16 SET EXEC="S STATUS=EDOBJ.%Save()"
XECUTE EXEC
IF STATUS'=1
SET ID=0
GOTO XNEW
+17 SET EXEC="S ID=EDOBJ.%Id()"
XECUTE EXEC
+18 SET EDOBJ=""
+19 ;
+20 ;Unlock global
XNEW SET EXEC="L -^BEDD.EDVISIT(0)"
XECUTE EXEC
+1 QUIT ID
+2 ;
+3 ;Retrieve printer IEN
DVIEN(PRINTER) ;Return the IEN associated with the printer
+1 ;
+2 IF $GET(PRINTER)=""
QUIT ""
+3 QUIT $ORDER(^%ZIS(1,"B",PRINTER,""))
+4 ;
DVLIST(DVLIST) ;
+1 ;
+2 NEW X,CNT,PRT,CNT,IEN
+3 ;
+4 ;Make sure initial variables are set
+5 SET X="S:$G(U)="""" U=""^"""
XECUTE X
+6 SET X="S:$G(DT)="""" DT=$$DT^XLFDT"
XECUTE X
+7 ;
+8 SET CNT=0
+9 ;
+10 SET PRT=""
FOR
SET PRT=$ORDER(^%ZIS(1,"B",PRT))
IF PRT=""
QUIT
Begin DoDot:1
+11 IF $EXTRACT(PRT,1,4)="NULL"
QUIT
+12 ;
+13 SET IEN=""
FOR
SET IEN=$ORDER(^%ZIS(1,"B",PRT,IEN))
IF 'IEN
QUIT
Begin DoDot:2
+14 ;
+15 NEW XSTYPE,XTYPE,X0,XOSD,X
+16 ;
+17 ;Printers only
+18 SET XSTYPE=+$GET(^%ZIS(1,IEN,"SUBTYPE"))
+19 IF $EXTRACT($GET(^%ZIS(2,XSTYPE,0)))'="P"
QUIT
+20 ;
+21 ;Type
+22 SET XTYPE=$PIECE($GET(^%ZIS(1,IEN,"TYPE")),U)
+23 IF "^TRM^HG^CHAN^OTH^"'[(U_XTYPE_U)
QUIT
+24 ;
+25 ;Queuing allowed
+26 SET X0=$GET(^%ZIS(1,IEN,0))
+27 IF $PIECE(X0,U,2)="0"!($PIECE(X0,U,12)=2)
QUIT
+28 ;
+29 ;Out of Service
+30 SET XOSD=+$GET(^%ZIS(1,IEN,90))
+31 ; Out of Service
IF XOSD
IF XOSD'>DT
QUIT
+32 ;
+33 ;Printer
+34 SET X=$PIECE(X0,U)
IF X=""
QUIT
+35 IF $EXTRACT(X,1,4)="NULL"
QUIT
+36 ;
+37 SET CNT=CNT+1
SET DVLIST(CNT)=IEN_U_X
End DoDot:2
End DoDot:1
+38 ;
+39 QUIT
+40 ;
ERR ;
+1 DO ^%ZTER
+2 QUIT
