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