BEDDUTID ;VNGT/HS/BEE-BEDD Utility Routine 2 ; 08 Nov 2011 12:00 PM
;;2.0;BEDD DASHBOARD;**1,2,3**;Jun 04, 2014;Build 12
;
;GDIT/HS/BEE 05/10/2018;CR#10213 - BEDD*2.0*3 - Allow different hospital locations
;
;Adapted from BEDDUTL1/CNDH/RPF
;
Q
;
KEYCK(DUZ) ;EP - Determine if user has BEDDZMGR Key
;
; Input:
; DUZ - User IEN
;
I $G(DUZ)="" Q 0
;
NEW KIEN
S KIEN=$O(^DIC(19.1,"B","BEDDZMGR","")) Q:KIEN="" 0
I DUZ>0,$D(^VA(200,"AB",KIEN,DUZ,KIEN)) Q 1
Q 0
;
ADDDX(VIEN,DXI,DUZ) ;EP - Add DX TO V POV FILE
;
; Add new DX to V POV (#9000010.07)
;
; Input:
; VIEN - Visit Entry Pointer
; DXI - Diagnosis Code - Entered from Discharge Page
; DUZ - User IEN
;
S VIEN=$G(VIEN,""),DXI=$G(DXI,"") S:$G(U)="" U="^"
;
NEW DFN,NOW,XIEN,PDX,I9,STS
;
;Make sure initial variables are set
S X="S:$G(U)="""" U=""^""" X X
S X="S:$G(DT)="""" DT=$$DT^XLFDT" X X
;
;Define DUZ variable
I $G(DUZ)="" S STS="Missing DUZ" Q
D DUZ^XUP(DUZ)
;
;Error Trapping
NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BEDDUTID D UNWIND^%ZTER" ; SAC 2006 2.2.3.3.2
;
S NOW=$$FNOW^BEDDUTIL
S DFN=$$GETF^BEDDUTIL(9000010,VIEN,.05,"I")
;
;Add entry to PROVIDER NARRATIVE - If not there
S XIEN=$O(^AUTNPOV("B",DXI)) I XIEN="" D
. NEW DIC,X,Y,DINUM,DLAYGO
. S DIC="^AUTNPOV(",DIC(0)="XML",X=DXI,DLAYGO="9999999.27"
. K DO,DD D FILE^DICN
. I +Y<0 Q
. S XIEN=+Y
I XIEN="" Q
;
;Determine if Primary/Secondary Diagnosis
S PDX="P" I $D(^AUPNVPOV("AD",VIEN)) S PDX="S"
;
;Hardset to UNCODED DIAGNOSIS
S I9=$O(^ICD9("AB",.9999,"")) I I9'="" D
. NEW DIC,X,Y,DINUM,DLAYGO
. S DIC="^AUPNVPOV(",DIC(0)="XML",X=I9,DLAYGO=9000010.07
. S DIC("DR")=".02////"_DFN_";.03////"_VIEN_";.04////"_XIEN_";.12////"_PDX_";1201////"_NOW
. K DO,DD D FILE^DICN
Q
;
EDCON(AMERVSIT,EDCONS) ;EP - Get list of ER Consults
;
; Input:
; AMERVSIT - Pointer to ER VISIT file
;
; Output:
; EDCONS Array - List of ER Consults
;
I $G(AMERVSIT)="" S EDCONS=0 Q
;
;Make sure initial variables are set
S X="S:$G(U)="""" U=""^""" X X
S X="S:$G(DT)="""" DT=$$DT^XLFDT" X X
;
;Error Trapping
NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BEDDUTID D UNWIND^%ZTER" ; SAC 2006 2.2.3.3.2
;
NEW EIEN
K EDCONS
S EDCONS=0
;
S EIEN=0 F S EIEN=$O(^AMERVSIT(AMERVSIT,19,EIEN)) Q:'EIEN D
. NEW DA,IENS,COTY,DATE,CONS
. S DA(1)=AMERVSIT,DA=EIEN,IENS=$$IENS^DILF(.DA)
. S COTY=$$GET1^DIQ(9009080.019,IENS,.01,"E") Q:COTY=""
. S DATE=$$FMTE^BEDDUTIL($$GET1^DIQ(9009080.019,IENS,.02,"I"))
. S CONS=$$GET1^DIQ(9009080.019,IENS,.03,"E")
. S EDCONS=EDCONS+1,EDCONS(EDCONS)=COTY_"^"_DATE_"^"_CONS
;
Q
;
PROC(AMERVSIT,ERPROC) ;EP - Get list of ER Procedures Performed
;
; Input:
; AMERVSIT - Pointer to ER VISIT file
;
; Output:
; ERPROC Array - List of ER Procedures Performed
;
I $G(AMERVSIT)="" S ERPROC=0 Q
;
;
;Make sure initial variables are set
S X="S:$G(U)="""" U=""^""" X X
S X="S:$G(DT)="""" DT=$$DT^XLFDT" X X
;
;Error Trapping
NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BEDDUTID D UNWIND^%ZTER" ; SAC 2006 2.2.3.3.2
;
NEW EIEN
K ERPROC
S ERPROC=0
;
S EIEN=0 F S EIEN=$O(^AMERVSIT(AMERVSIT,4,EIEN)) Q:'EIEN D
. NEW DA,IENS,PROC
. S DA(1)=AMERVSIT,DA=EIEN,IENS=$$IENS^DILF(.DA)
. S PROC=$$GET1^DIQ(9009080.04,IENS,.01,"E") Q:PROC=""
. S ERPROC=ERPROC+1,ERPROC(ERPROC)=PROC
;
Q
;
DX(AMERVSIT,ERDX) ;EP - Get list of ER DX'S
;
; Input:
; AMERVSIT - Pointer to ER VISIT file
;
; Output:
; ERDX Array - List of DX' LOGGED BY ER
;
I $G(AMERVSIT)="" S ERDX=0 Q
;
;
;Make sure initial variables are set
S X="S:$G(U)="""" U=""^""" X X
S X="S:$G(DT)="""" DT=$$DT^XLFDT" X X
;
;Error Trapping
NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BEDDUTID D UNWIND^%ZTER" ; SAC 2006 2.2.3.3.2
;
NEW EIEN
K ERDX
S ERDX=0
;
S EIEN=0 F S EIEN=$O(^AMERVSIT(AMERVSIT,5,EIEN)) Q:'EIEN D
. NEW DA,IENS,DX,DXN
. S DA(1)=AMERVSIT,DA=EIEN,IENS=$$IENS^DILF(.DA)
. S DX=$$GET1^DIQ(9009080.05,IENS,.01,"E") Q:DX=""
. S DXN=$$GET1^DIQ(9009080.05,IENS,1,"E")
. S ERDX=ERDX+1,ERDX(ERDX)=DX_"^"_DXN
;
Q
;
MDTRN(DFN) ;EP - Update Patient's MODE OF TRANSPORT
;
;Error Trapping
NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BEDDUTID D UNWIND^%ZTER" ; SAC 2006 2.2.3.3.2
;
;
;Make sure initial variables are set
S X="S:$G(U)="""" U=""^""" X X
S X="S:$G(DT)="""" DT=$$DT^XLFDT" X X
;
NEW MD,MDO,AMUPD,ERROR
;
S MD=$$GET1^DIQ(9009081,DFN_",",6,"I") Q:MD]"" 1
S MDO=$$GET1^DIQ(9009081,DFN_",",2.3,"I") Q:MDO="" 1
S AMUPD(9009081,DFN_",",6)=MDO
I $D(AMUPD) D FILE^DIE("","AMUPD","ERROR")
Q 1
;
EMV(VIEN) ;EP - Return V EMERGENCY VISIT RECORD entry
;
Q $O(^AUPNVER("AD",VIEN,""))
;
DSUM() ;EP - Return if Discharge Summary Global is defined
;
I $D(^TMP("BEDDDSC",$J,"XBDT")) Q 1
Q 0
;
HTIME(TM) ;EP - Given seconds portion of $H value, return time
;
NEW T
;
;To use FileMan Utility add the date, and then strip it off afterwards
S T=+$H_","_TM
S T=$$HTE^XLFDT(T)
Q $P(T,"@",2)
;
PRIMDX(VIEN,OBJID) ;EP - Retrieve/Save the Primary EHR DX
;
;Make sure initial variables are set
S X="S:$G(U)="""" U=""^""" X X
S X="S:$G(DT)="""" DT=$$DT^XLFDT" X X
;
NEW DX
;
S DX=""
;
I $D(^AUPNVPOV("AD",VIEN)) D
. NEW RIEN
. S ICD="",ICDN="",RPFI="",RPFIN=""
. S RIEN="" F S RIEN=$O(^AUPNVPOV("AD",VIEN,RIEN)) Q:RIEN="" D
.. NEW ICD,ICDN,RPFI,RPFIN
.. S (ICD,ICDN,RPFI,RPFIN)=""
.. I $$GET1^DIQ(9000010.07,RIEN_",",.12,"I")="P" D
... S ICD=$$GET1^DIQ(9000010.07,RIEN_",",".04","I")
... S RPFI=$$GET1^DIQ(9000010.07,RIEN_",",".01","I")
... S RPFIN=$$GET1^DIQ(80,RPFI_",",.01,"I")
.. I ICD>0 S ICDN=$$GET1^DIQ(9999999.27,ICD_",",.01,"I")
. I ICD>0 D
..S DX=ICD_"^"_ICDN_"^"_RPFI_"^"_RPFIN_"^"_OBJID
..D SAVEDX^BEDDUTW(DX)
Q DX
;
AGE(DFN) ;EP - Return Patients Age
;
;
;Make sure initial variables are set
S X="S:$G(U)="""" U=""^""" X X
S X="S:$G(DT)="""" DT=$$DT^XLFDT" X X
;
Q $$AGE^AUPNPAT(DFN,,1)
;
;
DSAVE(DFN,AMERVSIT,VIEN,OBJID,DUZ,SITE,BEDDARY) ;EP - Dashboard Discharge Screen Save
;
; Input:
; DFN - Patient IEN
; BEDDARY - Array of entries to save
;
;Error Trapping
NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BEDDUTIL D UNWIND^%ZTER" ; SAC 2006 2.2.3.3.2
;
;Make sure initial variables are set
S X="S:$G(U)="""" U=""^""" X X
S X="S:$G(DT)="""" DT=$$DT^XLFDT" X X
;
NEW AUPNVSIT,STS
;
;Define DUZ variable
I $G(DUZ)="" S STS="Missing DUZ" Q 0
D DUZ^XUP(DUZ)
;
;File ER ADMISSION entries
I $G(DFN)]"" D
. S:$D(BEDDARY("Trg")) AMUPD(9009081,DFN_",",20)=BEDDARY("Trg")
. S:$D(BEDDARY("TrgNow")) AMUPD(9009081,DFN_",",21)=$$DATE^BEDDUTIL(BEDDARY("TrgNow"))
. S:$D(BEDDARY("TrgN")) AMUPD(9009081,DFN_",",19)=BEDDARY("TrgN")
. S:$D(BEDDARY("AdPvTm")) AMUPD(9009081,DFN_",",22)=$$DATE^BEDDUTIL(BEDDARY("AdPvTm"))
. S:$D(BEDDARY("AdmPrv")) AMUPD(9009081,DFN_",",18)=BEDDARY("AdmPrv")
;
;File VISIT entries
;I $G(VIEN)]"" D
;. S:$G(BEDDARY("txcln"))]"" AMUPD(9000010,VIEN_",",.08)=$O(^DIC(40.7,"C",BEDDARY("txcln"),""))
;
I $D(AMUPD) D FILE^DIE("","AMUPD","ERROR")
;
;Complete Discharge
D DC^BEDDUTIS(DFN,OBJID,VIEN,DUZ,SITE,.BEDDARY)
;
;Flag visit as edited
S AUPNVSIT=VIEN D MOD^AUPNVSIT
;
I $D(ERROR) Q 0
Q 1
;
CLIN(CLIN) ;EP - Return List of Applicable Clinics
;
;Moved to BEDDUTL2
D CLIN^BEDDUTL2(.CLIN)
;
Q
;
DISP(DISP) ;EP - Return List of Dispositions
;
;Input:
; None
;
;Output:
; DISP Array - List of Dispositions
;
NEW CNT,DSIEN,DIEN,DSP
K DISP
S DSIEN=$O(^AMER(2,"B","DISPOSITION","")) Q:DSIEN=""
S DIEN="" F S DIEN=$O(^AMER(3,"AC",DSIEN,DIEN)) Q:+DIEN=0 D
. NEW D
. S D=$$GET1^DIQ(9009083,DIEN_",",".01","I") Q:D=""
. S DSP(D)=DIEN_"^"_D
;
;Re-sort
S CNT=0,DSP="" F S DSP=$O(DSP(DSP)) Q:DSP="" D
. S CNT=CNT+1
. S DISP(CNT)=DSP(DSP)
;
Q
;
TRNF(TRNF) ;EP - Return List of Transfer Facilities
;
;Input:
; None
;
;Output:
; TRNF Array - List of Transfer Facilities
;
NEW CNT,FCIEN,FIEN
K TRNF
S CNT=0,FCIEN="" F S FCIEN=$O(^AMER(2.1,"B",FCIEN)) Q:FCIEN="" D
. S FIEN="" F S FIEN=$O(^AMER(2.1,"B",FCIEN,FIEN)) Q:FIEN="" D
.. S CNT=CNT+1
.. S TRNF(CNT)=FIEN_"^"_$$GET1^DIQ(9009082.1,FIEN_",",".01","I")
;
Q
;
INST(INST) ;EP - Return list of Followup Instructions
;
;Input:
; None
;
;Output:
; INST Array - List of Followup Instructions
;
NEW CNT,INIEN,IIEN,INS
K INST
S INIEN=$O(^AMER(2,"B","FOLLOW UP INSTRUCTIONS","")) Q:INIEN=""
S IIEN="" F S IIEN=$O(^AMER(3,"AC",INIEN,IIEN)) Q:IIEN="" D
. S INS=$$GET1^DIQ(9009083,IIEN_",",".01","I") Q:INS=""
. S INS(INS)=IIEN_U_INS
;
S CNT=0,INS="" F S INS=$O(INS(INS)) Q:INS="" D
. S CNT=CNT+1
. S INST(CNT)=INS(INS)
;
Q
;
PROV(PROV) ;EP - Return List of Providers
;
;Input:
; None
;
;Output:
; PROV Array - List of Providers
;
NEW CNT,PNAME,PIEN,X
;
;Make sure initial variables are set
S X="S:$G(U)="""" U=""^""" X X
S X="S:$G(DT)="""" DT=$$DT^XLFDT" X X
;
K PROV
S CNT=0,PNAME="" F S PNAME=$O(^VA(200,"AK.PROVIDER",PNAME)) Q:PNAME="" D
. S PIEN=0 F S PIEN=$O(^VA(200,"AK.PROVIDER",PNAME,PIEN)) Q:+PIEN=0 D
.. ;BEDD*2.0*2;Handle future termination dates
.. ;I $$GET1^DIQ(200,PIEN_",","9.2","I")]"" Q
.. NEW TERM
.. S TERM=$$GET1^DIQ(200,PIEN_",","9.2","I")
.. I TERM]"",TERM<DT Q
.. ;
.. S CNT=CNT+1
.. S PROV(CNT)=PIEN_"^"_PNAME
;
Q
;
CCLN(CLIN) ;EP - Return Clinic Mnemonic
Q $$GET1^DIQ(40.7,CLIN_",",1,"I")
;
SCLN(CLN) ;EP - Convert Clinic
;
I CLN="" Q ""
;
NEW CLIN,XCLIN
S CLIN=$O(^DIC(40.7,"C",CLN,"")) Q:CLIN="" ""
S XCLIN=$$GET1^DIQ(40.7,CLIN_",",.01,"E") Q:XCLIN="" ""
S CLIN=$O(^AMER(3,"B",XCLIN,"")) Q:CLIN="" ""
Q CLIN
;
;
XDATE(X) ;EP - Convert External Date to FileMan
;
NEW %DT
;
S X=$TR(X," ","@")
;
;Strip off seconds
S X=$P(X,":",1,2)
;
S:X="N" X="NOW"
S %DT="T" D ^%DT
S:Y=-1 Y=""
;
Q $$FMTE^BEDDUTIL(Y)
;
DXLKP(VALUE,OBJID,DUZ,FILTER) ;EP - Lookup to File 80 (DX)
;
NEW VIEN,EXEC,VDT,SEX,STS
;
;Verify that the object id was passed in
I $G(OBJID)="" Q
;
;Make sure filter is populated
S:$G(FILTER)="" FILTER=0
;
;Make sure initial variables are set
S X="S:$G(U)="""" U=""^""" X X
S X="S:$G(DT)="""" DT=$$DT^XLFDT" X X
;
;Define DUZ variable
I $G(DUZ)="" S STS="Missing DUZ" Q
D DUZ^XUP(DUZ)
;
;Get the visit ien
S VIEN=""
S EXEC="S BEDDVST=""""" X EXEC
S EXEC="S BEDDVST=##CLASS(BEDD.EDVISIT).%OpenId(OBJID,1)" X EXEC
S EXEC="S VIEN=BEDDVST.VIEN" X EXEC
S EXEC="S BEDDVST=""""" X EXEC
;
;Get the visit date and gender
S VDT="" I $G(VIEN)]"" D
.NEW DFN
. S DFN=$$GET1^DIQ(9000010,VIEN_",",".05","I")
. S SEX=$$GET1^DIQ(2,DFN_",",".02","I")
. S VDT=$P($$GET1^DIQ(9000010,VIEN_",",".01","I"),".")
S:$G(VDT)="" VDT=DT
S:$G(SEX)="" SEX=""
;
;Get the gender
;
;Call the new lookup
D DXLKP^BEDDPOV(VALUE,VDT,.SEX,FILTER)
Q
;
ESAVE(DFN,AMERVSIT,VIEN,BEDDARY) ;EP - Dashboard Edit Screen Save
;
; Input:
; DFN - Patient IEN
; BEDDARY - Array of entries to save
;
NEW CLINIC
;
;Error Trapping
NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BEDDUTIL D UNWIND^%ZTER" ; SAC 2006 2.2.3.3.2
;
;File ER ADMISSION entries
I $G(DFN)]"" D
. ;BEDD*2.0*8;Switch complaint to field 23 (from 8)
. ;S:$D(BEDDARY("COMP")) AMUPD(9009081,DFN_",",8)=BEDDARY("COMP")
. S:$D(BEDDARY("COMP")) AMUPD(9009081,DFN_",",23)=BEDDARY("COMP")
. S:$D(BEDDARY("Trg")) AMUPD(9009081,DFN_",",20)=BEDDARY("Trg")
. S:$D(BEDDARY("TrgNow")) AMUPD(9009081,DFN_",",21)=$$DATE^BEDDUTIL(BEDDARY("TrgNow"))
. S:$D(BEDDARY("AdmPrv")) AMUPD(9009081,DFN_",",18)=BEDDARY("AdmPrv")
. S:$D(BEDDARY("TrgN")) AMUPD(9009081,DFN_",",19)=BEDDARY("TrgN")
. S:$D(BEDDARY("AdPvTm")) AMUPD(9009081,DFN_",",22)=BEDDARY("AdPvTm")
;
;File VISIT entries
S CLINIC=$G(BEDDARY("txcln"))
I $G(VIEN)]"" D
. NEW ERR
. ;GDIT/HS/BEE 05/10/2018;CR#10213 - BEDD*2.0*3 - Allow different hospital locations
. S ERR=$$CKHLOC^AMERBSD(VIEN,CLINIC)
. ;
. ;Chief Complaint
. S AMUPD(9000010,VIEN_",",1401)=$S($G(BEDDARY("COMP"))]"":BEDDARY("COMP"),1:"@")
. ;
. ;BEDDv2.0;Save Decision to admit date
. S AMUPD(9000010,VIEN_",",1116)=$S($G(BEDDARY("DecAdmit"))]"":BEDDARY("DecAdmit"),1:"@")
;
;File ER VISIT entries
I $G(AMERVSIT)]"" S AMUPD(9009080,AMERVSIT_",",.04)=$S(CLINIC]"":CLINIC,1:"@")
;
;File visit entries
I $D(AMUPD) D
. NEW AUPNVSIT
. D FILE^DIE("","AMUPD","ERROR")
. ;
. ;Flag that visit was changed
. D MOD^AUPNVSIT
;
;BEDD*2.0*1;Update V EMERGENCY VISIT
D VER^AMERVER($G(DFN),$G(VIEN))
;
I $D(ERROR) Q 0
Q 1
;
PLCHLD(OBJID,VIEN) ;EP - Look for Diagnosis Default
;
I $G(OBJID)="" Q ""
;
;
;Make sure initial variables are set
S X="S:$G(U)="""" U=""^""" X X
S X="S:$G(DT)="""" DT=$$DT^XLFDT" X X
;
NEW CDIEN,DXNM,DIC,X,Y,VDT,DFLTDX,BEDDPOV
;
;Get visit date, if blank use DT
I $G(VIEN)]"" S VDT=$P($$GET1^DIQ(9000010,VIEN,".01","I"),".")
S:$G(VDT)="" VDT=DT
;
;Quit if patient already has DX codes
;I $$DXCNT^BEDDUTIS(OBJID)>0 Q ""
I $$POV^AMERUTIL("",VIEN,.BEDDPOV)>0 Q ""
;
;Determine if pre-AICD 4.0, pre-ICD-10, or post ICD-10
S (DFLTDX,X)=".9999"
I $$VERSION^XPDUTL("AICD")>3.51,$$IMP^ICDEXA(30)'>VDT S (DFLTDX,X)="ZZZ.999"
;
S DIC="^ICD9(",DIC(0)="XMO" D ^DIC I +Y<0 Q ""
S CDIEN=+Y
;
S DXNM=$E($P($$ICDDX^AUPNVUTL(CDIEN,VDT),U,4),1,55)
Q DFLTDX_"^"_CDIEN_"^"_DXNM
;
UPPER(X) ;EP - Convert to uppercase
Q $TR(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
;
ERR ;EP - Capture the error
D ^%ZTER
Q
BEDDUTID ;VNGT/HS/BEE-BEDD Utility Routine 2 ; 08 Nov 2011 12:00 PM
+1 ;;2.0;BEDD DASHBOARD;**1,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 ;Adapted from BEDDUTL1/CNDH/RPF
+6 ;
+7 QUIT
+8 ;
KEYCK(DUZ) ;EP - Determine if user has BEDDZMGR Key
+1 ;
+2 ; Input:
+3 ; DUZ - User IEN
+4 ;
+5 IF $GET(DUZ)=""
QUIT 0
+6 ;
+7 NEW KIEN
+8 SET KIEN=$ORDER(^DIC(19.1,"B","BEDDZMGR",""))
IF KIEN=""
QUIT 0
+9 IF DUZ>0
IF $DATA(^VA(200,"AB",KIEN,DUZ,KIEN))
QUIT 1
+10 QUIT 0
+11 ;
ADDDX(VIEN,DXI,DUZ) ;EP - Add DX TO V POV FILE
+1 ;
+2 ; Add new DX to V POV (#9000010.07)
+3 ;
+4 ; Input:
+5 ; VIEN - Visit Entry Pointer
+6 ; DXI - Diagnosis Code - Entered from Discharge Page
+7 ; DUZ - User IEN
+8 ;
+9 SET VIEN=$GET(VIEN,"")
SET DXI=$GET(DXI,"")
IF $GET(U)=""
SET U="^"
+10 ;
+11 NEW DFN,NOW,XIEN,PDX,I9,STS
+12 ;
+13 ;Make sure initial variables are set
+14 SET X="S:$G(U)="""" U=""^"""
XECUTE X
+15 SET X="S:$G(DT)="""" DT=$$DT^XLFDT"
XECUTE X
+16 ;
+17 ;Define DUZ variable
+18 IF $GET(DUZ)=""
SET STS="Missing DUZ"
QUIT
+19 DO DUZ^XUP(DUZ)
+20 ;
+21 ;Error Trapping
+22 ; SAC 2006 2.2.3.3.2
NEW $ESTACK,$ETRAP
SET $ETRAP="D ERR^BEDDUTID D UNWIND^%ZTER"
+23 ;
+24 SET NOW=$$FNOW^BEDDUTIL
+25 SET DFN=$$GETF^BEDDUTIL(9000010,VIEN,.05,"I")
+26 ;
+27 ;Add entry to PROVIDER NARRATIVE - If not there
+28 SET XIEN=$ORDER(^AUTNPOV("B",DXI))
IF XIEN=""
Begin DoDot:1
+29 NEW DIC,X,Y,DINUM,DLAYGO
+30 SET DIC="^AUTNPOV("
SET DIC(0)="XML"
SET X=DXI
SET DLAYGO="9999999.27"
+31 KILL DO,DD
DO FILE^DICN
+32 IF +Y<0
QUIT
+33 SET XIEN=+Y
End DoDot:1
+34 IF XIEN=""
QUIT
+35 ;
+36 ;Determine if Primary/Secondary Diagnosis
+37 SET PDX="P"
IF $DATA(^AUPNVPOV("AD",VIEN))
SET PDX="S"
+38 ;
+39 ;Hardset to UNCODED DIAGNOSIS
+40 SET I9=$ORDER(^ICD9("AB",.9999,""))
IF I9'=""
Begin DoDot:1
+41 NEW DIC,X,Y,DINUM,DLAYGO
+42 SET DIC="^AUPNVPOV("
SET DIC(0)="XML"
SET X=I9
SET DLAYGO=9000010.07
+43 SET DIC("DR")=".02////"_DFN_";.03////"_VIEN_";.04////"_XIEN_";.12////"_PDX_";1201////"_NOW
+44 KILL DO,DD
DO FILE^DICN
End DoDot:1
+45 QUIT
+46 ;
EDCON(AMERVSIT,EDCONS) ;EP - Get list of ER Consults
+1 ;
+2 ; Input:
+3 ; AMERVSIT - Pointer to ER VISIT file
+4 ;
+5 ; Output:
+6 ; EDCONS Array - List of ER Consults
+7 ;
+8 IF $GET(AMERVSIT)=""
SET EDCONS=0
QUIT
+9 ;
+10 ;Make sure initial variables are set
+11 SET X="S:$G(U)="""" U=""^"""
XECUTE X
+12 SET X="S:$G(DT)="""" DT=$$DT^XLFDT"
XECUTE X
+13 ;
+14 ;Error Trapping
+15 ; SAC 2006 2.2.3.3.2
NEW $ESTACK,$ETRAP
SET $ETRAP="D ERR^BEDDUTID D UNWIND^%ZTER"
+16 ;
+17 NEW EIEN
+18 KILL EDCONS
+19 SET EDCONS=0
+20 ;
+21 SET EIEN=0
FOR
SET EIEN=$ORDER(^AMERVSIT(AMERVSIT,19,EIEN))
IF 'EIEN
QUIT
Begin DoDot:1
+22 NEW DA,IENS,COTY,DATE,CONS
+23 SET DA(1)=AMERVSIT
SET DA=EIEN
SET IENS=$$IENS^DILF(.DA)
+24 SET COTY=$$GET1^DIQ(9009080.019,IENS,.01,"E")
IF COTY=""
QUIT
+25 SET DATE=$$FMTE^BEDDUTIL($$GET1^DIQ(9009080.019,IENS,.02,"I"))
+26 SET CONS=$$GET1^DIQ(9009080.019,IENS,.03,"E")
+27 SET EDCONS=EDCONS+1
SET EDCONS(EDCONS)=COTY_"^"_DATE_"^"_CONS
End DoDot:1
+28 ;
+29 QUIT
+30 ;
PROC(AMERVSIT,ERPROC) ;EP - Get list of ER Procedures Performed
+1 ;
+2 ; Input:
+3 ; AMERVSIT - Pointer to ER VISIT file
+4 ;
+5 ; Output:
+6 ; ERPROC Array - List of ER Procedures Performed
+7 ;
+8 IF $GET(AMERVSIT)=""
SET ERPROC=0
QUIT
+9 ;
+10 ;
+11 ;Make sure initial variables are set
+12 SET X="S:$G(U)="""" U=""^"""
XECUTE X
+13 SET X="S:$G(DT)="""" DT=$$DT^XLFDT"
XECUTE X
+14 ;
+15 ;Error Trapping
+16 ; SAC 2006 2.2.3.3.2
NEW $ESTACK,$ETRAP
SET $ETRAP="D ERR^BEDDUTID D UNWIND^%ZTER"
+17 ;
+18 NEW EIEN
+19 KILL ERPROC
+20 SET ERPROC=0
+21 ;
+22 SET EIEN=0
FOR
SET EIEN=$ORDER(^AMERVSIT(AMERVSIT,4,EIEN))
IF 'EIEN
QUIT
Begin DoDot:1
+23 NEW DA,IENS,PROC
+24 SET DA(1)=AMERVSIT
SET DA=EIEN
SET IENS=$$IENS^DILF(.DA)
+25 SET PROC=$$GET1^DIQ(9009080.04,IENS,.01,"E")
IF PROC=""
QUIT
+26 SET ERPROC=ERPROC+1
SET ERPROC(ERPROC)=PROC
End DoDot:1
+27 ;
+28 QUIT
+29 ;
DX(AMERVSIT,ERDX) ;EP - Get list of ER DX'S
+1 ;
+2 ; Input:
+3 ; AMERVSIT - Pointer to ER VISIT file
+4 ;
+5 ; Output:
+6 ; ERDX Array - List of DX' LOGGED BY ER
+7 ;
+8 IF $GET(AMERVSIT)=""
SET ERDX=0
QUIT
+9 ;
+10 ;
+11 ;Make sure initial variables are set
+12 SET X="S:$G(U)="""" U=""^"""
XECUTE X
+13 SET X="S:$G(DT)="""" DT=$$DT^XLFDT"
XECUTE X
+14 ;
+15 ;Error Trapping
+16 ; SAC 2006 2.2.3.3.2
NEW $ESTACK,$ETRAP
SET $ETRAP="D ERR^BEDDUTID D UNWIND^%ZTER"
+17 ;
+18 NEW EIEN
+19 KILL ERDX
+20 SET ERDX=0
+21 ;
+22 SET EIEN=0
FOR
SET EIEN=$ORDER(^AMERVSIT(AMERVSIT,5,EIEN))
IF 'EIEN
QUIT
Begin DoDot:1
+23 NEW DA,IENS,DX,DXN
+24 SET DA(1)=AMERVSIT
SET DA=EIEN
SET IENS=$$IENS^DILF(.DA)
+25 SET DX=$$GET1^DIQ(9009080.05,IENS,.01,"E")
IF DX=""
QUIT
+26 SET DXN=$$GET1^DIQ(9009080.05,IENS,1,"E")
+27 SET ERDX=ERDX+1
SET ERDX(ERDX)=DX_"^"_DXN
End DoDot:1
+28 ;
+29 QUIT
+30 ;
MDTRN(DFN) ;EP - Update Patient's MODE OF TRANSPORT
+1 ;
+2 ;Error Trapping
+3 ; SAC 2006 2.2.3.3.2
NEW $ESTACK,$ETRAP
SET $ETRAP="D ERR^BEDDUTID D UNWIND^%ZTER"
+4 ;
+5 ;
+6 ;Make sure initial variables are set
+7 SET X="S:$G(U)="""" U=""^"""
XECUTE X
+8 SET X="S:$G(DT)="""" DT=$$DT^XLFDT"
XECUTE X
+9 ;
+10 NEW MD,MDO,AMUPD,ERROR
+11 ;
+12 SET MD=$$GET1^DIQ(9009081,DFN_",",6,"I")
IF MD]""
QUIT 1
+13 SET MDO=$$GET1^DIQ(9009081,DFN_",",2.3,"I")
IF MDO=""
QUIT 1
+14 SET AMUPD(9009081,DFN_",",6)=MDO
+15 IF $DATA(AMUPD)
DO FILE^DIE("","AMUPD","ERROR")
+16 QUIT 1
+17 ;
EMV(VIEN) ;EP - Return V EMERGENCY VISIT RECORD entry
+1 ;
+2 QUIT $ORDER(^AUPNVER("AD",VIEN,""))
+3 ;
DSUM() ;EP - Return if Discharge Summary Global is defined
+1 ;
+2 IF $DATA(^TMP("BEDDDSC",$JOB,"XBDT"))
QUIT 1
+3 QUIT 0
+4 ;
HTIME(TM) ;EP - Given seconds portion of $H value, return time
+1 ;
+2 NEW T
+3 ;
+4 ;To use FileMan Utility add the date, and then strip it off afterwards
+5 SET T=+$HOROLOG_","_TM
+6 SET T=$$HTE^XLFDT(T)
+7 QUIT $PIECE(T,"@",2)
+8 ;
PRIMDX(VIEN,OBJID) ;EP - Retrieve/Save the Primary EHR DX
+1 ;
+2 ;Make sure initial variables are set
+3 SET X="S:$G(U)="""" U=""^"""
XECUTE X
+4 SET X="S:$G(DT)="""" DT=$$DT^XLFDT"
XECUTE X
+5 ;
+6 NEW DX
+7 ;
+8 SET DX=""
+9 ;
+10 IF $DATA(^AUPNVPOV("AD",VIEN))
Begin DoDot:1
+11 NEW RIEN
+12 SET ICD=""
SET ICDN=""
SET RPFI=""
SET RPFIN=""
+13 SET RIEN=""
FOR
SET RIEN=$ORDER(^AUPNVPOV("AD",VIEN,RIEN))
IF RIEN=""
QUIT
Begin DoDot:2
+14 NEW ICD,ICDN,RPFI,RPFIN
+15 SET (ICD,ICDN,RPFI,RPFIN)=""
+16 IF $$GET1^DIQ(9000010.07,RIEN_",",.12,"I")="P"
Begin DoDot:3
+17 SET ICD=$$GET1^DIQ(9000010.07,RIEN_",",".04","I")
+18 SET RPFI=$$GET1^DIQ(9000010.07,RIEN_",",".01","I")
+19 SET RPFIN=$$GET1^DIQ(80,RPFI_",",.01,"I")
End DoDot:3
+20 IF ICD>0
SET ICDN=$$GET1^DIQ(9999999.27,ICD_",",.01,"I")
End DoDot:2
+21 IF ICD>0
Begin DoDot:2
+22 SET DX=ICD_"^"_ICDN_"^"_RPFI_"^"_RPFIN_"^"_OBJID
+23 DO SAVEDX^BEDDUTW(DX)
End DoDot:2
End DoDot:1
+24 QUIT DX
+25 ;
AGE(DFN) ;EP - Return Patients Age
+1 ;
+2 ;
+3 ;Make sure initial variables are set
+4 SET X="S:$G(U)="""" U=""^"""
XECUTE X
+5 SET X="S:$G(DT)="""" DT=$$DT^XLFDT"
XECUTE X
+6 ;
+7 QUIT $$AGE^AUPNPAT(DFN,,1)
+8 ;
+9 ;
DSAVE(DFN,AMERVSIT,VIEN,OBJID,DUZ,SITE,BEDDARY) ;EP - Dashboard Discharge Screen Save
+1 ;
+2 ; Input:
+3 ; DFN - Patient IEN
+4 ; BEDDARY - Array of entries to save
+5 ;
+6 ;Error Trapping
+7 ; SAC 2006 2.2.3.3.2
NEW $ESTACK,$ETRAP
SET $ETRAP="D ERR^BEDDUTIL D UNWIND^%ZTER"
+8 ;
+9 ;Make sure initial variables are set
+10 SET X="S:$G(U)="""" U=""^"""
XECUTE X
+11 SET X="S:$G(DT)="""" DT=$$DT^XLFDT"
XECUTE X
+12 ;
+13 NEW AUPNVSIT,STS
+14 ;
+15 ;Define DUZ variable
+16 IF $GET(DUZ)=""
SET STS="Missing DUZ"
QUIT 0
+17 DO DUZ^XUP(DUZ)
+18 ;
+19 ;File ER ADMISSION entries
+20 IF $GET(DFN)]""
Begin DoDot:1
+21 IF $DATA(BEDDARY("Trg"))
SET AMUPD(9009081,DFN_",",20)=BEDDARY("Trg")
+22 IF $DATA(BEDDARY("TrgNow"))
SET AMUPD(9009081,DFN_",",21)=$$DATE^BEDDUTIL(BEDDARY("TrgNow"))
+23 IF $DATA(BEDDARY("TrgN"))
SET AMUPD(9009081,DFN_",",19)=BEDDARY("TrgN")
+24 IF $DATA(BEDDARY("AdPvTm"))
SET AMUPD(9009081,DFN_",",22)=$$DATE^BEDDUTIL(BEDDARY("AdPvTm"))
+25 IF $DATA(BEDDARY("AdmPrv"))
SET AMUPD(9009081,DFN_",",18)=BEDDARY("AdmPrv")
End DoDot:1
+26 ;
+27 ;File VISIT entries
+28 ;I $G(VIEN)]"" D
+29 ;. S:$G(BEDDARY("txcln"))]"" AMUPD(9000010,VIEN_",",.08)=$O(^DIC(40.7,"C",BEDDARY("txcln"),""))
+30 ;
+31 IF $DATA(AMUPD)
DO FILE^DIE("","AMUPD","ERROR")
+32 ;
+33 ;Complete Discharge
+34 DO DC^BEDDUTIS(DFN,OBJID,VIEN,DUZ,SITE,.BEDDARY)
+35 ;
+36 ;Flag visit as edited
+37 SET AUPNVSIT=VIEN
DO MOD^AUPNVSIT
+38 ;
+39 IF $DATA(ERROR)
QUIT 0
+40 QUIT 1
+41 ;
CLIN(CLIN) ;EP - Return List of Applicable Clinics
+1 ;
+2 ;Moved to BEDDUTL2
+3 DO CLIN^BEDDUTL2(.CLIN)
+4 ;
+5 QUIT
+6 ;
DISP(DISP) ;EP - Return List of Dispositions
+1 ;
+2 ;Input:
+3 ; None
+4 ;
+5 ;Output:
+6 ; DISP Array - List of Dispositions
+7 ;
+8 NEW CNT,DSIEN,DIEN,DSP
+9 KILL DISP
+10 SET DSIEN=$ORDER(^AMER(2,"B","DISPOSITION",""))
IF DSIEN=""
QUIT
+11 SET DIEN=""
FOR
SET DIEN=$ORDER(^AMER(3,"AC",DSIEN,DIEN))
IF +DIEN=0
QUIT
Begin DoDot:1
+12 NEW D
+13 SET D=$$GET1^DIQ(9009083,DIEN_",",".01","I")
IF D=""
QUIT
+14 SET DSP(D)=DIEN_"^"_D
End DoDot:1
+15 ;
+16 ;Re-sort
+17 SET CNT=0
SET DSP=""
FOR
SET DSP=$ORDER(DSP(DSP))
IF DSP=""
QUIT
Begin DoDot:1
+18 SET CNT=CNT+1
+19 SET DISP(CNT)=DSP(DSP)
End DoDot:1
+20 ;
+21 QUIT
+22 ;
TRNF(TRNF) ;EP - Return List of Transfer Facilities
+1 ;
+2 ;Input:
+3 ; None
+4 ;
+5 ;Output:
+6 ; TRNF Array - List of Transfer Facilities
+7 ;
+8 NEW CNT,FCIEN,FIEN
+9 KILL TRNF
+10 SET CNT=0
SET FCIEN=""
FOR
SET FCIEN=$ORDER(^AMER(2.1,"B",FCIEN))
IF FCIEN=""
QUIT
Begin DoDot:1
+11 SET FIEN=""
FOR
SET FIEN=$ORDER(^AMER(2.1,"B",FCIEN,FIEN))
IF FIEN=""
QUIT
Begin DoDot:2
+12 SET CNT=CNT+1
+13 SET TRNF(CNT)=FIEN_"^"_$$GET1^DIQ(9009082.1,FIEN_",",".01","I")
End DoDot:2
End DoDot:1
+14 ;
+15 QUIT
+16 ;
INST(INST) ;EP - Return list of Followup Instructions
+1 ;
+2 ;Input:
+3 ; None
+4 ;
+5 ;Output:
+6 ; INST Array - List of Followup Instructions
+7 ;
+8 NEW CNT,INIEN,IIEN,INS
+9 KILL INST
+10 SET INIEN=$ORDER(^AMER(2,"B","FOLLOW UP INSTRUCTIONS",""))
IF INIEN=""
QUIT
+11 SET IIEN=""
FOR
SET IIEN=$ORDER(^AMER(3,"AC",INIEN,IIEN))
IF IIEN=""
QUIT
Begin DoDot:1
+12 SET INS=$$GET1^DIQ(9009083,IIEN_",",".01","I")
IF INS=""
QUIT
+13 SET INS(INS)=IIEN_U_INS
End DoDot:1
+14 ;
+15 SET CNT=0
SET INS=""
FOR
SET INS=$ORDER(INS(INS))
IF INS=""
QUIT
Begin DoDot:1
+16 SET CNT=CNT+1
+17 SET INST(CNT)=INS(INS)
End DoDot:1
+18 ;
+19 QUIT
+20 ;
PROV(PROV) ;EP - Return List of Providers
+1 ;
+2 ;Input:
+3 ; None
+4 ;
+5 ;Output:
+6 ; PROV Array - List of Providers
+7 ;
+8 NEW CNT,PNAME,PIEN,X
+9 ;
+10 ;Make sure initial variables are set
+11 SET X="S:$G(U)="""" U=""^"""
XECUTE X
+12 SET X="S:$G(DT)="""" DT=$$DT^XLFDT"
XECUTE X
+13 ;
+14 KILL PROV
+15 SET CNT=0
SET PNAME=""
FOR
SET PNAME=$ORDER(^VA(200,"AK.PROVIDER",PNAME))
IF PNAME=""
QUIT
Begin DoDot:1
+16 SET PIEN=0
FOR
SET PIEN=$ORDER(^VA(200,"AK.PROVIDER",PNAME,PIEN))
IF +PIEN=0
QUIT
Begin DoDot:2
+17 ;BEDD*2.0*2;Handle future termination dates
+18 ;I $$GET1^DIQ(200,PIEN_",","9.2","I")]"" Q
+19 NEW TERM
+20 SET TERM=$$GET1^DIQ(200,PIEN_",","9.2","I")
+21 IF TERM]""
IF TERM<DT
QUIT
+22 ;
+23 SET CNT=CNT+1
+24 SET PROV(CNT)=PIEN_"^"_PNAME
End DoDot:2
End DoDot:1
+25 ;
+26 QUIT
+27 ;
CCLN(CLIN) ;EP - Return Clinic Mnemonic
+1 QUIT $$GET1^DIQ(40.7,CLIN_",",1,"I")
+2 ;
SCLN(CLN) ;EP - Convert Clinic
+1 ;
+2 IF CLN=""
QUIT ""
+3 ;
+4 NEW CLIN,XCLIN
+5 SET CLIN=$ORDER(^DIC(40.7,"C",CLN,""))
IF CLIN=""
QUIT ""
+6 SET XCLIN=$$GET1^DIQ(40.7,CLIN_",",.01,"E")
IF XCLIN=""
QUIT ""
+7 SET CLIN=$ORDER(^AMER(3,"B",XCLIN,""))
IF CLIN=""
QUIT ""
+8 QUIT CLIN
+9 ;
+10 ;
XDATE(X) ;EP - Convert External Date to FileMan
+1 ;
+2 NEW %DT
+3 ;
+4 SET X=$TRANSLATE(X," ","@")
+5 ;
+6 ;Strip off seconds
+7 SET X=$PIECE(X,":",1,2)
+8 ;
+9 IF X="N"
SET X="NOW"
+10 SET %DT="T"
DO ^%DT
+11 IF Y=-1
SET Y=""
+12 ;
+13 QUIT $$FMTE^BEDDUTIL(Y)
+14 ;
DXLKP(VALUE,OBJID,DUZ,FILTER) ;EP - Lookup to File 80 (DX)
+1 ;
+2 NEW VIEN,EXEC,VDT,SEX,STS
+3 ;
+4 ;Verify that the object id was passed in
+5 IF $GET(OBJID)=""
QUIT
+6 ;
+7 ;Make sure filter is populated
+8 IF $GET(FILTER)=""
SET FILTER=0
+9 ;
+10 ;Make sure initial variables are set
+11 SET X="S:$G(U)="""" U=""^"""
XECUTE X
+12 SET X="S:$G(DT)="""" DT=$$DT^XLFDT"
XECUTE X
+13 ;
+14 ;Define DUZ variable
+15 IF $GET(DUZ)=""
SET STS="Missing DUZ"
QUIT
+16 DO DUZ^XUP(DUZ)
+17 ;
+18 ;Get the visit ien
+19 SET VIEN=""
+20 SET EXEC="S BEDDVST="""""
XECUTE EXEC
+21 SET EXEC="S BEDDVST=##CLASS(BEDD.EDVISIT).%OpenId(OBJID,1)"
XECUTE EXEC
+22 SET EXEC="S VIEN=BEDDVST.VIEN"
XECUTE EXEC
+23 SET EXEC="S BEDDVST="""""
XECUTE EXEC
+24 ;
+25 ;Get the visit date and gender
+26 SET VDT=""
IF $GET(VIEN)]""
Begin DoDot:1
+27 NEW DFN
+28 SET DFN=$$GET1^DIQ(9000010,VIEN_",",".05","I")
+29 SET SEX=$$GET1^DIQ(2,DFN_",",".02","I")
+30 SET VDT=$PIECE($$GET1^DIQ(9000010,VIEN_",",".01","I"),".")
End DoDot:1
+31 IF $GET(VDT)=""
SET VDT=DT
+32 IF $GET(SEX)=""
SET SEX=""
+33 ;
+34 ;Get the gender
+35 ;
+36 ;Call the new lookup
+37 DO DXLKP^BEDDPOV(VALUE,VDT,.SEX,FILTER)
+38 QUIT
+39 ;
ESAVE(DFN,AMERVSIT,VIEN,BEDDARY) ;EP - Dashboard Edit Screen Save
+1 ;
+2 ; Input:
+3 ; DFN - Patient IEN
+4 ; BEDDARY - Array of entries to save
+5 ;
+6 NEW CLINIC
+7 ;
+8 ;Error Trapping
+9 ; SAC 2006 2.2.3.3.2
NEW $ESTACK,$ETRAP
SET $ETRAP="D ERR^BEDDUTIL D UNWIND^%ZTER"
+10 ;
+11 ;File ER ADMISSION entries
+12 IF $GET(DFN)]""
Begin DoDot:1
+13 ;BEDD*2.0*8;Switch complaint to field 23 (from 8)
+14 ;S:$D(BEDDARY("COMP")) AMUPD(9009081,DFN_",",8)=BEDDARY("COMP")
+15 IF $DATA(BEDDARY("COMP"))
SET AMUPD(9009081,DFN_",",23)=BEDDARY("COMP")
+16 IF $DATA(BEDDARY("Trg"))
SET AMUPD(9009081,DFN_",",20)=BEDDARY("Trg")
+17 IF $DATA(BEDDARY("TrgNow"))
SET AMUPD(9009081,DFN_",",21)=$$DATE^BEDDUTIL(BEDDARY("TrgNow"))
+18 IF $DATA(BEDDARY("AdmPrv"))
SET AMUPD(9009081,DFN_",",18)=BEDDARY("AdmPrv")
+19 IF $DATA(BEDDARY("TrgN"))
SET AMUPD(9009081,DFN_",",19)=BEDDARY("TrgN")
+20 IF $DATA(BEDDARY("AdPvTm"))
SET AMUPD(9009081,DFN_",",22)=BEDDARY("AdPvTm")
End DoDot:1
+21 ;
+22 ;File VISIT entries
+23 SET CLINIC=$GET(BEDDARY("txcln"))
+24 IF $GET(VIEN)]""
Begin DoDot:1
+25 NEW ERR
+26 ;GDIT/HS/BEE 05/10/2018;CR#10213 - BEDD*2.0*3 - Allow different hospital locations
+27 SET ERR=$$CKHLOC^AMERBSD(VIEN,CLINIC)
+28 ;
+29 ;Chief Complaint
+30 SET AMUPD(9000010,VIEN_",",1401)=$SELECT($GET(BEDDARY("COMP"))]"":BEDDARY("COMP"),1:"@")
+31 ;
+32 ;BEDDv2.0;Save Decision to admit date
+33 SET AMUPD(9000010,VIEN_",",1116)=$SELECT($GET(BEDDARY("DecAdmit"))]"":BEDDARY("DecAdmit"),1:"@")
End DoDot:1
+34 ;
+35 ;File ER VISIT entries
+36 IF $GET(AMERVSIT)]""
SET AMUPD(9009080,AMERVSIT_",",.04)=$SELECT(CLINIC]"":CLINIC,1:"@")
+37 ;
+38 ;File visit entries
+39 IF $DATA(AMUPD)
Begin DoDot:1
+40 NEW AUPNVSIT
+41 DO FILE^DIE("","AMUPD","ERROR")
+42 ;
+43 ;Flag that visit was changed
+44 DO MOD^AUPNVSIT
End DoDot:1
+45 ;
+46 ;BEDD*2.0*1;Update V EMERGENCY VISIT
+47 DO VER^AMERVER($GET(DFN),$GET(VIEN))
+48 ;
+49 IF $DATA(ERROR)
QUIT 0
+50 QUIT 1
+51 ;
PLCHLD(OBJID,VIEN) ;EP - Look for Diagnosis Default
+1 ;
+2 IF $GET(OBJID)=""
QUIT ""
+3 ;
+4 ;
+5 ;Make sure initial variables are set
+6 SET X="S:$G(U)="""" U=""^"""
XECUTE X
+7 SET X="S:$G(DT)="""" DT=$$DT^XLFDT"
XECUTE X
+8 ;
+9 NEW CDIEN,DXNM,DIC,X,Y,VDT,DFLTDX,BEDDPOV
+10 ;
+11 ;Get visit date, if blank use DT
+12 IF $GET(VIEN)]""
SET VDT=$PIECE($$GET1^DIQ(9000010,VIEN,".01","I"),".")
+13 IF $GET(VDT)=""
SET VDT=DT
+14 ;
+15 ;Quit if patient already has DX codes
+16 ;I $$DXCNT^BEDDUTIS(OBJID)>0 Q ""
+17 IF $$POV^AMERUTIL("",VIEN,.BEDDPOV)>0
QUIT ""
+18 ;
+19 ;Determine if pre-AICD 4.0, pre-ICD-10, or post ICD-10
+20 SET (DFLTDX,X)=".9999"
+21 IF $$VERSION^XPDUTL("AICD")>3.51
IF $$IMP^ICDEXA(30)'>VDT
SET (DFLTDX,X)="ZZZ.999"
+22 ;
+23 SET DIC="^ICD9("
SET DIC(0)="XMO"
DO ^DIC
IF +Y<0
QUIT ""
+24 SET CDIEN=+Y
+25 ;
+26 SET DXNM=$EXTRACT($PIECE($$ICDDX^AUPNVUTL(CDIEN,VDT),U,4),1,55)
+27 QUIT DFLTDX_"^"_CDIEN_"^"_DXNM
+28 ;
UPPER(X) ;EP - Convert to uppercase
+1 QUIT $TRANSLATE(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
+2 ;
ERR ;EP - Capture the error
+1 DO ^%ZTER
+2 QUIT
