- ORWDXM4 ; SLC/KCM - Order Dialogs, Menus;05/09/17 ;Jun 21, 2022@14:26:46
- ;;3.0;ORDER ENTRY/RESULTS REPORTING;**10,85,215,296,280,394,350,434,569**;Dec 17, 1997;Build 23
- ;
- SETUP ; -- setup dialog (continued from ORWDXM1)
- ; if xfer med order, setup ORDIALOG differently
- I ORWMODE,$$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")
- ;p394 force interactive dialog for imaging QO for female of child-bearing age.
- N ORRAORD S ORRAORD=0 ;set is radiology flag to false (0)
- I ORDIALOG=$O(^ORD(101.41,"B","RA OERR EXAM",0)) D
- . N ORPRMPT1,ORPRMPT2,ORCODE S ORRAORD=1
- . Q:($G(ORTYPE)'="Q")!($G(ORSEX)'="F")
- . S ORPRMPT1=$O(^ORD(101.41,"B","OR GTX PREGNANT",0)),ORPRMPT2=$P($G(ORDIALOG(ORPRMPT1)),"^")
- . S ORCODE=$G(^ORD(101.41,ORDIALOG,10,ORPRMPT2,7)) N Y S Y="Y" X ORCODE K ORCODE
- . S:Y="Y" ORWPSWRG="" ;
- I ORRAORD 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","LR OTHER LAB AP 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","PSJ OR CLINIC 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","CLINIC 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","SD RTC",0)) D RTC^ORWDSD1 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
- S OCAT=$P($G(^OR(100,+IFN,0)),U,12)
- 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,PROMPT,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
- I '$D(ORTEST("Lab CollSamp")) D
- . N I,V,T,LC S LC=1
- . F I=1:1:$L(ORTEST,U) S V=+$P(ORTEST,U,I) D Q:'LC ;no LC samp
- .. S T=$$LAB60^ORCDVBEC(V) ;VBECS ID -> #60 ien
- .. I '$P($G(^LAB(60,T,0)),U,9) S LC=0 Q
- . S ORTEST("Lab CollSamp")=LC
- I '$D(ORTIME),'$D(ORIMTIME) D GETIMES^ORCDLR1
- 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^ORWDXM2
- 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
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HORWDXM4 7872 printed Feb 19, 2025@00:02:34 Page 2
- ORWDXM4 ; SLC/KCM - Order Dialogs, Menus;05/09/17 ;Jun 21, 2022@14:26:46
- +1 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**10,85,215,296,280,394,350,434,569**;Dec 17, 1997;Build 23
- +2 ;
- SETUP ; -- setup dialog (continued from ORWDXM1)
- +1 ; if xfer med order, setup ORDIALOG differently
- +2 IF ORWMODE
- IF $$ISMED(ORIT)
- IF $$CHGSTS(ORCAT,ORIT)
- DO MEDXFER
- QUIT
- +3 ; get base dialog (based on display group) & location of responses
- +4 IF ORWMODE
- Begin DoDot:1
- +5 SET ORDG=$PIECE(^OR(100,+ORIT,0),U,11)
- SET ORDIALOG=+$PIECE(^(0),U,5)
- +6 SET RSPREF="^OR(100,"_+ORIT_",4.5)"
- End DoDot:1
- +7 IF '$TEST
- Begin DoDot:1
- +8 NEW X0
- SET X0=$GET(^ORD(101.41,ORIT,0))
- +9 SET ORDIALOG=$SELECT($PIECE(X0,U,4)="D":ORIT,1:0)
- +10 SET ORDG=$PIECE(X0,U,5)
- if 'ORDG
- QUIT
- +11 IF 'ORDIALOG
- SET ORDIALOG=+$$DEFDLG^ORWDXQ(ORDG)
- +12 SET RSPREF="^ORD(101.41,"_ORIT_",6)"
- End DoDot:1
- +13 ; setup the ORDIALOG array
- +14 DO GETDLG^ORCD(ORDIALOG)
- +15 DO GETORDER^ORCD(RSPREF)
- +16 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 ;p394 force interactive dialog for imaging QO for female of child-bearing age.
- +9 ;set is radiology flag to false (0)
- NEW ORRAORD
- SET ORRAORD=0
- +10 IF ORDIALOG=$ORDER(^ORD(101.41,"B","RA OERR EXAM",0))
- Begin DoDot:1
- +11 NEW ORPRMPT1,ORPRMPT2,ORCODE
- SET ORRAORD=1
- +12 if ($GET(ORTYPE)'="Q")!($GET(ORSEX)'="F")
- QUIT
- +13 SET ORPRMPT1=$ORDER(^ORD(101.41,"B","OR GTX PREGNANT",0))
- SET ORPRMPT2=$PIECE($GET(ORDIALOG(ORPRMPT1)),"^")
- +14 SET ORCODE=$GET(^ORD(101.41,ORDIALOG,10,ORPRMPT2,7))
- NEW Y
- SET Y="Y"
- XECUTE ORCODE
- KILL ORCODE
- +15 ;
- if Y="Y"
- SET ORWPSWRG=""
- End DoDot:1
- +16 IF ORRAORD
- DO RA^ORWDXM2
- GOTO XENV
- +17 IF ORDIALOG=$ORDER(^ORD(101.41,"B","LR OTHER LAB TESTS",0))
- DO LR^ORWDXM2
- GOTO XENV
- +18 IF ORDIALOG=$ORDER(^ORD(101.41,"B","LR OTHER LAB AP TESTS",0))
- DO LR^ORWDXM2
- GOTO XENV
- +19 IF ORDIALOG=$ORDER(^ORD(101.41,"B","FHW1",0))
- DO DO^ORWDXM2
- GOTO XENV
- +20 IF ORDIALOG=$ORDER(^ORD(101.41,"B","FHW2",0))
- DO EL^ORWDXM2
- GOTO XENV
- +21 IF ORDIALOG=$ORDER(^ORD(101.41,"B","PSJ OR PAT OE",0))
- DO UD^ORWDXM2
- GOTO XENV
- +22 IF ORDIALOG=$ORDER(^ORD(101.41,"B","PSJ OR CLINIC OE",0))
- DO UD^ORWDXM2
- GOTO XENV
- +23 IF ORDIALOG=$ORDER(^ORD(101.41,"B","PSJI OR PAT FLUID OE",0))
- DO IV^ORWDXM2
- GOTO XENV
- +24 IF ORDIALOG=$ORDER(^ORD(101.41,"B","CLINIC OR PAT FLUID OE",0))
- DO IV^ORWDXM2
- GOTO XENV
- +25 IF ORDIALOG=$ORDER(^ORD(101.41,"B","PSO OERR",0))
- DO OP^ORWDXM2
- GOTO XENV
- +26 IF ORDIALOG=$ORDER(^ORD(101.41,"B","PSO SUPPLY",0))
- DO OP^ORWDXM2
- GOTO XENV
- +27 IF ORDIALOG=$ORDER(^ORD(101.41,"B","PS MEDS",0))
- DO PS^ORWDPS3
- GOTO XENV
- +28 IF ORDIALOG=$ORDER(^ORD(101.41,"B","VBEC BLOOD BANK",0))
- DO VB^ORWDXM4
- GOTO XENV
- +29 IF ORDIALOG=$ORDER(^ORD(101.41,"B","SD RTC",0))
- DO RTC^ORWDSD1
- GOTO XENV
- +30 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
- +2 SET OCAT=$PIECE($GET(^OR(100,+IFN,0)),U,12)
- +3 QUIT OCAT'=ECAT
- +4 ;
- 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,PROMPT,I,X,X0
- +6 SET P=+$ORDER(^ORD(101.41,"AB","OR GTX ORDERABLE ITEM",0))
- +7 SET I=0
- FOR
- SET I=$ORDER(ORDIALOG(P,I))
- if I<1
- QUIT
- SET X=+$GET(ORDIALOG(P,I))
- Begin DoDot:1
- +8 SET X0=$GET(^ORD(101.43,X,"VB"))
- SET X=+$PIECE($GET(^(0)),U,2)
- +9 IF $PIECE(X0,U)
- SET ORCOMP=ORCOMP_$SELECT($LENGTH(ORCOMP):U,1:"")_X
- QUIT
- +10 SET ORTEST=ORTEST_$SELECT($LENGTH(ORTEST):U,1:"")_X
- +11 IF X=2
- SET ORTAS=1
- End DoDot:1
- +12 IF '$DATA(ORTEST("Lab CollSamp"))
- Begin DoDot:1
- +13 NEW I,V,T,LC
- SET LC=1
- +14 ;no LC samp
- FOR I=1:1:$LENGTH(ORTEST,U)
- SET V=+$PIECE(ORTEST,U,I)
- Begin DoDot:2
- +15 ;VBECS ID -> #60 ien
- SET T=$$LAB60^ORCDVBEC(V)
- +16 IF '$PIECE($GET(^LAB(60,T,0)),U,9)
- SET LC=0
- QUIT
- End DoDot:2
- if 'LC
- QUIT
- +17 SET ORTEST("Lab CollSamp")=LC
- End DoDot:1
- +18 IF '$DATA(ORTIME)
- IF '$DATA(ORIMTIME)
- DO GETIMES^ORCDLR1
- +19 SET PROMPT=$ORDER(^ORD(101.41,"B","OR GTX COLLECTION TYPE",0))
- +20 IF $DATA(ORDIALOG(PROMPT,1))
- SET ORCOLLCT=ORDIALOG(PROMPT,1)
- IF 1
- +21 IF '$TEST
- SET EDITONLY=0
- SET ORCOLLCT=$$COLLTYPE^ORCDLR1
- +22 IF ORCOLLCT="I"
- Begin DoDot:1
- +23 SET PROMPT=$ORDER(^ORD(101.41,"B","OR GTX START DATE/TIME",0))
- +24 DO LRICTMOK^ORWDXM2
- End DoDot:1
- +25 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
