- 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
