ORWDXM1 ;SLC/KCM - Order Dialogs, Menus ;Aug 18, 2022@07:44:57
;;3.0;ORDER ENTRY/RESULTS REPORTING;**10,85,131,132,141,178,185,187,215,243,280,331,388,350,423,434,494,397,377,512,498,405**;Dec 17, 1997;Build 211
;
BLDQRSP(LST,ORIT,FLDS,ISIMO,ENCLOC) ; Build responses for an order
; LST=QuickLevel^ResponseID(ORIT;$H)^Dialog^Type^FormID^DGrp
; LST(n)=verify or reject text
; ORIT= ptr to 101.41 for quick order, 100 for copy
; 1 2 3 4 5 6 7 8 11-20
; FLDS=DFN^LOC^ORNP^INPT^SEX^AGE^EVENT^SC%^^^Key Variables...
; ORIT=+ORIT: ptr to 101.41, $E(ORIT)=C: copy $E(ORIT)=X: change
; !! SHOULD CHECK for PRE-CPRS ORDERS (treat as text?)
K ^TMP("ORWDXMQ",$J)
N ORWMODE ; 0:Dlg,Quick 1:copy 2:change
N TEMPCAT ; pt cat from DPT
N ISXFER ; Trnsfr order?
N ORIMO ;If IMO(inpt med on opt)
N TEMPORIT
N ADMLOC,PATLOC,ORDLOC,LEVEL,DELAY,SCHLOC,SCHTYP
S PATLOC=$P(FLDS,U,2)
S ORDLOC=$S(ORIT["C":+$P($G(^OR(100,+$P(ORIT,"C",2),0)),U,10),1:0)
S ORIMO=$G(ISIMO)
S ORWMODE=0,ISXFER=""
S:$E(ORIT)="C" ORWMODE=1 S:$E(ORIT)="T" ORWMODE=1,ISXFER=";T" ;treat xfer as copy
S:$E(ORIT)="X" ORWMODE=2
S TEMPORIT=ORIT
I ORWMODE S ORIT=$E(ORIT,2,999)
S LST(0)=""
;disable
D CHKDSBL^ORWDXM3(.LST,ORIT,ORWMODE) Q:+LST(0)=8
;action
D CHKVACT^ORWDXM3(.LST,ORIT,ORWMODE,$P(FLDS,U,3)) Q:+LST(0)=8
;no copy
I ORWMODE=1 D CHKCOPY^ORWDXM3(.LST,ORIT,FLDS) Q:+LST(0)=8
;change
I ORWMODE=2 D BLD4CHG^ORWDXM3(.LST,ORIT,FLDS) Q
I 'ORWMODE,($P(^ORD(101.41,+ORIT,0),U,4)="D"),$P(^ORD(101.41,+ORIT,0),"^",7)=$O(^DIC(9.4,"C","SD",0)) S LST(0)="0^0^"_$$DLGINFO^ORWDXM3(ORIT,ORWMODE_ISXFER) Q
I 'ORWMODE,($P(^ORD(101.41,+ORIT,0),U,4)="D"),'($O(^DIC(9.4,"C","OR",0))[$P(^ORD(101.41,+ORIT,0),U,7)) S LST(0)="0^0^"_$$DLGINFO^ORWDXM3(ORIT,ORWMODE_ISXFER) Q
N ORIMTYPE,ORCOMP,ORTAS,LRFZX,LRFSAMP,LRFSPEC,LRFDATE,LRFURG,LRFSCH
N ORTIME,ORCOLLCT,ORMAX,ORTEST,ORIMTIME,ORSMAX,ORSTMS,ORSCH
N PSJNOPC,ORMORE,ORINPT,ORXNP,ORSCHED,ORQTY,ORNOUNS,ORXNP,OREFILLS
N ORCOMPLX,ORQTY,ORCOPAY,ORDRUG,ORWPSPIK,ORWPSWRG,ORSD,ORDSUP,ORWP94
N ORPARAM,ORNPO,ORTIME,ORMEAL,ORTRAY,ORDATE,GMRCNOPD,GMRCNOAT,GMRCREAF
N ORTYPE,ORVP,ORL,ORNP,ORSEX,ORAGE,ORWARD,OREVENT,ORDIV,ORSC,KEYVAR
N ORDG,ORDIALOG,ORCAT,FIRST,ORQUIT,X,ORTRAIL,ORLEAD,RSPREF,AUTOACK
N OREVNTYP
S ORWP94=$O(^ORD(101.41,"AB","PS MEDS",0))>0
S ORVP=$P(FLDS,U,1)_";DPT(",ORNP=+$P(FLDS,U,3),ORSC=$P(FLDS,U,8)
S ORL=$P(FLDS,U,2)_";SC(",ORL(2)=ORL
S ORSEX=$P(FLDS,U,5),ORAGE=$P(FLDS,U,6),ORTYPE="Q",FIRST=1
I $P(FLDS,U,4),$G(^SC(+ORL,42)) S ORWARD=+^SC(+ORL,42)
I $L($P(FLDS,U,7)) D
. S OREVENT=$P(FLDS,U,7)
. S OREVNTYP=$P(OREVENT,";",2)
. S OREVENT("TS")=$P(OREVENT,";",3)
. S OREVENT("EFFECTIVE")=$P(OREVENT,";",4)
. S OREVENT=+$P(OREVENT,";",1)
I 'ORWMODE D
. D SETKEYV^ORWDXM3($P(FLDS,U,11,20)) ; from menu path
. S KEYVAR=$$KEYVAR^ORWDXM3(ORIT) ; from entry action
. D SETKEYV^ORWDXM3(KEYVAR)
K ^TMP("ORWORD",$J)
; init return record based on auto-accept
I ORWMODE S LST(0)="2^"_ORIT ;verify on copy
E S LST(0)=+$P($G(^ORD(101.41,ORIT,5)),U,8)_U_ORIT
S TEMPCAT=$S($L($P($G(^DPT(+ORVP,.1)),U)):"I",1:"O")
I TEMPCAT="I",+$P(FLDS,U,4)=1,$E(TEMPORIT)="C",$P($G(^ORD(100.98,$P($G(^OR(100,+ORIT,0)),U,11),0)),U)="OUTPATIENT MEDICATIONS" S TEMPCAT="O"
I $L($G(OREVNTYP)) D
. S ORCAT=$S(OREVNTYP="A":"I",OREVNTYP="T":"I",OREVNTYP="O":TEMPCAT,OREVNTYP="M":TEMPCAT,OREVNTYP="C":TEMPCAT,1:"O") I $G(OREVENT) D
.. N X S X=$$EVT^OREVNTX(OREVENT),X=$P($G(^ORD(100.5,+X,0)),U,7)
.. I OREVNTYP="T",X,X<4 S ORCAT="O" ;To pass=outpt
.. I OREVNTYP="D",X=41 S ORCAT="I" ;From ASIH=inpt
E S ORCAT=TEMPCAT
D SETUP^ORWDXM4 Q:+LST(0)=8
S X="OR GTX START DATE"_$S($G(ORWP94):"/TIME",1:"")
I ORWMODE,(ORDG=+$O(^ORD(100.98,"B","O RX",0))) D
. K ORDIALOG($$PTR^ORCD(X),1) ;remove old values
. I $$ISTITR^ORUTL3(+ORIT) D TITR(.ORDIALOG) ;add titration response when copying/changing old (pre-v32/p405) titration orders
. I ORWMODE=2,$$DRAFT^ORWDX2(ORIT) Q ;keep comments
. K:ISXFER'["T" ORDIALOG($$PTR^ORCD("OR GTX WORD PROCESSING 1"),1)
D SETUPS^ORWDXM4 ;moved to save space, expects X
Q:+LST(0)=8
I $G(ORQUIT) S LST(0)="0^0^"_$$DLGINFO^ORWDXM3(ORIT,ORWMODE_ISXFER)_"^"_$G(KEYVAR) Q
N SEQ,DA,XCODE,MUSTASK,PROMPT,INST,KEY,IVFID,CLIVFID,VBFID
S IVFID=$O(^ORD(101.41,"B","PSJI OR PAT FLUID OE",0))
S CLIVFID=$O(^ORD(101.41,"B","CLINIC OR PAT FLUID OE",0))
S VBFID=$O(^ORD(101.41,"B","VBEC BLOOD BANK",0))
;AGP CPRS 31 changes for 31. Diet order with active tubefeeding orders cannot be autoaccept
;tubefeeding orders cannot be autoaccept either.
;S AUTOACK=$S($D(ORWPSWRG):0,1:1)
I ORDIALOG=$O(^ORD(101.41,"B","FHW8",0)) S AUTOACK=0
S AUTOACK=$S($D(ORWPSWRG):0,$G(AUTOACK)'="":AUTOACK,1:1)
; If copying, clear bad dates. Later, SETITEM will fill dates with default values. ;DJE-VM *331
I ORWMODE=1 D ;
. I ORDIALOG=VBFID,$$VAL^ORCD("DATE/TIME WANTED")<$$NOW^XLFDT D
.. K ORDIALOG($P(ORDIALOG("B","DATE/TIME WANTED"),"^",2),1)
.. K ORDIALOG($P(ORDIALOG("B","SPECIMEN STATUS"),"^",2),1)
. I $L($$VAL^ORCD("START DATE")) D ;
. . S X=$$VAL^ORCD("START DATE"),%DT="TX" D ^%DT
. . I Y'<$$DT^XLFDT,(($L($$VAL^ORCD("STOP DATE"))=0)!('$$FTDCOMP^ORCD("START DATE","STOP DATE",">"))) Q ;quit if valid dates: start not in the past or stop after start
. . K ORDIALOG($$PTR("START DATE"),1),ORDIALOG($$PTR("START DATE/TIME"),1) ;erase bad start and stop dates.
. . K ORDIALOG($$PTR("STOP DATE"),1),ORDIALOG($$PTR("STOP DATE/TIME"),1)
. ; check start and stop dates found in diet orders
. I $L($$VAL^ORCD("EFFECTIVE DATE/TIME")) D ;
. . S X=$$VAL^ORCD("EFFECTIVE DATE/TIME"),%DT="TX" D ^%DT
. . I Y'<$$DT^XLFDT,(($L($$VAL^ORCD("EXPIRATION DATE/TIME"))=0)!('$$FTDCOMP^ORCD("EFFECTIVE DATE/TIME","EXPIRATION DATE/TIME",">"))) Q ;quit if valid dates: start not in the past or stop after start
. . K ORDIALOG($P(ORDIALOG("B","EFFECTIVE DATE/TIME"),U,2),1) ;erase bad start and stop dates.
. . K ORDIALOG($P(ORDIALOG("B","EXPIRATION DATE/TIME"),U,2),1)
. ; check date desired field found in imaging orders
. I $L($$VAL^ORCD("DATE DESIRED")) D ;
. . S X=$$VAL^ORCD("DATE DESIRED")
. . ;OR 512 Erase future date if in +## or +##M format
. . I X["+" K ORDIALOG($P(ORDIALOG("B","DATE DESIRED"),U,2),1) Q
. . S %DT="TX" D ^%DT
. . I Y'<$$DT^XLFDT Q ;quit if not a past date
. . K ORDIALOG($P(ORDIALOG("B","DATE DESIRED"),U,2),1) ;erase bad date
. ; check collection date field found in lab orders
. I $L($$VAL^ORCD("COLLECTION DATE/TIME")) D ;
. . S X=$$VAL^ORCD("COLLECTION DATE/TIME")
. . I X="NEXT" Q ;No need to check this.
. . S %DT="TX" D ^%DT
. . I $P(Y,".",2),Y'<$E($$NOW^XLFDT,1,12) Q ;quit if not a past date and time (lab is more precise than other dates)
. . I $P(Y,".",2)="",Y'<$$DT^XLFDT Q ;
. . K ORDIALOG($P(ORDIALOG("B","COLLECTION DATE/TIME"),U,2),1) ;erase bad date
. ;if copying a "Return to Clinic" order, force user to enter a date
. I $L($$VAL^ORCD("RETURN TO CLINIC DATE")) D
. . K ORDIALOG($P(ORDIALOG("B","RETURN TO CLINIC DATE"),U,2),1)
S SEQ=0 F S SEQ=$O(^ORD(101.41,+ORDIALOG,10,"B",SEQ)) Q:'SEQ D
. S DA=0 F S DA=$O(^ORD(101.41,+ORDIALOG,10,"B",SEQ,DA)) Q:'DA D
. . ; skip if child prmpt
. . I $P(^ORD(101.41,+ORDIALOG,10,DA,0),U,11) Q
. . ; set dflt for prmpt, chk if interactive
. . S PROMPT=$P(^ORD(101.41,+ORDIALOG,10,DA,0),U,2)
. . D SETITEM(DA,PROMPT,1,.MUSTASK)
. . I MUSTASK S AUTOACK=0 Q
. . ; iterate through child items if parent & edit only
. . Q:'$D(^ORD(101.41,+ORDIALOG,10,"DAD",PROMPT))
. . N CSEQ,CDA,CPROMPT,INST,ORQUIT
. . S CSEQ=0 F S CSEQ=$O(^ORD(101.41,+ORDIALOG,10,"DAD",PROMPT,CSEQ)) Q:'CSEQ D Q:$G(ORQUIT)
. . . S CDA=$O(^ORD(101.41,+ORDIALOG,10,"DAD",PROMPT,CSEQ,0))
. . . S CPROMPT=$P(^ORD(101.41,+ORDIALOG,10,CDA,0),U,2)
. . . ; if req & no instances then need interaction
. . . I $P(^ORD(101.41,+ORDIALOG,10,CDA,0),U,6) D
. . . . I ORDIALOG=IVFID!(ORDIALOG=CLIVFID) Q
. . . . I '$O(ORDIALOG(CPROMPT,0)) S AUTOACK=0
. . . S INST=0 F S INST=$O(ORDIALOG(CPROMPT,INST)) Q:'INST D
. . . . N ORASK D VBASK^ORWDXM4(INST) ; set ORASK for VBECS
. . . . ; set dflt for each child prmpt
. . . . D SETITEM(CDA,CPROMPT,INST,.MUSTASK)
. . . . ; if no val & child prmpt req'd then need interaction
. . . . I MUSTASK,$P(^ORD(101.41,+ORDIALOG,10,CDA,0),U,6) S AUTOACK=0
N IVDLG,CLINFDLG,SPLYDLG
S IVDLG=$O(^ORD(101.41,"AB","PSJI OR PAT FLUID OE",0))
S CLINFDLG=$O(^ORD(101.41,"AB","CLINIC OR PAT FLUID OE",0))
S SPLYDLG=$O(^ORD(101.41,"AB","PSO SUPPLY",0))
I $$ISMED(ORIT),(ORDIALOG'=IVDLG),(ORDIALOG'=CLINFDLG),(ORDIALOG'=SPLYDLG),(ORCAT="I") D
. N P
. F P="PATIENT INSTRUCTIONS","DAYS SUPPLY","QUANTITY","REFILLS","ROUTING","SERVICE CONNECTED" K ORDIALOG($$PTR(P),1)
. I '$$ISQO(ORIT) K ORDIALOG($$PTR("START DATE/TIME"),1) ; kill if not a non-VA med quick order. p388
S KEY=$S(ORWMODE:"C",1:"")_ORIT_"-"_$P($H,",",2),SEQ=0
I $$ISINPMED(ORIT) D
.S LEVEL=$P(LST(0),U),DELAY=$S($P($G(OREVENT),";")>0:1,1:0)
.I LEVEL=2!(ISIMO) D ADMTIME^ORWDXM2(ORDLOC,PATLOC,ENCLOC,DELAY,ISIMO)
I ($$ISMED(ORIT)),'($$VALQO^ORWDXM3(ORIT,$G(ORVP))) S AUTOACK=0
I 'ORWMODE,$P(^ORD(101.41,+ORIT,0),U,7)=$O(^DIC(9.4,"C","SD",0)),'($$SDRTCVER^ORWDXM3(.ORDIALOG)) S AUTOACK=0
S PROMPT=0 F S PROMPT=$O(ORDIALOG(PROMPT)) Q:'PROMPT D
. I '$D(^ORD(101.41,ORDIALOG,10,"D",PROMPT)) K ORDIALOG(PROMPT) Q
. S INST=0 F S INST=$O(ORDIALOG(PROMPT,INST)) Q:'INST D
. . S SEQ=SEQ+1,^TMP("ORWDXMQ",$J,KEY,SEQ,0)=U_PROMPT_U_INST
. . ; save word proc val
. . I $E(ORDIALOG(PROMPT,0))="W",$L(ORDIALOG(PROMPT,INST)) D
. . . M ^TMP("ORWDXMQ",$J,KEY,SEQ,2)=@ORDIALOG(PROMPT,INST)
. . ; save other val types
. . E S ^TMP("ORWDXMQ",$J,KEY,SEQ,1)=ORDIALOG(PROMPT,INST)
I AUTOACK D
. I ORWMODE S AUTOACK=2
. I 'ORWMODE,($P(^ORD(101.41,ORIT,0),U,8)!'LST(0)) S AUTOACK=2
;I ($$ISMED(ORIT)),'($$VALQO^ORWDXM3(ORIT)) S AUTOACK=0
I ORIMO,ORWMODE S AUTOACK=2
; accept Herbal/OTC/NonVA Med quick orders
I 'ORWMODE,$L($G(^ORD(101.41,+ORIT,0))),($P(^ORD(100.98,$P(^ORD(101.41,+ORIT,0),U,5),0),U,3)="NV RX"),($P($G(^ORD(101.41,+ORIT,5)),U,8)) S AUTOACK=1
;I AUTOACK=2,$$ISMED(ORIT),(ORDIALOG=IVDLG),$$VERORD^ORWDXM3=0 S AUTOACK=0
I AUTOACK=2,$$ISMED(ORIT),$$VERORD^ORWDXM3(ORIT,$G(ORVP))=0 S AUTOACK=0
I AUTOACK=2 D VERTXT^ORWDXM2
;IF NEED TO CHANGE GUI DISPLAY TYPE CHANGE AUTOACK VALUE
I AUTOACK>0 D
.I $$ISRAD^ORWDXM3(ORIT),'$$VALRADQO^ORWDXM3(.ORDIALOG) S AUTOACK=0
;
S LST(0)=AUTOACK_U_KEY_U_$$DLGINFO^ORWDXM3(ORIT,ORWMODE_ISXFER)_"^"_$G(KEYVAR)
I $P(LST(0),U,4)="D" S $P(LST(0),U,4)="Q"
I ORWMODE=1 S $P(LST(0),U,4)="C"
K ^TMP("ORWORD",$J)
K ^TMP("PSJINS",$J),^TMP("PSJMR",$J),^TMP("PSJNOUN",$J)
Q
SETITEM(DA,PROMPT,INST,MUSTASK) ; set dflt val & return if must prompt
N EDITONLY,Y,VALIV,XCODE
S MUSTASK=0,EDITONLY=0,VALIV=0
I $D(^TMP("ORWDHTM",$J,ORDIALOG,PROMPT)) D
. I $E(ORDIALOG(PROMPT,0))="W" D
. . S ^TMP("ORWORD",$J,PROMPT,INST,1,0)=^TMP("ORWDHTM",$J,ORDIALOG,PROMPT)
. . S ORDIALOG(PROMPT,INST)="^TMP(""ORWORD"","_$J_","_PROMPT_","_INST_")"
. E S ORDIALOG(PROMPT,INST)=^TMP("ORWDHTM",$J,ORDIALOG,PROMPT)
I $D(^TMP("ORWDHTM",$J,ORIT,PROMPT)) D
. S ORDIALOG(PROMPT,INST)=^TMP("ORWDHTM",$J,ORIT,PROMPT)
. ; NEED TO CLEAN UP ^TMP("ORWDHTM") after process order set!!!
;
; skip if a value already exists for this prompt and not WP
Q:$D(ORDIALOG(PROMPT,INST))&($E(ORDIALOG(PROMPT,0))'="W")
; execute default action if no value in QO, checking EDITONLY afterwards
I '$D(ORDIALOG(PROMPT,INST)) D
. ;
. ;Intermittent IV orders do not require a solution or an infusion rate
. I PROMPT=$$PTR("INFUSION RATE"),$$GETIVTYP^ORWDXM3="I" S VALIV=1 Q
. I PROMPT=$$PTR("ORDERABLE ITEM"),$$GETIVTYP^ORWDXM3="I" S VALIV=1 Q
. I $E(ORDIALOG(PROMPT,0))="W",$D(^ORD(101.41,+ORDIALOG,10,DA,8))>9 D
. . M ^TMP("ORWORD",$J,PROMPT,INST)=^ORD(101.41,+ORDIALOG,10,DA,8)
. . S ORDIALOG(PROMPT,INST)="^TMP(""ORWORD"","_$J_","_PROMPT_","_INST_")"
. E D
. . S XCODE=$$SUBCODE($G(^ORD(101.41,+ORDIALOG,10,DA,7)))
. . I $L(XCODE) X XCODE S:$D(Y) ORDIALOG(PROMPT,INST)=Y
Q:VALIV=1
Q:$G(EDITONLY)
I 'ORWMODE,$P($G(^ORD(101.41,+ORDIALOG,10,DA,0)),U,8) Q
I ORWMODE,($P($G(^ORD(101.41,+ORDIALOG,10,DA,0)),U,9)'["W"),'$P($G(^ORD(101.41,+ORDIALOG,10,DA,0)),U,6)!$D(ORDIALOG(PROMPT,INST)) Q
I 'ORWMODE,LST(0),$D(ORDIALOG(PROMPT,INST)),($E(ORDIALOG(PROMPT,0))="W") Q
I 'ORWMODE,LST(0),'$P($G(^ORD(101.41,+ORDIALOG,10,DA,0)),U,6) Q
I 'ORWMODE,PROMPT=$$PTR("CLINICALLY INDICATED DATE"),$$ISPROS Q
S XCODE=$$SUBCODE($G(^ORD(101.41,+ORDIALOG,10,DA,3)))
I $L(XCODE) X XCODE Q:'$T
S MUSTASK=1
Q
SUBCODE(X) ; substitute code
I X["$$REQDCOMM^ORCDLR" Q "I $$LRRQCM^ORWDXM2"
I X["$$ASKSAMP^ORCDLR" Q "I $$LRASMP^ORWDXM2"
I X["$$SCHEDULD^ORCDRA1" Q "I $$SCHEDULD^ORWDXM2"
I X["(^PSX(550,""C"")" Q "S Y=$E($$DEFPICK^ORWDPS32) K:'$L(Y) Y"
I X["I $$ASKURG^ORCDVBEC" Q "I 1"
I X["K:$G(ORASK)" Q "I $G(ORASK)"
Q X
PTR(NAME) ; -- Returns pointer to OR GTX NAME
Q +$O(^ORD(101.41,"AB",$E("OR GTX "_NAME,1,63),0))
;
ISINPMED(IFN) ;
N PKG,RESULT,Y
I 'ORWMODE S PKG=$P($G(^ORD(101.41,IFN,0)),U,7)
E S PKG=$P($G(^OR(100,+IFN,0)),U,14)
S Y=$$GET1^DIQ(9.4,+PKG_",",1)
S RESULT=$S($E(Y,1,3)="PSJ":1,1:0)
Q RESULT
;
ISMED(IFN) ; return 1 if pharmacy order dlg used
N PKG
I 'ORWMODE S PKG=$P($G(^ORD(101.41,IFN,0)),U,7)
E S PKG=$P($G(^OR(100,+IFN,0)),U,14)
Q $$NMSP^ORCD(PKG)="PS"
SITEVAL() ;return 1 if site does want the reason for study to carry through from past orders of this ordering session
I $$GET^XPAR("ALL^SRV.`"_+^VA(200,DUZ,5),"OR RA RFS CARRY ON")=0 Q 0
Q 1
SVRPC(RET,X) ;RPC FOR SITEVAL
S RET=$$SITEVAL
Q
ISQO(IFN) ;return 1 if a non-VA medication quick order type of order dialog. p388
I $P($G(^ORD(101.41,IFN,0)),U,5)'=$O(^ORD(100.98,"B","NV RX",0)) Q 0
I $P($G(^ORD(101.41,IFN,0)),U,4)="Q" Q 1
Q 0
ISPROS() ;return 1 if OI is prosthetics service
N ORDITM,ORCONSVC,ORG
Q:'$D(ORDIALOG("B","CONSULT TO SERVICE/SPECIALTY")) 0
S ORDITM=$P((ORDIALOG("B","CONSULT TO SERVICE/SPECIALTY")),U,2)
S ORDITM=$G(ORDIALOG(ORDITM,1)) I $G(ORDITM)="" Q 0
S ORCONSVC=$P(^ORD(101.43,ORDITM,0),U,2),ORCONSVC=$P(ORCONSVC,";",1) Q:$G(ORCONSVC)="" 0
D ISPROSVC^ORQQCN2(.ORG,ORCONSVC)
I +$G(ORG)>0 Q 1
Q 0
TITR(ORDIALOG) ; add titration response when copying/changing old (pre-v32/p405) titration orders
N ORTITRDLG
S ORTITRDLG=$$PTR("TITRATION")
I '$D(ORDIALOG(ORTITRDLG,1)) D
. S ORDIALOG(ORTITRDLG,1)=1
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HORWDXM1 14543 printed Sep 23, 2025@20:12:18 Page 2
ORWDXM1 ;SLC/KCM - Order Dialogs, Menus ;Aug 18, 2022@07:44:57
+1 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**10,85,131,132,141,178,185,187,215,243,280,331,388,350,423,434,494,397,377,512,498,405**;Dec 17, 1997;Build 211
+2 ;
BLDQRSP(LST,ORIT,FLDS,ISIMO,ENCLOC) ; Build responses for an order
+1 ; LST=QuickLevel^ResponseID(ORIT;$H)^Dialog^Type^FormID^DGrp
+2 ; LST(n)=verify or reject text
+3 ; ORIT= ptr to 101.41 for quick order, 100 for copy
+4 ; 1 2 3 4 5 6 7 8 11-20
+5 ; FLDS=DFN^LOC^ORNP^INPT^SEX^AGE^EVENT^SC%^^^Key Variables...
+6 ; ORIT=+ORIT: ptr to 101.41, $E(ORIT)=C: copy $E(ORIT)=X: change
+7 ; !! SHOULD CHECK for PRE-CPRS ORDERS (treat as text?)
+8 KILL ^TMP("ORWDXMQ",$JOB)
+9 ; 0:Dlg,Quick 1:copy 2:change
NEW ORWMODE
+10 ; pt cat from DPT
NEW TEMPCAT
+11 ; Trnsfr order?
NEW ISXFER
+12 ;If IMO(inpt med on opt)
NEW ORIMO
+13 NEW TEMPORIT
+14 NEW ADMLOC,PATLOC,ORDLOC,LEVEL,DELAY,SCHLOC,SCHTYP
+15 SET PATLOC=$PIECE(FLDS,U,2)
+16 SET ORDLOC=$SELECT(ORIT["C":+$PIECE($GET(^OR(100,+$PIECE(ORIT,"C",2),0)),U,10),1:0)
+17 SET ORIMO=$GET(ISIMO)
+18 SET ORWMODE=0
SET ISXFER=""
+19 ;treat xfer as copy
if $EXTRACT(ORIT)="C"
SET ORWMODE=1
if $EXTRACT(ORIT)="T"
SET ORWMODE=1
SET ISXFER=";T"
+20 if $EXTRACT(ORIT)="X"
SET ORWMODE=2
+21 SET TEMPORIT=ORIT
+22 IF ORWMODE
SET ORIT=$EXTRACT(ORIT,2,999)
+23 SET LST(0)=""
+24 ;disable
+25 DO CHKDSBL^ORWDXM3(.LST,ORIT,ORWMODE)
if +LST(0)=8
QUIT
+26 ;action
+27 DO CHKVACT^ORWDXM3(.LST,ORIT,ORWMODE,$PIECE(FLDS,U,3))
if +LST(0)=8
QUIT
+28 ;no copy
+29 IF ORWMODE=1
DO CHKCOPY^ORWDXM3(.LST,ORIT,FLDS)
if +LST(0)=8
QUIT
+30 ;change
+31 IF ORWMODE=2
DO BLD4CHG^ORWDXM3(.LST,ORIT,FLDS)
QUIT
+32 IF 'ORWMODE
IF ($PIECE(^ORD(101.41,+ORIT,0),U,4)="D")
IF $PIECE(^ORD(101.41,+ORIT,0),"^",7)=$ORDER(^DIC(9.4,"C","SD",0))
SET LST(0)="0^0^"_$$DLGINFO^ORWDXM3(ORIT,ORWMODE_ISXFER)
QUIT
+33 IF 'ORWMODE
IF ($PIECE(^ORD(101.41,+ORIT,0),U,4)="D")
IF '($ORDER(^DIC(9.4,"C","OR",0))[$PIECE(^ORD(101.41,+ORIT,0),U,7))
SET LST(0)="0^0^"_$$DLGINFO^ORWDXM3(ORIT,ORWMODE_ISXFER)
QUIT
+34 NEW ORIMTYPE,ORCOMP,ORTAS,LRFZX,LRFSAMP,LRFSPEC,LRFDATE,LRFURG,LRFSCH
+35 NEW ORTIME,ORCOLLCT,ORMAX,ORTEST,ORIMTIME,ORSMAX,ORSTMS,ORSCH
+36 NEW PSJNOPC,ORMORE,ORINPT,ORXNP,ORSCHED,ORQTY,ORNOUNS,ORXNP,OREFILLS
+37 NEW ORCOMPLX,ORQTY,ORCOPAY,ORDRUG,ORWPSPIK,ORWPSWRG,ORSD,ORDSUP,ORWP94
+38 NEW ORPARAM,ORNPO,ORTIME,ORMEAL,ORTRAY,ORDATE,GMRCNOPD,GMRCNOAT,GMRCREAF
+39 NEW ORTYPE,ORVP,ORL,ORNP,ORSEX,ORAGE,ORWARD,OREVENT,ORDIV,ORSC,KEYVAR
+40 NEW ORDG,ORDIALOG,ORCAT,FIRST,ORQUIT,X,ORTRAIL,ORLEAD,RSPREF,AUTOACK
+41 NEW OREVNTYP
+42 SET ORWP94=$ORDER(^ORD(101.41,"AB","PS MEDS",0))>0
+43 SET ORVP=$PIECE(FLDS,U,1)_";DPT("
SET ORNP=+$PIECE(FLDS,U,3)
SET ORSC=$PIECE(FLDS,U,8)
+44 SET ORL=$PIECE(FLDS,U,2)_";SC("
SET ORL(2)=ORL
+45 SET ORSEX=$PIECE(FLDS,U,5)
SET ORAGE=$PIECE(FLDS,U,6)
SET ORTYPE="Q"
SET FIRST=1
+46 IF $PIECE(FLDS,U,4)
IF $GET(^SC(+ORL,42))
SET ORWARD=+^SC(+ORL,42)
+47 IF $LENGTH($PIECE(FLDS,U,7))
Begin DoDot:1
+48 SET OREVENT=$PIECE(FLDS,U,7)
+49 SET OREVNTYP=$PIECE(OREVENT,";",2)
+50 SET OREVENT("TS")=$PIECE(OREVENT,";",3)
+51 SET OREVENT("EFFECTIVE")=$PIECE(OREVENT,";",4)
+52 SET OREVENT=+$PIECE(OREVENT,";",1)
End DoDot:1
+53 IF 'ORWMODE
Begin DoDot:1
+54 ; from menu path
DO SETKEYV^ORWDXM3($PIECE(FLDS,U,11,20))
+55 ; from entry action
SET KEYVAR=$$KEYVAR^ORWDXM3(ORIT)
+56 DO SETKEYV^ORWDXM3(KEYVAR)
End DoDot:1
+57 KILL ^TMP("ORWORD",$JOB)
+58 ; init return record based on auto-accept
+59 ;verify on copy
IF ORWMODE
SET LST(0)="2^"_ORIT
+60 IF '$TEST
SET LST(0)=+$PIECE($GET(^ORD(101.41,ORIT,5)),U,8)_U_ORIT
+61 SET TEMPCAT=$SELECT($LENGTH($PIECE($GET(^DPT(+ORVP,.1)),U)):"I",1:"O")
+62 IF TEMPCAT="I"
IF +$PIECE(FLDS,U,4)=1
IF $EXTRACT(TEMPORIT)="C"
IF $PIECE($GET(^ORD(100.98,$PIECE($GET(^OR(100,+ORIT,0)),U,11),0)),U)="OUTPATIENT MEDICATIONS"
SET TEMPCAT="O"
+63 IF $LENGTH($GET(OREVNTYP))
Begin DoDot:1
+64 SET ORCAT=$SELECT(OREVNTYP="A":"I",OREVNTYP="T":"I",OREVNTYP="O":TEMPCAT,OREVNTYP="M":TEMPCAT,OREVNTYP="C":TEMPCAT,1:"O")
IF $GET(OREVENT)
Begin DoDot:2
+65 NEW X
SET X=$$EVT^OREVNTX(OREVENT)
SET X=$PIECE($GET(^ORD(100.5,+X,0)),U,7)
+66 ;To pass=outpt
IF OREVNTYP="T"
IF X
IF X<4
SET ORCAT="O"
+67 ;From ASIH=inpt
IF OREVNTYP="D"
IF X=41
SET ORCAT="I"
End DoDot:2
End DoDot:1
+68 IF '$TEST
SET ORCAT=TEMPCAT
+69 DO SETUP^ORWDXM4
if +LST(0)=8
QUIT
+70 SET X="OR GTX START DATE"_$SELECT($GET(ORWP94):"/TIME",1:"")
+71 IF ORWMODE
IF (ORDG=+$ORDER(^ORD(100.98,"B","O RX",0)))
Begin DoDot:1
+72 ;remove old values
KILL ORDIALOG($$PTR^ORCD(X),1)
+73 ;add titration response when copying/changing old (pre-v32/p405) titration orders
IF $$ISTITR^ORUTL3(+ORIT)
DO TITR(.ORDIALOG)
+74 ;keep comments
IF ORWMODE=2
IF $$DRAFT^ORWDX2(ORIT)
QUIT
+75 if ISXFER'["T"
KILL ORDIALOG($$PTR^ORCD("OR GTX WORD PROCESSING 1"),1)
End DoDot:1
+76 ;moved to save space, expects X
DO SETUPS^ORWDXM4
+77 if +LST(0)=8
QUIT
+78 IF $GET(ORQUIT)
SET LST(0)="0^0^"_$$DLGINFO^ORWDXM3(ORIT,ORWMODE_ISXFER)_"^"_$GET(KEYVAR)
QUIT
+79 NEW SEQ,DA,XCODE,MUSTASK,PROMPT,INST,KEY,IVFID,CLIVFID,VBFID
+80 SET IVFID=$ORDER(^ORD(101.41,"B","PSJI OR PAT FLUID OE",0))
+81 SET CLIVFID=$ORDER(^ORD(101.41,"B","CLINIC OR PAT FLUID OE",0))
+82 SET VBFID=$ORDER(^ORD(101.41,"B","VBEC BLOOD BANK",0))
+83 ;AGP CPRS 31 changes for 31. Diet order with active tubefeeding orders cannot be autoaccept
+84 ;tubefeeding orders cannot be autoaccept either.
+85 ;S AUTOACK=$S($D(ORWPSWRG):0,1:1)
+86 IF ORDIALOG=$ORDER(^ORD(101.41,"B","FHW8",0))
SET AUTOACK=0
+87 SET AUTOACK=$SELECT($DATA(ORWPSWRG):0,$GET(AUTOACK)'="":AUTOACK,1:1)
+88 ; If copying, clear bad dates. Later, SETITEM will fill dates with default values. ;DJE-VM *331
+89 ;
IF ORWMODE=1
Begin DoDot:1
+90 IF ORDIALOG=VBFID
IF $$VAL^ORCD("DATE/TIME WANTED")<$$NOW^XLFDT
Begin DoDot:2
+91 KILL ORDIALOG($PIECE(ORDIALOG("B","DATE/TIME WANTED"),"^",2),1)
+92 KILL ORDIALOG($PIECE(ORDIALOG("B","SPECIMEN STATUS"),"^",2),1)
End DoDot:2
+93 ;
IF $LENGTH($$VAL^ORCD("START DATE"))
Begin DoDot:2
+94 SET X=$$VAL^ORCD("START DATE")
SET %DT="TX"
DO ^%DT
+95 ;quit if valid dates: start not in the past or stop after start
IF Y'<$$DT^XLFDT
IF (($LENGTH($$VAL^ORCD("STOP DATE"))=0)!('$$FTDCOMP^ORCD("START DATE","STOP DATE",">")))
QUIT
+96 ;erase bad start and stop dates.
KILL ORDIALOG($$PTR("START DATE"),1),ORDIALOG($$PTR("START DATE/TIME"),1)
+97 KILL ORDIALOG($$PTR("STOP DATE"),1),ORDIALOG($$PTR("STOP DATE/TIME"),1)
End DoDot:2
+98 ; check start and stop dates found in diet orders
+99 ;
IF $LENGTH($$VAL^ORCD("EFFECTIVE DATE/TIME"))
Begin DoDot:2
+100 SET X=$$VAL^ORCD("EFFECTIVE DATE/TIME")
SET %DT="TX"
DO ^%DT
+101 ;quit if valid dates: start not in the past or stop after start
IF Y'<$$DT^XLFDT
IF (($LENGTH($$VAL^ORCD("EXPIRATION DATE/TIME"))=0)!('$$FTDCOMP^ORCD("EFFECTIVE DATE/TIME","EXPIRATION DATE/TIME",">")))
QUIT
+102 ;erase bad start and stop dates.
KILL ORDIALOG($PIECE(ORDIALOG("B","EFFECTIVE DATE/TIME"),U,2),1)
+103 KILL ORDIALOG($PIECE(ORDIALOG("B","EXPIRATION DATE/TIME"),U,2),1)
End DoDot:2
+104 ; check date desired field found in imaging orders
+105 ;
IF $LENGTH($$VAL^ORCD("DATE DESIRED"))
Begin DoDot:2
+106 SET X=$$VAL^ORCD("DATE DESIRED")
+107 ;OR 512 Erase future date if in +## or +##M format
+108 IF X["+"
KILL ORDIALOG($PIECE(ORDIALOG("B","DATE DESIRED"),U,2),1)
QUIT
+109 SET %DT="TX"
DO ^%DT
+110 ;quit if not a past date
IF Y'<$$DT^XLFDT
QUIT
+111 ;erase bad date
KILL ORDIALOG($PIECE(ORDIALOG("B","DATE DESIRED"),U,2),1)
End DoDot:2
+112 ; check collection date field found in lab orders
+113 ;
IF $LENGTH($$VAL^ORCD("COLLECTION DATE/TIME"))
Begin DoDot:2
+114 SET X=$$VAL^ORCD("COLLECTION DATE/TIME")
+115 ;No need to check this.
IF X="NEXT"
QUIT
+116 SET %DT="TX"
DO ^%DT
+117 ;quit if not a past date and time (lab is more precise than other dates)
IF $PIECE(Y,".",2)
IF Y'<$EXTRACT($$NOW^XLFDT,1,12)
QUIT
+118 ;
IF $PIECE(Y,".",2)=""
IF Y'<$$DT^XLFDT
QUIT
+119 ;erase bad date
KILL ORDIALOG($PIECE(ORDIALOG("B","COLLECTION DATE/TIME"),U,2),1)
End DoDot:2
+120 ;if copying a "Return to Clinic" order, force user to enter a date
+121 IF $LENGTH($$VAL^ORCD("RETURN TO CLINIC DATE"))
Begin DoDot:2
+122 KILL ORDIALOG($PIECE(ORDIALOG("B","RETURN TO CLINIC DATE"),U,2),1)
End DoDot:2
End DoDot:1
+123 SET SEQ=0
FOR
SET SEQ=$ORDER(^ORD(101.41,+ORDIALOG,10,"B",SEQ))
if 'SEQ
QUIT
Begin DoDot:1
+124 SET DA=0
FOR
SET DA=$ORDER(^ORD(101.41,+ORDIALOG,10,"B",SEQ,DA))
if 'DA
QUIT
Begin DoDot:2
+125 ; skip if child prmpt
+126 IF $PIECE(^ORD(101.41,+ORDIALOG,10,DA,0),U,11)
QUIT
+127 ; set dflt for prmpt, chk if interactive
+128 SET PROMPT=$PIECE(^ORD(101.41,+ORDIALOG,10,DA,0),U,2)
+129 DO SETITEM(DA,PROMPT,1,.MUSTASK)
+130 IF MUSTASK
SET AUTOACK=0
QUIT
+131 ; iterate through child items if parent & edit only
+132 if '$DATA(^ORD(101.41,+ORDIALOG,10,"DAD",PROMPT))
QUIT
+133 NEW CSEQ,CDA,CPROMPT,INST,ORQUIT
+134 SET CSEQ=0
FOR
SET CSEQ=$ORDER(^ORD(101.41,+ORDIALOG,10,"DAD",PROMPT,CSEQ))
if 'CSEQ
QUIT
Begin DoDot:3
+135 SET CDA=$ORDER(^ORD(101.41,+ORDIALOG,10,"DAD",PROMPT,CSEQ,0))
+136 SET CPROMPT=$PIECE(^ORD(101.41,+ORDIALOG,10,CDA,0),U,2)
+137 ; if req & no instances then need interaction
+138 IF $PIECE(^ORD(101.41,+ORDIALOG,10,CDA,0),U,6)
Begin DoDot:4
+139 IF ORDIALOG=IVFID!(ORDIALOG=CLIVFID)
QUIT
+140 IF '$ORDER(ORDIALOG(CPROMPT,0))
SET AUTOACK=0
End DoDot:4
+141 SET INST=0
FOR
SET INST=$ORDER(ORDIALOG(CPROMPT,INST))
if 'INST
QUIT
Begin DoDot:4
+142 ; set ORASK for VBECS
NEW ORASK
DO VBASK^ORWDXM4(INST)
+143 ; set dflt for each child prmpt
+144 DO SETITEM(CDA,CPROMPT,INST,.MUSTASK)
+145 ; if no val & child prmpt req'd then need interaction
+146 IF MUSTASK
IF $PIECE(^ORD(101.41,+ORDIALOG,10,CDA,0),U,6)
SET AUTOACK=0
End DoDot:4
End DoDot:3
if $GET(ORQUIT)
QUIT
End DoDot:2
End DoDot:1
+147 NEW IVDLG,CLINFDLG,SPLYDLG
+148 SET IVDLG=$ORDER(^ORD(101.41,"AB","PSJI OR PAT FLUID OE",0))
+149 SET CLINFDLG=$ORDER(^ORD(101.41,"AB","CLINIC OR PAT FLUID OE",0))
+150 SET SPLYDLG=$ORDER(^ORD(101.41,"AB","PSO SUPPLY",0))
+151 IF $$ISMED(ORIT)
IF (ORDIALOG'=IVDLG)
IF (ORDIALOG'=CLINFDLG)
IF (ORDIALOG'=SPLYDLG)
IF (ORCAT="I")
Begin DoDot:1
+152 NEW P
+153 FOR P="PATIENT INSTRUCTIONS","DAYS SUPPLY","QUANTITY","REFILLS","ROUTING","SERVICE CONNECTED"
KILL ORDIALOG($$PTR(P),1)
+154 ; kill if not a non-VA med quick order. p388
IF '$$ISQO(ORIT)
KILL ORDIALOG($$PTR("START DATE/TIME"),1)
End DoDot:1
+155 SET KEY=$SELECT(ORWMODE:"C",1:"")_ORIT_"-"_$PIECE($HOROLOG,",",2)
SET SEQ=0
+156 IF $$ISINPMED(ORIT)
Begin DoDot:1
+157 SET LEVEL=$PIECE(LST(0),U)
SET DELAY=$SELECT($PIECE($GET(OREVENT),";")>0:1,1:0)
+158 IF LEVEL=2!(ISIMO)
DO ADMTIME^ORWDXM2(ORDLOC,PATLOC,ENCLOC,DELAY,ISIMO)
End DoDot:1
+159 IF ($$ISMED(ORIT))
IF '($$VALQO^ORWDXM3(ORIT,$GET(ORVP)))
SET AUTOACK=0
+160 IF 'ORWMODE
IF $PIECE(^ORD(101.41,+ORIT,0),U,7)=$ORDER(^DIC(9.4,"C","SD",0))
IF '($$SDRTCVER^ORWDXM3(.ORDIALOG))
SET AUTOACK=0
+161 SET PROMPT=0
FOR
SET PROMPT=$ORDER(ORDIALOG(PROMPT))
if 'PROMPT
QUIT
Begin DoDot:1
+162 IF '$DATA(^ORD(101.41,ORDIALOG,10,"D",PROMPT))
KILL ORDIALOG(PROMPT)
QUIT
+163 SET INST=0
FOR
SET INST=$ORDER(ORDIALOG(PROMPT,INST))
if 'INST
QUIT
Begin DoDot:2
+164 SET SEQ=SEQ+1
SET ^TMP("ORWDXMQ",$JOB,KEY,SEQ,0)=U_PROMPT_U_INST
+165 ; save word proc val
+166 IF $EXTRACT(ORDIALOG(PROMPT,0))="W"
IF $LENGTH(ORDIALOG(PROMPT,INST))
Begin DoDot:3
+167 MERGE ^TMP("ORWDXMQ",$JOB,KEY,SEQ,2)=@ORDIALOG(PROMPT,INST)
End DoDot:3
+168 ; save other val types
+169 IF '$TEST
SET ^TMP("ORWDXMQ",$JOB,KEY,SEQ,1)=ORDIALOG(PROMPT,INST)
End DoDot:2
End DoDot:1
+170 IF AUTOACK
Begin DoDot:1
+171 IF ORWMODE
SET AUTOACK=2
+172 IF 'ORWMODE
IF ($PIECE(^ORD(101.41,ORIT,0),U,8)!'LST(0))
SET AUTOACK=2
End DoDot:1
+173 ;I ($$ISMED(ORIT)),'($$VALQO^ORWDXM3(ORIT)) S AUTOACK=0
+174 IF ORIMO
IF ORWMODE
SET AUTOACK=2
+175 ; accept Herbal/OTC/NonVA Med quick orders
+176 IF 'ORWMODE
IF $LENGTH($GET(^ORD(101.41,+ORIT,0)))
IF ($PIECE(^ORD(100.98,$PIECE(^ORD(101.41,+ORIT,0),U,5),0),U,3)="NV RX")
IF ($PIECE($GET(^ORD(101.41,+ORIT,5)),U,8))
SET AUTOACK=1
+177 ;I AUTOACK=2,$$ISMED(ORIT),(ORDIALOG=IVDLG),$$VERORD^ORWDXM3=0 S AUTOACK=0
+178 IF AUTOACK=2
IF $$ISMED(ORIT)
IF $$VERORD^ORWDXM3(ORIT,$GET(ORVP))=0
SET AUTOACK=0
+179 IF AUTOACK=2
DO VERTXT^ORWDXM2
+180 ;IF NEED TO CHANGE GUI DISPLAY TYPE CHANGE AUTOACK VALUE
+181 IF AUTOACK>0
Begin DoDot:1
+182 IF $$ISRAD^ORWDXM3(ORIT)
IF '$$VALRADQO^ORWDXM3(.ORDIALOG)
SET AUTOACK=0
End DoDot:1
+183 ;
+184 SET LST(0)=AUTOACK_U_KEY_U_$$DLGINFO^ORWDXM3(ORIT,ORWMODE_ISXFER)_"^"_$GET(KEYVAR)
+185 IF $PIECE(LST(0),U,4)="D"
SET $PIECE(LST(0),U,4)="Q"
+186 IF ORWMODE=1
SET $PIECE(LST(0),U,4)="C"
+187 KILL ^TMP("ORWORD",$JOB)
+188 KILL ^TMP("PSJINS",$JOB),^TMP("PSJMR",$JOB),^TMP("PSJNOUN",$JOB)
+189 QUIT
SETITEM(DA,PROMPT,INST,MUSTASK) ; set dflt val & return if must prompt
+1 NEW EDITONLY,Y,VALIV,XCODE
+2 SET MUSTASK=0
SET EDITONLY=0
SET VALIV=0
+3 IF $DATA(^TMP("ORWDHTM",$JOB,ORDIALOG,PROMPT))
Begin DoDot:1
+4 IF $EXTRACT(ORDIALOG(PROMPT,0))="W"
Begin DoDot:2
+5 SET ^TMP("ORWORD",$JOB,PROMPT,INST,1,0)=^TMP("ORWDHTM",$JOB,ORDIALOG,PROMPT)
+6 SET ORDIALOG(PROMPT,INST)="^TMP(""ORWORD"","_$JOB_","_PROMPT_","_INST_")"
End DoDot:2
+7 IF '$TEST
SET ORDIALOG(PROMPT,INST)=^TMP("ORWDHTM",$JOB,ORDIALOG,PROMPT)
End DoDot:1
+8 IF $DATA(^TMP("ORWDHTM",$JOB,ORIT,PROMPT))
Begin DoDot:1
+9 SET ORDIALOG(PROMPT,INST)=^TMP("ORWDHTM",$JOB,ORIT,PROMPT)
+10 ; NEED TO CLEAN UP ^TMP("ORWDHTM") after process order set!!!
End DoDot:1
+11 ;
+12 ; skip if a value already exists for this prompt and not WP
+13 if $DATA(ORDIALOG(PROMPT,INST))&($EXTRACT(ORDIALOG(PROMPT,0))'="W")
QUIT
+14 ; execute default action if no value in QO, checking EDITONLY afterwards
+15 IF '$DATA(ORDIALOG(PROMPT,INST))
Begin DoDot:1
+16 ;
+17 ;Intermittent IV orders do not require a solution or an infusion rate
+18 IF PROMPT=$$PTR("INFUSION RATE")
IF $$GETIVTYP^ORWDXM3="I"
SET VALIV=1
QUIT
+19 IF PROMPT=$$PTR("ORDERABLE ITEM")
IF $$GETIVTYP^ORWDXM3="I"
SET VALIV=1
QUIT
+20 IF $EXTRACT(ORDIALOG(PROMPT,0))="W"
IF $DATA(^ORD(101.41,+ORDIALOG,10,DA,8))>9
Begin DoDot:2
+21 MERGE ^TMP("ORWORD",$JOB,PROMPT,INST)=^ORD(101.41,+ORDIALOG,10,DA,8)
+22 SET ORDIALOG(PROMPT,INST)="^TMP(""ORWORD"","_$JOB_","_PROMPT_","_INST_")"
End DoDot:2
+23 IF '$TEST
Begin DoDot:2
+24 SET XCODE=$$SUBCODE($GET(^ORD(101.41,+ORDIALOG,10,DA,7)))
+25 IF $LENGTH(XCODE)
XECUTE XCODE
if $DATA(Y)
SET ORDIALOG(PROMPT,INST)=Y
End DoDot:2
End DoDot:1
+26 if VALIV=1
QUIT
+27 if $GET(EDITONLY)
QUIT
+28 IF 'ORWMODE
IF $PIECE($GET(^ORD(101.41,+ORDIALOG,10,DA,0)),U,8)
QUIT
+29 IF ORWMODE
IF ($PIECE($GET(^ORD(101.41,+ORDIALOG,10,DA,0)),U,9)'["W")
IF '$PIECE($GET(^ORD(101.41,+ORDIALOG,10,DA,0)),U,6)!$DATA(ORDIALOG(PROMPT,INST))
QUIT
+30 IF 'ORWMODE
IF LST(0)
IF $DATA(ORDIALOG(PROMPT,INST))
IF ($EXTRACT(ORDIALOG(PROMPT,0))="W")
QUIT
+31 IF 'ORWMODE
IF LST(0)
IF '$PIECE($GET(^ORD(101.41,+ORDIALOG,10,DA,0)),U,6)
QUIT
+32 IF 'ORWMODE
IF PROMPT=$$PTR("CLINICALLY INDICATED DATE")
IF $$ISPROS
QUIT
+33 SET XCODE=$$SUBCODE($GET(^ORD(101.41,+ORDIALOG,10,DA,3)))
+34 IF $LENGTH(XCODE)
XECUTE XCODE
if '$TEST
QUIT
+35 SET MUSTASK=1
+36 QUIT
SUBCODE(X) ; substitute code
+1 IF X["$$REQDCOMM^ORCDLR"
QUIT "I $$LRRQCM^ORWDXM2"
+2 IF X["$$ASKSAMP^ORCDLR"
QUIT "I $$LRASMP^ORWDXM2"
+3 IF X["$$SCHEDULD^ORCDRA1"
QUIT "I $$SCHEDULD^ORWDXM2"
+4 IF X["(^PSX(550,""C"")"
QUIT "S Y=$E($$DEFPICK^ORWDPS32) K:'$L(Y) Y"
+5 IF X["I $$ASKURG^ORCDVBEC"
QUIT "I 1"
+6 IF X["K:$G(ORASK)"
QUIT "I $G(ORASK)"
+7 QUIT X
PTR(NAME) ; -- Returns pointer to OR GTX NAME
+1 QUIT +$ORDER(^ORD(101.41,"AB",$EXTRACT("OR GTX "_NAME,1,63),0))
+2 ;
ISINPMED(IFN) ;
+1 NEW PKG,RESULT,Y
+2 IF 'ORWMODE
SET PKG=$PIECE($GET(^ORD(101.41,IFN,0)),U,7)
+3 IF '$TEST
SET PKG=$PIECE($GET(^OR(100,+IFN,0)),U,14)
+4 SET Y=$$GET1^DIQ(9.4,+PKG_",",1)
+5 SET RESULT=$SELECT($EXTRACT(Y,1,3)="PSJ":1,1:0)
+6 QUIT RESULT
+7 ;
ISMED(IFN) ; return 1 if pharmacy order dlg used
+1 NEW PKG
+2 IF 'ORWMODE
SET PKG=$PIECE($GET(^ORD(101.41,IFN,0)),U,7)
+3 IF '$TEST
SET PKG=$PIECE($GET(^OR(100,+IFN,0)),U,14)
+4 QUIT $$NMSP^ORCD(PKG)="PS"
SITEVAL() ;return 1 if site does want the reason for study to carry through from past orders of this ordering session
+1 IF $$GET^XPAR("ALL^SRV.`"_+^VA(200,DUZ,5),"OR RA RFS CARRY ON")=0
QUIT 0
+2 QUIT 1
SVRPC(RET,X) ;RPC FOR SITEVAL
+1 SET RET=$$SITEVAL
+2 QUIT
ISQO(IFN) ;return 1 if a non-VA medication quick order type of order dialog. p388
+1 IF $PIECE($GET(^ORD(101.41,IFN,0)),U,5)'=$ORDER(^ORD(100.98,"B","NV RX",0))
QUIT 0
+2 IF $PIECE($GET(^ORD(101.41,IFN,0)),U,4)="Q"
QUIT 1
+3 QUIT 0
ISPROS() ;return 1 if OI is prosthetics service
+1 NEW ORDITM,ORCONSVC,ORG
+2 if '$DATA(ORDIALOG("B","CONSULT TO SERVICE/SPECIALTY"))
QUIT 0
+3 SET ORDITM=$PIECE((ORDIALOG("B","CONSULT TO SERVICE/SPECIALTY")),U,2)
+4 SET ORDITM=$GET(ORDIALOG(ORDITM,1))
IF $GET(ORDITM)=""
QUIT 0
+5 SET ORCONSVC=$PIECE(^ORD(101.43,ORDITM,0),U,2)
SET ORCONSVC=$PIECE(ORCONSVC,";",1)
if $GET(ORCONSVC)=""
QUIT 0
+6 DO ISPROSVC^ORQQCN2(.ORG,ORCONSVC)
+7 IF +$GET(ORG)>0
QUIT 1
+8 QUIT 0
TITR(ORDIALOG) ; add titration response when copying/changing old (pre-v32/p405) titration orders
+1 NEW ORTITRDLG
+2 SET ORTITRDLG=$$PTR("TITRATION")
+3 IF '$DATA(ORDIALOG(ORTITRDLG,1))
Begin DoDot:1
+4 SET ORDIALOG(ORTITRDLG,1)=1
End DoDot:1
+5 QUIT
