ORWDX.m

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