- ORMEVNT1 ;SLC/MKB-Trigger HL7 msg off OR events,ORMTIME ; 6/8/10 9:55am
- ;;3.0;ORDER ENTRY/RESULTS REPORTING;**141,165,177,186,215,324,538**;Dec 17, 1997;Build 1
- ;
- ;DBIA Section
- ; 3559 - Direct read of ^SRF
- ;10039 - Direct read of ^DIC(42,
- ;
- OR2(ORSRDA) ;Queue EDO process to background, return control to surgery
- ;
- N ZTRTN,ZTDESC,ZTDTH,ZTIO,ZTSK,ZTSAVE
- S ZTRTN="OR2Q^ORMEVNT1",ZTDTH=$H,ZTDESC="Surgery triggered EDO processing",ZTIO="",ZTSAVE("ORSRDA")="" D ^%ZTLOAD
- Q
- ;
- OR2Q ; -- Kill logic, from Surgery package [DBIA #3558]
- I $D(^XTMP("ORSURG",ORSRDA)) D OR2(ORSRDA) Q ;186 requeue if flag set
- N X,Y,DA,OREVT,ORSRF,ORACT
- S OREVT=+$O(^ORE(100.2,"ASR",+$G(ORSRDA),0)) Q:OREVT<1
- S ORSRF=$G(^SRF(+ORSRDA,.2)),ORACT=$S($L($P(ORSRF,U,12)):"ED",1:"DL")
- D ACTLOG^OREVNTX(OREVT,ORACT)
- Q
- ;
- OR1(ORSRDA,ORSRX) ;Queue EDO process to background, return control to surgery
- N ZTRTN,ZTDESC,ZTDTH,ZTIO,ZTSK,ZTSAVE
- S ZTRTN="OR1Q^ORMEVNT1",ZTDTH=$H,ZTDESC="Surgery triggered EDO processing",ZTIO="",ZTSAVE("ORSRDA")="",ZTSAVE("ORSRX")="" D ^%ZTLOAD
- Q
- ;
- OR1Q ; -- Set logic, from Surgery package [DBIA #3558]
- I $D(^XTMP("ORSURG",ORSRDA)) D OR1(ORSRDA,ORSRX) Q ;186 requeue if flag set
- N X S X=ORSRX
- I $G(^SRF(+$G(ORSRDA),"CON")),$D(^ORE(100.2,"ASR",+^("CON"))) Q ;concurrent
- Q:$D(^ORE(100.2,"ASR",+$G(ORSRDA))) Q:'$$CURRENT ;edit
- ;
- N ORSR0,DFN,VAIP,VAERR,X,Y,DA,ORVP,ORL,ORDIV,ORTS,OREVENT,ORDCRULE,ORPRINT
- S ORSR0=$G(^SRF(+$G(ORSRDA),0)),DFN=+$P(ORSR0,U)
- D IN5^VADPT Q:'$G(VAIP(13)) ;not admitted
- S ^XTMP("ORSURG",ORSRDA)=$$FMADD^XLFDT(DT,5)_U_DT ;186 Set flag
- S ORL=$P($G(^SRS(+$P(ORSR0,U,2),0)),U)_";SC(",ORDIV=$$DIV(+ORL) ;DBIA #3362
- ;*324 Add set ORDIV to grab the institution
- I '$G(LOC) S ORL=+$G(^DIC(42,+$G(VAIP(5)),44))_";SC(",ORDIV=$$DIV(+ORL) ;186 If no O.R. loc then use current loc
- S ORTS=+$G(VAIP(8)) ; need surg spec too? DBIA #991
- S ORVP=DFN_";DPT(",OREVENT=$$PATEVT,ORDCRULE=$$DCEVT
- D:ORDCRULE AUTODC(ORDCRULE,ORSRX) I OREVENT D
- . D RELEASE(OREVENT),DONE^OREVNTX(OREVENT,ORSRX,,ORSRDA)
- . D ACTLOG^OREVNTX(OREVENT,"NW","O")
- I $O(ORPRINT(0)),$G(ORL) D PRINTS^ORWD1(.ORPRINT,+ORL)
- K ^XTMP("ORSURG",ORSRDA) ;186
- Q
- ;
- DIV(LOC) ; -- Return Institution file #4 ptr for LOC
- N X0,Y S X0=$G(^SC(+LOC,0))
- S Y=$S($P(X0,U,4):$P(X0,U,4),$P(X0,U,15):$$SITE^VASITE(DT,$P(X0,U,15)),1:+$G(DUZ(2)))
- Q Y
- ;
- CURRENT() ; -- Is posted mvt the latest one?
- N Y S Y=$S((DT-X)<1:1,1:0)
- Q Y
- ;
- PATEVT() ; -- Find match to new data in Patient Event file
- N EVT,IFN,X0,Y S EVT=0,Y=""
- F S EVT=+$O(^ORE(100.2,"AE",+ORVP,EVT)) Q:EVT<1 S IFN=$O(^(EVT,0)) D Q:Y
- . Q:$$LAPSED^OREVNTX(+IFN) ;don't release orders
- . S X0=$G(^ORD(100.5,EVT,0))
- . I $P(X0,U,2)="O",$P(X0,U,3)=ORDIV S Y=+IFN Q
- Q Y
- ;
- DCEVT() ; -- Find match to event in AutoDC Rules file for [new] ORDIV
- N Y I '$G(^DPT(+ORVP,.105)) Q 0 ;no auto-dc's if not admitted
- S Y=+$O(^ORD(100.6,"AE",ORDIV,"O",0))
- Q Y
- ;
- AUTODC(ORDC,ORDT) ; -- DC orders based on rule ORDC [also from ORMEVNT]
- ; Expects VAIP array with current admission data
- N ORADM,ORNOW,ORN,X,OREASON,ORNATR,ORCREATE,ORPRNT,ORSIG,ORDG,ORI,ORPKG,ORLIST,ORIFN,OR0,ORDER,ORERR
- S OREASON=+$P($G(^ORD(100.6,ORDC,0)),U,4) I OREASON<1 D
- . S OREASON=$S('$G(DGPMT):"OROR",DGPMT=1:"ORADMIT",DGPMT=2:"ORTRANS",DGPMT=3:"ORDIS",1:"ORSPEC")
- . S OREASON=+$O(^ORD(100.03,"C",OREASON,0))
- S ORNATR=+$P($G(^ORD(100.03,+$G(OREASON),0)),U,7)
- S:ORNATR'>0 ORNATR=+$O(^ORD(100.02,"C","A",0))
- S X=$G(^ORD(100.02,ORNATR,1)),ORCREATE=+$P(X,U),ORPRNT=+$P(X,U,2)
- S ORSIG=$S('ORCREATE:"",1:$P(X,U,4)),ORDG=$O(^ORD(100.98,"B","ALL",0))
- S ORI=0 F S ORI=$O(^ORD(100.6,ORDC,7,"B",ORI)) Q:ORI<1 S ORPKG(ORI)=1
- D:$G(DGPMT)'=1 CHKOBS S:'$G(ORADM) ORADM=+$G(VAIP(13,1)) S ORNOW=$$NOW^XLFDT,ORN="A",ORI=6 ;177
- I $G(DGPMT)=1 S ORI=2,ORADM="",ORN="A"
- I $G(DGPMT)=3,"^12^38^"[(U_$P(DGPMA,U,18)_U) S ORI=2,ORADM="",ORN=""
- D EN^ORQ1(ORVP,ORDG,ORI,,ORADM,ORNOW),ADMORD S ORI=0
- DC1 F S ORI=$O(^TMP("ORR",$J,ORLIST,ORI)) Q:ORI'>0 S ORIFN=^(ORI) D
- . ;Q:$P(ORIFN,";",2)>1 ; or DC/Delete actions ??
- . Q:"^1^2^7^11^12^13^"[(U_$P(^OR(100,+ORIFN,3),U,3)_U) S OR0=$G(^(0))
- . Q:'$G(ORPKG($P(OR0,U,14))) Q:$D(^ORD(100.6,ORDC,10,"B",+$P(OR0,U,11)))
- . S X=+$$VALUE^ORX8(+ORIFN,"ORDERABLE") Q:$D(^ORD(100.6,ORDC,8,"B",X))
- . Q:'$$VALID^ORCACT0(ORIFN,"DC",,ORN) ;ok to auto-dc order?
- . I '$G(OREVENT) S OREVENT=+$$NEW^OREVNT(+ORVP) ;no delayed orders
- . S ORDER=+ORIFN_$S(ORCREATE:";"_$$ACTION^ORCSAVE("DC",+ORIFN,$G(ORNP),,$G(ORDT)),1:"")
- . D EN^ORCSEND(ORDER,"DC",ORSIG,1,ORNATR,$G(OREASON),.ORERR) Q:$G(ORERR)
- . S $P(^OR(100,+ORIFN,6),U,8)=OREVENT D SAVE(ORIFN,OREVENT,3)
- . S:ORPRNT ORPRINT=$G(ORPRINT)+1,ORPRINT(ORPRINT)=ORDER_"^1"
- ;*324 Create an event if package orders auto-dcd but no orders released or dc'd by CPRS.
- I '$G(OREVENT),$G(DGPMDA),$D(^XTMP("ORDC-"_DGPMDA)) S OREVENT=$$NEW^OREVNT(+ORVP)
- DC2 I $G(OREVENT) D
- . S $P(^ORE(100.2,OREVENT,1),U,3)=ORDC,^ORE(100.2,"DC",ORDC,OREVENT)=""
- . I $G(DGPMDA),$D(^XTMP("ORDC-"_DGPMDA)) D XTMP ;save order#'s
- K ^TMP("ORR",$J,ORLIST),^XTMP("ORDC-"_$G(DGPMDA))
- Q
- ;
- RELEASE(OREVT) ; -- release orders for OREVT [also from ORMEVNT]
- ; Returns ORPRINT(#)=order^prints for orders released
- Q:'$G(OREVT) N ORPARM,ORLR,ORX,ORI,ORV,ORIFN,ORERR,OR0,OR3,ORLAB
- S ORPARM="" I $G(ORL) F ORI="CHART COPY","LABELS","REQUISITIONS","SERVICE","WORK COPY" S ORX=$S(ORI="SERVICE":0,1:$$GET^XPAR("ALL^"_ORL,"ORPF PROMPT FOR "_ORI,1,"I")),ORPARM=ORPARM_U_$S(ORX="*":0,1:1)
- I $D(^XTMP("ORSURG",+$G(ORSRDA))) S ORL=+$G(^DIC(42,+$G(VAIP(5)),44))_";SC(" ;186 Reset loc
- F ORI="LR","VBEC" S ORX=+$O(^DIC(9.4,"C",ORI,0)) S:ORX ORLR(ORX)=1
- S ORX=OREVT,ORI=0
- F S ORI=+$O(^ORE(100.2,"DAD",OREVT,ORI)) Q:ORI<1 S ORX=ORX_U_ORI
- F ORV=1:1:$L(ORX,U) S OREVT=$P(ORX,U,ORV) D ;event[+children]
- . F S ORI=$O(^OR(100,"AEVNT",ORVP,OREVT,ORI)) Q:ORI'>0 D
- .. S ORIFN=ORI,OR0=$G(^OR(100,ORIFN,0)),OR3=$G(^(3))
- .. I ORIFN=+$P($G(^ORE(100.2,OREVT,0)),U,4) D Q ;event order
- ... Q:$$TYPE^OREVNTX(OREVT)="D" Q:$P(OR3,U,3)=11
- ... S ORPRINT=+$G(ORPRINT)+1,ORPRINT(ORPRINT)=ORIFN_";1"_ORPARM
- .. Q:$P(OR3,U,3)'=10 Q:$P(OR3,U,9) ;released or cancelled, has parent
- .. S:$G(ORL) $P(^OR(100,ORIFN,0),U,10)=ORL ;set location
- .. S:$G(ORTS) $P(^OR(100,ORIFN,0),U,13)=ORTS ;set specialty
- .. I $G(ORLR(+$P(OR0,U,14))),'$G(ORLAB) D BHS^ORMBLD(ORVP) S ORLAB=1
- .. K ORERR D EN1^ORCSEND(ORIFN,.ORERR) Q:$G(ORERR)
- .. Q:"^10^11^"[(U_$P($G(^OR(100,ORIFN,3)),U,3)_U) D SAVE(ORIFN,OREVT,2)
- .. S ORPRINT=+$G(ORPRINT)+1,ORPRINT(ORPRINT)=ORIFN_";1"_ORPARM
- D BTS^ORMBLD(ORVP):$G(ORLAB) ;send batch hdr/tlr segments for labs
- Q
- ;
- ADMORD ; -- Add admission order to list
- ; Uses VAIP(13),ORADM from AUTODC
- ;Q:$G(DGPMT)'=3
- I $G(DGPMT)=3 Q:"^12^38^"[(U_$P(DGPMA,U,18)_U) ;already included
- N LAST,ADMEVT,IFN
- S LAST=+$O(^ORE(100.2,"ADT",+$G(VAIP(13)),""),-1),ADMEVT=+$O(^(LAST,0))
- S IFN=+$P($G(^ORE(100.2,ADMEVT,0)),U,4) Q:IFN<1
- I $P($G(^OR(100,IFN,8,1,0)),U,16)<ORADM D ;add to auto-dc list
- . N ORI S ORI=+$O(^TMP("ORR",$J,ORLIST,"A"),-1),ORI=ORI+1
- . S ^TMP("ORR",$J,ORLIST,ORI)=IFN
- Q
- ;
- XTMP ; -- Save auto-dc'd by package order numbers
- N ORDC,ORIFN,X Q:'$G(OREVENT)
- S ORDC="ORDC-"_$G(DGPMDA),ORIFN=0
- F S ORIFN=+$O(^XTMP(ORDC,ORIFN)) Q:ORIFN<1 S X=$G(^(ORIFN)) D
- . D SAVE(ORIFN,OREVENT,3,X)
- . S $P(^OR(100,+ORIFN,6),U,8)=OREVENT
- Q
- ;
- SAVE(IFN,EVT,NODE,PKG) ; -- Save order# IFN with EVT at NODE
- ; NODE=2: Released orders, NODE=3: Auto-DC'd orders
- Q:'$G(IFN)!'$G(EVT)!'$G(NODE) ;missing data
- Q:$D(^ORE(100.2,EVT,NODE,+IFN,0)) ;already saved
- N I,HDR,TOTAL
- F I=1:1:10 L +^ORE(100.2,EVT,NODE,0):1 Q:$T H 2
- Q:'$T S HDR=$G(^ORE(100.2,EVT,NODE,0))
- I '$L(HDR) S:NODE=2 HDR="^100.26PA^^" S:NODE=3 HDR="^100.27PA^^"
- Q:'$L(HDR) S TOTAL=+$P(HDR,U,4),$P(HDR,U,3,4)=+IFN_U_(TOTAL+1)
- S ^ORE(100.2,EVT,NODE,0)=HDR L -^ORE(100.2,EVT,NODE,0)
- S ^ORE(100.2,EVT,NODE,+IFN,0)=+IFN_$S($D(PKG):U_PKG,1:"")
- Q
- ;
- EXP ; -- expire an order from EXP^ORMEVNT(ORDER,ORSTOP)
- ; [ORMTIME]
- G:'$D(^OR(100,+ORDER,0)) EXPQ
- N OR0,ORNMSP,ORSTS
- S OR0=$G(^OR(100,+ORDER,0)),ORSTS=$P($G(^(3)),U,3)
- I "^1^2^7^12^13^14^"[(U_ORSTS_U) G EXPQ ;done
- I $O(^OR(100,+ORDER,2,0)) G EXPQ ;parent
- I $P(^ORD(100.98,$P(OR0,U,11),0),U,3)="NV RX" G EXPQ ;Non-VA med
- S ORNMSP=$$NMSP^ORCD($P(OR0,U,14))
- D:ORNMSP="PS"!(ORNMSP="FH") MSG^ORMBLD(+ORDER,"SS")
- I ORNMSP="OR"!(ORNMSP="FH"),"^1^7^"'[(U_ORSTS_U) D
- . D STATUS^ORCSAVE2(+ORDER,7) ;ck FH
- . D MSG^ORMBLDOR(+ORDER,"SC")
- EXPQ K ^OR(100,"AE",ORSTOP,ORDER)
- Q
- ;
- ACT ; -- activate an order from ACTIVE^ORMEVNT(ORDER,ORSTRT)
- ; [ORMTIME]
- G:'$D(^OR(100,+ORDER,0)) ACTQ
- N OR0,ORNMSP,ORSTS
- S OR0=$G(^OR(100,+ORDER,0)),ORSTS=$P($G(^(3)),U,3)
- I "^1^2^6^7^12^13^14^"[(U_ORSTS_U) G ACTQ ;done
- I $O(^OR(100,+ORDER,2,0)) G ACTQ ;parent
- S ORNMSP=$$NMSP^ORCD($P(OR0,U,14))
- D:ORNMSP="PS"!(ORNMSP="FH") MSG^ORMBLD(+ORDER,"SS")
- I ORNMSP="OR"!(ORNMSP="FH"),ORSTS=8 D
- . D STATUS^ORCSAVE2(+ORDER,6) ;ck FH
- . D MSG^ORMBLDOR(+ORDER,"SC")
- ACTQ K ^OR(100,"AD",ORSTRT,ORDER)
- Q
- ;
- PUR ; -- purge an order
- ; from PURGE^ORMEVNT(ORDER)
- N ORSTS,ORPK,ORNMSP,ORCHLD Q:'$D(^OR(100,ORDER))
- S ORSTS=$P($G(^OR(100,ORDER,3)),U,3),ORPK=$G(^(4)),ORNMSP=$P($G(^(0)),U,14),ORNMSP=$$NMSP^ORCD(ORNMSP)
- I '$L(ORPK)!(ORSTS=11)!(ORNMSP="OR")!(ORNMSP="LR"&('ORPK)) D DELETE^ORCSAVE2(ORDER) Q
- I '$D(^OR(100,ORDER,2)) D MSG^ORMBLD(ORDER,"Z@") Q
- S ORCHLD=0 F S ORCHLD=$O(^OR(100,ORDER,2,ORCHLD)) Q:ORCHLD'>0 D MSG^ORMBLD(ORCHLD,"Z@")
- I '$O(^OR(100,ORDER,2,0)) D DELETE^ORCSAVE2(ORDER) ; delete parent
- Q
- ;
- CHKOBS ;177, previous dx from obs?
- N INVDT,PDCDT,PDCMVT,CADMDT
- S CADMDT=+$G(VAIP(13,1)) Q:'CADMDT ;Current admission d/t of movement
- S INVDT=9999999.9999999-(+VAIP(3)) ;Inverse date of movement
- S PDCDT=$O(^DGPM("ATID3",DFN,INVDT)) Q:'+PDCDT ;No previous discharge
- S PDCMVT=$O(^DGPM("ATID3",DFN,PDCDT,0))
- Q:+$$MVT^DGPMOBS(PDCMVT)'=1 ;Quit if previous discharge not from obs
- N VAIP
- S VAIP("E")=PDCMVT
- D IN5^VADPT
- Q:'$G(VAIP(13)) ;No previous admission data
- Q:$$FMDIFF^XLFDT(CADMDT,+$G(VAIP(3)),2)>3600 ;Quit if previous discharge was more than 1 hour before admission
- S ORADM=+$G(VAIP(13,1))
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HORMEVNT1 10293 printed Feb 18, 2025@23:58:27 Page 2
- ORMEVNT1 ;SLC/MKB-Trigger HL7 msg off OR events,ORMTIME ; 6/8/10 9:55am
- +1 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**141,165,177,186,215,324,538**;Dec 17, 1997;Build 1
- +2 ;
- +3 ;DBIA Section
- +4 ; 3559 - Direct read of ^SRF
- +5 ;10039 - Direct read of ^DIC(42,
- +6 ;
- OR2(ORSRDA) ;Queue EDO process to background, return control to surgery
- +1 ;
- +2 NEW ZTRTN,ZTDESC,ZTDTH,ZTIO,ZTSK,ZTSAVE
- +3 SET ZTRTN="OR2Q^ORMEVNT1"
- SET ZTDTH=$HOROLOG
- SET ZTDESC="Surgery triggered EDO processing"
- SET ZTIO=""
- SET ZTSAVE("ORSRDA")=""
- DO ^%ZTLOAD
- +4 QUIT
- +5 ;
- OR2Q ; -- Kill logic, from Surgery package [DBIA #3558]
- +1 ;186 requeue if flag set
- IF $DATA(^XTMP("ORSURG",ORSRDA))
- DO OR2(ORSRDA)
- QUIT
- +2 NEW X,Y,DA,OREVT,ORSRF,ORACT
- +3 SET OREVT=+$ORDER(^ORE(100.2,"ASR",+$GET(ORSRDA),0))
- if OREVT<1
- QUIT
- +4 SET ORSRF=$GET(^SRF(+ORSRDA,.2))
- SET ORACT=$SELECT($LENGTH($PIECE(ORSRF,U,12)):"ED",1:"DL")
- +5 DO ACTLOG^OREVNTX(OREVT,ORACT)
- +6 QUIT
- +7 ;
- OR1(ORSRDA,ORSRX) ;Queue EDO process to background, return control to surgery
- +1 NEW ZTRTN,ZTDESC,ZTDTH,ZTIO,ZTSK,ZTSAVE
- +2 SET ZTRTN="OR1Q^ORMEVNT1"
- SET ZTDTH=$HOROLOG
- SET ZTDESC="Surgery triggered EDO processing"
- SET ZTIO=""
- SET ZTSAVE("ORSRDA")=""
- SET ZTSAVE("ORSRX")=""
- DO ^%ZTLOAD
- +3 QUIT
- +4 ;
- OR1Q ; -- Set logic, from Surgery package [DBIA #3558]
- +1 ;186 requeue if flag set
- IF $DATA(^XTMP("ORSURG",ORSRDA))
- DO OR1(ORSRDA,ORSRX)
- QUIT
- +2 NEW X
- SET X=ORSRX
- +3 ;concurrent
- IF $GET(^SRF(+$GET(ORSRDA),"CON"))
- IF $DATA(^ORE(100.2,"ASR",+^("CON")))
- QUIT
- +4 ;edit
- if $DATA(^ORE(100.2,"ASR",+$GET(ORSRDA)))
- QUIT
- if '$$CURRENT
- QUIT
- +5 ;
- +6 NEW ORSR0,DFN,VAIP,VAERR,X,Y,DA,ORVP,ORL,ORDIV,ORTS,OREVENT,ORDCRULE,ORPRINT
- +7 SET ORSR0=$GET(^SRF(+$GET(ORSRDA),0))
- SET DFN=+$PIECE(ORSR0,U)
- +8 ;not admitted
- DO IN5^VADPT
- if '$GET(VAIP(13))
- QUIT
- +9 ;186 Set flag
- SET ^XTMP("ORSURG",ORSRDA)=$$FMADD^XLFDT(DT,5)_U_DT
- +10 ;DBIA #3362
- SET ORL=$PIECE($GET(^SRS(+$PIECE(ORSR0,U,2),0)),U)_";SC("
- SET ORDIV=$$DIV(+ORL)
- +11 ;*324 Add set ORDIV to grab the institution
- +12 ;186 If no O.R. loc then use current loc
- IF '$GET(LOC)
- SET ORL=+$GET(^DIC(42,+$GET(VAIP(5)),44))_";SC("
- SET ORDIV=$$DIV(+ORL)
- +13 ; need surg spec too? DBIA #991
- SET ORTS=+$GET(VAIP(8))
- +14 SET ORVP=DFN_";DPT("
- SET OREVENT=$$PATEVT
- SET ORDCRULE=$$DCEVT
- +15 if ORDCRULE
- DO AUTODC(ORDCRULE,ORSRX)
- IF OREVENT
- Begin DoDot:1
- +16 DO RELEASE(OREVENT)
- DO DONE^OREVNTX(OREVENT,ORSRX,,ORSRDA)
- +17 DO ACTLOG^OREVNTX(OREVENT,"NW","O")
- End DoDot:1
- +18 IF $ORDER(ORPRINT(0))
- IF $GET(ORL)
- DO PRINTS^ORWD1(.ORPRINT,+ORL)
- +19 ;186
- KILL ^XTMP("ORSURG",ORSRDA)
- +20 QUIT
- +21 ;
- DIV(LOC) ; -- Return Institution file #4 ptr for LOC
- +1 NEW X0,Y
- SET X0=$GET(^SC(+LOC,0))
- +2 SET Y=$SELECT($PIECE(X0,U,4):$PIECE(X0,U,4),$PIECE(X0,U,15):$$SITE^VASITE(DT,$PIECE(X0,U,15)),1:+$GET(DUZ(2)))
- +3 QUIT Y
- +4 ;
- CURRENT() ; -- Is posted mvt the latest one?
- +1 NEW Y
- SET Y=$SELECT((DT-X)<1:1,1:0)
- +2 QUIT Y
- +3 ;
- PATEVT() ; -- Find match to new data in Patient Event file
- +1 NEW EVT,IFN,X0,Y
- SET EVT=0
- SET Y=""
- +2 FOR
- SET EVT=+$ORDER(^ORE(100.2,"AE",+ORVP,EVT))
- if EVT<1
- QUIT
- SET IFN=$ORDER(^(EVT,0))
- Begin DoDot:1
- +3 ;don't release orders
- if $$LAPSED^OREVNTX(+IFN)
- QUIT
- +4 SET X0=$GET(^ORD(100.5,EVT,0))
- +5 IF $PIECE(X0,U,2)="O"
- IF $PIECE(X0,U,3)=ORDIV
- SET Y=+IFN
- QUIT
- End DoDot:1
- if Y
- QUIT
- +6 QUIT Y
- +7 ;
- DCEVT() ; -- Find match to event in AutoDC Rules file for [new] ORDIV
- +1 ;no auto-dc's if not admitted
- NEW Y
- IF '$GET(^DPT(+ORVP,.105))
- QUIT 0
- +2 SET Y=+$ORDER(^ORD(100.6,"AE",ORDIV,"O",0))
- +3 QUIT Y
- +4 ;
- AUTODC(ORDC,ORDT) ; -- DC orders based on rule ORDC [also from ORMEVNT]
- +1 ; Expects VAIP array with current admission data
- +2 NEW ORADM,ORNOW,ORN,X,OREASON,ORNATR,ORCREATE,ORPRNT,ORSIG,ORDG,ORI,ORPKG,ORLIST,ORIFN,OR0,ORDER,ORERR
- +3 SET OREASON=+$PIECE($GET(^ORD(100.6,ORDC,0)),U,4)
- IF OREASON<1
- Begin DoDot:1
- +4 SET OREASON=$SELECT('$GET(DGPMT):"OROR",DGPMT=1:"ORADMIT",DGPMT=2:"ORTRANS",DGPMT=3:"ORDIS",1:"ORSPEC")
- +5 SET OREASON=+$ORDER(^ORD(100.03,"C",OREASON,0))
- End DoDot:1
- +6 SET ORNATR=+$PIECE($GET(^ORD(100.03,+$GET(OREASON),0)),U,7)
- +7 if ORNATR'>0
- SET ORNATR=+$ORDER(^ORD(100.02,"C","A",0))
- +8 SET X=$GET(^ORD(100.02,ORNATR,1))
- SET ORCREATE=+$PIECE(X,U)
- SET ORPRNT=+$PIECE(X,U,2)
- +9 SET ORSIG=$SELECT('ORCREATE:"",1:$PIECE(X,U,4))
- SET ORDG=$ORDER(^ORD(100.98,"B","ALL",0))
- +10 SET ORI=0
- FOR
- SET ORI=$ORDER(^ORD(100.6,ORDC,7,"B",ORI))
- if ORI<1
- QUIT
- SET ORPKG(ORI)=1
- +11 ;177
- if $GET(DGPMT)'=1
- DO CHKOBS
- if '$GET(ORADM)
- SET ORADM=+$GET(VAIP(13,1))
- SET ORNOW=$$NOW^XLFDT
- SET ORN="A"
- SET ORI=6
- +12 IF $GET(DGPMT)=1
- SET ORI=2
- SET ORADM=""
- SET ORN="A"
- +13 IF $GET(DGPMT)=3
- IF "^12^38^"[(U_$PIECE(DGPMA,U,18)_U)
- SET ORI=2
- SET ORADM=""
- SET ORN=""
- +14 DO EN^ORQ1(ORVP,ORDG,ORI,,ORADM,ORNOW)
- DO ADMORD
- SET ORI=0
- DC1 FOR
- SET ORI=$ORDER(^TMP("ORR",$JOB,ORLIST,ORI))
- if ORI'>0
- QUIT
- SET ORIFN=^(ORI)
- Begin DoDot:1
- +1 ;Q:$P(ORIFN,";",2)>1 ; or DC/Delete actions ??
- +2 if "^1^2^7^11^12^13^"[(U_$PIECE(^OR(100,+ORIFN,3),U,3)_U)
- QUIT
- SET OR0=$GET(^(0))
- +3 if '$GET(ORPKG($PIECE(OR0,U,14)))
- QUIT
- if $DATA(^ORD(100.6,ORDC,10,"B",+$PIECE(OR0,U,11)))
- QUIT
- +4 SET X=+$$VALUE^ORX8(+ORIFN,"ORDERABLE")
- if $DATA(^ORD(100.6,ORDC,8,"B",X))
- QUIT
- +5 ;ok to auto-dc order?
- if '$$VALID^ORCACT0(ORIFN,"DC",,ORN)
- QUIT
- +6 ;no delayed orders
- IF '$GET(OREVENT)
- SET OREVENT=+$$NEW^OREVNT(+ORVP)
- +7 SET ORDER=+ORIFN_$SELECT(ORCREATE:";"_$$ACTION^ORCSAVE("DC",+ORIFN,$GET(ORNP),,$GET(ORDT)),1:"")
- +8 DO EN^ORCSEND(ORDER,"DC",ORSIG,1,ORNATR,$GET(OREASON),.ORERR)
- if $GET(ORERR)
- QUIT
- +9 SET $PIECE(^OR(100,+ORIFN,6),U,8)=OREVENT
- DO SAVE(ORIFN,OREVENT,3)
- +10 if ORPRNT
- SET ORPRINT=$GET(ORPRINT)+1
- SET ORPRINT(ORPRINT)=ORDER_"^1"
- End DoDot:1
- +11 ;*324 Create an event if package orders auto-dcd but no orders released or dc'd by CPRS.
- +12 IF '$GET(OREVENT)
- IF $GET(DGPMDA)
- IF $DATA(^XTMP("ORDC-"_DGPMDA))
- SET OREVENT=$$NEW^OREVNT(+ORVP)
- DC2 IF $GET(OREVENT)
- Begin DoDot:1
- +1 SET $PIECE(^ORE(100.2,OREVENT,1),U,3)=ORDC
- SET ^ORE(100.2,"DC",ORDC,OREVENT)=""
- +2 ;save order#'s
- IF $GET(DGPMDA)
- IF $DATA(^XTMP("ORDC-"_DGPMDA))
- DO XTMP
- End DoDot:1
- +3 KILL ^TMP("ORR",$JOB,ORLIST),^XTMP("ORDC-"_$GET(DGPMDA))
- +4 QUIT
- +5 ;
- RELEASE(OREVT) ; -- release orders for OREVT [also from ORMEVNT]
- +1 ; Returns ORPRINT(#)=order^prints for orders released
- +2 if '$GET(OREVT)
- QUIT
- NEW ORPARM,ORLR,ORX,ORI,ORV,ORIFN,ORERR,OR0,OR3,ORLAB
- +3 SET ORPARM=""
- IF $GET(ORL)
- FOR ORI="CHART COPY","LABELS","REQUISITIONS","SERVICE","WORK COPY"
- SET ORX=$SELECT(ORI="SERVICE":0,1:$$GET^XPAR("ALL^"_ORL,"ORPF PROMPT FOR "_ORI,1,"I"))
- SET ORPARM=ORPARM_U_$SELECT(ORX="*":0,1:1)
- +4 ;186 Reset loc
- IF $DATA(^XTMP("ORSURG",+$GET(ORSRDA)))
- SET ORL=+$GET(^DIC(42,+$GET(VAIP(5)),44))_";SC("
- +5 FOR ORI="LR","VBEC"
- SET ORX=+$ORDER(^DIC(9.4,"C",ORI,0))
- if ORX
- SET ORLR(ORX)=1
- +6 SET ORX=OREVT
- SET ORI=0
- +7 FOR
- SET ORI=+$ORDER(^ORE(100.2,"DAD",OREVT,ORI))
- if ORI<1
- QUIT
- SET ORX=ORX_U_ORI
- +8 ;event[+children]
- FOR ORV=1:1:$LENGTH(ORX,U)
- SET OREVT=$PIECE(ORX,U,ORV)
- Begin DoDot:1
- +9 FOR
- SET ORI=$ORDER(^OR(100,"AEVNT",ORVP,OREVT,ORI))
- if ORI'>0
- QUIT
- Begin DoDot:2
- +10 SET ORIFN=ORI
- SET OR0=$GET(^OR(100,ORIFN,0))
- SET OR3=$GET(^(3))
- +11 ;event order
- IF ORIFN=+$PIECE($GET(^ORE(100.2,OREVT,0)),U,4)
- Begin DoDot:3
- +12 if $$TYPE^OREVNTX(OREVT)="D"
- QUIT
- if $PIECE(OR3,U,3)=11
- QUIT
- +13 SET ORPRINT=+$GET(ORPRINT)+1
- SET ORPRINT(ORPRINT)=ORIFN_";1"_ORPARM
- End DoDot:3
- QUIT
- +14 ;released or cancelled, has parent
- if $PIECE(OR3,U,3)'=10
- QUIT
- if $PIECE(OR3,U,9)
- QUIT
- +15 ;set location
- if $GET(ORL)
- SET $PIECE(^OR(100,ORIFN,0),U,10)=ORL
- +16 ;set specialty
- if $GET(ORTS)
- SET $PIECE(^OR(100,ORIFN,0),U,13)=ORTS
- +17 IF $GET(ORLR(+$PIECE(OR0,U,14)))
- IF '$GET(ORLAB)
- DO BHS^ORMBLD(ORVP)
- SET ORLAB=1
- +18 KILL ORERR
- DO EN1^ORCSEND(ORIFN,.ORERR)
- if $GET(ORERR)
- QUIT
- +19 if "^10^11^"[(U_$PIECE($GET(^OR(100,ORIFN,3)),U,3)_U)
- QUIT
- DO SAVE(ORIFN,OREVT,2)
- +20 SET ORPRINT=+$GET(ORPRINT)+1
- SET ORPRINT(ORPRINT)=ORIFN_";1"_ORPARM
- End DoDot:2
- End DoDot:1
- +21 ;send batch hdr/tlr segments for labs
- if $GET(ORLAB)
- DO BTS^ORMBLD(ORVP)
- +22 QUIT
- +23 ;
- ADMORD ; -- Add admission order to list
- +1 ; Uses VAIP(13),ORADM from AUTODC
- +2 ;Q:$G(DGPMT)'=3
- +3 ;already included
- IF $GET(DGPMT)=3
- if "^12^38^"[(U_$PIECE(DGPMA,U,18)_U)
- QUIT
- +4 NEW LAST,ADMEVT,IFN
- +5 SET LAST=+$ORDER(^ORE(100.2,"ADT",+$GET(VAIP(13)),""),-1)
- SET ADMEVT=+$ORDER(^(LAST,0))
- +6 SET IFN=+$PIECE($GET(^ORE(100.2,ADMEVT,0)),U,4)
- if IFN<1
- QUIT
- +7 ;add to auto-dc list
- IF $PIECE($GET(^OR(100,IFN,8,1,0)),U,16)<ORADM
- Begin DoDot:1
- +8 NEW ORI
- SET ORI=+$ORDER(^TMP("ORR",$JOB,ORLIST,"A"),-1)
- SET ORI=ORI+1
- +9 SET ^TMP("ORR",$JOB,ORLIST,ORI)=IFN
- End DoDot:1
- +10 QUIT
- +11 ;
- XTMP ; -- Save auto-dc'd by package order numbers
- +1 NEW ORDC,ORIFN,X
- if '$GET(OREVENT)
- QUIT
- +2 SET ORDC="ORDC-"_$GET(DGPMDA)
- SET ORIFN=0
- +3 FOR
- SET ORIFN=+$ORDER(^XTMP(ORDC,ORIFN))
- if ORIFN<1
- QUIT
- SET X=$GET(^(ORIFN))
- Begin DoDot:1
- +4 DO SAVE(ORIFN,OREVENT,3,X)
- +5 SET $PIECE(^OR(100,+ORIFN,6),U,8)=OREVENT
- End DoDot:1
- +6 QUIT
- +7 ;
- SAVE(IFN,EVT,NODE,PKG) ; -- Save order# IFN with EVT at NODE
- +1 ; NODE=2: Released orders, NODE=3: Auto-DC'd orders
- +2 ;missing data
- if '$GET(IFN)!'$GET(EVT)!'$GET(NODE)
- QUIT
- +3 ;already saved
- if $DATA(^ORE(100.2,EVT,NODE,+IFN,0))
- QUIT
- +4 NEW I,HDR,TOTAL
- +5 FOR I=1:1:10
- LOCK +^ORE(100.2,EVT,NODE,0):1
- if $TEST
- QUIT
- HANG 2
- +6 if '$TEST
- QUIT
- SET HDR=$GET(^ORE(100.2,EVT,NODE,0))
- +7 IF '$LENGTH(HDR)
- if NODE=2
- SET HDR="^100.26PA^^"
- if NODE=3
- SET HDR="^100.27PA^^"
- +8 if '$LENGTH(HDR)
- QUIT
- SET TOTAL=+$PIECE(HDR,U,4)
- SET $PIECE(HDR,U,3,4)=+IFN_U_(TOTAL+1)
- +9 SET ^ORE(100.2,EVT,NODE,0)=HDR
- LOCK -^ORE(100.2,EVT,NODE,0)
- +10 SET ^ORE(100.2,EVT,NODE,+IFN,0)=+IFN_$SELECT($DATA(PKG):U_PKG,1:"")
- +11 QUIT
- +12 ;
- EXP ; -- expire an order from EXP^ORMEVNT(ORDER,ORSTOP)
- +1 ; [ORMTIME]
- +2 if '$DATA(^OR(100,+ORDER,0))
- GOTO EXPQ
- +3 NEW OR0,ORNMSP,ORSTS
- +4 SET OR0=$GET(^OR(100,+ORDER,0))
- SET ORSTS=$PIECE($GET(^(3)),U,3)
- +5 ;done
- IF "^1^2^7^12^13^14^"[(U_ORSTS_U)
- GOTO EXPQ
- +6 ;parent
- IF $ORDER(^OR(100,+ORDER,2,0))
- GOTO EXPQ
- +7 ;Non-VA med
- IF $PIECE(^ORD(100.98,$PIECE(OR0,U,11),0),U,3)="NV RX"
- GOTO EXPQ
- +8 SET ORNMSP=$$NMSP^ORCD($PIECE(OR0,U,14))
- +9 if ORNMSP="PS"!(ORNMSP="FH")
- DO MSG^ORMBLD(+ORDER,"SS")
- +10 IF ORNMSP="OR"!(ORNMSP="FH")
- IF "^1^7^"'[(U_ORSTS_U)
- Begin DoDot:1
- +11 ;ck FH
- DO STATUS^ORCSAVE2(+ORDER,7)
- +12 DO MSG^ORMBLDOR(+ORDER,"SC")
- End DoDot:1
- EXPQ KILL ^OR(100,"AE",ORSTOP,ORDER)
- +1 QUIT
- +2 ;
- ACT ; -- activate an order from ACTIVE^ORMEVNT(ORDER,ORSTRT)
- +1 ; [ORMTIME]
- +2 if '$DATA(^OR(100,+ORDER,0))
- GOTO ACTQ
- +3 NEW OR0,ORNMSP,ORSTS
- +4 SET OR0=$GET(^OR(100,+ORDER,0))
- SET ORSTS=$PIECE($GET(^(3)),U,3)
- +5 ;done
- IF "^1^2^6^7^12^13^14^"[(U_ORSTS_U)
- GOTO ACTQ
- +6 ;parent
- IF $ORDER(^OR(100,+ORDER,2,0))
- GOTO ACTQ
- +7 SET ORNMSP=$$NMSP^ORCD($PIECE(OR0,U,14))
- +8 if ORNMSP="PS"!(ORNMSP="FH")
- DO MSG^ORMBLD(+ORDER,"SS")
- +9 IF ORNMSP="OR"!(ORNMSP="FH")
- IF ORSTS=8
- Begin DoDot:1
- +10 ;ck FH
- DO STATUS^ORCSAVE2(+ORDER,6)
- +11 DO MSG^ORMBLDOR(+ORDER,"SC")
- End DoDot:1
- ACTQ KILL ^OR(100,"AD",ORSTRT,ORDER)
- +1 QUIT
- +2 ;
- PUR ; -- purge an order
- +1 ; from PURGE^ORMEVNT(ORDER)
- +2 NEW ORSTS,ORPK,ORNMSP,ORCHLD
- if '$DATA(^OR(100,ORDER))
- QUIT
- +3 SET ORSTS=$PIECE($GET(^OR(100,ORDER,3)),U,3)
- SET ORPK=$GET(^(4))
- SET ORNMSP=$PIECE($GET(^(0)),U,14)
- SET ORNMSP=$$NMSP^ORCD(ORNMSP)
- +4 IF '$LENGTH(ORPK)!(ORSTS=11)!(ORNMSP="OR")!(ORNMSP="LR"&('ORPK))
- DO DELETE^ORCSAVE2(ORDER)
- QUIT
- +5 IF '$DATA(^OR(100,ORDER,2))
- DO MSG^ORMBLD(ORDER,"Z@")
- QUIT
- +6 SET ORCHLD=0
- FOR
- SET ORCHLD=$ORDER(^OR(100,ORDER,2,ORCHLD))
- if ORCHLD'>0
- QUIT
- DO MSG^ORMBLD(ORCHLD,"Z@")
- +7 ; delete parent
- IF '$ORDER(^OR(100,ORDER,2,0))
- DO DELETE^ORCSAVE2(ORDER)
- +8 QUIT
- +9 ;
- CHKOBS ;177, previous dx from obs?
- +1 NEW INVDT,PDCDT,PDCMVT,CADMDT
- +2 ;Current admission d/t of movement
- SET CADMDT=+$GET(VAIP(13,1))
- if 'CADMDT
- QUIT
- +3 ;Inverse date of movement
- SET INVDT=9999999.9999999-(+VAIP(3))
- +4 ;No previous discharge
- SET PDCDT=$ORDER(^DGPM("ATID3",DFN,INVDT))
- if '+PDCDT
- QUIT
- +5 SET PDCMVT=$ORDER(^DGPM("ATID3",DFN,PDCDT,0))
- +6 ;Quit if previous discharge not from obs
- if +$$MVT^DGPMOBS(PDCMVT)'=1
- QUIT
- +7 NEW VAIP
- +8 SET VAIP("E")=PDCMVT
- +9 DO IN5^VADPT
- +10 ;No previous admission data
- if '$GET(VAIP(13))
- QUIT
- +11 ;Quit if previous discharge was more than 1 hour before admission
- if $$FMDIFF^XLFDT(CADMDT,+$GET(VAIP(3)),2)>3600
- QUIT
- +12 SET ORADM=+$GET(VAIP(13,1))
- +13 QUIT