ORWDXM4 ; SLC/KCM - Order Dialogs, Menus;01-Apr-2013 16:20;PLS
;;3.0;ORDER ENTRY/RESULTS REPORTING;**10,85,215,296,1010**;Dec 17, 1997;Build 47
; Modified - IHS/MSC/MGH - 06/04/12 - Line CHGSTS+3
; IHS/MSC/PLS - 04/01/13 - Line SETUP+2
SETUP ; -- setup dialog (continued from ORWDXM1)
; if xfer med order, setup ORDIALOG differently
;I ORWMODE,$$ISMED(ORIT),$$CHGSTS(ORCAT,ORIT) D MEDXFER Q
I ORWMODE,ORWMODE'=3,$$ISMED(ORIT),$$CHGSTS(ORCAT,ORIT) D MEDXFER Q
; get base dialog (based on display group) & location of responses
I ORWMODE D
. S ORDG=$P(^OR(100,+ORIT,0),U,11),ORDIALOG=+$P(^(0),U,5)
. S RSPREF="^OR(100,"_+ORIT_",4.5)"
E D
. N X0 S X0=$G(^ORD(101.41,ORIT,0))
. S ORDIALOG=$S($P(X0,U,4)="D":ORIT,1:0)
. S ORDG=$P(X0,U,5) Q:'ORDG
. I 'ORDIALOG S ORDIALOG=+$$DEFDLG^ORWDXQ(ORDG)
. S RSPREF="^ORD(101.41,"_ORIT_",6)"
; setup the ORDIALOG array
D GETDLG^ORCD(ORDIALOG)
D GETORDER^ORCD(RSPREF)
Q
SETUPS ; -- setup for specific types of dialogs (continued from ORWDXM1)
; pharmacy uses ORCAT to know order package
I ORDIALOG=$O(^ORD(101.41,"B","PSO OERR",0)) S ORCAT="O"
I ORDIALOG=$O(^ORD(101.41,"B","PSJ OR PAT OE",0)) D
. I ORCAT="O",'ORIMO S ORWPSWRG="" ; not auto-ack, pt not inpt
. S ORCAT="I"
I ORCAT="O",$D(OREVENT("EFFECTIVE")),(ORDG=+$O(^ORD(100.98,"B","O RX",0))) D
. S ORDIALOG($O(^ORD(101.41,"B",X,0)),1)=OREVENT("EFFECTIVE")
I ORDIALOG=$O(^ORD(101.41,"B","RA OERR EXAM",0)) D RA^ORWDXM2 G XENV
I ORDIALOG=$O(^ORD(101.41,"B","LR OTHER LAB TESTS",0)) D LR^ORWDXM2 G XENV
I ORDIALOG=$O(^ORD(101.41,"B","FHW1",0)) D DO^ORWDXM2 G XENV
I ORDIALOG=$O(^ORD(101.41,"B","FHW2",0)) D EL^ORWDXM2 G XENV
I ORDIALOG=$O(^ORD(101.41,"B","PSJ OR PAT OE",0)) D UD^ORWDXM2 G XENV
I ORDIALOG=$O(^ORD(101.41,"B","PSJI OR PAT FLUID OE",0)) D IV^ORWDXM2 G XENV
I ORDIALOG=$O(^ORD(101.41,"B","PSO OERR",0)) D OP^ORWDXM2 G XENV
I ORDIALOG=$O(^ORD(101.41,"B","PSO SUPPLY",0)) D OP^ORWDXM2 G XENV
I ORDIALOG=$O(^ORD(101.41,"B","PS MEDS",0)) D PS^ORWDPS3 G XENV
I ORDIALOG=$O(^ORD(101.41,"B","VBEC BLOOD BANK",0)) D VB^ORWDXM4 G XENV
I ORDIALOG=$O(^ORD(101.41,"B","GMRAOR ALLERGY ENTER/EDIT",0)) S ORQUIT=1
XENV ; end case
Q
MEDXFER ; -- setup ORDIALOG for a med that is transferred (from SETUP)
;
; use ORWDPS3 if OR*3*94 installed
I ORWP94 G MEDXFER^ORWDPS3
;
N UDLG,FDLG,ODLG,DLG,OI K ^TMP("PS",$J)
S UDLG=$O(^ORD(101.41,"AB","PSJ OR PAT OE",0))
S FDLG=$O(^ORD(101.41,"AB","PSJI OR PAT FLUID OE",0))
S ODLG=$O(^ORD(101.41,"AB","PSO OERR",0))
S DLG=$P($G(^OR(100,+ORIT,0)),U,5)
S ORDIALOG=$S(+DLG=UDLG:ODLG,+DLG=ODLG:UDLG,+DLG=FDLG:FDLG,1:0)
I 'ORDIALOG D SETERR(ORIT,"Incomplete Order Record") Q
S ORDG=+$P(^ORD(101.41,ORDIALOG,0),U,5)
D GETDLG^ORCD(ORDIALOG)
D GETORDER^ORCD("^OR(100,"_+ORIT_",4.5)")
S OI=$$VAL^ORCD("MEDICATION")
I '$$MEDOK(OI,ORCAT) D SETERR(ORIT,"This may not be ordered as an "_$S(ORCAT="I":"in",1:"out")_"patient drug.") Q
I $G(^ORD(101.43,OI,.1)),(^(.1)<$$NOW^XLFDT) D SETERR(ORIT,"This may no longer be ordered.") Q
K ORDIALOG($$PTR("DISPENSE DRUG"),1)
K ORDIALOG($$PTR("WORD PROCESSING 1"),1)
I ORDIALOG=ODLG D IN2OUT ; could call IN^ORCMED except for writes
I ORDIALOG=UDLG D OUT2IN ; could call OUT^ORCMED except for writes
Q
IN2OUT ; -- make inpatient responses into outpatient
N I,DDRUG,PKGID,DOSE
S DOSE=$G(ORDIALOG($$PTR("INSTRUCTIONS"),1))
F I="INSTRUCTIONS","UNITS/DOSE","FREE TEXT","DISPENSE DRUG" K ORDIALOG($$PTR(I),1)
S PKGID=$G(^OR(100,+ORIT,4))_";"_$P(^(0),U,12)
D OEL^PSOORRL(+ORVP,PKGID) S DDRUG=$G(^TMP("PS",$J,"DD",1,0))
I $P(DDRUG,U,3) S ORDIALOG($$PTR("DISPENSE DRUG"),1)=$P(DDRUG,U,3)
; keep instructions if IV med, otherwise use units returned
I $P($G(^ORD(101.43,OI,"PS")),U)=2 S ORDIALOG($$PTR("INSTRUCTIONS"),1)=DOSE
E S:$P(DDRUG,U,2) ORDIALOG($$PTR("INSTRUCTIONS"),1)=$P(DDRUG,U,2)
; change orderable item if new orderable item returned
I $P(DDRUG,U,4),$P(DDRUG,U,4)'=+$P($G(^ORD(101.43,OI,0)),U,2) D
. S OI=+$O(^ORD(101.43,"ID",+$P(DDRUG,U,4)_";99PSP",0))
. S:OI ORDIALOG($$PTR("ORDERABLE ITEM"),1)=OI
Q
OUT2IN ; make outpatient responses into inpatient
N ORP,ORI,PROMPT,PKGID,DDRUG,ONE
D CHANGED^ORCDPS("XFR") ; Kill extra values not in inpt dialog
S PKGID=$G(^OR(100,+ORIT,4))_";"_$P(^(0),U,12)
D OEL^PSOORRL(+ORVP,PKGID) S DDRUG=$G(^TMP("PS",$J,"DD",1,0))
S:$P(DDRUG,U,3) ORDIALOG($$PTR("DISPENSE DRUG"),1)=$P(DDRUG,U,3)
I $P(DDRUG,U,4),$P(DDRUG,U,4)'=+$P($G(^ORD(101.43,+OI,0)),U,2) D
. S OI=+$O(^ORD(101.43,"ID",+$P(DDRUG,U,4)_";99PSP",0))
. S:OI ORDIALOG($$PTR("ORDERABLE ITEM"),1)=OI
S ONE=$O(ORDIALOG($$PTR("INSTRUCTIONS"),0)) ; first inst
F ORP="ROUTE","SCHEDULE" D
. S ORI=0,PROMPT=$$PTR(ORP)
. F S ORI=$O(ORDIALOG(PROMPT,ORI)) Q:ORI'>0 I ORDIALOG(PROMPT,ORI)=""!(ORI>ONE) K ORDIALOG(PROMPT,ORI)
Q
PTR(NAME) ; -- Returns pointer to OR GTX NAME (copied from ORCMED)
Q +$O(^ORD(101.41,"AB",$E("OR GTX "_NAME,1,63),0))
;
MEDOK(OI,CAT) ; return 1 if med may be ordered for this patient category
N P S P=$S(CAT="I":1,1:2)
Q $P($G(^ORD(101.43,+OI,"PS")),U,P)
;
CHGSTS(ECAT,IFN) ; return 1 if out to in or in to out
N OCAT,PKG
S OCAT=$P($G(^OR(100,+IFN,0)),U,12)
;IHS/MSC/MGH patch 1010
S PKG=$P($G(^OR(100,+IFN,0)),U,14)
I $P($G(^DIC(9.4,PKG,0)),U,2)="PSH" S OCAT="O"
Q OCAT'=ECAT
;
ISMED(IFN) ; return 1 if this is a pharmacy order
N PKG S PKG=$P($G(^OR(100,+IFN,0)),U,14)
Q $$NMSP^ORCD(PKG)="PS"
SETERR(ID,X) ; sets LST to rejection with error message
D GETTXT^ORWORR(.LST,ID)
S LST(0)="8^0",LST(.5)=X,LST(.6)=""
Q
VB ; setup environment for VBECS
; -- setup ORTIME, ORIMTIME arrays
D GETIMES^ORCDLR1
; -- setup ORCOMP, ORTEST, and ORTAS
S (ORCOMP,ORTEST,ORTAS)=""
N P,I,X,X0 S P=+$O(^ORD(101.41,"AB","OR GTX ORDERABLE ITEM",0))
S I=0 F S I=$O(ORDIALOG(P,I)) Q:I<1 S X=+$G(ORDIALOG(P,I)) D
. S X0=$G(^ORD(101.43,X,"VB")),X=+$P($G(^(0)),U,2)
. I $P(X0,U) S ORCOMP=ORCOMP_$S($L(ORCOMP):U,1:"")_X Q
. S ORTEST=ORTEST_$S($L(ORTEST):U,1:"")_X
. I X=2 S ORTAS=1
Q
VBASK(I) ; set the ORASK variable for child component prompts in VBECS order
I ORDIALOG'=$O(^ORD(101.41,"B","VBEC BLOOD BANK",0)) Q
N P S P=+$O(^ORD(101.41,"AB","OR GTX ORDERABLE ITEM",0))
N OI S OI=+$G(ORDIALOG(P,I))
I +$G(^ORD(101.43,+$G(OI),"VB")) S ORASK=1
Q
VBQO(IFN) ;Check to see if it's a good VBECS QO
;regular order treated as good QO
;
I $P($G(^ORD(101.41,IFN,0)),U,4)'="Q" Q 1
N ODP,ODG,RESULT,P,TNS,I
S RESULT=0
S ODP=+$P($G(^ORD(101.41,IFN,0)),U,7),ODG=+$P($G(^(0)),U,5)
S ODP=$$GET1^DIQ(9.4,+ODP_",",1),ODG=$P($G(^ORD(100.98,ODG,0)),U,3)
I ODP'["VBEC" Q 1
Q RESULT
ORWDXM4 ; SLC/KCM - Order Dialogs, Menus;01-Apr-2013 16:20;PLS
+1 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**10,85,215,296,1010**;Dec 17, 1997;Build 47
+2 ; Modified - IHS/MSC/MGH - 06/04/12 - Line CHGSTS+3
+3 ; IHS/MSC/PLS - 04/01/13 - Line SETUP+2
SETUP ; -- setup dialog (continued from ORWDXM1)
+1 ; if xfer med order, setup ORDIALOG differently
+2 ;I ORWMODE,$$ISMED(ORIT),$$CHGSTS(ORCAT,ORIT) D MEDXFER Q
+3 IF ORWMODE
IF ORWMODE'=3
IF $$ISMED(ORIT)
IF $$CHGSTS(ORCAT,ORIT)
DO MEDXFER
QUIT
+4 ; get base dialog (based on display group) & location of responses
+5 IF ORWMODE
Begin DoDot:1
+6 SET ORDG=$PIECE(^OR(100,+ORIT,0),U,11)
SET ORDIALOG=+$PIECE(^(0),U,5)
+7 SET RSPREF="^OR(100,"_+ORIT_",4.5)"
End DoDot:1
+8 IF '$TEST
Begin DoDot:1
+9 NEW X0
SET X0=$GET(^ORD(101.41,ORIT,0))
+10 SET ORDIALOG=$SELECT($PIECE(X0,U,4)="D":ORIT,1:0)
+11 SET ORDG=$PIECE(X0,U,5)
IF 'ORDG
QUIT
+12 IF 'ORDIALOG
SET ORDIALOG=+$$DEFDLG^ORWDXQ(ORDG)
+13 SET RSPREF="^ORD(101.41,"_ORIT_",6)"
End DoDot:1
+14 ; setup the ORDIALOG array
+15 DO GETDLG^ORCD(ORDIALOG)
+16 DO GETORDER^ORCD(RSPREF)
+17 QUIT
SETUPS ; -- setup for specific types of dialogs (continued from ORWDXM1)
+1 ; pharmacy uses ORCAT to know order package
+2 IF ORDIALOG=$ORDER(^ORD(101.41,"B","PSO OERR",0))
SET ORCAT="O"
+3 IF ORDIALOG=$ORDER(^ORD(101.41,"B","PSJ OR PAT OE",0))
Begin DoDot:1
+4 ; not auto-ack, pt not inpt
IF ORCAT="O"
IF 'ORIMO
SET ORWPSWRG=""
+5 SET ORCAT="I"
End DoDot:1
+6 IF ORCAT="O"
IF $DATA(OREVENT("EFFECTIVE"))
IF (ORDG=+$ORDER(^ORD(100.98,"B","O RX",0)))
Begin DoDot:1
+7 SET ORDIALOG($ORDER(^ORD(101.41,"B",X,0)),1)=OREVENT("EFFECTIVE")
End DoDot:1
+8 IF ORDIALOG=$ORDER(^ORD(101.41,"B","RA OERR EXAM",0))
DO RA^ORWDXM2
GOTO XENV
+9 IF ORDIALOG=$ORDER(^ORD(101.41,"B","LR OTHER LAB TESTS",0))
DO LR^ORWDXM2
GOTO XENV
+10 IF ORDIALOG=$ORDER(^ORD(101.41,"B","FHW1",0))
DO DO^ORWDXM2
GOTO XENV
+11 IF ORDIALOG=$ORDER(^ORD(101.41,"B","FHW2",0))
DO EL^ORWDXM2
GOTO XENV
+12 IF ORDIALOG=$ORDER(^ORD(101.41,"B","PSJ OR PAT OE",0))
DO UD^ORWDXM2
GOTO XENV
+13 IF ORDIALOG=$ORDER(^ORD(101.41,"B","PSJI OR PAT FLUID OE",0))
DO IV^ORWDXM2
GOTO XENV
+14 IF ORDIALOG=$ORDER(^ORD(101.41,"B","PSO OERR",0))
DO OP^ORWDXM2
GOTO XENV
+15 IF ORDIALOG=$ORDER(^ORD(101.41,"B","PSO SUPPLY",0))
DO OP^ORWDXM2
GOTO XENV
+16 IF ORDIALOG=$ORDER(^ORD(101.41,"B","PS MEDS",0))
DO PS^ORWDPS3
GOTO XENV
+17 IF ORDIALOG=$ORDER(^ORD(101.41,"B","VBEC BLOOD BANK",0))
DO VB^ORWDXM4
GOTO XENV
+18 IF ORDIALOG=$ORDER(^ORD(101.41,"B","GMRAOR ALLERGY ENTER/EDIT",0))
SET ORQUIT=1
XENV ; end case
+1 QUIT
MEDXFER ; -- setup ORDIALOG for a med that is transferred (from SETUP)
+1 ;
+2 ; use ORWDPS3 if OR*3*94 installed
+3 IF ORWP94
GOTO MEDXFER^ORWDPS3
+4 ;
+5 NEW UDLG,FDLG,ODLG,DLG,OI
KILL ^TMP("PS",$JOB)
+6 SET UDLG=$ORDER(^ORD(101.41,"AB","PSJ OR PAT OE",0))
+7 SET FDLG=$ORDER(^ORD(101.41,"AB","PSJI OR PAT FLUID OE",0))
+8 SET ODLG=$ORDER(^ORD(101.41,"AB","PSO OERR",0))
+9 SET DLG=$PIECE($GET(^OR(100,+ORIT,0)),U,5)
+10 SET ORDIALOG=$SELECT(+DLG=UDLG:ODLG,+DLG=ODLG:UDLG,+DLG=FDLG:FDLG,1:0)
+11 IF 'ORDIALOG
DO SETERR(ORIT,"Incomplete Order Record")
QUIT
+12 SET ORDG=+$PIECE(^ORD(101.41,ORDIALOG,0),U,5)
+13 DO GETDLG^ORCD(ORDIALOG)
+14 DO GETORDER^ORCD("^OR(100,"_+ORIT_",4.5)")
+15 SET OI=$$VAL^ORCD("MEDICATION")
+16 IF '$$MEDOK(OI,ORCAT)
DO SETERR(ORIT,"This may not be ordered as an "_$SELECT(ORCAT="I":"in",1:"out")_"patient drug.")
QUIT
+17 IF $GET(^ORD(101.43,OI,.1))
IF (^(.1)<$$NOW^XLFDT)
DO SETERR(ORIT,"This may no longer be ordered.")
QUIT
+18 KILL ORDIALOG($$PTR("DISPENSE DRUG"),1)
+19 KILL ORDIALOG($$PTR("WORD PROCESSING 1"),1)
+20 ; could call IN^ORCMED except for writes
IF ORDIALOG=ODLG
DO IN2OUT
+21 ; could call OUT^ORCMED except for writes
IF ORDIALOG=UDLG
DO OUT2IN
+22 QUIT
IN2OUT ; -- make inpatient responses into outpatient
+1 NEW I,DDRUG,PKGID,DOSE
+2 SET DOSE=$GET(ORDIALOG($$PTR("INSTRUCTIONS"),1))
+3 FOR I="INSTRUCTIONS","UNITS/DOSE","FREE TEXT","DISPENSE DRUG"
KILL ORDIALOG($$PTR(I),1)
+4 SET PKGID=$GET(^OR(100,+ORIT,4))_";"_$PIECE(^(0),U,12)
+5 DO OEL^PSOORRL(+ORVP,PKGID)
SET DDRUG=$GET(^TMP("PS",$JOB,"DD",1,0))
+6 IF $PIECE(DDRUG,U,3)
SET ORDIALOG($$PTR("DISPENSE DRUG"),1)=$PIECE(DDRUG,U,3)
+7 ; keep instructions if IV med, otherwise use units returned
+8 IF $PIECE($GET(^ORD(101.43,OI,"PS")),U)=2
SET ORDIALOG($$PTR("INSTRUCTIONS"),1)=DOSE
+9 IF '$TEST
IF $PIECE(DDRUG,U,2)
SET ORDIALOG($$PTR("INSTRUCTIONS"),1)=$PIECE(DDRUG,U,2)
+10 ; change orderable item if new orderable item returned
+11 IF $PIECE(DDRUG,U,4)
IF $PIECE(DDRUG,U,4)'=+$PIECE($GET(^ORD(101.43,OI,0)),U,2)
Begin DoDot:1
+12 SET OI=+$ORDER(^ORD(101.43,"ID",+$PIECE(DDRUG,U,4)_";99PSP",0))
+13 IF OI
SET ORDIALOG($$PTR("ORDERABLE ITEM"),1)=OI
End DoDot:1
+14 QUIT
OUT2IN ; make outpatient responses into inpatient
+1 NEW ORP,ORI,PROMPT,PKGID,DDRUG,ONE
+2 ; Kill extra values not in inpt dialog
DO CHANGED^ORCDPS("XFR")
+3 SET PKGID=$GET(^OR(100,+ORIT,4))_";"_$PIECE(^(0),U,12)
+4 DO OEL^PSOORRL(+ORVP,PKGID)
SET DDRUG=$GET(^TMP("PS",$JOB,"DD",1,0))
+5 IF $PIECE(DDRUG,U,3)
SET ORDIALOG($$PTR("DISPENSE DRUG"),1)=$PIECE(DDRUG,U,3)
+6 IF $PIECE(DDRUG,U,4)
IF $PIECE(DDRUG,U,4)'=+$PIECE($GET(^ORD(101.43,+OI,0)),U,2)
Begin DoDot:1
+7 SET OI=+$ORDER(^ORD(101.43,"ID",+$PIECE(DDRUG,U,4)_";99PSP",0))
+8 IF OI
SET ORDIALOG($$PTR("ORDERABLE ITEM"),1)=OI
End DoDot:1
+9 ; first inst
SET ONE=$ORDER(ORDIALOG($$PTR("INSTRUCTIONS"),0))
+10 FOR ORP="ROUTE","SCHEDULE"
Begin DoDot:1
+11 SET ORI=0
SET PROMPT=$$PTR(ORP)
+12 FOR
SET ORI=$ORDER(ORDIALOG(PROMPT,ORI))
IF ORI'>0
QUIT
IF ORDIALOG(PROMPT,ORI)=""!(ORI>ONE)
KILL ORDIALOG(PROMPT,ORI)
End DoDot:1
+13 QUIT
PTR(NAME) ; -- Returns pointer to OR GTX NAME (copied from ORCMED)
+1 QUIT +$ORDER(^ORD(101.41,"AB",$EXTRACT("OR GTX "_NAME,1,63),0))
+2 ;
MEDOK(OI,CAT) ; return 1 if med may be ordered for this patient category
+1 NEW P
SET P=$SELECT(CAT="I":1,1:2)
+2 QUIT $PIECE($GET(^ORD(101.43,+OI,"PS")),U,P)
+3 ;
CHGSTS(ECAT,IFN) ; return 1 if out to in or in to out
+1 NEW OCAT,PKG
+2 SET OCAT=$PIECE($GET(^OR(100,+IFN,0)),U,12)
+3 ;IHS/MSC/MGH patch 1010
+4 SET PKG=$PIECE($GET(^OR(100,+IFN,0)),U,14)
+5 IF $PIECE($GET(^DIC(9.4,PKG,0)),U,2)="PSH"
SET OCAT="O"
+6 QUIT OCAT'=ECAT
+7 ;
ISMED(IFN) ; return 1 if this is a pharmacy order
+1 NEW PKG
SET PKG=$PIECE($GET(^OR(100,+IFN,0)),U,14)
+2 QUIT $$NMSP^ORCD(PKG)="PS"
SETERR(ID,X) ; sets LST to rejection with error message
+1 DO GETTXT^ORWORR(.LST,ID)
+2 SET LST(0)="8^0"
SET LST(.5)=X
SET LST(.6)=""
+3 QUIT
VB ; setup environment for VBECS
+1 ; -- setup ORTIME, ORIMTIME arrays
+2 DO GETIMES^ORCDLR1
+3 ; -- setup ORCOMP, ORTEST, and ORTAS
+4 SET (ORCOMP,ORTEST,ORTAS)=""
+5 NEW P,I,X,X0
SET P=+$ORDER(^ORD(101.41,"AB","OR GTX ORDERABLE ITEM",0))
+6 SET I=0
FOR
SET I=$ORDER(ORDIALOG(P,I))
IF I<1
QUIT
SET X=+$GET(ORDIALOG(P,I))
Begin DoDot:1
+7 SET X0=$GET(^ORD(101.43,X,"VB"))
SET X=+$PIECE($GET(^(0)),U,2)
+8 IF $PIECE(X0,U)
SET ORCOMP=ORCOMP_$SELECT($LENGTH(ORCOMP):U,1:"")_X
QUIT
+9 SET ORTEST=ORTEST_$SELECT($LENGTH(ORTEST):U,1:"")_X
+10 IF X=2
SET ORTAS=1
End DoDot:1
+11 QUIT
VBASK(I) ; set the ORASK variable for child component prompts in VBECS order
+1 IF ORDIALOG'=$ORDER(^ORD(101.41,"B","VBEC BLOOD BANK",0))
QUIT
+2 NEW P
SET P=+$ORDER(^ORD(101.41,"AB","OR GTX ORDERABLE ITEM",0))
+3 NEW OI
SET OI=+$GET(ORDIALOG(P,I))
+4 IF +$GET(^ORD(101.43,+$GET(OI),"VB"))
SET ORASK=1
+5 QUIT
VBQO(IFN) ;Check to see if it's a good VBECS QO
+1 ;regular order treated as good QO
+2 ;
+3 IF $PIECE($GET(^ORD(101.41,IFN,0)),U,4)'="Q"
QUIT 1
+4 NEW ODP,ODG,RESULT,P,TNS,I
+5 SET RESULT=0
+6 SET ODP=+$PIECE($GET(^ORD(101.41,IFN,0)),U,7)
SET ODG=+$PIECE($GET(^(0)),U,5)
+7 SET ODP=$$GET1^DIQ(9.4,+ODP_",",1)
SET ODG=$PIECE($GET(^ORD(100.98,ODG,0)),U,3)
+8 IF ODP'["VBEC"
QUIT 1
+9 QUIT RESULT
