BEDDUTIL ;VNGT/HS/BEE-BEDD Utility Routine ; 08 Nov 2011 12:00 PM
;;2.0;BEDD DASHBOARD;**1,2**;Jun 04, 2014;Build 26
;
Q
;
CHECKAV(BEDDAV) ;EP - Auth AC/VC, Ret DUZ
;
; Input: BEDDAV-ACCESS_";"_VERIFY
; Output: DUZ
;
N BEDDDUZ,XUF
;
S:$G(U)="" U="^"
S:$G(DT)="" DT=$$DT^XLFDT
;
;Err Trap
NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BEDDUTIL D UNWIND^%ZTER" ; SAC 2006 2.2.3.3.2
;
S XUF=0
S BEDDDUZ=$$CHECKAV^XUS(BEDDAV)
I BEDDDUZ=0 Q 0
;
;Ret DUZ if user inactive
I (+$P($G(^VA(200,BEDDDUZ,0)),U,11)'>0)!(+$P($G(^VA(200,BEDDDUZ,0)),U,11)'<DT) Q BEDDDUZ
Q 0
;
AUTH(BEDDDUZ) ;EP - Auth User for ED Access
;
; Input: BEDDDUZ - User's DUZ
; Output: 0-Not Auth/1-Auth
;
N BEDDKEY
;
S:$G(U)="" U="^"
;
;Error Trap
NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BEDDUTIL D UNWIND^%ZTER" ; SAC 2006 2.2.3.3.2
;
I $G(BEDDDUZ)<1 Q 0
S BEDDKEY=$O(^DIC(19.1,"B","BEDDZDASH","")) I BEDDKEY="" Q 0
I '$D(^VA(200,"AB",BEDDKEY,BEDDDUZ,BEDDKEY)) Q 0
Q 1
;
SNAME(SITE) ;EP - Ret Site Name
;
I $G(SITE)="" Q ""
;
Q $$GET1^DIQ(4,SITE_",",".01","E")
;
SITE(BEDDST) ;EP - Assemble List of Sites From File 40.8
;
; Input: BEDDSITE - Empty Arr
; Output: BEDDSITE - List of file 4 entries pointed to by file 40.8 entries
;
N BEDDSITE,BEDDIEN
;
S:$G(U)="" U="^"
;
;Error Trap
NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BEDDUTIL D UNWIND^%ZTER" ; SAC 2006 2.2.3.3.2
;
S BEDDSITE="" F S BEDDSITE=$O(^DG(40.8,"B",BEDDSITE)) Q:BEDDSITE="" D
. S BEDDIEN="" F S BEDDIEN=$O(^DG(40.8,"B",BEDDSITE,BEDDIEN)) Q:BEDDIEN="" D
.. NEW INNM,INIEN
.. S INIEN=$$GET1^DIQ(40.8,BEDDIEN_",",.07,"I") Q:INIEN=""
.. S INNM=$$GET1^DIQ(4,INIEN_",",".01","I") Q:INNM=""
.. S BEDDST(INNM_":"_INIEN)=INNM_U_INIEN
Q
;
BEDDLST(BEDD,SITE) ;EP - Assemble ED List
;
; Input: BEDD - Empty Array
; SITE - Site to look up
; Output: BEDD - List of Dashboard Pats
;
S SITE=$G(SITE)
;
;Error Trap
NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BEDDUTIL D UNWIND^%ZTER" ; SAC 2006 2.2.3.3.2
;
NEW BEDDDAY,BEDDIEN,BEDDGL,BEDDTOT,BEDDBDY,PNDLKBDY,BEDDGLD
;
;BEDD*2.0*1;Pull pending look back days
S PNDLKBDY=10
I +$G(SITE)=0,SITE'="Whiteboard" D
. NEW SIEN,ST,EXEC
. S SIEN=$O(^BEDD.EDSYSTEMD("")) Q:SIEN=""
. S EXEC="S ST=##CLASS(BEDD.EDSYSTEM).%OpenId(SIEN,0)" X EXEC
. S EXEC="S SITE=ST.Site" X EXEC
I +$G(SITE)]"" D
. NEW SYSIEN,EXEC,EDSYSTEM,ISITE
. S ISITE=$S(SITE="Whiteboard":"999999",1:SITE)
. S EXEC="S SYSIEN=$O(^BEDD.EDSYSTEMI(""SiteIdx"","" ""_ISITE,""""))" X EXEC
. I $G(SYSIEN)="" Q
. S EXEC="S EDSYSTEM=##CLASS(BEDD.EDSYSTEM).%OpenId(SYSIEN,0)" X EXEC
. S EXEC="S PNDLKBDY=EDSYSTEM.PendingStsLookBack" X EXEC
. I +PNDLKBDY=0 S PNDLKBDY=10
;
K BEDD
;
;BEDD*2.0*1;Use parameter
S BEDDBDY=$P($H,",")-PNDLKBDY,BEDDDAY=""
S BEDDGL="^BEDD.EDVISITI(""ArrIdx"")"
S BEDDGLD="^BEDD.EDVISITD"
F S BEDDDAY=$O(@BEDDGL@(BEDDDAY),-1) Q:((BEDDDAY="")!(BEDDDAY<BEDDBDY)) D
. S BEDDIEN="" F S BEDDIEN=$O(@BEDDGL@(BEDDDAY,BEDDIEN),-1) Q:BEDDIEN="" D
.. ;
.. ;Remove deleted entries
.. I '$D(@BEDDGLD@(BEDDIEN)) Q
.. ;
.. NEW TRG,ROOM,EDWTIM,EDSTAT,EDTRG,EDROOM,PTDFN
.. S (EDSTAT,EDTRG,EDROOM,EDWTIM,PTDFN)=""
.. ;
.. ;Ret entry
.. D BEDDED^BEDDUTW(BEDDIEN,.EDSTAT,.EDTRG,.EDROOM,.EDWTIM,.PTDFN)
.. ;
.. I EDSTAT=9 Q
.. I EDSTAT=8 Q
.. ;
.. ;Strip dupes
.. Q:$G(PTDFN)=""
.. I $D(BEDD("D",PTDFN)) Q
.. S BEDD("D",PTDFN)=""
.. ;
.. S TRG="" I EDTRG'="" S TRG=EDTRG
.. S:TRG="" TRG=" "
.. S ROOM=" " I EDROOM'="" S ROOM=EDROOM
.. I EDSTAT=1 S BEDD(EDSTAT,BEDDIEN)=EDWTIM
.. I EDSTAT=2 S BEDD(EDSTAT,TRG,BEDDIEN)=EDWTIM
.. I EDSTAT=3 S BEDD(EDSTAT,ROOM,BEDDIEN)=EDWTIM
.. I EDSTAT=4 S BEDD(EDSTAT,TRG,BEDDIEN)=EDWTIM
.. S BEDD("SUM",EDSTAT,BEDDIEN)=EDWTIM
.. S $P(BEDDTOT(EDSTAT),"^")=$P($G(BEDDTOT(EDSTAT)),"^")+1
.. S $P(BEDDTOT(EDSTAT),"^",2)=$P($G(BEDDTOT(EDSTAT)),"^",2)+EDWTIM
.. ;
.. ;Track entries
.. S BEDD("L",BEDDIEN)=""
;
;Assemble Totals
S EDSTAT="" F S EDSTAT=$O(BEDDTOT(EDSTAT)) Q:EDSTAT="" D
. NEW CNT,WTG,AVG
. S CNT=$P(BEDDTOT(EDSTAT),"^")
. S WTG=$P(BEDDTOT(EDSTAT),"^",2)
. S AVG="" I CNT>0,WTG>0 S AVG=WTG\CNT
. S BEDD("TSUM",EDSTAT)=CNT_"^"_WTG_"^"_AVG
;
;Check (and Repair) Room Occupancy
D RMAV^BEDDUTW(.BEDD)
;
Q
;
GETCC(BEDDIEN,BEDDCOMP,TYPE) ;EP - Get V NARRATIVE TEXT
;
; Input:
; BEDDIEN - V NARRATIVE TEXT Entry IEN
; BEDDCOMP - BEDD.EDVISIT - Complaint field value
; TYPE - Return type - P-Presenting, C-Chief, Null-All
;
; Output:
; V NARRATIVE TEXT (1st) or Complaint value (2nd)
;
;Error Trap
NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BEDDUTIL D UNWIND^%ZTER" ; SAC 2006 2.2.3.3.2
;
S TYPE=$G(TYPE)
;
;Ret only pres comp
I TYPE="P" Q BEDDCOMP
;
NEW BEDDCTXT
S BEDDIEN=$G(BEDDIEN,""),BEDDCOMP=$G(BEDDCOMP,"")
S BEDDCTXT=""
;
I $G(BEDDIEN)]"",$D(^AUPNVNT("AD",BEDDIEN)) D
. NEW BEDDCC
. S BEDDCC=$O(^AUPNVNT("AD",BEDDIEN,""),-1)
. I $D(^AUPNVNT(BEDDCC,11,0)) D
.. N LN
.. S LN=0 F S LN=$O(^AUPNVNT(BEDDCC,11,LN)) Q:LN="" D
... S BEDDCTXT=$G(BEDDCTXT)_$S(BEDDCTXT="":"",1:" ")_$G(^AUPNVNT(BEDDCC,11,LN,0))
;
S:BEDDCTXT="" BEDDCTXT=BEDDCOMP
;
Q BEDDCTXT
;
GETF(BEDDFILE,BEDDIEN,BEDDFLD,BEDDIE) ; EP - Ret val from spec file/field
;
; Input:
; BEDDFILE - RPMS file numb
; BEDDIEN - File IEN
; BEDDFLD - Field to ret
; BEDDIE - Int/Ext disp
;
; Output:
; Val in the field
;
;Error Trap
NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BEDDUTIL D UNWIND^%ZTER" ; SAC 2006 2.2.3.3.2
;
I BEDDFILE=""!(BEDDFLD="") Q ""
I $TR(BEDDIEN,",")'?1N.N Q ""
S:$G(BEDDIE)="" BEDDIE="E"
S:$E(BEDDIEN,$L(BEDDIEN))'="," BEDDIEN=BEDDIEN_","
Q $$GET1^DIQ(BEDDFILE,BEDDIEN,BEDDFLD,BEDDIE)
;
GETOSTAT(DFN) ; EP - Get Order Summ By Pack Type
;
; Input:
; DFN - Patient IEN
;
; Output:
; Package Order Summ for T and T-1
;
;Error Trap
NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BEDDUTIL D UNWIND^%ZTER" ; SAC 2006 2.2.3.3.2
;
NEW BEDDORD,BEDDOST,BEDDIX,BYDT,X,X1,X2,YDT
;
I $G(DFN)="" Q ""
;
S:$G(DT)="" DT=$$DT^XLFDT
S X1=DT,X2=-1 D C^%DTC S YDT=X
S BYDT=9999999-YDT
;
S BEDDIX="" F S BEDDIX=$O(^OR(100,"AC",DFN_";DPT(",BEDDIX)) Q:BEDDIX>BYDT!'BEDDIX D
. NEW BEDDOIEN S BEDDOIEN="" F S BEDDOIEN=$O(^OR(100,"AC",DFN_";DPT(",BEDDIX,BEDDOIEN)) Q:BEDDOIEN="" D
.. NEW BEDDOSTS,BEDDORDT,BEDDOITM,BEDDOPRF
.. S BEDDOSTS=$$GET1^DIQ(100,BEDDOIEN_",",5,"E") Q:BEDDOSTS=""
.. S BEDDORDT=$$GET1^DIQ(100,BEDDOIEN_",",4,"I")
.. Q:BEDDORDT<YDT
.. ;
.. S BEDDOITM=$$GET1^DIQ(100,BEDDOIEN_",",7,"E")
.. S:BEDDOITM="" BEDDOITM=$$GET1^DIQ(100,BEDDOIEN_",",2,"E")
.. S BEDDOPRF=$$GET1^DIQ(100,BEDDOIEN_",",33,"E")
.. S BEDDOITM=$E(BEDDOITM,1,2)
.. S BEDDOITM=$S(BEDDOITM="LR":"LAB",BEDDOITM="RA":"RAD",BEDDOITM="PS":"RX",BEDDOITM="GM":"CONSULT",1:BEDDOITM)
.. Q:BEDDOITM=""
.. S BEDDORD(BEDDOITM,BEDDOSTS)=$G(BEDDORD(BEDDOITM,BEDDOSTS))+1
;
S (BEDDORD,BEDDIX)="" F S BEDDIX=$O(BEDDORD(BEDDIX)) Q:BEDDIX="" D
. N BEDDIX1 S BEDDIX1="" F S BEDDIX1=$O(BEDDORD(BEDDIX,BEDDIX1)) Q:BEDDIX1="" D
.. S BEDDORD=$G(BEDDORD)_BEDDORD(BEDDIX,BEDDIX1)_" "_BEDDIX1_" "_BEDDIX_"; "
Q BEDDORD
;
LOGSEC(DUZ,DFN) ;EP - Adds/updates entry in DG Security Log file
;
; Input:
; DUZ - User IEN
; DFN - Patient IEN
;
;Error Trap
NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BEDDUTIL D UNWIND^%ZTER" ; SAC 2006 2.2.3.3.2
;
NEW DGOPTI,DGOPT2
;
S DGOPTI=$O(^DIC(19,"B","BEDDEDIT",0)) Q:DGOPTI=""
S DGOPT2=$P(^DIC(19,DGOPTI,0),"^",1)_"^"_$P(^DIC(19,DGOPTI,0),"^",2)
I $TR(DGOPT2,"^","")]"" D SETLOG1^DGSEC(DFN,DUZ,,DGOPT2)
;
Q
;
PPR(BEDDVIEN,OBJID,DFN) ;EP - Ret the Primary Prov
;
;Error Trap
NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BEDDUTIL D UNWIND^%ZTER" ; SAC 2006 2.2.3.3.2
;
NEW PPR,EDOBJ,PIEN
;
S PPR=""
I $G(BEDDVIEN)="" Q ""
S PIEN="" F S PIEN=$O(^AUPNVPRV("AD",BEDDVIEN,PIEN),-1) Q:PIEN="" I $$GET1^DIQ(9000010.06,PIEN_",",.04,"I")="P" S PPR=$$GET1^DIQ(9000010.06,PIEN_",",.01,"E") Q
;
I $G(DFN)]"",PPR="" S PPR=$$PTPCP^BEDDUTIL(DFN)
I $G(OBJID)]"",PPR'="" D UPPRV^BEDDUTW(OBJID,PPR)
Q PPR
;
XNOW(FORM) ;EP - Ret Curr Ext Date and Time
;
; Input:
; FORM (Optional) - Sec parm of XLFDT call
;
; Output:
; Date/Time in MMM DD,CCYY@HH:MM:SS format
;
;Error Trap
NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BEDDUTIL D UNWIND^%ZTER" ; SAC 2006 2.2.3.3.2
;
S FORM=$G(FORM,"")
NEW %,%H,%I,X
D NOW^%DTC
Q $$FMTE^XLFDT(%,FORM)
;
FNOW() ;EP - Return Current FileMan Date and Time
;
; Input:
; None
;
; Output:
; Date/Time in FileMan CYYMMDD.HHMMSS format
;
;Error Trap
NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BEDDUTIL D UNWIND^%ZTER" ; SAC 2006 2.2.3.3.2
;
NEW %,%H,%I,X
D NOW^%DTC
Q %
;
DATE(DATE) ;EP - Convert stand dt/time to FileMan dt/time
;
; Input:
; DATE - In stand format
;
; Output:
; Date/Time in FileMan CYYMMDD.HHMMSS format
; -1 is if it couldn't conv to FileMan date
;
;Error Trap
NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BEDDUTIL D UNWIND^%ZTER" ; SAC 2006 2.2.3.3.2
;
NEW %DT,X,Y
I DATE[":" D
. I DATE["/",$L(DATE," ")=3 S DATE=$P(DATE," ",1)_"@"_$P(DATE," ",2)_$P(DATE," ",3) Q
. I $L(DATE," ")=3 S DATE=$P(DATE," ",1,2)_"@"_$P(DATE," ",3)
. I $L(DATE," ")>3 S DATE=$P(DATE," ",1,3)_"@"_$P(DATE," ",4,99)
S %DT="TS",X=DATE D ^%DT
I Y=-1 S Y=""
;
Q Y
;
NEW(D,AMERDFN,D0,D1,DFN,NODSP) ;EP - Create ED Entry - Called from AMER routine
;
; Input:
; D - Current entry information - Quit if defined
; AMERDFN/DFN - Patient's DFN entry
; D0/D1 - VIEN/ADT info
; NODSP - Do not display to screen
;
NEW BEDDSYS,BEDDADT,BEDDDFN,VIEN,ID,X
;
S BEDDADT=$G(D1),BEDDDFN=$G(DFN),VIEN=$G(D0),NODSP=$G(NODSP)
;
;Error Trap
NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BEDDUTIL D UNWIND^%ZTER" ; SAC 2006 2.2.3.3.2
;
;Check if entry already def
I $G(D)]"" Q
;
I '$G(NODSP) W !,"Setting data for Dashboard..."
;
D EDSYS^BEDDUTW(.BEDDSYS)
;
S ID=$$NEW^BEDDUTW(AMERDFN,VIEN) I ID=0 Q
;
;Report/Label Disp
I '$G(NODSP) D
. I $D(BEDDSYS("MRC")) W !!!,"Select printer for PATIENT MEDICATION WORKSHEET...",!! D EN^BEDDMREC(BEDDDFN,VIEN)
. I $D(BEDDSYS("PRS")) W !!!,"Select printer for PATIENT ROUTING SLIP...",!! D EN^BEDDEHRS(BEDDDFN)
. I $D(BEDDSYS("ARM")) D
.. W !!!,"Select printer for Patient WristBand/Embossed Card...",!! H 1
.. S DFN=BEDDDFN S X="AGCARD" D HDR^AG,DFN^AGCARD D PHDR^AG
;
;Special Code to Update MODE OF TRANSPORT field
S X=$$MDTRN^BEDDUTID(BEDDDFN)
;
Q
;
XCLIN(CODE) ;EP - Ret Ext Clinic
;
; Input:
; CODE - CODE field val from 40.7
;
; Output:
; NAME (.01) 40.7 val
;
;Error Trap
NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BEDDUTIL D UNWIND^%ZTER" ; SAC 2006 2.2.3.3.2
;
NEW DIC,X,Y
;
S DIC="^DIC(40.7,",X=CODE,DIC(0)="M"
D ^DIC
;
Q $P(Y,"^",2)
;
PTALG(DFN) ;EP - Ret Patient Allergies
;
; Input:
; DFN - Pat IEN
;
; Output:
; List of Allergies
;
;Error Trap
NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BEDDUTIL D UNWIND^%ZTER" ; SAC 2006 2.2.3.3.2
;
NEW PTALG,X,BEDDI
;
S PTALG=""
;
K ^TMP("PTADR",$J)
;
S X=$$MAIN^TIULADR(DFN,,"^TMP(""PTADR"",$J)",0)
S BEDDI="" F S BEDDI=$O(^TMP("PTADR",$J,BEDDI)) Q:BEDDI="" S PTALG=PTALG_" "_$G(^TMP("PTADR",$J,BEDDI,0))
;
K ^TMP("PTADR",$J)
Q PTALG
;
PTPCP(DFN) ;EP - Ret Patient PCP
;
; Input:
; DFN - Pat IEN
;
; Output:
; Pat PCP
;
;Error Trap
NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BEDDUTIL D UNWIND^%ZTER" ; SAC 2006 2.2.3.3.2
;
Q $P($$DPCP(DFN),"^",2)
;
TRGUPD(VIEN) ;EP - Update ER ADMISSION TRIAGE NURSE/ADMITTING PROV/ACUITY
;
; Input:
; VIEN - Pointer to 9000010 VISIT file
;
; Output
; Pointer to TRG MEASUREMENT TYPE (if def)
;
I $G(VIEN)="" Q ""
;
;Error Trap
NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BEDDUTIL D UNWIND^%ZTER" ; SAC 2006 2.2.3.3.2
;
NEW AMUPD,ERROR,BEDDTRG,BEDDTRGD,BEDDTRGN,BEDDTRGI,DFN,MYTRG
;
S (BEDDTRG,BEDDTRGD,BEDDTRGN)=""
S BEDDTRGI=$O(^AUTTMSR("B","TRG",""))
I $D(^AUPNVMSR("AD",VIEN)) D
. NEW MIEN
. S MIEN="" F S MIEN=$O(^AUPNVMSR("AD",VIEN,MIEN)) Q:'MIEN D
.. I BEDDTRGD="" S BEDDTRGD=$$GET1^DIQ(9000010.01,MIEN_",",1201,"I"),BEDDTRGN=$$GET1^DIQ(9000010.01,MIEN_",",1204,"I")
.. I BEDDTRGI]"",BEDDTRG="",BEDDTRGI=$$GET1^DIQ(9000010.01,MIEN_",",.01,"I") S BEDDTRG=$$GET1^DIQ(9000010.01,MIEN_",",.04,"I")
;
S DFN=$$GET1^DIQ(9000010,VIEN_",",.05,"I") Q:'$D(^AMERADM(DFN)) BEDDTRG
I BEDDTRG]"" D BLDTRG(.MYTRG) I $D(MYTRG(BEDDTRG)) S AMUPD(9009081,DFN_",",20)=$P(MYTRG(BEDDTRG),"^",3)
I BEDDTRGD]"" S AMUPD(9009081,DFN_",",21)=BEDDTRGD
I BEDDTRGN]"" S AMUPD(9009081,DFN_",",19)=BEDDTRGN
;
Q BEDDTRG
;
BLDTRG(MYTRG) ;EP - Build Acuity MYTRG array
;
;Moved to overflow routine
D BLDTRG^BEDDUTW1(.MYTRG)
Q
;
INJCAUSE(OBJID) ;EP - Ret Cause of Injury - Not Implemented
Q ""
;
INJSTG(OBJID) ;EP - Ret Setting of Injury - Not Implemented
Q ""
;
IND(OBJID) ;EP - Ret the Industry - Not Implemented
Q ""
;
OCC(OBJID) ;EP - Ret the Occupation - Not Implemented
Q ""
;
TODLH(DTTM) ;EP - Convert Ext Date to $H
;
S DTTM=$$DATE^BEDDUTIU($G(DTTM))
Q $$FMTH^XLFDT(DTTM)
;
FMTE(FMDT,FORM) ;EP - Conv FMan to Standard External Dt/Time
S:$G(FORM)="" FORM="5ZM"
Q $TR($$FMTE^XLFDT(FMDT,FORM),"@"," ")
;
FM2HD(FMDT) ;EP - Conv FMan Dt/Time to $H date portion
Q $$FMTH^XLFDT(FMDT,1)
;
SECWTG(HDT,HTM) ;EP - Calc Diff in Seconds from $H
I $G(HDT)="" Q ""
Q $P($$HDIFF^XLFDT($H,HDT_","_HTM,2),".")
;
MINWTG(HDT,HTM) ;EP - Calc Diff in Minutes from $H
I $G(HDT)="" Q ""
Q $P($$HDIFF^XLFDT($H,HDT_","_HTM,2)/60,".")
;
FM2HT(FMDT) ;EP - Conv FMan Date/Time to $H time portion
Q $P($$FMTH^XLFDT(FMDT),",",2)
;
DPCP(DFN) ;EP -- Get patient's designated primary care provider
;
;Description
; Checks 'Designated Provider Management System' first
; for patient's primary care provider, otherwise it
; checks Patient file.
;Input
; DFN
;Output
; DPCPN^DPCPNM
; DPCPN - Primary Care Provider internal entry number
; DPCPNM - Primary Care Provider Name
;
NEW DPCAT,DPIEN,DPCPN,DPCPNM
S DPCPN=""
S DPCAT=$O(^BDPTCAT("B","DESIGNATED PRIMARY PROVIDER",""))
I DPCAT'="" D
. S DPIEN=$O(^BDPRECN("AA",DFN,DPCAT,""))
. I DPIEN="" Q
. S DPCPN=$$GET1^DIQ(90360.1,DPIEN_",",.03,"I")
. S DPCPNM=$$GET1^DIQ(90360.1,DPIEN_",",.03,"E")
I DPCPN'="" Q DPCPN_"^"_DPCPNM
;
S DPCPN=$$GET1^DIQ(9000001,DFN_",",.14,"I")
S DPCPNM=$$GET1^DIQ(9000001,DFN_",",.14,"E")
Q DPCPN_"^"_DPCPNM
;
ERR ;
D ^%ZTER
Q
BEDDUTIL ;VNGT/HS/BEE-BEDD Utility Routine ; 08 Nov 2011 12:00 PM
+1 ;;2.0;BEDD DASHBOARD;**1,2**;Jun 04, 2014;Build 26
+2 ;
+3 QUIT
+4 ;
CHECKAV(BEDDAV) ;EP - Auth AC/VC, Ret DUZ
+1 ;
+2 ; Input: BEDDAV-ACCESS_";"_VERIFY
+3 ; Output: DUZ
+4 ;
+5 NEW BEDDDUZ,XUF
+6 ;
+7 IF $GET(U)=""
SET U="^"
+8 IF $GET(DT)=""
SET DT=$$DT^XLFDT
+9 ;
+10 ;Err Trap
+11 ; SAC 2006 2.2.3.3.2
NEW $ESTACK,$ETRAP
SET $ETRAP="D ERR^BEDDUTIL D UNWIND^%ZTER"
+12 ;
+13 SET XUF=0
+14 SET BEDDDUZ=$$CHECKAV^XUS(BEDDAV)
+15 IF BEDDDUZ=0
QUIT 0
+16 ;
+17 ;Ret DUZ if user inactive
+18 IF (+$PIECE($GET(^VA(200,BEDDDUZ,0)),U,11)'>0)!(+$PIECE($GET(^VA(200,BEDDDUZ,0)),U,11)'<DT)
QUIT BEDDDUZ
+19 QUIT 0
+20 ;
AUTH(BEDDDUZ) ;EP - Auth User for ED Access
+1 ;
+2 ; Input: BEDDDUZ - User's DUZ
+3 ; Output: 0-Not Auth/1-Auth
+4 ;
+5 NEW BEDDKEY
+6 ;
+7 IF $GET(U)=""
SET U="^"
+8 ;
+9 ;Error Trap
+10 ; SAC 2006 2.2.3.3.2
NEW $ESTACK,$ETRAP
SET $ETRAP="D ERR^BEDDUTIL D UNWIND^%ZTER"
+11 ;
+12 IF $GET(BEDDDUZ)<1
QUIT 0
+13 SET BEDDKEY=$ORDER(^DIC(19.1,"B","BEDDZDASH",""))
IF BEDDKEY=""
QUIT 0
+14 IF '$DATA(^VA(200,"AB",BEDDKEY,BEDDDUZ,BEDDKEY))
QUIT 0
+15 QUIT 1
+16 ;
SNAME(SITE) ;EP - Ret Site Name
+1 ;
+2 IF $GET(SITE)=""
QUIT ""
+3 ;
+4 QUIT $$GET1^DIQ(4,SITE_",",".01","E")
+5 ;
SITE(BEDDST) ;EP - Assemble List of Sites From File 40.8
+1 ;
+2 ; Input: BEDDSITE - Empty Arr
+3 ; Output: BEDDSITE - List of file 4 entries pointed to by file 40.8 entries
+4 ;
+5 NEW BEDDSITE,BEDDIEN
+6 ;
+7 IF $GET(U)=""
SET U="^"
+8 ;
+9 ;Error Trap
+10 ; SAC 2006 2.2.3.3.2
NEW $ESTACK,$ETRAP
SET $ETRAP="D ERR^BEDDUTIL D UNWIND^%ZTER"
+11 ;
+12 SET BEDDSITE=""
FOR
SET BEDDSITE=$ORDER(^DG(40.8,"B",BEDDSITE))
IF BEDDSITE=""
QUIT
Begin DoDot:1
+13 SET BEDDIEN=""
FOR
SET BEDDIEN=$ORDER(^DG(40.8,"B",BEDDSITE,BEDDIEN))
IF BEDDIEN=""
QUIT
Begin DoDot:2
+14 NEW INNM,INIEN
+15 SET INIEN=$$GET1^DIQ(40.8,BEDDIEN_",",.07,"I")
IF INIEN=""
QUIT
+16 SET INNM=$$GET1^DIQ(4,INIEN_",",".01","I")
IF INNM=""
QUIT
+17 SET BEDDST(INNM_":"_INIEN)=INNM_U_INIEN
End DoDot:2
End DoDot:1
+18 QUIT
+19 ;
BEDDLST(BEDD,SITE) ;EP - Assemble ED List
+1 ;
+2 ; Input: BEDD - Empty Array
+3 ; SITE - Site to look up
+4 ; Output: BEDD - List of Dashboard Pats
+5 ;
+6 SET SITE=$GET(SITE)
+7 ;
+8 ;Error Trap
+9 ; SAC 2006 2.2.3.3.2
NEW $ESTACK,$ETRAP
SET $ETRAP="D ERR^BEDDUTIL D UNWIND^%ZTER"
+10 ;
+11 NEW BEDDDAY,BEDDIEN,BEDDGL,BEDDTOT,BEDDBDY,PNDLKBDY,BEDDGLD
+12 ;
+13 ;BEDD*2.0*1;Pull pending look back days
+14 SET PNDLKBDY=10
+15 IF +$GET(SITE)=0
IF SITE'="Whiteboard"
Begin DoDot:1
+16 NEW SIEN,ST,EXEC
+17 SET SIEN=$ORDER(^BEDD.EDSYSTEMD(""))
IF SIEN=""
QUIT
+18 SET EXEC="S ST=##CLASS(BEDD.EDSYSTEM).%OpenId(SIEN,0)"
XECUTE EXEC
+19 SET EXEC="S SITE=ST.Site"
XECUTE EXEC
End DoDot:1
+20 IF +$GET(SITE)]""
Begin DoDot:1
+21 NEW SYSIEN,EXEC,EDSYSTEM,ISITE
+22 SET ISITE=$SELECT(SITE="Whiteboard":"999999",1:SITE)
+23 SET EXEC="S SYSIEN=$O(^BEDD.EDSYSTEMI(""SiteIdx"","" ""_ISITE,""""))"
XECUTE EXEC
+24 IF $GET(SYSIEN)=""
QUIT
+25 SET EXEC="S EDSYSTEM=##CLASS(BEDD.EDSYSTEM).%OpenId(SYSIEN,0)"
XECUTE EXEC
+26 SET EXEC="S PNDLKBDY=EDSYSTEM.PendingStsLookBack"
XECUTE EXEC
+27 IF +PNDLKBDY=0
SET PNDLKBDY=10
End DoDot:1
+28 ;
+29 KILL BEDD
+30 ;
+31 ;BEDD*2.0*1;Use parameter
+32 SET BEDDBDY=$PIECE($HOROLOG,",")-PNDLKBDY
SET BEDDDAY=""
+33 SET BEDDGL="^BEDD.EDVISITI(""ArrIdx"")"
+34 SET BEDDGLD="^BEDD.EDVISITD"
+35 FOR
SET BEDDDAY=$ORDER(@BEDDGL@(BEDDDAY),-1)
IF ((BEDDDAY="")!(BEDDDAY<BEDDBDY))
QUIT
Begin DoDot:1
+36 SET BEDDIEN=""
FOR
SET BEDDIEN=$ORDER(@BEDDGL@(BEDDDAY,BEDDIEN),-1)
IF BEDDIEN=""
QUIT
Begin DoDot:2
+37 ;
+38 ;Remove deleted entries
+39 IF '$DATA(@BEDDGLD@(BEDDIEN))
QUIT
+40 ;
+41 NEW TRG,ROOM,EDWTIM,EDSTAT,EDTRG,EDROOM,PTDFN
+42 SET (EDSTAT,EDTRG,EDROOM,EDWTIM,PTDFN)=""
+43 ;
+44 ;Ret entry
+45 DO BEDDED^BEDDUTW(BEDDIEN,.EDSTAT,.EDTRG,.EDROOM,.EDWTIM,.PTDFN)
+46 ;
+47 IF EDSTAT=9
QUIT
+48 IF EDSTAT=8
QUIT
+49 ;
+50 ;Strip dupes
+51 IF $GET(PTDFN)=""
QUIT
+52 IF $DATA(BEDD("D",PTDFN))
QUIT
+53 SET BEDD("D",PTDFN)=""
+54 ;
+55 SET TRG=""
IF EDTRG'=""
SET TRG=EDTRG
+56 IF TRG=""
SET TRG=" "
+57 SET ROOM=" "
IF EDROOM'=""
SET ROOM=EDROOM
+58 IF EDSTAT=1
SET BEDD(EDSTAT,BEDDIEN)=EDWTIM
+59 IF EDSTAT=2
SET BEDD(EDSTAT,TRG,BEDDIEN)=EDWTIM
+60 IF EDSTAT=3
SET BEDD(EDSTAT,ROOM,BEDDIEN)=EDWTIM
+61 IF EDSTAT=4
SET BEDD(EDSTAT,TRG,BEDDIEN)=EDWTIM
+62 SET BEDD("SUM",EDSTAT,BEDDIEN)=EDWTIM
+63 SET $PIECE(BEDDTOT(EDSTAT),"^")=$PIECE($GET(BEDDTOT(EDSTAT)),"^")+1
+64 SET $PIECE(BEDDTOT(EDSTAT),"^",2)=$PIECE($GET(BEDDTOT(EDSTAT)),"^",2)+EDWTIM
+65 ;
+66 ;Track entries
+67 SET BEDD("L",BEDDIEN)=""
End DoDot:2
End DoDot:1
+68 ;
+69 ;Assemble Totals
+70 SET EDSTAT=""
FOR
SET EDSTAT=$ORDER(BEDDTOT(EDSTAT))
IF EDSTAT=""
QUIT
Begin DoDot:1
+71 NEW CNT,WTG,AVG
+72 SET CNT=$PIECE(BEDDTOT(EDSTAT),"^")
+73 SET WTG=$PIECE(BEDDTOT(EDSTAT),"^",2)
+74 SET AVG=""
IF CNT>0
IF WTG>0
SET AVG=WTG\CNT
+75 SET BEDD("TSUM",EDSTAT)=CNT_"^"_WTG_"^"_AVG
End DoDot:1
+76 ;
+77 ;Check (and Repair) Room Occupancy
+78 DO RMAV^BEDDUTW(.BEDD)
+79 ;
+80 QUIT
+81 ;
GETCC(BEDDIEN,BEDDCOMP,TYPE) ;EP - Get V NARRATIVE TEXT
+1 ;
+2 ; Input:
+3 ; BEDDIEN - V NARRATIVE TEXT Entry IEN
+4 ; BEDDCOMP - BEDD.EDVISIT - Complaint field value
+5 ; TYPE - Return type - P-Presenting, C-Chief, Null-All
+6 ;
+7 ; Output:
+8 ; V NARRATIVE TEXT (1st) or Complaint value (2nd)
+9 ;
+10 ;Error Trap
+11 ; SAC 2006 2.2.3.3.2
NEW $ESTACK,$ETRAP
SET $ETRAP="D ERR^BEDDUTIL D UNWIND^%ZTER"
+12 ;
+13 SET TYPE=$GET(TYPE)
+14 ;
+15 ;Ret only pres comp
+16 IF TYPE="P"
QUIT BEDDCOMP
+17 ;
+18 NEW BEDDCTXT
+19 SET BEDDIEN=$GET(BEDDIEN,"")
SET BEDDCOMP=$GET(BEDDCOMP,"")
+20 SET BEDDCTXT=""
+21 ;
+22 IF $GET(BEDDIEN)]""
IF $DATA(^AUPNVNT("AD",BEDDIEN))
Begin DoDot:1
+23 NEW BEDDCC
+24 SET BEDDCC=$ORDER(^AUPNVNT("AD",BEDDIEN,""),-1)
+25 IF $DATA(^AUPNVNT(BEDDCC,11,0))
Begin DoDot:2
+26 NEW LN
+27 SET LN=0
FOR
SET LN=$ORDER(^AUPNVNT(BEDDCC,11,LN))
IF LN=""
QUIT
Begin DoDot:3
+28 SET BEDDCTXT=$GET(BEDDCTXT)_$SELECT(BEDDCTXT="":"",1:" ")_$GET(^AUPNVNT(BEDDCC,11,LN,0))
End DoDot:3
End DoDot:2
End DoDot:1
+29 ;
+30 IF BEDDCTXT=""
SET BEDDCTXT=BEDDCOMP
+31 ;
+32 QUIT BEDDCTXT
+33 ;
GETF(BEDDFILE,BEDDIEN,BEDDFLD,BEDDIE) ; EP - Ret val from spec file/field
+1 ;
+2 ; Input:
+3 ; BEDDFILE - RPMS file numb
+4 ; BEDDIEN - File IEN
+5 ; BEDDFLD - Field to ret
+6 ; BEDDIE - Int/Ext disp
+7 ;
+8 ; Output:
+9 ; Val in the field
+10 ;
+11 ;Error Trap
+12 ; SAC 2006 2.2.3.3.2
NEW $ESTACK,$ETRAP
SET $ETRAP="D ERR^BEDDUTIL D UNWIND^%ZTER"
+13 ;
+14 IF BEDDFILE=""!(BEDDFLD="")
QUIT ""
+15 IF $TRANSLATE(BEDDIEN,",")'?1N.N
QUIT ""
+16 IF $GET(BEDDIE)=""
SET BEDDIE="E"
+17 IF $EXTRACT(BEDDIEN,$LENGTH(BEDDIEN))'=","
SET BEDDIEN=BEDDIEN_","
+18 QUIT $$GET1^DIQ(BEDDFILE,BEDDIEN,BEDDFLD,BEDDIE)
+19 ;
GETOSTAT(DFN) ; EP - Get Order Summ By Pack Type
+1 ;
+2 ; Input:
+3 ; DFN - Patient IEN
+4 ;
+5 ; Output:
+6 ; Package Order Summ for T and T-1
+7 ;
+8 ;Error Trap
+9 ; SAC 2006 2.2.3.3.2
NEW $ESTACK,$ETRAP
SET $ETRAP="D ERR^BEDDUTIL D UNWIND^%ZTER"
+10 ;
+11 NEW BEDDORD,BEDDOST,BEDDIX,BYDT,X,X1,X2,YDT
+12 ;
+13 IF $GET(DFN)=""
QUIT ""
+14 ;
+15 IF $GET(DT)=""
SET DT=$$DT^XLFDT
+16 SET X1=DT
SET X2=-1
DO C^%DTC
SET YDT=X
+17 SET BYDT=9999999-YDT
+18 ;
+19 SET BEDDIX=""
FOR
SET BEDDIX=$ORDER(^OR(100,"AC",DFN_";DPT(",BEDDIX))
IF BEDDIX>BYDT!'BEDDIX
QUIT
Begin DoDot:1
+20 NEW BEDDOIEN
SET BEDDOIEN=""
FOR
SET BEDDOIEN=$ORDER(^OR(100,"AC",DFN_";DPT(",BEDDIX,BEDDOIEN))
IF BEDDOIEN=""
QUIT
Begin DoDot:2
+21 NEW BEDDOSTS,BEDDORDT,BEDDOITM,BEDDOPRF
+22 SET BEDDOSTS=$$GET1^DIQ(100,BEDDOIEN_",",5,"E")
IF BEDDOSTS=""
QUIT
+23 SET BEDDORDT=$$GET1^DIQ(100,BEDDOIEN_",",4,"I")
+24 IF BEDDORDT<YDT
QUIT
+25 ;
+26 SET BEDDOITM=$$GET1^DIQ(100,BEDDOIEN_",",7,"E")
+27 IF BEDDOITM=""
SET BEDDOITM=$$GET1^DIQ(100,BEDDOIEN_",",2,"E")
+28 SET BEDDOPRF=$$GET1^DIQ(100,BEDDOIEN_",",33,"E")
+29 SET BEDDOITM=$EXTRACT(BEDDOITM,1,2)
+30 SET BEDDOITM=$SELECT(BEDDOITM="LR":"LAB",BEDDOITM="RA":"RAD",BEDDOITM="PS":"RX",BEDDOITM="GM":"CONSULT",1:BEDDOITM)
+31 IF BEDDOITM=""
QUIT
+32 SET BEDDORD(BEDDOITM,BEDDOSTS)=$GET(BEDDORD(BEDDOITM,BEDDOSTS))+1
End DoDot:2
End DoDot:1
+33 ;
+34 SET (BEDDORD,BEDDIX)=""
FOR
SET BEDDIX=$ORDER(BEDDORD(BEDDIX))
IF BEDDIX=""
QUIT
Begin DoDot:1
+35 NEW BEDDIX1
SET BEDDIX1=""
FOR
SET BEDDIX1=$ORDER(BEDDORD(BEDDIX,BEDDIX1))
IF BEDDIX1=""
QUIT
Begin DoDot:2
+36 SET BEDDORD=$GET(BEDDORD)_BEDDORD(BEDDIX,BEDDIX1)_" "_BEDDIX1_" "_BEDDIX_"; "
End DoDot:2
End DoDot:1
+37 QUIT BEDDORD
+38 ;
LOGSEC(DUZ,DFN) ;EP - Adds/updates entry in DG Security Log file
+1 ;
+2 ; Input:
+3 ; DUZ - User IEN
+4 ; DFN - Patient IEN
+5 ;
+6 ;Error Trap
+7 ; SAC 2006 2.2.3.3.2
NEW $ESTACK,$ETRAP
SET $ETRAP="D ERR^BEDDUTIL D UNWIND^%ZTER"
+8 ;
+9 NEW DGOPTI,DGOPT2
+10 ;
+11 SET DGOPTI=$ORDER(^DIC(19,"B","BEDDEDIT",0))
IF DGOPTI=""
QUIT
+12 SET DGOPT2=$PIECE(^DIC(19,DGOPTI,0),"^",1)_"^"_$PIECE(^DIC(19,DGOPTI,0),"^",2)
+13 IF $TRANSLATE(DGOPT2,"^","")]""
DO SETLOG1^DGSEC(DFN,DUZ,,DGOPT2)
+14 ;
+15 QUIT
+16 ;
PPR(BEDDVIEN,OBJID,DFN) ;EP - Ret the Primary Prov
+1 ;
+2 ;Error Trap
+3 ; SAC 2006 2.2.3.3.2
NEW $ESTACK,$ETRAP
SET $ETRAP="D ERR^BEDDUTIL D UNWIND^%ZTER"
+4 ;
+5 NEW PPR,EDOBJ,PIEN
+6 ;
+7 SET PPR=""
+8 IF $GET(BEDDVIEN)=""
QUIT ""
+9 SET PIEN=""
FOR
SET PIEN=$ORDER(^AUPNVPRV("AD",BEDDVIEN,PIEN),-1)
IF PIEN=""
QUIT
IF $$GET1^DIQ(9000010.06,PIEN_",",.04,"I")="P"
SET PPR=$$GET1^DIQ(9000010.06,PIEN_",",.01,"E")
QUIT
+10 ;
+11 IF $GET(DFN)]""
IF PPR=""
SET PPR=$$PTPCP^BEDDUTIL(DFN)
+12 IF $GET(OBJID)]""
IF PPR'=""
DO UPPRV^BEDDUTW(OBJID,PPR)
+13 QUIT PPR
+14 ;
XNOW(FORM) ;EP - Ret Curr Ext Date and Time
+1 ;
+2 ; Input:
+3 ; FORM (Optional) - Sec parm of XLFDT call
+4 ;
+5 ; Output:
+6 ; Date/Time in MMM DD,CCYY@HH:MM:SS format
+7 ;
+8 ;Error Trap
+9 ; SAC 2006 2.2.3.3.2
NEW $ESTACK,$ETRAP
SET $ETRAP="D ERR^BEDDUTIL D UNWIND^%ZTER"
+10 ;
+11 SET FORM=$GET(FORM,"")
+12 NEW %,%H,%I,X
+13 DO NOW^%DTC
+14 QUIT $$FMTE^XLFDT(%,FORM)
+15 ;
FNOW() ;EP - Return Current FileMan Date and Time
+1 ;
+2 ; Input:
+3 ; None
+4 ;
+5 ; Output:
+6 ; Date/Time in FileMan CYYMMDD.HHMMSS format
+7 ;
+8 ;Error Trap
+9 ; SAC 2006 2.2.3.3.2
NEW $ESTACK,$ETRAP
SET $ETRAP="D ERR^BEDDUTIL D UNWIND^%ZTER"
+10 ;
+11 NEW %,%H,%I,X
+12 DO NOW^%DTC
+13 QUIT %
+14 ;
DATE(DATE) ;EP - Convert stand dt/time to FileMan dt/time
+1 ;
+2 ; Input:
+3 ; DATE - In stand format
+4 ;
+5 ; Output:
+6 ; Date/Time in FileMan CYYMMDD.HHMMSS format
+7 ; -1 is if it couldn't conv to FileMan date
+8 ;
+9 ;Error Trap
+10 ; SAC 2006 2.2.3.3.2
NEW $ESTACK,$ETRAP
SET $ETRAP="D ERR^BEDDUTIL D UNWIND^%ZTER"
+11 ;
+12 NEW %DT,X,Y
+13 IF DATE[":"
Begin DoDot:1
+14 IF DATE["/"
IF $LENGTH(DATE," ")=3
SET DATE=$PIECE(DATE," ",1)_"@"_$PIECE(DATE," ",2)_$PIECE(DATE," ",3)
QUIT
+15 IF $LENGTH(DATE," ")=3
SET DATE=$PIECE(DATE," ",1,2)_"@"_$PIECE(DATE," ",3)
+16 IF $LENGTH(DATE," ")>3
SET DATE=$PIECE(DATE," ",1,3)_"@"_$PIECE(DATE," ",4,99)
End DoDot:1
+17 SET %DT="TS"
SET X=DATE
DO ^%DT
+18 IF Y=-1
SET Y=""
+19 ;
+20 QUIT Y
+21 ;
NEW(D,AMERDFN,D0,D1,DFN,NODSP) ;EP - Create ED Entry - Called from AMER routine
+1 ;
+2 ; Input:
+3 ; D - Current entry information - Quit if defined
+4 ; AMERDFN/DFN - Patient's DFN entry
+5 ; D0/D1 - VIEN/ADT info
+6 ; NODSP - Do not display to screen
+7 ;
+8 NEW BEDDSYS,BEDDADT,BEDDDFN,VIEN,ID,X
+9 ;
+10 SET BEDDADT=$GET(D1)
SET BEDDDFN=$GET(DFN)
SET VIEN=$GET(D0)
SET NODSP=$GET(NODSP)
+11 ;
+12 ;Error Trap
+13 ; SAC 2006 2.2.3.3.2
NEW $ESTACK,$ETRAP
SET $ETRAP="D ERR^BEDDUTIL D UNWIND^%ZTER"
+14 ;
+15 ;Check if entry already def
+16 IF $GET(D)]""
QUIT
+17 ;
+18 IF '$GET(NODSP)
WRITE !,"Setting data for Dashboard..."
+19 ;
+20 DO EDSYS^BEDDUTW(.BEDDSYS)
+21 ;
+22 SET ID=$$NEW^BEDDUTW(AMERDFN,VIEN)
IF ID=0
QUIT
+23 ;
+24 ;Report/Label Disp
+25 IF '$GET(NODSP)
Begin DoDot:1
+26 IF $DATA(BEDDSYS("MRC"))
WRITE !!!,"Select printer for PATIENT MEDICATION WORKSHEET...",!!
DO EN^BEDDMREC(BEDDDFN,VIEN)
+27 IF $DATA(BEDDSYS("PRS"))
WRITE !!!,"Select printer for PATIENT ROUTING SLIP...",!!
DO EN^BEDDEHRS(BEDDDFN)
+28 IF $DATA(BEDDSYS("ARM"))
Begin DoDot:2
+29 WRITE !!!,"Select printer for Patient WristBand/Embossed Card...",!!
HANG 1
+30 SET DFN=BEDDDFN
SET X="AGCARD"
DO HDR^AG
DO DFN^AGCARD
DO PHDR^AG
End DoDot:2
End DoDot:1
+31 ;
+32 ;Special Code to Update MODE OF TRANSPORT field
+33 SET X=$$MDTRN^BEDDUTID(BEDDDFN)
+34 ;
+35 QUIT
+36 ;
XCLIN(CODE) ;EP - Ret Ext Clinic
+1 ;
+2 ; Input:
+3 ; CODE - CODE field val from 40.7
+4 ;
+5 ; Output:
+6 ; NAME (.01) 40.7 val
+7 ;
+8 ;Error Trap
+9 ; SAC 2006 2.2.3.3.2
NEW $ESTACK,$ETRAP
SET $ETRAP="D ERR^BEDDUTIL D UNWIND^%ZTER"
+10 ;
+11 NEW DIC,X,Y
+12 ;
+13 SET DIC="^DIC(40.7,"
SET X=CODE
SET DIC(0)="M"
+14 DO ^DIC
+15 ;
+16 QUIT $PIECE(Y,"^",2)
+17 ;
PTALG(DFN) ;EP - Ret Patient Allergies
+1 ;
+2 ; Input:
+3 ; DFN - Pat IEN
+4 ;
+5 ; Output:
+6 ; List of Allergies
+7 ;
+8 ;Error Trap
+9 ; SAC 2006 2.2.3.3.2
NEW $ESTACK,$ETRAP
SET $ETRAP="D ERR^BEDDUTIL D UNWIND^%ZTER"
+10 ;
+11 NEW PTALG,X,BEDDI
+12 ;
+13 SET PTALG=""
+14 ;
+15 KILL ^TMP("PTADR",$JOB)
+16 ;
+17 SET X=$$MAIN^TIULADR(DFN,,"^TMP(""PTADR"",$J)",0)
+18 SET BEDDI=""
FOR
SET BEDDI=$ORDER(^TMP("PTADR",$JOB,BEDDI))
IF BEDDI=""
QUIT
SET PTALG=PTALG_" "_$GET(^TMP("PTADR",$JOB,BEDDI,0))
+19 ;
+20 KILL ^TMP("PTADR",$JOB)
+21 QUIT PTALG
+22 ;
PTPCP(DFN) ;EP - Ret Patient PCP
+1 ;
+2 ; Input:
+3 ; DFN - Pat IEN
+4 ;
+5 ; Output:
+6 ; Pat PCP
+7 ;
+8 ;Error Trap
+9 ; SAC 2006 2.2.3.3.2
NEW $ESTACK,$ETRAP
SET $ETRAP="D ERR^BEDDUTIL D UNWIND^%ZTER"
+10 ;
+11 QUIT $PIECE($$DPCP(DFN),"^",2)
+12 ;
TRGUPD(VIEN) ;EP - Update ER ADMISSION TRIAGE NURSE/ADMITTING PROV/ACUITY
+1 ;
+2 ; Input:
+3 ; VIEN - Pointer to 9000010 VISIT file
+4 ;
+5 ; Output
+6 ; Pointer to TRG MEASUREMENT TYPE (if def)
+7 ;
+8 IF $GET(VIEN)=""
QUIT ""
+9 ;
+10 ;Error Trap
+11 ; SAC 2006 2.2.3.3.2
NEW $ESTACK,$ETRAP
SET $ETRAP="D ERR^BEDDUTIL D UNWIND^%ZTER"
+12 ;
+13 NEW AMUPD,ERROR,BEDDTRG,BEDDTRGD,BEDDTRGN,BEDDTRGI,DFN,MYTRG
+14 ;
+15 SET (BEDDTRG,BEDDTRGD,BEDDTRGN)=""
+16 SET BEDDTRGI=$ORDER(^AUTTMSR("B","TRG",""))
+17 IF $DATA(^AUPNVMSR("AD",VIEN))
Begin DoDot:1
+18 NEW MIEN
+19 SET MIEN=""
FOR
SET MIEN=$ORDER(^AUPNVMSR("AD",VIEN,MIEN))
IF 'MIEN
QUIT
Begin DoDot:2
+20 IF BEDDTRGD=""
SET BEDDTRGD=$$GET1^DIQ(9000010.01,MIEN_",",1201,"I")
SET BEDDTRGN=$$GET1^DIQ(9000010.01,MIEN_",",1204,"I")
+21 IF BEDDTRGI]""
IF BEDDTRG=""
IF BEDDTRGI=$$GET1^DIQ(9000010.01,MIEN_",",.01,"I")
SET BEDDTRG=$$GET1^DIQ(9000010.01,MIEN_",",.04,"I")
End DoDot:2
End DoDot:1
+22 ;
+23 SET DFN=$$GET1^DIQ(9000010,VIEN_",",.05,"I")
IF '$DATA(^AMERADM(DFN))
QUIT BEDDTRG
+24 IF BEDDTRG]""
DO BLDTRG(.MYTRG)
IF $DATA(MYTRG(BEDDTRG))
SET AMUPD(9009081,DFN_",",20)=$PIECE(MYTRG(BEDDTRG),"^",3)
+25 IF BEDDTRGD]""
SET AMUPD(9009081,DFN_",",21)=BEDDTRGD
+26 IF BEDDTRGN]""
SET AMUPD(9009081,DFN_",",19)=BEDDTRGN
+27 ;
+28 QUIT BEDDTRG
+29 ;
BLDTRG(MYTRG) ;EP - Build Acuity MYTRG array
+1 ;
+2 ;Moved to overflow routine
+3 DO BLDTRG^BEDDUTW1(.MYTRG)
+4 QUIT
+5 ;
INJCAUSE(OBJID) ;EP - Ret Cause of Injury - Not Implemented
+1 QUIT ""
+2 ;
INJSTG(OBJID) ;EP - Ret Setting of Injury - Not Implemented
+1 QUIT ""
+2 ;
IND(OBJID) ;EP - Ret the Industry - Not Implemented
+1 QUIT ""
+2 ;
OCC(OBJID) ;EP - Ret the Occupation - Not Implemented
+1 QUIT ""
+2 ;
TODLH(DTTM) ;EP - Convert Ext Date to $H
+1 ;
+2 SET DTTM=$$DATE^BEDDUTIU($GET(DTTM))
+3 QUIT $$FMTH^XLFDT(DTTM)
+4 ;
FMTE(FMDT,FORM) ;EP - Conv FMan to Standard External Dt/Time
+1 IF $GET(FORM)=""
SET FORM="5ZM"
+2 QUIT $TRANSLATE($$FMTE^XLFDT(FMDT,FORM),"@"," ")
+3 ;
FM2HD(FMDT) ;EP - Conv FMan Dt/Time to $H date portion
+1 QUIT $$FMTH^XLFDT(FMDT,1)
+2 ;
SECWTG(HDT,HTM) ;EP - Calc Diff in Seconds from $H
+1 IF $GET(HDT)=""
QUIT ""
+2 QUIT $PIECE($$HDIFF^XLFDT($HOROLOG,HDT_","_HTM,2),".")
+3 ;
MINWTG(HDT,HTM) ;EP - Calc Diff in Minutes from $H
+1 IF $GET(HDT)=""
QUIT ""
+2 QUIT $PIECE($$HDIFF^XLFDT($HOROLOG,HDT_","_HTM,2)/60,".")
+3 ;
FM2HT(FMDT) ;EP - Conv FMan Date/Time to $H time portion
+1 QUIT $PIECE($$FMTH^XLFDT(FMDT),",",2)
+2 ;
DPCP(DFN) ;EP -- Get patient's designated primary care provider
+1 ;
+2 ;Description
+3 ; Checks 'Designated Provider Management System' first
+4 ; for patient's primary care provider, otherwise it
+5 ; checks Patient file.
+6 ;Input
+7 ; DFN
+8 ;Output
+9 ; DPCPN^DPCPNM
+10 ; DPCPN - Primary Care Provider internal entry number
+11 ; DPCPNM - Primary Care Provider Name
+12 ;
+13 NEW DPCAT,DPIEN,DPCPN,DPCPNM
+14 SET DPCPN=""
+15 SET DPCAT=$ORDER(^BDPTCAT("B","DESIGNATED PRIMARY PROVIDER",""))
+16 IF DPCAT'=""
Begin DoDot:1
+17 SET DPIEN=$ORDER(^BDPRECN("AA",DFN,DPCAT,""))
+18 IF DPIEN=""
QUIT
+19 SET DPCPN=$$GET1^DIQ(90360.1,DPIEN_",",.03,"I")
+20 SET DPCPNM=$$GET1^DIQ(90360.1,DPIEN_",",.03,"E")
End DoDot:1
+21 IF DPCPN'=""
QUIT DPCPN_"^"_DPCPNM
+22 ;
+23 SET DPCPN=$$GET1^DIQ(9000001,DFN_",",.14,"I")
+24 SET DPCPNM=$$GET1^DIQ(9000001,DFN_",",.14,"E")
+25 QUIT DPCPN_"^"_DPCPNM
+26 ;
ERR ;
+1 DO ^%ZTER
+2 QUIT
