EDPCONV ;SLC/MKB - Process incoming mail to convert local ED Visits ;2/28/12 08:33am
;;2.0;EMERGENCY DEPARTMENT;**2**;Feb 24, 2012;Build 23
;
AREA(DIV) ; -- Return #231.9 ien for DIVision (#4 ien)
Q +$O(^EDPB(231.9,"C",DIV,0))
;
VST(OLD) ; -- Copy OLD(node) ER visit entry into ^EDP(230)
N X,I,EDPY,EDPSITE,EDPDIFF,EDPAREA,EDPSTA,EDPLOG,EDPI,PNM,SSN
S EDPSITE=$G(OLD("SITE")),X=$G(OLD("TZ")),EDPDIFF=0 ;$$TZONE(X)
S EDPAREA=$$AREA(EDPSITE) Q:EDPAREA<1
S EDPSTA=$$STA^XUAF4(EDPSITE) ;station number
F I=0,1,2,3,4,6,9 S OLD(I)=$G(OLD(I)) ;defined
S X=$P(OLD(0),U,5),EDPY=$$NEW(230,X) Q:EDPY<1
S PNM=$P(OLD(0),U),SSN=$P(OLD(0),U,3) ;patient name, ssn
S EDPLOG(0)=X_U_EDPSITE_U_EDPAREA_U_PNM_U_SSN_U_$P(OLD(6),U,2)_U_$G(OLD("CLOSED"))_U_$P(OLD(4),U,4,5)_U_$$ARR($P(OLD(0),U,6))_U_$$PID(PNM,SSN) ;_U_EDPDIFF
S X=$P(OLD(9),U,3) S:'X X=$P(OLD(6),U,3) ;disposition
S EDPLOG(1)=$P(OLD(1),U)_U_$$DISP(X)_U_$P(OLD(9),U,2)_U_$P(OLD(9),U)_U_$$DEL($P(OLD(4),U,7))
S X=$P(OLD(2),U) S:$L(X) EDPLOG(2)=X
S EDPLOG(3)=U_$$STS($P(OLD(0),U,4))_U_$$ACU($P(OLD(4),U,3))_U_$$LOC($P(OLD(3),U,2))_U_$P(OLD(4),U)_U_$P(OLD(4),U,2)_U_$P(OLD(4),U,6)_U_$P(OLD(6),U)
I $D(OLD(8)) M EDPLOG(4)=OLD(8) S $P(EDPLOG(4,0),U,2)="230.04A" D
. S EDPI=0 F S EDPI=$O(EDPLOG(4,EDPI)) Q:EDPI<1 D
.. S X=$P($G(EDPLOG(4,EDPI,0)),U,2) Q:'$L(X) ;code -> ien
.. I X?1"ICD-9-CODE-".E S X=$P(X,"-",4)
.. I X["/" S X=$P(X,"/")
.. ;Begin EDP*2.0*2 CHANGES.
.. S X=$$ICDDX^EDPLEX(X,$P($G(^EDP(230,EDPY,0),2781001),U,8)),$P(EDPLOG(4,EDPI,0),U,2)=$S(X>0:+X,1:"")
.. ;End EDP*2.0*2 CHANGES.
; Save/Xref log entry
M ^EDP(230,EDPY)=EDPLOG
D XREF(230,EDPY)
;
; Set History from Movement nodes
S EDPI="MVT" F S EDPI=$O(OLD(EDPI)) Q:EDPI'?1"MVT"1.N D HIST(EDPI,EDPY)
;
; Create Orders list for active visits
I '$G(OLD("CLOSED")) S X=EDPLOG(0) D ORDERS(EDPY,X)
;
S OLD(230)=EDPY ;return new ien
Q
;
HIST(MVTI,LOG) ; -- Copy OLD(MVTI) into ^EDP(230.1)
N EDPY,MVT,ACT
S EDPY=$$NEW(230.1,LOG) Q:EDPY<1
S MVT=OLD(MVTI)
S ACT(0)=LOG_U_$P(MVT,U,2)_U_U_$P($G(^EDP(230,LOG,0)),U,4,6)
S ACT(3)=U_$$STS($P(MVT,U,3))_U_$$ACU($P(MVT,U,4))_U_$$LOC($P(MVT,U,5))_U_$P(MVT,U,6,8)
; Save/Xref history
M ^EDP(230.1,EDPY)=ACT
D XREF(230.1,EDPY)
Q
;
NEW(FILE,X) ; -- Return ien of new entry in FILE
N DO,DIC,DA,Y
S DIC="^EDP("_FILE_",",DIC(0)="LF" D FILE^DICN
Q +Y
;
XREF(FILE,DA) ; -- Set all xrefs for DA in FILE
N DIK
S DIK="^EDP("_FILE_"," D IX1^DIK
Q
;
PID(NM,ID) ; -- Return brief id (L0000) for patient
N Y S Y=$E(NM)_$E(ID,6,9)
Q Y
;
TZONE(X) ; -- Return #minutes local offset for time zone
N Y S Y=$E(X)_(60*$E(X,2,3)+$E(X,4,5))
Q Y
;
ACU(X) ; -- Return[/add] #233.1 ien for Acuity X
I $G(X)="" Q ""
N Y,NODE S NODE=$G(OLD("ACU"_+X)) Q:NODE="" $$NOVALUE
S X=$P(NODE,U,2),Y=""
S:$L(X) Y=+$O(^EDPB(233.1,"AB","acuity",X,0)) Q:Y Y
; add local item
N FDA,FDAIEN,DIERR,ERR,NM
S NM=$P(NODE,U),NM=$S(NM["-":$P(NM,"-",2),1:NM)
S FDA(233.1,"+1,",.01)=EDPSTA_".acuity."_$$LOW^XLFSTR(NM)
S FDA(233.1,"+1,",.02)=X
S FDA(233.1,"+1,",.03)=X
D UPDATE^DIE("","FDA","FDAIEN","ERR")
S Y=$S('$D(DIERR):+$G(FDAIEN(1)),1:"")
Q Y
;
STS(X) ; -- Return[/add] #233.1 ien for Status X
I $G(X)="" Q ""
N Y,NODE
S NODE=$G(OLD("STS"_+X)),Y="" Q:NODE="" $$NOVALUE
S X=$P(NODE,U,1) S:$L(X) Y=+$O(^EDPB(233.1,"AC","status",X,0)) Q:Y Y
S X=$P(NODE,U,4) S:$L(X) Y=+$O(^EDPB(233.1,"AB","status",X,0)) Q:Y Y
; add local item
N FDA,FDAIEN,DIERR,ERR
S FDA(233.1,"+1,",.01)=EDPSTA_".status."_$$LOW^XLFSTR(X)
S FDA(233.1,"+1,",.02)=$P(NODE,U) ;text
S FDA(233.1,"+1,",.03)=X ;display/abbreviation
S:$P(NODE,U,6)="Y" FDA(233.1,"+1,",.05)="A" ;admission flag
D UPDATE^DIE("","FDA","FDAIEN","ERR")
S Y=$S('$D(DIERR):+$G(FDAIEN(1)),1:"")
Q Y
;
DEL(X) ; -- Return[/add] #233.1 ien for Delay Reason X
I $G(X)="" Q ""
N Y,NODE
S NODE=$G(OLD("DEL"_+X)),Y="" Q:NODE="" $$NOVALUE
S X=$P(NODE,U,1) S:$L(X) Y=+$O(^EDPB(233.1,"AC","delay",X,0)) Q:Y Y
S X=$P(NODE,U,3) S:$L(X) Y=+$O(^EDPB(233.1,"AB","delay",X,0)) Q:Y Y
; add local item
N FDA,FDAIEN,DIERR,ERR
S FDA(233.1,"+1,",.01)=EDPSTA_".delay."_$$LOW^XLFSTR(X)
S FDA(233.1,"+1,",.02)=$P(NODE,U) ;name
S FDA(233.1,"+1,",.03)=$P(NODE,U,3) ;abbreviation
S FDA(233.1,"+1,",.05)=$P(NODE,U,5) ;report flag
D UPDATE^DIE("","FDA","FDAIEN","ERR")
S Y=$S('$D(DIERR):+$G(FDAIEN(1)),1:"")
Q Y
;
ARR(X) ; -- Return[/add] #233.1 ien for Arrival Mode X
I $G(X)="" Q ""
N Y,NODE
S NODE=$G(OLD("ARR"_+X)),Y="" Q:NODE="" $$NOVALUE
S X=$P($P(NODE,U)," ") S:$L(X) Y=+$O(^EDPB(233.1,"AC","source",X,0)) Q:Y Y
; add local item
N FDA,FDAIEN,DIERR,ERR
S FDA(233.1,"+1,",.01)=EDPSTA_".source."_$$LOW^XLFSTR(X)
S FDA(233.1,"+1,",.02)=X
D UPDATE^DIE("","FDA","FDAIEN","ERR")
S Y=$S('$D(DIERR):+$G(FDAIEN(1)),1:"")
Q Y
;
DISP(X) ; -- Return[/add] #233.1 ien for Disposition code X
I $G(X)="" Q ""
N Y,NODE
S NODE=$G(OLD("DIS"_X)),Y="" Q:NODE="" $$NOVALUE
S:X X=$P(NODE,U,5) ;ien -> abbreviation
I $L(X) S Y=+$O(^EDPB(233.1,"AB","disposition",X,0)) Q:Y Y
E S X=$P(NODE,U) S:$L(X) Y=+$O(^EDPB(233.1,"AC","disposition",X,0)) Q:Y Y
; add local item
N FDA,FDAIEN,DIERR,ERR
S X=$P($P(NODE,U)," ") ;1st word, for name
S FDA(233.1,"+1,",.01)=EDPSTA_".disposition."_$$LOW^XLFSTR(X)
S FDA(233.1,"+1,",.02)=$P(NODE,U) ;Display Name
S FDA(233.1,"+1,",.03)=$P(NODE,U,5) ;Abbreviation
S:$P(NODE,U,7) FDA(233.1,"+1,",.05)="M" ;Missed Opportunity
S:$P(NODE,U,6) FDA(233.1,"+1,",.05)="A" ;Admission
S:$P(NODE,U,8) FDA(233.1,"+1,",.05)="VA" ;VA Admission
D UPDATE^DIE("","FDA","FDAIEN","ERR")
S Y=$S('$D(DIERR):+$G(FDAIEN(1)),1:"")
Q Y
;
LOC(X) ; -- Return[/add] #231.8 ien for Location X
I $G(X)="" Q ""
N Y,NODE
S NODE=$G(OLD("LOC"_+X)) S:NODE="" NODE="UNKNOWN^UNK^^0^^^0"
S X=$P(NODE,U,2),Y=""
S:$L(X) Y=+$O(^EDPB(231.8,"AC",EDPSITE,EDPAREA,X,0)) Q:Y Y
; add local item
N FDA,FDAIEN,DIERR,ERR,X
S FDA(231.8,"+1,",.01)=$TR($P(NODE,U),"-") ;Name
S FDA(231.8,"+1,",.02)=EDPSITE ;Institution ien
S FDA(231.8,"+1,",.03)=EDPAREA ;Area ien
S FDA(231.8,"+1,",.04)='$P(NODE,U,4) ;Inactive
S FDA(231.8,"+1,",.05)=$P(NODE,U,6) ;Sequence
S FDA(231.8,"+1,",.06)=$P(NODE,U,2) ;Display Name
S X=$P(NODE,U,7),X=$S(X=2:0,X=0:2,1:1)
S FDA(231.8,"+1,",.07)=X ;Display When
S FDA(231.8,"+1,",.08)=$$STS($P(NODE,U,8)) ;Default Status ien
S FDA(231.8,"+1,",.1)=$P(NODE,U,9) ;Shared Name [Room]
D UPDATE^DIE("","FDA","FDAIEN","ERR")
S Y=$S('$D(DIERR):+$G(FDAIEN(1)),1:"")
LCQ ;exit
Q Y
;
NOVALUE() Q $O(^EDPB(233.1,"B","edp.reserved.novalue",0))
;
ORDERS(LOG,NODE) ; -- build Orders multiple
N ORLIST,DFN,IN,OUT,ORI,ORIFN,STS,REL,PKG,X,Y,DIC,DA
S DFN=+$P(NODE,U,6) Q:DFN<1
S IN=$P(NODE,U,8) Q:IN<1 Q:IN<$$FMADD^XLFDT(DT,-1) ;old
S OUT=$P(NODE,U,9) S:OUT<1 OUT=$$NOW^XLFDT
K ^TMP("ORR",$J) D EN^ORQ1(DFN_";DPT(",,1,,IN,OUT) S ORI=0
F S ORI=$O(^TMP("ORR",$J,ORLIST,ORI)) Q:ORI<1 S ORIFN=+$G(^(ORI)) D
. Q:$O(^EDP(230,LOG,8,"B",ORIFN,0))
. S X=$$GET1^DIQ(100,ORIFN_",",5,"I") Q:(X=10)!(X=11) ;unreleased
. S STS=$S("^1^2^7^12^13^14^"[(U_X_U):"C","^3^6^9^15^"[(U_X_U):"A",1:"N")
. S REL=$$GET1^DIQ(100.008,"1,"_ORIFN_",",16,"I")
. S X=$$GET1^DIQ(100,ORIFN_",","12:1")
. S PKG=$S($E(X,1,2)="LR":"L",$E(X,1,2)="PS":"M",$E(X,1,2)="RA":"R",X="GMRC":"C",1:"A")
. ; add to subfile
. K X,Y,DIC,DA
. S DIC="^EDP(230,"_LOG_",8,",DIC(0)="LZ",DA(1)=LOG,X=+ORIFN
. S DIC("DR")=".02///"_PKG_";.03///"_STS_";.05///"_REL
. ;S:$$VAL("stat") DIC("DR")=DIC("DR")_";.04///1"
. D FILE^DICN
K ^TMP("ORR",$J,ORLIST)
Q
;
; ------- fix ICD9 Code field -------
;
ICD ; -- convert ICD codes to #80 iens
N EDP1,EDP2,X0,X,Y
S EDP1=0 F S EDP1=$O(^EDP(230,EDP1)) Q:EDP1<1 I $D(^(EDP1,4)) D
. S EDP2=0 F S EDP2=$O(^EDP(230,EDP1,4,EDP2)) Q:EDP2<1 S X0=$G(^(EDP2,0)) D
.. S X=$P(X0,U,2) Q:'$L(X)
.. I X?1"ICD-9-CODE-".E S X=$P(X,"-",4)
.. I X["/" S X=$P(X,"/")
.. S Y=$$ICDDX^ICDCODE(X)
.. I Y>0 S $P(^EDP(230,EDP1,4,EDP2,0),U,2)=+Y
Q
;
SHOWICD(BEG,END) ; -- show Dx nodes from BEG to END
N IEN,DA,X0,X
S BEG=$G(BEG,0),END=$G(END,9999999)
S IEN=BEG F S IEN=$O(^EDP(230,IEN)) Q:(IEN<1)!(IEN>END) I $D(^(IEN,4)) D
. S DA=0 F S DA=$O(^EDP(230,IEN,4,DA)) Q:DA<1 S X0=$G(^(DA,0)) D
.. S X=$P(X0,U,2) Q:X="" ;show any non-ien value
.. I $S(X<0:1,+X'=X:1,X[".":1,1:0) W !,IEN,?10,DA,?15,X0
Q
;
; ------ fix Tracking Room-Bed file #231.8 ------
;
MARK(STN) ; -- mark duplicate locations with correct ien,
; for repointing from STN to Institution ien set
N AREA,NM,IEN,LOC
S AREA=+$O(^EDPB(231.8,"AC",STN,0))
S NM="" F S NM=$O(^EDPB(231.8,"AC",STN,AREA,NM)) Q:NM="" D
. S LOC=+$O(^EDPB(231.8,"AC",STN,AREA,NM,0)) ;keep 1st, or
. I $G(^EDPB(231.8,LOC,"FIX")) S LOC=^("FIX") ;manually set to desired
. S IEN=LOC F S IEN=+$O(^EDPB(231.8,"AC",STN,AREA,NM,IEN)) Q:IEN<1 S ^EDPB(231.8,IEN,"FIX")=LOC
Q
;
LOOP ; -- loop through Log,History files and repoint if FIX node exists
N FILE,IEN,LOC,FIX
F FILE=230,230.1 D
. S IEN=0 F S IEN=$O(^EDP(FILE,IEN)) Q:IEN<1 S LOC=$P($G(^(IEN,3)),U,4) I LOC D
.. S FIX=+$G(^EDPB(231.8,LOC,"FIX"))
.. I FIX S $P(^EDP(FILE,IEN,3),U,4)=FIX
Q
;
DIK ; -- remove duplicate entries from #231.8
N IEN,DA,DIK
S IEN=0 F S IEN=$O(^EDPB(231.8,IEN)) Q:IEN<1 I $G(^(IEN,"FIX")) D
. S DA=IEN,DIK="^EDPB(231.8," D ^DIK
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HEDPCONV 9589 printed Dec 13, 2024@01:51:42 Page 2
EDPCONV ;SLC/MKB - Process incoming mail to convert local ED Visits ;2/28/12 08:33am
+1 ;;2.0;EMERGENCY DEPARTMENT;**2**;Feb 24, 2012;Build 23
+2 ;
AREA(DIV) ; -- Return #231.9 ien for DIVision (#4 ien)
+1 QUIT +$ORDER(^EDPB(231.9,"C",DIV,0))
+2 ;
VST(OLD) ; -- Copy OLD(node) ER visit entry into ^EDP(230)
+1 NEW X,I,EDPY,EDPSITE,EDPDIFF,EDPAREA,EDPSTA,EDPLOG,EDPI,PNM,SSN
+2 ;$$TZONE(X)
SET EDPSITE=$GET(OLD("SITE"))
SET X=$GET(OLD("TZ"))
SET EDPDIFF=0
+3 SET EDPAREA=$$AREA(EDPSITE)
if EDPAREA<1
QUIT
+4 ;station number
SET EDPSTA=$$STA^XUAF4(EDPSITE)
+5 ;defined
FOR I=0,1,2,3,4,6,9
SET OLD(I)=$GET(OLD(I))
+6 SET X=$PIECE(OLD(0),U,5)
SET EDPY=$$NEW(230,X)
if EDPY<1
QUIT
+7 ;patient name, ssn
SET PNM=$PIECE(OLD(0),U)
SET SSN=$PIECE(OLD(0),U,3)
+8 ;_U_EDPDIFF
SET EDPLOG(0)=X_U_EDPSITE_U_EDPAREA_U_PNM_U_SSN_U_$PIECE(OLD(6),U,2)_U_$GET(OLD("CLOSED"))_U_$PIECE(OLD(4),U,4,5)_U_$$ARR($PIECE(OLD(0),U,6))_U_$$PID(PNM,SSN)
+9 ;disposition
SET X=$PIECE(OLD(9),U,3)
if 'X
SET X=$PIECE(OLD(6),U,3)
+10 SET EDPLOG(1)=$PIECE(OLD(1),U)_U_$$DISP(X)_U_$PIECE(OLD(9),U,2)_U_$PIECE(OLD(9),U)_U_$$DEL($PIECE(OLD(4),U,7))
+11 SET X=$PIECE(OLD(2),U)
if $LENGTH(X)
SET EDPLOG(2)=X
+12 SET EDPLOG(3)=U_$$STS($PIECE(OLD(0),U,4))_U_$$ACU($PIECE(OLD(4),U,3))_U_$$LOC($PIECE(OLD(3),U,2))_U_$PIECE(OLD(4),U)_U_$PIECE(OLD(4),U,2)_U_$PIECE(OLD(4),U,6)_U_$PIECE(OLD(6),U)
+13 IF $DATA(OLD(8))
MERGE EDPLOG(4)=OLD(8)
SET $PIECE(EDPLOG(4,0),U,2)="230.04A"
Begin DoDot:1
+14 SET EDPI=0
FOR
SET EDPI=$ORDER(EDPLOG(4,EDPI))
if EDPI<1
QUIT
Begin DoDot:2
+15 ;code -> ien
SET X=$PIECE($GET(EDPLOG(4,EDPI,0)),U,2)
if '$LENGTH(X)
QUIT
+16 IF X?1"ICD-9-CODE-".E
SET X=$PIECE(X,"-",4)
+17 IF X["/"
SET X=$PIECE(X,"/")
+18 ;Begin EDP*2.0*2 CHANGES.
+19 SET X=$$ICDDX^EDPLEX(X,$PIECE($GET(^EDP(230,EDPY,0),2781001),U,8))
SET $PIECE(EDPLOG(4,EDPI,0),U,2)=$SELECT(X>0:+X,1:"")
+20 ;End EDP*2.0*2 CHANGES.
End DoDot:2
End DoDot:1
+21 ; Save/Xref log entry
+22 MERGE ^EDP(230,EDPY)=EDPLOG
+23 DO XREF(230,EDPY)
+24 ;
+25 ; Set History from Movement nodes
+26 SET EDPI="MVT"
FOR
SET EDPI=$ORDER(OLD(EDPI))
if EDPI'?1"MVT"1.N
QUIT
DO HIST(EDPI,EDPY)
+27 ;
+28 ; Create Orders list for active visits
+29 IF '$GET(OLD("CLOSED"))
SET X=EDPLOG(0)
DO ORDERS(EDPY,X)
+30 ;
+31 ;return new ien
SET OLD(230)=EDPY
+32 QUIT
+33 ;
HIST(MVTI,LOG) ; -- Copy OLD(MVTI) into ^EDP(230.1)
+1 NEW EDPY,MVT,ACT
+2 SET EDPY=$$NEW(230.1,LOG)
if EDPY<1
QUIT
+3 SET MVT=OLD(MVTI)
+4 SET ACT(0)=LOG_U_$PIECE(MVT,U,2)_U_U_$PIECE($GET(^EDP(230,LOG,0)),U,4,6)
+5 SET ACT(3)=U_$$STS($PIECE(MVT,U,3))_U_$$ACU($PIECE(MVT,U,4))_U_$$LOC($PIECE(MVT,U,5))_U_$PIECE(MVT,U,6,8)
+6 ; Save/Xref history
+7 MERGE ^EDP(230.1,EDPY)=ACT
+8 DO XREF(230.1,EDPY)
+9 QUIT
+10 ;
NEW(FILE,X) ; -- Return ien of new entry in FILE
+1 NEW DO,DIC,DA,Y
+2 SET DIC="^EDP("_FILE_","
SET DIC(0)="LF"
DO FILE^DICN
+3 QUIT +Y
+4 ;
XREF(FILE,DA) ; -- Set all xrefs for DA in FILE
+1 NEW DIK
+2 SET DIK="^EDP("_FILE_","
DO IX1^DIK
+3 QUIT
+4 ;
PID(NM,ID) ; -- Return brief id (L0000) for patient
+1 NEW Y
SET Y=$EXTRACT(NM)_$EXTRACT(ID,6,9)
+2 QUIT Y
+3 ;
TZONE(X) ; -- Return #minutes local offset for time zone
+1 NEW Y
SET Y=$EXTRACT(X)_(60*$EXTRACT(X,2,3)+$EXTRACT(X,4,5))
+2 QUIT Y
+3 ;
ACU(X) ; -- Return[/add] #233.1 ien for Acuity X
+1 IF $GET(X)=""
QUIT ""
+2 NEW Y,NODE
SET NODE=$GET(OLD("ACU"_+X))
if NODE=""
QUIT $$NOVALUE
+3 SET X=$PIECE(NODE,U,2)
SET Y=""
+4 if $LENGTH(X)
SET Y=+$ORDER(^EDPB(233.1,"AB","acuity",X,0))
if Y
QUIT Y
+5 ; add local item
+6 NEW FDA,FDAIEN,DIERR,ERR,NM
+7 SET NM=$PIECE(NODE,U)
SET NM=$SELECT(NM["-":$PIECE(NM,"-",2),1:NM)
+8 SET FDA(233.1,"+1,",.01)=EDPSTA_".acuity."_$$LOW^XLFSTR(NM)
+9 SET FDA(233.1,"+1,",.02)=X
+10 SET FDA(233.1,"+1,",.03)=X
+11 DO UPDATE^DIE("","FDA","FDAIEN","ERR")
+12 SET Y=$SELECT('$DATA(DIERR):+$GET(FDAIEN(1)),1:"")
+13 QUIT Y
+14 ;
STS(X) ; -- Return[/add] #233.1 ien for Status X
+1 IF $GET(X)=""
QUIT ""
+2 NEW Y,NODE
+3 SET NODE=$GET(OLD("STS"_+X))
SET Y=""
if NODE=""
QUIT $$NOVALUE
+4 SET X=$PIECE(NODE,U,1)
if $LENGTH(X)
SET Y=+$ORDER(^EDPB(233.1,"AC","status",X,0))
if Y
QUIT Y
+5 SET X=$PIECE(NODE,U,4)
if $LENGTH(X)
SET Y=+$ORDER(^EDPB(233.1,"AB","status",X,0))
if Y
QUIT Y
+6 ; add local item
+7 NEW FDA,FDAIEN,DIERR,ERR
+8 SET FDA(233.1,"+1,",.01)=EDPSTA_".status."_$$LOW^XLFSTR(X)
+9 ;text
SET FDA(233.1,"+1,",.02)=$PIECE(NODE,U)
+10 ;display/abbreviation
SET FDA(233.1,"+1,",.03)=X
+11 ;admission flag
if $PIECE(NODE,U,6)="Y"
SET FDA(233.1,"+1,",.05)="A"
+12 DO UPDATE^DIE("","FDA","FDAIEN","ERR")
+13 SET Y=$SELECT('$DATA(DIERR):+$GET(FDAIEN(1)),1:"")
+14 QUIT Y
+15 ;
DEL(X) ; -- Return[/add] #233.1 ien for Delay Reason X
+1 IF $GET(X)=""
QUIT ""
+2 NEW Y,NODE
+3 SET NODE=$GET(OLD("DEL"_+X))
SET Y=""
if NODE=""
QUIT $$NOVALUE
+4 SET X=$PIECE(NODE,U,1)
if $LENGTH(X)
SET Y=+$ORDER(^EDPB(233.1,"AC","delay",X,0))
if Y
QUIT Y
+5 SET X=$PIECE(NODE,U,3)
if $LENGTH(X)
SET Y=+$ORDER(^EDPB(233.1,"AB","delay",X,0))
if Y
QUIT Y
+6 ; add local item
+7 NEW FDA,FDAIEN,DIERR,ERR
+8 SET FDA(233.1,"+1,",.01)=EDPSTA_".delay."_$$LOW^XLFSTR(X)
+9 ;name
SET FDA(233.1,"+1,",.02)=$PIECE(NODE,U)
+10 ;abbreviation
SET FDA(233.1,"+1,",.03)=$PIECE(NODE,U,3)
+11 ;report flag
SET FDA(233.1,"+1,",.05)=$PIECE(NODE,U,5)
+12 DO UPDATE^DIE("","FDA","FDAIEN","ERR")
+13 SET Y=$SELECT('$DATA(DIERR):+$GET(FDAIEN(1)),1:"")
+14 QUIT Y
+15 ;
ARR(X) ; -- Return[/add] #233.1 ien for Arrival Mode X
+1 IF $GET(X)=""
QUIT ""
+2 NEW Y,NODE
+3 SET NODE=$GET(OLD("ARR"_+X))
SET Y=""
if NODE=""
QUIT $$NOVALUE
+4 SET X=$PIECE($PIECE(NODE,U)," ")
if $LENGTH(X)
SET Y=+$ORDER(^EDPB(233.1,"AC","source",X,0))
if Y
QUIT Y
+5 ; add local item
+6 NEW FDA,FDAIEN,DIERR,ERR
+7 SET FDA(233.1,"+1,",.01)=EDPSTA_".source."_$$LOW^XLFSTR(X)
+8 SET FDA(233.1,"+1,",.02)=X
+9 DO UPDATE^DIE("","FDA","FDAIEN","ERR")
+10 SET Y=$SELECT('$DATA(DIERR):+$GET(FDAIEN(1)),1:"")
+11 QUIT Y
+12 ;
DISP(X) ; -- Return[/add] #233.1 ien for Disposition code X
+1 IF $GET(X)=""
QUIT ""
+2 NEW Y,NODE
+3 SET NODE=$GET(OLD("DIS"_X))
SET Y=""
if NODE=""
QUIT $$NOVALUE
+4 ;ien -> abbreviation
if X
SET X=$PIECE(NODE,U,5)
+5 IF $LENGTH(X)
SET Y=+$ORDER(^EDPB(233.1,"AB","disposition",X,0))
if Y
QUIT Y
+6 IF '$TEST
SET X=$PIECE(NODE,U)
if $LENGTH(X)
SET Y=+$ORDER(^EDPB(233.1,"AC","disposition",X,0))
if Y
QUIT Y
+7 ; add local item
+8 NEW FDA,FDAIEN,DIERR,ERR
+9 ;1st word, for name
SET X=$PIECE($PIECE(NODE,U)," ")
+10 SET FDA(233.1,"+1,",.01)=EDPSTA_".disposition."_$$LOW^XLFSTR(X)
+11 ;Display Name
SET FDA(233.1,"+1,",.02)=$PIECE(NODE,U)
+12 ;Abbreviation
SET FDA(233.1,"+1,",.03)=$PIECE(NODE,U,5)
+13 ;Missed Opportunity
if $PIECE(NODE,U,7)
SET FDA(233.1,"+1,",.05)="M"
+14 ;Admission
if $PIECE(NODE,U,6)
SET FDA(233.1,"+1,",.05)="A"
+15 ;VA Admission
if $PIECE(NODE,U,8)
SET FDA(233.1,"+1,",.05)="VA"
+16 DO UPDATE^DIE("","FDA","FDAIEN","ERR")
+17 SET Y=$SELECT('$DATA(DIERR):+$GET(FDAIEN(1)),1:"")
+18 QUIT Y
+19 ;
LOC(X) ; -- Return[/add] #231.8 ien for Location X
+1 IF $GET(X)=""
QUIT ""
+2 NEW Y,NODE
+3 SET NODE=$GET(OLD("LOC"_+X))
if NODE=""
SET NODE="UNKNOWN^UNK^^0^^^0"
+4 SET X=$PIECE(NODE,U,2)
SET Y=""
+5 if $LENGTH(X)
SET Y=+$ORDER(^EDPB(231.8,"AC",EDPSITE,EDPAREA,X,0))
if Y
QUIT Y
+6 ; add local item
+7 NEW FDA,FDAIEN,DIERR,ERR,X
+8 ;Name
SET FDA(231.8,"+1,",.01)=$TRANSLATE($PIECE(NODE,U),"-")
+9 ;Institution ien
SET FDA(231.8,"+1,",.02)=EDPSITE
+10 ;Area ien
SET FDA(231.8,"+1,",.03)=EDPAREA
+11 ;Inactive
SET FDA(231.8,"+1,",.04)='$PIECE(NODE,U,4)
+12 ;Sequence
SET FDA(231.8,"+1,",.05)=$PIECE(NODE,U,6)
+13 ;Display Name
SET FDA(231.8,"+1,",.06)=$PIECE(NODE,U,2)
+14 SET X=$PIECE(NODE,U,7)
SET X=$SELECT(X=2:0,X=0:2,1:1)
+15 ;Display When
SET FDA(231.8,"+1,",.07)=X
+16 ;Default Status ien
SET FDA(231.8,"+1,",.08)=$$STS($PIECE(NODE,U,8))
+17 ;Shared Name [Room]
SET FDA(231.8,"+1,",.1)=$PIECE(NODE,U,9)
+18 DO UPDATE^DIE("","FDA","FDAIEN","ERR")
+19 SET Y=$SELECT('$DATA(DIERR):+$GET(FDAIEN(1)),1:"")
LCQ ;exit
+1 QUIT Y
+2 ;
NOVALUE() QUIT $ORDER(^EDPB(233.1,"B","edp.reserved.novalue",0))
+1 ;
ORDERS(LOG,NODE) ; -- build Orders multiple
+1 NEW ORLIST,DFN,IN,OUT,ORI,ORIFN,STS,REL,PKG,X,Y,DIC,DA
+2 SET DFN=+$PIECE(NODE,U,6)
if DFN<1
QUIT
+3 ;old
SET IN=$PIECE(NODE,U,8)
if IN<1
QUIT
if IN<$$FMADD^XLFDT(DT,-1)
QUIT
+4 SET OUT=$PIECE(NODE,U,9)
if OUT<1
SET OUT=$$NOW^XLFDT
+5 KILL ^TMP("ORR",$JOB)
DO EN^ORQ1(DFN_";DPT(",,1,,IN,OUT)
SET ORI=0
+6 FOR
SET ORI=$ORDER(^TMP("ORR",$JOB,ORLIST,ORI))
if ORI<1
QUIT
SET ORIFN=+$GET(^(ORI))
Begin DoDot:1
+7 if $ORDER(^EDP(230,LOG,8,"B",ORIFN,0))
QUIT
+8 ;unreleased
SET X=$$GET1^DIQ(100,ORIFN_",",5,"I")
if (X=10)!(X=11)
QUIT
+9 SET STS=$SELECT("^1^2^7^12^13^14^"[(U_X_U):"C","^3^6^9^15^"[(U_X_U):"A",1:"N")
+10 SET REL=$$GET1^DIQ(100.008,"1,"_ORIFN_",",16,"I")
+11 SET X=$$GET1^DIQ(100,ORIFN_",","12:1")
+12 SET PKG=$SELECT($EXTRACT(X,1,2)="LR":"L",$EXTRACT(X,1,2)="PS":"M",$EXTRACT(X,1,2)="RA":"R",X="GMRC":"C",1:"A")
+13 ; add to subfile
+14 KILL X,Y,DIC,DA
+15 SET DIC="^EDP(230,"_LOG_",8,"
SET DIC(0)="LZ"
SET DA(1)=LOG
SET X=+ORIFN
+16 SET DIC("DR")=".02///"_PKG_";.03///"_STS_";.05///"_REL
+17 ;S:$$VAL("stat") DIC("DR")=DIC("DR")_";.04///1"
+18 DO FILE^DICN
End DoDot:1
+19 KILL ^TMP("ORR",$JOB,ORLIST)
+20 QUIT
+21 ;
+22 ; ------- fix ICD9 Code field -------
+23 ;
ICD ; -- convert ICD codes to #80 iens
+1 NEW EDP1,EDP2,X0,X,Y
+2 SET EDP1=0
FOR
SET EDP1=$ORDER(^EDP(230,EDP1))
if EDP1<1
QUIT
IF $DATA(^(EDP1,4))
Begin DoDot:1
+3 SET EDP2=0
FOR
SET EDP2=$ORDER(^EDP(230,EDP1,4,EDP2))
if EDP2<1
QUIT
SET X0=$GET(^(EDP2,0))
Begin DoDot:2
+4 SET X=$PIECE(X0,U,2)
if '$LENGTH(X)
QUIT
+5 IF X?1"ICD-9-CODE-".E
SET X=$PIECE(X,"-",4)
+6 IF X["/"
SET X=$PIECE(X,"/")
+7 SET Y=$$ICDDX^ICDCODE(X)
+8 IF Y>0
SET $PIECE(^EDP(230,EDP1,4,EDP2,0),U,2)=+Y
End DoDot:2
End DoDot:1
+9 QUIT
+10 ;
SHOWICD(BEG,END) ; -- show Dx nodes from BEG to END
+1 NEW IEN,DA,X0,X
+2 SET BEG=$GET(BEG,0)
SET END=$GET(END,9999999)
+3 SET IEN=BEG
FOR
SET IEN=$ORDER(^EDP(230,IEN))
if (IEN<1)!(IEN>END)
QUIT
IF $DATA(^(IEN,4))
Begin DoDot:1
+4 SET DA=0
FOR
SET DA=$ORDER(^EDP(230,IEN,4,DA))
if DA<1
QUIT
SET X0=$GET(^(DA,0))
Begin DoDot:2
+5 ;show any non-ien value
SET X=$PIECE(X0,U,2)
if X=""
QUIT
+6 IF $SELECT(X<0:1,+X'=X:1,X[".":1,1:0)
WRITE !,IEN,?10,DA,?15,X0
End DoDot:2
End DoDot:1
+7 QUIT
+8 ;
+9 ; ------ fix Tracking Room-Bed file #231.8 ------
+10 ;
MARK(STN) ; -- mark duplicate locations with correct ien,
+1 ; for repointing from STN to Institution ien set
+2 NEW AREA,NM,IEN,LOC
+3 SET AREA=+$ORDER(^EDPB(231.8,"AC",STN,0))
+4 SET NM=""
FOR
SET NM=$ORDER(^EDPB(231.8,"AC",STN,AREA,NM))
if NM=""
QUIT
Begin DoDot:1
+5 ;keep 1st, or
SET LOC=+$ORDER(^EDPB(231.8,"AC",STN,AREA,NM,0))
+6 ;manually set to desired
IF $GET(^EDPB(231.8,LOC,"FIX"))
SET LOC=^("FIX")
+7 SET IEN=LOC
FOR
SET IEN=+$ORDER(^EDPB(231.8,"AC",STN,AREA,NM,IEN))
if IEN<1
QUIT
SET ^EDPB(231.8,IEN,"FIX")=LOC
End DoDot:1
+8 QUIT
+9 ;
LOOP ; -- loop through Log,History files and repoint if FIX node exists
+1 NEW FILE,IEN,LOC,FIX
+2 FOR FILE=230,230.1
Begin DoDot:1
+3 SET IEN=0
FOR
SET IEN=$ORDER(^EDP(FILE,IEN))
if IEN<1
QUIT
SET LOC=$PIECE($GET(^(IEN,3)),U,4)
IF LOC
Begin DoDot:2
+4 SET FIX=+$GET(^EDPB(231.8,LOC,"FIX"))
+5 IF FIX
SET $PIECE(^EDP(FILE,IEN,3),U,4)=FIX
End DoDot:2
End DoDot:1
+6 QUIT
+7 ;
DIK ; -- remove duplicate entries from #231.8
+1 NEW IEN,DA,DIK
+2 SET IEN=0
FOR
SET IEN=$ORDER(^EDPB(231.8,IEN))
if IEN<1
QUIT
IF $GET(^(IEN,"FIX"))
Begin DoDot:1
+3 SET DA=IEN
SET DIK="^EDPB(231.8,"
DO ^DIK
End DoDot:1
+4 QUIT
