- 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 Feb 19, 2025@00:02:31 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