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

ORWDX.m

Go to the documentation of this file.
  1. ORWDX ; SLC/KCM/REV/JLI - Order dialog utilities ;20-Nov-2012 10:12;PLS
  1. ;;3.0;ORDER ENTRY/RESULTS REPORTING;**10,85,125,131,132,141,164,178,187,190,1006,1007,195,215,246,243,283,296,1010**;Dec 17, 1997;Build 47
  1. ;Per VHA Directive 2004-038, this routine should not be modified.
  1. ;Reference to DIC(9.4 supported by IA #2058
  1. ;Modified - IHS/MSC/PLS - 08/06/2010 - MEDREC Line Label
  1. ; 01/25/2011 - Added reference to BEHORX OUTSIDE MED DOSAGE FORM
  1. ;
  1. ORDITM(Y,FROM,DIR,XREF) ; Subset of orderable items
  1. ; Y(n)=IEN^.01 Name^.01 Name -or- IEN^Synonym <.01 Name>^.01 Name
  1. N I,IEN,CNT,X,DTXT,CURTM,DEFROUTE
  1. S DEFROUTE=""
  1. S I=0,CNT=44,CURTM=$$NOW^XLFDT
  1. F Q:I'<CNT S FROM=$O(^ORD(101.43,XREF,FROM),DIR) Q:FROM="" D
  1. . S IEN="" F S IEN=$O(^ORD(101.43,XREF,FROM,IEN),DIR) Q:'IEN D
  1. . . S X=^ORD(101.43,XREF,FROM,IEN)
  1. . . I +$P(X,U,3),$P(X,U,3)<CURTM Q
  1. . . Q:$P(X,U,5) S I=I+1
  1. . . I XREF="S.IVA RX"!(XREF="S.IVB RX") S DEFROUTE=$P($G(^ORD(101.43,IEN,"PS")),U,8)
  1. . . I 'X S Y(I)=IEN_U_$P(X,U,2)_U_$P(X,U,2)_U_DEFROUTE
  1. . . E S Y(I)=IEN_U_$P(X,U,2)_$C(9)_"<"_$P(X,U,4)_">"_U_$P(X,U,4)_U_DEFROUTE
  1. Q
  1. ODITMBC(Y,XREF,ODLST) ;
  1. N CNT,NM,XRF
  1. S CNT=0,NM=0,XRF=XREF
  1. F S CNT=$O(ODLST(CNT)) Q:'CNT D FNDINFO(.Y,ODLST(CNT))
  1. Q
  1. FNDINFO(Y,ODIEN) ;
  1. D FNDINFO^ORWDX1(.Y,.ODIEN)
  1. Q
  1. DLGDEF(LST,DLG) ; Format mapping for a dlg
  1. D DLGDEF^ORWDX1(.LST,.DLG)
  1. Q
  1. DLGQUIK(LST,QO) ;(NOT USED)
  1. D LOADRSP(.LST,QO)
  1. Q
  1. LOADRSP(LST,RSPID,TRANS) ; Load responses from 101.41 or 100
  1. ; RSPID: C123456;1-3243 = cached copy, 134-3234 = cached quick
  1. ; X123456;1 = change order, 134 = quick dialog
  1. N I,J,DLG,INST,ID,VAL,ILST,ROOT,ORLOC S ROOT=""
  1. I RSPID["-" S ROOT="^TMP(""ORWDXMQ"",$J,"""_RSPID_""")" G XROOT^ORWDX2
  1. I $E(RSPID)="X" S ROOT="^OR(100,"_+$P(RSPID,"X",2)_",4.5)" G XROOT^ORWDX2
  1. I +RSPID=RSPID S ROOT="^ORD(101.41,"_+RSPID_",6)" G XROOT^ORWDX2
  1. Q:ROOT=""
  1. G XROOT^ORWDX2
  1. SAVE(REC,ORVP,ORNP,ORL,DLG,ORDG,ORIT,ORIFN,ORDIALOG,ORDEA,ORAPPT,ORSRC,OREVTDF) ;
  1. ; ORVP=DFN, ORNP=Provider, ORL=Location, DLG=Order Dialog,
  1. ; ORDG=Display Group, ORIT=Quick Order Dialog, ORAPPT=Appointment
  1. N ORDUZ,ORSTS,OREVENT,ORCAT,ORDA,ORTS,ORNEW,ORCHECK,ORLOG,ORLEAD,ORTRAIL,ORPKG,ORWP94,ORCATFN,OREVTYPE,ONPASS
  1. N XCNT,XCOMM,XDONE,XX ;SBR
  1. S (XCOMM,XCNT)="" ;SBR
  1. I $G(ORIFN)'="" D ;SBR problem only occurs on change or renew orders
  1. . S XCNT=$O(^OR(100,+ORIFN,4.5,"ID","COMMENT",XCNT)) ;SBR
  1. . I XCNT'="" S XCOMM=$P($G(^OR(100,+ORIFN,4.5,XCNT,0)),"^",2) ;SBR
  1. . I XCOMM'="" S XDONE=0,XX="" F S XX=$O(ORDIALOG("WP",XCOMM,1,XX)) Q:XX="" D ;SBR
  1. . . I ORDIALOG("WP",XCOMM,1,XX,0)'="" S XDONE=1 Q ;SBR
  1. . I XCOMM'="",'$G(XDONE),$D(ORDIALOG("WP",XCOMM)) K ORDIALOG("WP",XCOMM) ;SBR
  1. S ORCATFN="" I $L($P(DLG,U,2)) S ORCATFN=$P(DLG,U,2),DLG=$P(DLG,U,1)
  1. ;Remove treating facility if inpatient and IMO order 26.42
  1. I $G(^DPT(ORVP,.1))'="",$P($G(^ORD(100.98,ORDG,0)),U)="CLINIC ORDERS" K ORDIALOG("ORTS")
  1. I $G(ORDIALOG("ORTS")) S ORTS=ORDIALOG("ORTS") K ORDIALOG("ORTS")
  1. I $G(ORDIALOG("ORSLOG")) S ORLOG=ORDIALOG("ORSLOG") K ORDIALOG("ORSLOG")
  1. I $D(ORDIALOG("OREVENT")) S OREVENT=ORDIALOG("OREVENT") K ORDIALOG("OREVENT")
  1. ;=====================================================
  1. ; Changed for v26.27 (RV)
  1. S ORCAT=$$INPT^ORCD,ORCAT=$S(ORCAT=1:"I",1:"O")
  1. ;I $L($G(OREVENT)) D
  1. ;. S ONPASS=0
  1. ;. S OREVTYPE=$$TYPE^OREVNTX(OREVENT)
  1. ;. I OREVTYPE="T" D ISPASS^OREVNTX1(.ONPASS,+OREVENT,"T")
  1. ;. S ORCAT=$S(OREVTYPE="A":"I",OREVTYPE="T":"I",ONPASS=1:"O",1:"O")
  1. ;E S ORCAT=$S($L($P($G(^DPT(+ORVP,.1)),U)):"I",1:"O")
  1. ;=====================================================
  1. I DLG="PS MEDS" S ORWP94=1 D
  1. . I ORIT=$O(^ORD(101.41,"AB","PSO SUPPLY",0)) S DLG="PSO SUPPLY"
  1. . I ORIT=$O(^ORD(101.41,"AB","PSO OERR",0)) S DLG="PSO OERR"
  1. . I ORIT=$O(^ORD(101.41,"AB","PSJ OR PAT OE",0)) S DLG="PSJ OR PAT OE"
  1. I DLG="PSO OERR" S ORCAT="O" I $G(OREVENT("EFFECTIVE")) D
  1. . S ORDIALOG($O(^ORD(101.41,"B","OR GTX START DATE"_$S($G(ORWP94):"/TIME",1:""),0)),1)=OREVENT("EFFECTIVE")
  1. I DLG="PSJ OR PAT OE" S ORCAT="I"
  1. S:DLG="FHW1" ORCAT="I" S:DLG?1"FHW "2.7U1" MEAL" ORCAT="O"
  1. S ORVP=ORVP_";DPT(",ORL(2)=ORL_";SC(",ORL=ORL(2)
  1. I ORDG=$O(^ORD(100.98,"B","LAB",0)) D ;use section
  1. . N OI,SUB S OI=+$G(ORDIALOG($$PTR^ORCD("OR GTX ORDERABLE ITEM"),1))
  1. . S SUB=$P($G(^ORD(101.43,OI,"LR")),U,6),ORDG=$$DGRP^ORMLR(SUB)
  1. K:'ORDG ORDG K:'ORIT ORIT ; Dgrp & Quick must be non-zero
  1. M ORCHECK=ORDIALOG("ORCHECK") K ORDIALOG("ORCHECK")
  1. S ORDIALOG=$O(^ORD(101.41,"AB",DLG,0))
  1. I 'ORDIALOG S ORDIALOG=$O(^ORD(101.41,"B",DLG,0))
  1. I $D(ORDIALOG("ORLEAD")) S ORLEAD=ORDIALOG("ORLEAD")
  1. I $D(ORDIALOG("ORTRAIL")) S ORTRAIL=ORDIALOG("ORTRAIL")
  1. D GETDLG1^ORCD(ORDIALOG)
  1. I $L(ORCATFN) S ORCAT=ORCATFN
  1. I $G(ORWP94) D
  1. . N SIGPRMT S SIGPRMT=$O(^ORD(101.41,"B","OR GTX SIG",0))
  1. . N INSPRMT S INSPRMT=$O(^ORD(101.41,"B","OR GTX INSTRUCTIONS",0))
  1. . I $L($G(ORDIALOG(SIGPRMT,1))) S ORDIALOG(INSPRMT,"FORMAT")="@"
  1. . I ORCAT="O" S ORPKG=$O(^DIC(9.4,"C","PSO",0))
  1. . I ORCAT="I" S ORPKG=$O(^DIC(9.4,"C","PSJ",0))
  1. S ORSRC=$G(ORSRC)
  1. D DELPI^ORWDX1 ;delete empty PI
  1. I $G(ORIFN)="" D ; new order
  1. . D EN^ORCSAVE
  1. . S REC="" I ORIFN D GETBYIFN^ORWORR(.REC,ORIFN)
  1. . I '$D(^TMP("ORECALL",$J,ORDIALOG)) M ^TMP("ORECALL",$J,ORDIALOG)=ORDIALOG
  1. E D
  1. . N OR0
  1. . S OR0=$G(^OR(100,+ORIFN,0)),ORSTS=$P($G(^(3)),U,3),ORDG=$P(OR0,U,11)
  1. . I $L($P(OR0,U,17)),ORSTS=10 S OREVENT=$P(OR0,U,17),OREVENT("TS")=$P(OR0,U,13)
  1. . D XX^ORCSAVE ; edit order
  1. . S REC="" S ORIFN=+ORIFN_";"_ORDA D GETBYIFN^ORWORR(.REC,ORIFN)
  1. MEDREC ;IHS/MSC/REC/PLS - If dosage form is Miscellaneous set order action to validate
  1. N OD,ODID,ORDID,ORDITEM,NVA,POI,IDF
  1. S OD=$O(^ORD(101.41,"AB","OR GTX ORDERABLE ITEM",0)) Q:'OD
  1. S ODID=$P($G(^ORD(101.41,OD,1)),U,3) Q:$G(ODID)']""
  1. S ORDID=$O(^OR(100,+ORIFN,4.5,"ID",ODID,0)) Q:'ORDID
  1. S ORDITEM=+$G(^OR(100,+ORIFN,4.5,ORDID,1)) Q:'ORDITEM
  1. S NVA=$P($G(^ORD(101.43,ORDITEM,"PS")),U,7) Q:'NVA
  1. S POI=+$P(^ORD(101.43,ORDITEM,0),U,2) Q:'POI
  1. S IDF=$P($G(^PS(50.7,POI,0)),U,2) Q:'IDF
  1. I DLG="PSH OERR",IDF=$$GET^XPAR("SYS","BEHORX OUTSIDE MED DOSAGE FORM") D
  1. .N OR8 S OR8=0 F S OR8=$O(^OR(100,+ORIFN,8,OR8)) Q:'OR8 D
  1. ..N BEHFDA
  1. ..S BEHFDA(100.008,OR8_","_+ORIFN_",",2)="VALIDATE"
  1. ..D UPDATE^DIE("E","BEHFDA","","")
  1. ..S $P(REC(OR8),"^",30)="VA"
  1. E D
  1. .N OR8 S OR8=0 F S OR8=$O(^OR(100,+ORIFN,8,OR8)) Q:'OR8 D
  1. ..N ORACTION S ORACTION=$P(^OR(100,+ORIFN,8,OR8,0),U,2)
  1. ..I ORACTION="VA" D
  1. ...N BEHFDA
  1. ...S BEHFDA(100.008,OR8_","_+ORIFN_",",2)="XX"
  1. ...D UPDATE^DIE("E","BEHFDA","","")
  1. ...S $P(REC(OR8),U,30)=""
  1. Q
  1. SENDED(ORWLST,ORIENS,TS,LOC) ; Release EDOs to svc
  1. N OK,ORVP,ORWERR,ORSIGST,ORDA,ORNATURE,ORIX,X,PTEVT,ORIFN,J,EVENT,LOCK,OR3
  1. S ORWERR="",ORIX=0,LOC=LOC_";SC("
  1. F S ORIX=$O(ORIENS(ORIX)) Q:'ORIX D Q:ORWERR]""
  1. . S (ORIFN,ORWLST(ORIX))=ORIENS(ORIX)
  1. . S PTEVT=$P(^OR(100,+ORIFN,0),U,17)
  1. . I PTEVT D
  1. .. I $D(EVENT(PTEVT)) S LOCK=1 Q
  1. .. S LOCK=$$LCKEVT^ORX2(PTEVT) S:LOCK EVENT(PTEVT)=""
  1. . I 'LOCK S ORWERR="1^delayed event is locked - another user is processing orders for this event" S ORWLST(ORIX)=ORWLST(ORIX)_"^E^"_ORWERR Q
  1. . S ORDA=$P(ORIFN,";",2) S:'ORDA ORDA=1
  1. . S ORVP=$P($G(^OR(100,+ORIFN,0)),U,2)
  1. . I $D(^OR(100,+ORIFN,8,ORDA,0)) D
  1. .. S ORSIGST=$P($G(^(0)),U,4),ORNATURE=$P($G(^(0)),U,12) ;naked references refer to OR(100,+ORIFN,8,ORDA on line above
  1. . S OK=$$LOCK1^ORX2(ORIFN) I 'OK S ORWERR="1^"_$P(OK,U,2)
  1. . I OK,$G(LOCK) D
  1. .. S OR3=$G(^OR(100,+ORIFN,3)) I $P(OR3,"^",3)'=10!($P(OR3,"^",9)]"") D UNLK1^ORX2(ORIENS(ORIX)) Q ;order already released or has a parent
  1. .. S:$G(LOC) $P(^OR(100,+ORIFN,0),U,10)=LOC ;set location
  1. .. S:$G(TS) $P(^OR(100,+ORIFN,0),U,13)=TS ;set specialty
  1. .. D EN2^ORCSEND(ORIENS(ORIX),ORSIGST,ORNATURE,.ORWERR),UNLK1^ORX2(ORIENS(ORIX)) ;add ,LOCK to if statement for 195
  1. . I $L(ORWERR) S ORWLST(ORIX)=ORWLST(ORIX)_"^E^"_ORWERR Q
  1. . E D
  1. .. S PTEVT=$P($G(^OR(100,+ORIENS(ORIX),0)),U,17)
  1. .. D:$$TYPE^OREVNTX(PTEVT)="M" SAVE^ORMEVNT1(ORIENS(ORIX),PTEVT,2)
  1. . S X="RS"
  1. . S $P(ORWLST(ORIX),U,2)=X
  1. S J=0 F S J=$O(EVENT(J)) Q:'+J D UNLEVT^ORX2(J) ;195
  1. Q
  1. SEND(ORWLST,DFN,ORNP,ORL,ES,ORWREC) ; Sign
  1. ; DFN=Patient, ORNP=Provider, ORL=Location, ES=Encrypted ES code
  1. ; ORWREC(n)=ORIFN;Action^Signature Sts^Release Sts^Nature of Order
  1. SEND1 N ORVP,ORWI,ORWERR,ORWREL,ORWSIG,ORWNATR,ORDERID,ORBEF,ORLR,ORLAB,X,I
  1. S ORVP=DFN_";DPT(",ORL=ORL_";SC(",ORL(2)=ORL,ORWLST=0
  1. F I="LR","VBEC" S X=+$O(^DIC(9.4,"C",I,0)) S:X ORLR(X)=1
  1. S ORWI=0 F S ORWI=$O(ORWREC(ORWI)) Q:'ORWI D
  1. . S X=ORWREC(ORWI),ORWERR=""
  1. . S ORDERID=$P(X,U),ORWSIG=$P(X,U,2),ORWREL=$P(X,U,3),ORWNATR=$P(X,U,4)
  1. . S ORBEF=0
  1. . I '$D(^OR(100,+ORDERID,0)) Q
  1. . I $D(^OR(100,+ORDERID,8,+$P(ORDERID,";",2),0)) S ORBEF=$P(^OR(100,+ORDERID,8,+$P(ORDERID,";",2),0),U,15)
  1. . S:$D(^OR(100,+ORDERID,8,+$P(ORDERID,";",2),0)) ORWNATR=$S($P(^OR(100,+ORDERID,8,+$P(ORDERID,";",2),0),"^",4)=3:"",1:ORWNATR)
  1. . S ORWERR=$$CHKACT^ORWDXR(ORDERID,ORWSIG,ORWREL,ORWNATR)
  1. . I $L(ORWERR) S ORWERR="1^"_ORWERR
  1. . I '$L(ORWERR) D
  1. .. I $G(ORLR(+$P(^OR(100,+ORDERID,0),U,14))),'$G(ORLAB) D ; lab batch start
  1. ... I $L($T(BHS^ORMBLD)) D BHS^ORMBLD(ORVP) S ORLAB=1
  1. .. N OK S OK=$$LOCK1^ORX2(ORDERID) I 'OK S ORWERR="1^"_$P(OK,U,2)
  1. .. I OK D EN^ORCSEND(ORDERID,"",ORWSIG,ORWREL,ORWNATR,"",.ORWERR),UNLK1^ORX2(ORDERID)
  1. . S ORWLST(ORWI)=ORDERID,X=""
  1. . I $L(ORWERR) S ORWLST(ORWI)=ORWLST(ORWI)_"^E^"_ORWERR Q
  1. . I ORWREL,((ORBEF=10)!(ORBEF=11)),($P(^OR(100,+ORDERID,3),U,3)'=10) S X="R"
  1. . I ORWSIG'=2 S X=X_"S"
  1. . S $P(ORWLST(ORWI),U,2)=X
  1. I $G(ORLAB) D BTS^ORMBLD(ORVP)
  1. Q
  1. DLGID(VAL,ORIFN) ; return dlg IEN for order
  1. S VAL=$P(^OR(100,+ORIFN,0),U,5)
  1. S VAL=$S($P(VAL,";",2)="ORD(101.41,":+VAL,1:0)
  1. Q
  1. FORMID(VAL,ORIFN) ; Base dlg FormID for an order
  1. N DLG
  1. S VAL=0,DLG=$P(^OR(100,+ORIFN,0),U,5)
  1. Q:$P(DLG,";",2)'="ORD(101.41,"
  1. D FORMID^ORWDXM(.VAL,+DLG)
  1. Q
  1. AGAIN(VAL,DLG) ; return true to keep dlg for another order
  1. S VAL=''$P($G(^ORD(101.41,DLG,0)),U,9)
  1. Q
  1. DGRP(VAL,DLG) ; Display grp pointer for a dlg
  1. S DLG=$S($E(DLG)="`":+$P(DLG,"`",2),1:$O(^ORD(101.41,"AB",DLG,0))) ;kcm
  1. S VAL=$P($G(^ORD(101.41,DLG,0)),U,5)
  1. Q
  1. DGNM(VAL,NM) ; Display grp pointer for name
  1. S VAL=$O(^ORD(100.98,"B",NM,0))
  1. Q
  1. WRLST(LST,LOC) ; List of dlgs for writing orders
  1. G WRLST1^ORWDX1
  1. MSG(LST,IEN) ; Msg text for orderable item
  1. N I
  1. S I=0 F S I=$O(^ORD(101.43,IEN,8,I)) Q:I'>0 S LST(I)=^(I,0)
  1. Q
  1. DISMSG(VAL,IEN) ; Disabled mge for ordering dlg
  1. S VAL=$P($G(^ORD(101.41,+IEN,0)),U,3)
  1. Q
  1. LOCK(OK,DFN) ; Attempt to lock pt for ordering
  1. S OK=$$LOCK^ORX2(DFN)
  1. Q
  1. UNLOCK(OK,DFN) ; Unlock pt for ordering
  1. D UNLOCK^ORX2(DFN) S OK=1
  1. Q
  1. LOCKORD(OK,ORIFN) ; Attempt to lock order
  1. S OK=$$LOCK1^ORX2(ORIFN)
  1. Q
  1. UNLKORD(OK,ORIFN) ; Unlock order
  1. D UNLK1^ORX2(ORIFN) S OK=1
  1. Q
  1. UNLKOTH(OK,ORIFN) ; Unlock pt not by this session
  1. K ^XTMP("ORPTLK-"_ORIFN) S OK=1
  1. Q