ORWDXM2 ; SLC/KCM - Quick Orders ; 11/1/11 11:30am
;;3.0;ORDER ENTRY/RESULTS REPORTING;**10,85,109,116,132,158,187,195,215,243,280,356,377**;Dec 17, 1997;Build 582
;
ADMTIME(ORDLOC,PATLOC,ENCLOC,DELAY,ISIMO) ;
N ADMLOC,INST,SCHLOC,SCHTYPE
S ADMLOC=+$P($G(ORDIALOG("B","ADMINISTRATION TIMES")),U,2)
I ADMLOC>0,ORDLOC>0,PATLOC'=ORDLOC D Q
.S INST=0 F S INST=$O(ORDIALOG(ADMLOC,INST)) Q:+INST'>0 D
..S ORDIALOG(ADMLOC,INST)=""
I ADMLOC>0,$S(ENCLOC'=PATLOC:1,ISIMO:1,DELAY:1,1:0) D Q
.S INST=0 F S INST=$O(ORDIALOG(ADMLOC,INST)) Q:+INST'>0 D
..S ORDIALOG(ADMLOC,INST)=""
S SCHLOC=+$P($G(ORDIALOG("B","SCHEDULE TYPE")),U,2) Q:SCHLOC'>0
S INST=0 F S INST=$O(ORDIALOG(SCHLOC,INST)) Q:+INST'>0 D
.S SCHTYP=$G(ORDIALOG(SCHLOC,INST)) Q:SCHTYP=""
.I $S(SCHTYP="P":1,SCHTYP="O":1,SCHTYP="OC":1,1:0),ADMLOC>0 S ORDIALOG(ADMLOC,INST)=""
Q
;
CLRRCL(OK) ; clear ORECALL
S OK=1
K ^TMP("ORECALL",$J),^TMP("ORWDXMQ",$J)
Q
VERTXT ; set verify text for order
N SEQ,DA,X,PROMPT,MULT,CHILD,INST,TITLE,TEMP,ILST,SPACES
N ISADMIN
S ILST=0,$P(SPACES," ",31)=""
S SEQ=0 F S SEQ=$O(^ORD(101.41,+ORDIALOG,10,"B",SEQ)) Q:SEQ'>0 D
. S DA=0 F S DA=$O(^ORD(101.41,+ORDIALOG,10,"B",SEQ,DA)) Q:'DA D
. . S X0=$G(^ORD(101.41,+ORDIALOG,10,DA,0))
. . S ISADMIN=$S(+OREVENT>0:0,ISIMO=1:0,$P($G(^ORD(101.41,$P(X0,U,2),0)),U)="OR GTX ADMIN TIMES":1,1:0)
. . I ISADMIN=1,ORDLOC>0,ORDLOC'=PATLOC Q
. . I $P(X0,U,9)["*",ISADMIN=0 Q
. . S PROMPT=$P(X0,U,2),MULT=$P(X0,U,7),CHILD=$P(X0,U,11) I CHILD,ISADMIN=0 Q
. . Q:'PROMPT S INST=$O(ORDIALOG(PROMPT,0)) Q:'INST ; no values
. . S TITLE=$S($L($G(ORDIALOG(PROMPT,"TTL"))):ORDIALOG(PROMPT,"TTL"),1:ORDIALOG(PROMPT,"A"))
. . I $E(ORDIALOG(PROMPT,0))="W" D
. . . N IWP,WP,CNT
. . . S IWP=0,CNT=0
. . . F S IWP=$O(^TMP("ORWORD",$J,PROMPT,INST,IWP)) Q:'IWP D
. . . . S CNT=CNT+1,WP(CNT)=^TMP("ORWORD",$J,PROMPT,INST,IWP,0)
. . . I CNT=1 S ILST=ILST+1,LST(ILST)=$J(TITLE,30)_WP(1)
. . . I CNT>1 D
. . . . S ILST=ILST+1,LST(ILST)=TITLE,IWP=0
. . . . F S IWP=$O(WP(IWP)) Q:'IWP S ILST=ILST+1,LST(ILST)=WP(IWP)
. . E D
. . . S TEMP=$$ITEM^ORCDLG(PROMPT,INST) I TEMP="" Q
. . . S ILST=ILST+1,LST(ILST)=$J(TITLE,30)
. . . ;S LST(ILST)=LST(ILST)_$$ITEM^ORCDLG(PROMPT,INST)
. . . S LST(ILST)=LST(ILST)_TEMP
. . Q:'MULT Q:'$O(ORDIALOG(PROMPT,INST)) ; done
. . F S INST=$O(ORDIALOG(PROMPT,INST)) Q:INST'>0 S ILST=ILST+1,LST(ILST)=SPACES_$$ITEM^ORCDLG(PROMPT,INST)
;*356 Only display SC and TF for orders that are not new.
I $G(ORWMODE) D DISPLAY^ORWDBA3 ;for display of Billing Aware data from orig order
Q
RA ; setup environment for radiology
; -- get imaging types based on display group of quick order and
; setup list of imaging locations based on imaging type
N ISPREG,ORY,ITYPE,IFN,CNT,ORIMLOC,PROMPT
S ORDIV=$$DIV^ORCDRA1,ITYPE=$P($G(^ORD(100.98,+ORDG,0)),U,3)
S ORIMTYPE=$O(^RA(79.2,"C",ITYPE,0))
D EN4^RAO7PC1(ITYPE,"ORY")
S (IFN,CNT)=0 F S IFN=$O(ORY(IFN)) Q:IFN'>0 D
. S CNT=CNT+1,ORIMLOC(CNT)=ORY(IFN),ORIMLOC("B",$P(ORY(IFN),U,2))=IFN
I '$$GET^XPAR("ALL","RA SUBMIT PROMPT",1,"Q"),CNT>1 K ORIMLOC
E S ORIMLOC=CNT_"^1"
S PROMPT=$O(^ORD(101.41,"B","OR GTX IMAGING LOCATION",0))
I $G(ORIMLOC) M ORDIALOG(PROMPT,"LIST")=ORIMLOC
Q
LR ; setup environment for lab
; -- setup ORTIME, ORIMTIME & ORTEST arrays
; setup ORMAX, ORDG, & ORCOLLCT variables
N PROMPT,INST,EDITONLY
D GETIMES^ORCDLR1 ; sets up ORTIME and ORIMTIME arrays
S ORMAX=$$GET^XPAR("ALL^LOC.`"_+ORL,"LR MAX DAYS CONTINUOUS",1,"Q")
S PROMPT=$O(^ORD(101.41,"B","OR GTX ORDERABLE ITEM",0)),INST=1
D LRTEST ; sets up ORTEST array and ORDG
S PROMPT=$O(^ORD(101.41,"B","OR GTX COLLECTION TYPE",0))
I $D(ORDIALOG(PROMPT,1)) S ORCOLLCT=ORDIALOG(PROMPT,1) I 1
E S EDITONLY=0,ORCOLLCT=$$COLLTYPE^ORCDLR1
I ORCOLLCT="I" D
. S PROMPT=$O(^ORD(101.41,"B","OR GTX START DATE/TIME",0))
. D LRICTMOK
S PROMPT=$O(^ORD(101.41,"B","OR GTX ADMIN SCHEDULE",0))
I $D(ORDIALOG(PROMPT,1)) S ORSCH=ORDIALOG(PROMPT,1)
Q
LRTEST ; -- Setup ORTEST() array of ordering parameters (copied from ORCDLR)
N OI,TST,DG
S OI=+$G(ORDIALOG(PROMPT,INST)) Q:'OI
I '$D(ORTEST) S TST=+$P($G(^ORD(101.43,OI,0)),U,2) D TEST^LR7OR3(TST,.ORTEST) S ORTEST=TST
S DG=$P($G(^ORD(101.43,+OI,"LR")),U,6) S:'$L(DG) DG="LAB"
S DG=$O(^ORD(100.98,"B",DG,0)) S:DG ORDG=DG
Q
LRRQCM() ; return true if lab test has required comments
I $O(^TMP("ORWORD",$J,PROMPT,INST,0)) Q 1 ; edit via WP
N LRTEST,LRSAMP,LRSPEC,LRTSTN,LRTCOM,LRCCOM,DA,CNT,I,REQDCOMM,OI,TST
S LRSAMP=$$VAL^ORCD("COLLECTION SAMPLE"),LRSPEC=$$VAL^ORCD("SPECIMEN")
S OI=+$G(ORDIALOG(PROMPT,INST)) Q:'OI 0
I '$D(ORTEST) S TST=+$P($G(^ORD(101.43,OI,0)),U,2) D TEST^LR7OR3(TST,.ORTEST) S ORTEST=TST
S LRTSTN=1,LRTEST(1)=+ORTEST,DA=$O(^LAB(60,LRTEST(1),3,"B",+LRSAMP,0))
S REQDCOMM=$P($G(^LAB(60,LRTEST(1),3,+DA,0)),U,6)
S:'REQDCOMM REQDCOMM=+$P($G(^LAB(60,LRTEST(1),0)),U,19)
Q REQDCOMM
LRASMP() ; return true to ask collection sample (from ASKSAMP^ORCDLR)
N DEFSAMP,SAMP0
S DEFSAMP=$G(ORDIALOG(PROMPT,INST)),SAMP0=$G(^LAB(62,+DEFSAMP,0))
I (ORCOLLCT="LC")!(ORCOLLCT="I"),$G(ORTEST("Lab CollSamp")) Q 0
I $G(ORTEST("Unique CollSamp")),DEFSAMP Q 0 ; unique -> don't ask
I 'DEFSAMP!('FIRST) Q 1 ; no default or edit -> ask
I $G(ORDIALOG(PROMPT,"LIST"))="1^1" Q 0 ; only one choice
Q 1
LRICTMOK ;
Q:'$D(ORDIALOG(PROMPT,1))
N ORY
D VALDT^ORWU(.ORY,ORDIALOG(PROMPT,1))
I +$$VALID^LR7OV4(DUZ(2),ORY)=0 S ORDIALOG(PROMPT,1)=""
Q
DO ; setup environment for diet order
; partially copied from EN^ORCDFH
I ORCAT'="I" D Q
. S ORQUIT=1
. S LST(0)="8^0"
. S LST(.5)="This type of diet may be entered for inpatients only."
D EN^FHWOR8(+ORVP,.ORPARAM) ; set FH ordering parameters
S:'$L($G(ORPARAM(3))) ORPARAM(3)="T" ; for now
N PROMPT,OI ; set NPO flag if NPO diet
S PROMPT=$O(^ORD(101.41,"B","OR GTX ORDERABLE ITEM",0))
S OI=+$G(ORDIALOG(PROMPT,1))
S ORNPO=($P($G(^ORD(101.43,OI,0)),U)="NPO")
S PROMPT=$O(^ORD(101.41,"B","OR GTX START DATE/TIME",0))
S X=$G(ORDIALOG(PROMPT,1)) I $L(X) D CNV^ORCDFH1 S ORDIALOG(PROMPT,1)=$G(X)
;AGP TEST FOR ACTIVE TUBEFEEDING ORDERS
I $$CURRENT^ORCDFH("TF")>0 S AUTOACK=0
Q
EL ; setup environment for early/late tray
D EN^FHWOR8(+ORVP,.ORPARAM) ; set FH ordering parameters
S:'$L($G(ORPARAM(3))) ORPARAM(3)="T" ; for now
D EN2^ORCDFH ; setup ORTIME array
N PROMPT ; set ORMEAL,ORTRAY
S PROMPT=$O(^ORD(101.41,"B","OR GTX MEAL",0))
I $D(ORDIALOG(PROMPT,1)) S ORMEAL=ORDIALOG(PROMPT,1)
S PROMPT=$O(^ORD(101.41,"B","OR GTX ORDERABLE ITEM",0))
I $D(ORDIALOG(PROMPT,1)) S ORTRAY=ORDIALOG(PROMPT,1)
;AGP TEST FOR ACTIVE TUBEFEEDING ORDERS
I $$CURRENT^ORCDFH("TF")>0 S AUTOACK=0
Q
UD ; setup environment for unit dose med
I $G(ORWP94) G PS^ORWDPS3 ; if patch 94 installed
;
D AUTHMED Q:$G(ORQUIT) ; checks authorized to write meds
N PROMPT,OI
S PROMPT=$O(^ORD(101.41,"B","OR GTX ORDERABLE ITEM",0))
I $D(ORDIALOG(PROMPT,1)) S OI=ORDIALOG(PROMPT,1) D MEDACTV(1) Q:$G(ORQUIT)
D INSTR^ORCDPS(OI) ; sets up instructions, routes, etc.
D CHOICES^ORCDPS("U") ; gets list of dispense drugs
Q
IV ; setup environment for IV fluid
D AUTHMED Q:$G(ORQUIT) ; checks authorized to write meds
; sets up list of volumes if only one solution
; otherwise, let the dialog go interactive
N PROMPT,INST,CNT,OI
S PROMPT=$O(^ORD(101.41,"B","OR GTX ORDERABLE ITEM",0))
S (CNT,INST)=0
F S INST=$O(ORDIALOG(PROMPT,INST)) Q:'INST D Q:$G(ORQUIT)
. S CNT=CNT+1
. S OI=ORDIALOG(PROMPT,INST) D MEDACTV(3) ; check active solutions
I CNT=1 S INST=1 D VOLUME^ORCDPSIV
S PROMPT=$O(^ORD(101.41,"B","OR GTX ADDITIVE",0))
S INST=0
F S INST=$O(ORDIALOG(PROMPT,INST)) Q:'INST D Q:$G(ORQUIT)
. S OI=ORDIALOG(PROMPT,INST) D MEDACTV(4) ; check active additives
Q
OP ; setup environment for outpatient pharmacy
I $G(ORWP94) G PS^ORWDPS3 ; if patch 94 installed
;
D AUTHMED Q:$G(ORQUIT) ; checks authorized to write meds
N PROMPT,INST,CNT,OI
S PROMPT=$O(^ORD(101.41,"B","OR GTX ORDERABLE ITEM",0)),OI=0
I $D(ORDIALOG(PROMPT,1)) S OI=$G(ORDIALOG(PROMPT,1)) D MEDACTV(2) Q:$G(ORQUIT)
D:+OI INSTR^ORCDPS(OI) ; sets up instructions, routes, etc.
D CHOICES^ORCDPS("O") ; gets list of dispense drugs
; get defaults for drug, refills if only one dispense drug
S PROMPT=$O(^ORD(101.41,"B","OR GTX DISPENSE DRUG",0))
S (CNT,INST)=0
F S INST=$O(ORDIALOG(PROMPT,INST)) Q:'INST S CNT=CNT+1
I CNT=1 D
. S ORDRUG=+$G(ORDIALOG(PROMPT,1)),ORCOMPLX=0
. S OREFILLS=$P($G(ORDIALOG(PROMPT,"LIST","D",ORDRUG)),U,3)
. S:'$L(OREFILLS) OREFILLS=11
E S ORCOMPLX=1,OREFILLS=11 ; force interactive on complex order
S ORCOPAY=1 ; ask SC if can't determine copay
I $G(ORDRUG),$L($T(ASKSC^ORCDPS)) S ORCOPAY=$$ASKSC^ORCDPS
Q
AUTHMED ; sets ORQUIT if not authorized to write meds
N NOAUTH,NAME
D AUTH^ORWDPS32(.NOAUTH,ORNP)
I +NOAUTH D
. S ORQUIT=1
. S LST(0)="8^0"
. ; FIX FOR REMEDY 71069, CQ 15917
. S LST(.5)=$P(NOAUTH,U,2)
. ;S NAME=$P($G(^VA(200,+ORNP,20)),U,2)
. ;I '$L(NAME) S NAME=$P($G(^VA(200,+ORNP,0)),U,1)
. ;S LST(.5)=NAME_" is not authorized to write med orders."
Q
MEDACTV(USAGE) ; sets ORQUIT if the orderable item is not active for a med
Q:'$G(OI) S USAGE=+$G(USAGE)
I $G(^ORD(101.43,OI,.1)),^(.1)'>$$NOW^XLFDT D Q
. S ORQUIT=1,LST(0)="8^0"
. S LST(.5)=$P($G(^ORD(101.43,OI,0)),U)_" has been inactivated and may not be ordered anymore."
I USAGE,'$P($G(^ORD(101.43,OI,"PS")),U,USAGE) D Q
. S ORQUIT=1,LST(0)="8^0"
. S LST(.5)=$P($G(^ORD(101.43,OI,0)),U)_" may not be ordered as an "_$S(USAGE=1:"inpatient medication",USAGE=2:"outpatient medication",USAGE=3:"IV solution",1:"IV additive")_" anymore."
Q
SCHEDULD() ; Is patient scheduled for PREOP (Imaging)
I $G(ORDIALOG(PROMPT,1)) Q 1 ; don't ask - already have date
E Q 0
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HORWDXM2 10099 printed Apr 09, 2024@21:36:38 Page 2
ORWDXM2 ; SLC/KCM - Quick Orders ; 11/1/11 11:30am
+1 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**10,85,109,116,132,158,187,195,215,243,280,356,377**;Dec 17, 1997;Build 582
+2 ;
ADMTIME(ORDLOC,PATLOC,ENCLOC,DELAY,ISIMO) ;
+1 NEW ADMLOC,INST,SCHLOC,SCHTYPE
+2 SET ADMLOC=+$PIECE($GET(ORDIALOG("B","ADMINISTRATION TIMES")),U,2)
+3 IF ADMLOC>0
IF ORDLOC>0
IF PATLOC'=ORDLOC
Begin DoDot:1
+4 SET INST=0
FOR
SET INST=$ORDER(ORDIALOG(ADMLOC,INST))
if +INST'>0
QUIT
Begin DoDot:2
+5 SET ORDIALOG(ADMLOC,INST)=""
End DoDot:2
End DoDot:1
QUIT
+6 IF ADMLOC>0
IF $SELECT(ENCLOC'=PATLOC:1,ISIMO:1,DELAY:1,1:0)
Begin DoDot:1
+7 SET INST=0
FOR
SET INST=$ORDER(ORDIALOG(ADMLOC,INST))
if +INST'>0
QUIT
Begin DoDot:2
+8 SET ORDIALOG(ADMLOC,INST)=""
End DoDot:2
End DoDot:1
QUIT
+9 SET SCHLOC=+$PIECE($GET(ORDIALOG("B","SCHEDULE TYPE")),U,2)
if SCHLOC'>0
QUIT
+10 SET INST=0
FOR
SET INST=$ORDER(ORDIALOG(SCHLOC,INST))
if +INST'>0
QUIT
Begin DoDot:1
+11 SET SCHTYP=$GET(ORDIALOG(SCHLOC,INST))
if SCHTYP=""
QUIT
+12 IF $SELECT(SCHTYP="P":1,SCHTYP="O":1,SCHTYP="OC":1,1:0)
IF ADMLOC>0
SET ORDIALOG(ADMLOC,INST)=""
End DoDot:1
+13 QUIT
+14 ;
CLRRCL(OK) ; clear ORECALL
+1 SET OK=1
+2 KILL ^TMP("ORECALL",$JOB),^TMP("ORWDXMQ",$JOB)
+3 QUIT
VERTXT ; set verify text for order
+1 NEW SEQ,DA,X,PROMPT,MULT,CHILD,INST,TITLE,TEMP,ILST,SPACES
+2 NEW ISADMIN
+3 SET ILST=0
SET $PIECE(SPACES," ",31)=""
+4 SET SEQ=0
FOR
SET SEQ=$ORDER(^ORD(101.41,+ORDIALOG,10,"B",SEQ))
if SEQ'>0
QUIT
Begin DoDot:1
+5 SET DA=0
FOR
SET DA=$ORDER(^ORD(101.41,+ORDIALOG,10,"B",SEQ,DA))
if 'DA
QUIT
Begin DoDot:2
+6 SET X0=$GET(^ORD(101.41,+ORDIALOG,10,DA,0))
+7 SET ISADMIN=$SELECT(+OREVENT>0:0,ISIMO=1:0,$PIECE($GET(^ORD(101.41,$PIECE(X0,U,2),0)),U)="OR GTX ADMIN TIMES":1,1:0)
+8 IF ISADMIN=1
IF ORDLOC>0
IF ORDLOC'=PATLOC
QUIT
+9 IF $PIECE(X0,U,9)["*"
IF ISADMIN=0
QUIT
+10 SET PROMPT=$PIECE(X0,U,2)
SET MULT=$PIECE(X0,U,7)
SET CHILD=$PIECE(X0,U,11)
IF CHILD
IF ISADMIN=0
QUIT
+11 ; no values
if 'PROMPT
QUIT
SET INST=$ORDER(ORDIALOG(PROMPT,0))
if 'INST
QUIT
+12 SET TITLE=$SELECT($LENGTH($GET(ORDIALOG(PROMPT,"TTL"))):ORDIALOG(PROMPT,"TTL"),1:ORDIALOG(PROMPT,"A"))
+13 IF $EXTRACT(ORDIALOG(PROMPT,0))="W"
Begin DoDot:3
+14 NEW IWP,WP,CNT
+15 SET IWP=0
SET CNT=0
+16 FOR
SET IWP=$ORDER(^TMP("ORWORD",$JOB,PROMPT,INST,IWP))
if 'IWP
QUIT
Begin DoDot:4
+17 SET CNT=CNT+1
SET WP(CNT)=^TMP("ORWORD",$JOB,PROMPT,INST,IWP,0)
End DoDot:4
+18 IF CNT=1
SET ILST=ILST+1
SET LST(ILST)=$JUSTIFY(TITLE,30)_WP(1)
+19 IF CNT>1
Begin DoDot:4
+20 SET ILST=ILST+1
SET LST(ILST)=TITLE
SET IWP=0
+21 FOR
SET IWP=$ORDER(WP(IWP))
if 'IWP
QUIT
SET ILST=ILST+1
SET LST(ILST)=WP(IWP)
End DoDot:4
End DoDot:3
+22 IF '$TEST
Begin DoDot:3
+23 SET TEMP=$$ITEM^ORCDLG(PROMPT,INST)
IF TEMP=""
QUIT
+24 SET ILST=ILST+1
SET LST(ILST)=$JUSTIFY(TITLE,30)
+25 ;S LST(ILST)=LST(ILST)_$$ITEM^ORCDLG(PROMPT,INST)
+26 SET LST(ILST)=LST(ILST)_TEMP
End DoDot:3
+27 ; done
if 'MULT
QUIT
if '$ORDER(ORDIALOG(PROMPT,INST))
QUIT
+28 FOR
SET INST=$ORDER(ORDIALOG(PROMPT,INST))
if INST'>0
QUIT
SET ILST=ILST+1
SET LST(ILST)=SPACES_$$ITEM^ORCDLG(PROMPT,INST)
End DoDot:2
End DoDot:1
+29 ;*356 Only display SC and TF for orders that are not new.
+30 ;for display of Billing Aware data from orig order
IF $GET(ORWMODE)
DO DISPLAY^ORWDBA3
+31 QUIT
RA ; setup environment for radiology
+1 ; -- get imaging types based on display group of quick order and
+2 ; setup list of imaging locations based on imaging type
+3 NEW ISPREG,ORY,ITYPE,IFN,CNT,ORIMLOC,PROMPT
+4 SET ORDIV=$$DIV^ORCDRA1
SET ITYPE=$PIECE($GET(^ORD(100.98,+ORDG,0)),U,3)
+5 SET ORIMTYPE=$ORDER(^RA(79.2,"C",ITYPE,0))
+6 DO EN4^RAO7PC1(ITYPE,"ORY")
+7 SET (IFN,CNT)=0
FOR
SET IFN=$ORDER(ORY(IFN))
if IFN'>0
QUIT
Begin DoDot:1
+8 SET CNT=CNT+1
SET ORIMLOC(CNT)=ORY(IFN)
SET ORIMLOC("B",$PIECE(ORY(IFN),U,2))=IFN
End DoDot:1
+9 IF '$$GET^XPAR("ALL","RA SUBMIT PROMPT",1,"Q")
IF CNT>1
KILL ORIMLOC
+10 IF '$TEST
SET ORIMLOC=CNT_"^1"
+11 SET PROMPT=$ORDER(^ORD(101.41,"B","OR GTX IMAGING LOCATION",0))
+12 IF $GET(ORIMLOC)
MERGE ORDIALOG(PROMPT,"LIST")=ORIMLOC
+13 QUIT
LR ; setup environment for lab
+1 ; -- setup ORTIME, ORIMTIME & ORTEST arrays
+2 ; setup ORMAX, ORDG, & ORCOLLCT variables
+3 NEW PROMPT,INST,EDITONLY
+4 ; sets up ORTIME and ORIMTIME arrays
DO GETIMES^ORCDLR1
+5 SET ORMAX=$$GET^XPAR("ALL^LOC.`"_+ORL,"LR MAX DAYS CONTINUOUS",1,"Q")
+6 SET PROMPT=$ORDER(^ORD(101.41,"B","OR GTX ORDERABLE ITEM",0))
SET INST=1
+7 ; sets up ORTEST array and ORDG
DO LRTEST
+8 SET PROMPT=$ORDER(^ORD(101.41,"B","OR GTX COLLECTION TYPE",0))
+9 IF $DATA(ORDIALOG(PROMPT,1))
SET ORCOLLCT=ORDIALOG(PROMPT,1)
IF 1
+10 IF '$TEST
SET EDITONLY=0
SET ORCOLLCT=$$COLLTYPE^ORCDLR1
+11 IF ORCOLLCT="I"
Begin DoDot:1
+12 SET PROMPT=$ORDER(^ORD(101.41,"B","OR GTX START DATE/TIME",0))
+13 DO LRICTMOK
End DoDot:1
+14 SET PROMPT=$ORDER(^ORD(101.41,"B","OR GTX ADMIN SCHEDULE",0))
+15 IF $DATA(ORDIALOG(PROMPT,1))
SET ORSCH=ORDIALOG(PROMPT,1)
+16 QUIT
LRTEST ; -- Setup ORTEST() array of ordering parameters (copied from ORCDLR)
+1 NEW OI,TST,DG
+2 SET OI=+$GET(ORDIALOG(PROMPT,INST))
if 'OI
QUIT
+3 IF '$DATA(ORTEST)
SET TST=+$PIECE($GET(^ORD(101.43,OI,0)),U,2)
DO TEST^LR7OR3(TST,.ORTEST)
SET ORTEST=TST
+4 SET DG=$PIECE($GET(^ORD(101.43,+OI,"LR")),U,6)
if '$LENGTH(DG)
SET DG="LAB"
+5 SET DG=$ORDER(^ORD(100.98,"B",DG,0))
if DG
SET ORDG=DG
+6 QUIT
LRRQCM() ; return true if lab test has required comments
+1 ; edit via WP
IF $ORDER(^TMP("ORWORD",$JOB,PROMPT,INST,0))
QUIT 1
+2 NEW LRTEST,LRSAMP,LRSPEC,LRTSTN,LRTCOM,LRCCOM,DA,CNT,I,REQDCOMM,OI,TST
+3 SET LRSAMP=$$VAL^ORCD("COLLECTION SAMPLE")
SET LRSPEC=$$VAL^ORCD("SPECIMEN")
+4 SET OI=+$GET(ORDIALOG(PROMPT,INST))
if 'OI
QUIT 0
+5 IF '$DATA(ORTEST)
SET TST=+$PIECE($GET(^ORD(101.43,OI,0)),U,2)
DO TEST^LR7OR3(TST,.ORTEST)
SET ORTEST=TST
+6 SET LRTSTN=1
SET LRTEST(1)=+ORTEST
SET DA=$ORDER(^LAB(60,LRTEST(1),3,"B",+LRSAMP,0))
+7 SET REQDCOMM=$PIECE($GET(^LAB(60,LRTEST(1),3,+DA,0)),U,6)
+8 if 'REQDCOMM
SET REQDCOMM=+$PIECE($GET(^LAB(60,LRTEST(1),0)),U,19)
+9 QUIT REQDCOMM
LRASMP() ; return true to ask collection sample (from ASKSAMP^ORCDLR)
+1 NEW DEFSAMP,SAMP0
+2 SET DEFSAMP=$GET(ORDIALOG(PROMPT,INST))
SET SAMP0=$GET(^LAB(62,+DEFSAMP,0))
+3 IF (ORCOLLCT="LC")!(ORCOLLCT="I")
IF $GET(ORTEST("Lab CollSamp"))
QUIT 0
+4 ; unique -> don't ask
IF $GET(ORTEST("Unique CollSamp"))
IF DEFSAMP
QUIT 0
+5 ; no default or edit -> ask
IF 'DEFSAMP!('FIRST)
QUIT 1
+6 ; only one choice
IF $GET(ORDIALOG(PROMPT,"LIST"))="1^1"
QUIT 0
+7 QUIT 1
LRICTMOK ;
+1 if '$DATA(ORDIALOG(PROMPT,1))
QUIT
+2 NEW ORY
+3 DO VALDT^ORWU(.ORY,ORDIALOG(PROMPT,1))
+4 IF +$$VALID^LR7OV4(DUZ(2),ORY)=0
SET ORDIALOG(PROMPT,1)=""
+5 QUIT
DO ; setup environment for diet order
+1 ; partially copied from EN^ORCDFH
+2 IF ORCAT'="I"
Begin DoDot:1
+3 SET ORQUIT=1
+4 SET LST(0)="8^0"
+5 SET LST(.5)="This type of diet may be entered for inpatients only."
End DoDot:1
QUIT
+6 ; set FH ordering parameters
DO EN^FHWOR8(+ORVP,.ORPARAM)
+7 ; for now
if '$LENGTH($GET(ORPARAM(3)))
SET ORPARAM(3)="T"
+8 ; set NPO flag if NPO diet
NEW PROMPT,OI
+9 SET PROMPT=$ORDER(^ORD(101.41,"B","OR GTX ORDERABLE ITEM",0))
+10 SET OI=+$GET(ORDIALOG(PROMPT,1))
+11 SET ORNPO=($PIECE($GET(^ORD(101.43,OI,0)),U)="NPO")
+12 SET PROMPT=$ORDER(^ORD(101.41,"B","OR GTX START DATE/TIME",0))
+13 SET X=$GET(ORDIALOG(PROMPT,1))
IF $LENGTH(X)
DO CNV^ORCDFH1
SET ORDIALOG(PROMPT,1)=$GET(X)
+14 ;AGP TEST FOR ACTIVE TUBEFEEDING ORDERS
+15 IF $$CURRENT^ORCDFH("TF")>0
SET AUTOACK=0
+16 QUIT
EL ; setup environment for early/late tray
+1 ; set FH ordering parameters
DO EN^FHWOR8(+ORVP,.ORPARAM)
+2 ; for now
if '$LENGTH($GET(ORPARAM(3)))
SET ORPARAM(3)="T"
+3 ; setup ORTIME array
DO EN2^ORCDFH
+4 ; set ORMEAL,ORTRAY
NEW PROMPT
+5 SET PROMPT=$ORDER(^ORD(101.41,"B","OR GTX MEAL",0))
+6 IF $DATA(ORDIALOG(PROMPT,1))
SET ORMEAL=ORDIALOG(PROMPT,1)
+7 SET PROMPT=$ORDER(^ORD(101.41,"B","OR GTX ORDERABLE ITEM",0))
+8 IF $DATA(ORDIALOG(PROMPT,1))
SET ORTRAY=ORDIALOG(PROMPT,1)
+9 ;AGP TEST FOR ACTIVE TUBEFEEDING ORDERS
+10 IF $$CURRENT^ORCDFH("TF")>0
SET AUTOACK=0
+11 QUIT
UD ; setup environment for unit dose med
+1 ; if patch 94 installed
IF $GET(ORWP94)
GOTO PS^ORWDPS3
+2 ;
+3 ; checks authorized to write meds
DO AUTHMED
if $GET(ORQUIT)
QUIT
+4 NEW PROMPT,OI
+5 SET PROMPT=$ORDER(^ORD(101.41,"B","OR GTX ORDERABLE ITEM",0))
+6 IF $DATA(ORDIALOG(PROMPT,1))
SET OI=ORDIALOG(PROMPT,1)
DO MEDACTV(1)
if $GET(ORQUIT)
QUIT
+7 ; sets up instructions, routes, etc.
DO INSTR^ORCDPS(OI)
+8 ; gets list of dispense drugs
DO CHOICES^ORCDPS("U")
+9 QUIT
IV ; setup environment for IV fluid
+1 ; checks authorized to write meds
DO AUTHMED
if $GET(ORQUIT)
QUIT
+2 ; sets up list of volumes if only one solution
+3 ; otherwise, let the dialog go interactive
+4 NEW PROMPT,INST,CNT,OI
+5 SET PROMPT=$ORDER(^ORD(101.41,"B","OR GTX ORDERABLE ITEM",0))
+6 SET (CNT,INST)=0
+7 FOR
SET INST=$ORDER(ORDIALOG(PROMPT,INST))
if 'INST
QUIT
Begin DoDot:1
+8 SET CNT=CNT+1
+9 ; check active solutions
SET OI=ORDIALOG(PROMPT,INST)
DO MEDACTV(3)
End DoDot:1
if $GET(ORQUIT)
QUIT
+10 IF CNT=1
SET INST=1
DO VOLUME^ORCDPSIV
+11 SET PROMPT=$ORDER(^ORD(101.41,"B","OR GTX ADDITIVE",0))
+12 SET INST=0
+13 FOR
SET INST=$ORDER(ORDIALOG(PROMPT,INST))
if 'INST
QUIT
Begin DoDot:1
+14 ; check active additives
SET OI=ORDIALOG(PROMPT,INST)
DO MEDACTV(4)
End DoDot:1
if $GET(ORQUIT)
QUIT
+15 QUIT
OP ; setup environment for outpatient pharmacy
+1 ; if patch 94 installed
IF $GET(ORWP94)
GOTO PS^ORWDPS3
+2 ;
+3 ; checks authorized to write meds
DO AUTHMED
if $GET(ORQUIT)
QUIT
+4 NEW PROMPT,INST,CNT,OI
+5 SET PROMPT=$ORDER(^ORD(101.41,"B","OR GTX ORDERABLE ITEM",0))
SET OI=0
+6 IF $DATA(ORDIALOG(PROMPT,1))
SET OI=$GET(ORDIALOG(PROMPT,1))
DO MEDACTV(2)
if $GET(ORQUIT)
QUIT
+7 ; sets up instructions, routes, etc.
if +OI
DO INSTR^ORCDPS(OI)
+8 ; gets list of dispense drugs
DO CHOICES^ORCDPS("O")
+9 ; get defaults for drug, refills if only one dispense drug
+10 SET PROMPT=$ORDER(^ORD(101.41,"B","OR GTX DISPENSE DRUG",0))
+11 SET (CNT,INST)=0
+12 FOR
SET INST=$ORDER(ORDIALOG(PROMPT,INST))
if 'INST
QUIT
SET CNT=CNT+1
+13 IF CNT=1
Begin DoDot:1
+14 SET ORDRUG=+$GET(ORDIALOG(PROMPT,1))
SET ORCOMPLX=0
+15 SET OREFILLS=$PIECE($GET(ORDIALOG(PROMPT,"LIST","D",ORDRUG)),U,3)
+16 if '$LENGTH(OREFILLS)
SET OREFILLS=11
End DoDot:1
+17 ; force interactive on complex order
IF '$TEST
SET ORCOMPLX=1
SET OREFILLS=11
+18 ; ask SC if can't determine copay
SET ORCOPAY=1
+19 IF $GET(ORDRUG)
IF $LENGTH($TEXT(ASKSC^ORCDPS))
SET ORCOPAY=$$ASKSC^ORCDPS
+20 QUIT
AUTHMED ; sets ORQUIT if not authorized to write meds
+1 NEW NOAUTH,NAME
+2 DO AUTH^ORWDPS32(.NOAUTH,ORNP)
+3 IF +NOAUTH
Begin DoDot:1
+4 SET ORQUIT=1
+5 SET LST(0)="8^0"
+6 ; FIX FOR REMEDY 71069, CQ 15917
+7 SET LST(.5)=$PIECE(NOAUTH,U,2)
+8 ;S NAME=$P($G(^VA(200,+ORNP,20)),U,2)
+9 ;I '$L(NAME) S NAME=$P($G(^VA(200,+ORNP,0)),U,1)
+10 ;S LST(.5)=NAME_" is not authorized to write med orders."
End DoDot:1
+11 QUIT
MEDACTV(USAGE) ; sets ORQUIT if the orderable item is not active for a med
+1 if '$GET(OI)
QUIT
SET USAGE=+$GET(USAGE)
+2 IF $GET(^ORD(101.43,OI,.1))
IF ^(.1)'>$$NOW^XLFDT
Begin DoDot:1
+3 SET ORQUIT=1
SET LST(0)="8^0"
+4 SET LST(.5)=$PIECE($GET(^ORD(101.43,OI,0)),U)_" has been inactivated and may not be ordered anymore."
End DoDot:1
QUIT
+5 IF USAGE
IF '$PIECE($GET(^ORD(101.43,OI,"PS")),U,USAGE)
Begin DoDot:1
+6 SET ORQUIT=1
SET LST(0)="8^0"
+7 SET LST(.5)=$PIECE($GET(^ORD(101.43,OI,0)),U)_" may not be ordered as an "_$SELECT(USAGE=1:"inpatient medication",USAGE=2:"outpatient medication",USAGE=3:"IV solution",1:"IV additive")_" anymore."
End DoDot:1
QUIT
+8 QUIT
SCHEDULD() ; Is patient scheduled for PREOP (Imaging)
+1 ; don't ask - already have date
IF $GET(ORDIALOG(PROMPT,1))
QUIT 1
+2 IF '$TEST
QUIT 0
+3 QUIT
