Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: ORMEVNT1

ORMEVNT1.m

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