ORWDXM1.m

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 ---ORWDXM1   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