- 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 Jan 18, 2025@03:37:09 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