ORWDPS1.m

ORWDPS1 ; SLC/KCM/JLI - Pharmacy Calls for Windows Dialog; 03/10/2008

 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**85,132,141,163,215,255,243**;Dec 17, 1997;Build 242

 ;

ODSLCT(LST,PSTYPE,DFN,LOC) ; return default lists for dialog

 ; PSTYPE: pharmacy type (U=unit dose, F=IV fluids, O=outpatient)

 N ILST S ILST=0

 S ILST=ILST+1,LST(ILST)="~Priority" D PRIOR

 S ILST=ILST+1,LST(ILST)="~DispMsg"

 S ILST=ILST+1,LST(ILST)="d"_$$DISPMSG

 ;

 ; I PSTYPE="F" D  Q                           ; IV Fluids

 ; . S ILST=ILST+1,LST(ILST)="~ShortList" D SHORT

 ;

 I PSTYPE="O" D                                ; Outpatient

 . S ILST=ILST+1,LST(ILST)="~Refills"

 . S ILST=ILST+1,LST(ILST)="d0^0"

 . S ILST=ILST+1,LST(ILST)="~Pickup"

 . S ILST=ILST+1,LST(ILST)="d"_$$DEFPICK($G(LOC))

 . ; S ILST=ILST+1,LST(ILST)="~Supply"

 . ; S ILST=ILST+1,LST(ILST)="d^"_$$DEFSPLY(DFN)

 Q

PKI(ORY,OI,PSTYPE,ORVP,PKIACTIV) ; return DEA Schedule for drug

 N ILST,ORDOSE,ORWPSOI,ORWDOSES,X1,X2,X

 K ^TMP("PSJINS",$J),^TMP("PSJMR",$J),^TMP("PSJNOUN",$J),^TMP("PSJSCH",$J),^TMP("PSSDIN",$J)

 S ILST=0

 S ORWPSOI=0

 S:+OI ORWPSOI=+$P($G(^ORD(101.43,+OI,0)),U,2)

 D START^PSSJORDF(ORWPSOI,$S(PSTYPE="U":"I",1:"O")) ; dflt route, schedule, etc.

 I '$L($T(DOSE^PSSOPKI1)) D DOSE^PSSORUTL(.ORDOSE,ORWPSOI,PSTYPE,ORVP)       ; dflt doses

 I $L($T(DOSE^PSSOPKI1)) D DOSE^PSSOPKI1(.ORDOSE,ORWPSOI,PSTYPE,ORVP)       ; dflt doses NEW PKI CODE from pharmacy

 D EN^PSSDIN(ORWPSOI)                               ; nfi text

 S ORY="" ;PKI

 I $D(ORDOSE("DEA")) S X="",X1=$P(ORDOSE("DEA"),";"),X2=$P(ORDOSE("DEA"),";",2) D

 . I '$L(X2) Q

 . I $G(PKIACTIV) S X=X2

 S ORY=X

 K ^TMP("PSJINS",$J),^TMP("PSJMR",$J),^TMP("PSJNOUN",$J),^TMP("PSJSCH",$J),^TMP("PSSDIN",$J)

 Q

PRIOR ; from DLGSLCT, get list of allowed priorities

 N X,XREF

 S XREF=$S(PSTYPE="O":"S.PSO",1:"S.PSJ")

 S X="" F  S X=$O(^ORD(101.42,XREF,X)) Q:'$L(X)  D

 . I XREF["PSJ",X'="ASAP",X'="ROUTINE",X'="STAT" Q

 . S ILST=ILST+1,LST(ILST)="i"_$O(^ORD(101.42,XREF,X,0))_U_X

 S ILST=ILST+1,LST(ILST)="d"_$O(^ORD(101.42,"B","ROUTINE",0))_U_"ROUTINE"

 Q

DEFPICK(LOC)       ; return default routing

 N X,DLG,PRMT

 S DLG=$O(^ORD(101.41,"AB","PSO OERR",0)),X=""

 S PRMT=$O(^ORD(101.41,"AB","OR GTX ROUTING",0))

 I $D(^TMP("ORECALL",$J,+DLG,+PRMT,1)) S X=^(1)

 I X'="" S EDITONLY=1 Q X  ; EDITONLY used by default action

 ;

 ;S X=$$GET^XPAR("ALL^"_"LOC.`"_LOC,"ORWDPS ROUTING DEFAULT",1,"I")

 S X=$$GET^XPAR("LOC.`"_LOC_"^SYS","ORWDPS ROUTING DEFAULT",1,"I")

 I X="C" S X="C^in Clinic" G XPICK

 I X="M" S X="M^by Mail"   G XPICK

 I X="W" S X="W^at Window" G XPICK

 I X="N" S X=""            G XPICK

 I X=""  S X=$S($D(^PSX(550,"C")):"M^by Mail",1:"W^at Window")

XPICK Q X

 ;

DEFSPLY(DFN)    ; return default days supply for this patient

 N ORWX

 S ORWX("PATIENT")=DFN

 D DSUP^PSOSIGDS(.ORWX)

 Q $G(ORWX("DAYS SUPPLY"))

 ;

DFLTSPLY(VAL,UPD,SCH,PAT,DRG)        ; return days supply given quantity

 ; VAL: default days supply

 N ORWX,I

 S ORWX("PATIENT")=PAT

 I DRG S ORWX("DRUG")=DRG

 F I=1:1:$L(UPD,U)-1 D

 . S ORWX("DOSE ORDERED",I)=$P(UPD,U,I)

 . S ORWX("SCHEDULE",I)=$P(SCH,U,I)

 D DSUP^PSOSIGDS(.ORWX)

 S VAL=$G(ORWX("DAYS SUPPLY"))

 Q

DISPMSG()       ; return 1 to suppress dispense message

 Q +$$GET^XPAR("ALL","ORWDPS SUPPRESS DISPENSE MSG",1,"I")

 ;

DOWSCH(LST,DFN,LOCIEN)     ; return all schedules

 N CNT,FREQ,ILST,ORARRAY,WIEN

 S WIEN=$$WARDIEN^ORWDPS32(+$G(LOCIEN))

 D SCHED^PSS51P1(WIEN,.ORARRAY)

 S ILST=0

 S CNT=0 F  S CNT=$O(ORARRAY(CNT)) Q:CNT'>0  D

 .S NODE=$G(ORARRAY(CNT))

 .I $P(NODE,U,4)="C" D

 ..K ^TMP($J,"ORWDPS1 DOWSCH")

 ..D ZERO^PSS51P1($P(NODE,U),,,,"ORWDPS1 DOWSCH")

 ..S FREQ=$G(^TMP($J,"ORWDPS1 DOWSCH",$P(NODE,U),2))

 ..K ^TMP($J,"ORWDPS1 DOWSCH")

 ..I +FREQ=0 Q

 ..I +FREQ>1440 Q

 ..S ILST=ILST+1,LST(ILST)=$P(ORARRAY(CNT),U,2,5)

 Q

 ;

SCHALL(LST,DFN,LOCIEN)     ; return all schedules

 N CNT,ILST,ORARRAY,WIEN

 S WIEN=$$WARDIEN^ORWDPS32(+$G(LOCIEN))

 D SCHED^PSS51P1(WIEN,.ORARRAY)

 S ILST=0

 S CNT=0 F  S CNT=$O(ORARRAY(CNT)) Q:CNT'>0  D

 .S ILST=ILST+1,LST(ILST)=$P(ORARRAY(CNT),U,2,5)

 Q

 ;

FORMALT(ORLST,ORIEN,PSTYPE) ; return a list of formulary alternatives

 N PSID,I

 S ORIEN=+$P(^ORD(101.43,ORIEN,0),U,2)

 D EN1^PSSUTIL1(.ORIEN,PSTYPE)

 S PSID=0,I=0

 F  S PSID=$O(ORIEN(PSID)) Q:'PSID  D

 . S OI=+$O(^ORD(101.43,"ID",PSID_";99PSP",0))

 . I OI S I=I+1,ORLST(I)=OI,$P(ORLST(I),U,2)=$P(^ORD(101.43,OI,0),U)

 Q

DOSEALT(LST,DDRUG,CUROI,PSTYPE) ; return a list of formulary alternatives for dose

 N I,OI,ORWLST,ILST S ILST=0

 D ENRFA^PSJORUTL(DDRUG,PSTYPE,.ORWLST)

 S I=0 F  S I=$O(ORWLST(I)) Q:'I  D

 . S OI=+$O(^ORD(101.43,"ID",+$P(ORWLST(I),U,4)_";99PSP",0))

 . I OI,OI'=CUROI S ILST=ILST+1,LST(ILST)=OI_U_$P(^ORD(101.43,OI,0),U)

 Q

QOMEDALT(ORY,ODIEN) ;

 N ARRAY,IDIEN,ORDERID,PKG,PSTYPE,VALUE

 S ORY=0,PKG=+$P(^ORD(101.41,ODIEN,0),U,7)

 S PSTYPE=$S($$GET1^DIQ(9.4,PKG_",",1)="PSO":"O",1:"I")

 S ORDERID=$O(^ORD(101.41,"B","OR GTX ORDERABLE ITEM","")) Q:ORDERID'>0

 S IDIEN=$O(^ORD(101.41,ODIEN,6,"D",ORDERID,"")) Q:IDIEN'>0

 S VALUE=$G(^ORD(101.41,ODIEN,6,IDIEN,1)) Q:VALUE'>0

 I $P($G(^ORD(101.43,VALUE,"PS")),U,6)=1 S ORY=VALUE

 ;D FORMALT(.ARRAY,VALUE,PSTYPE) I $D(ARRAY)>0 S ORY=VALUE

 ;I ORY=0,$P($G(^ORD(101.43,VALUE,"PS")),U,6)=1 S ORY=VALUE

 Q

FAILDEA(FAIL,OI,ORNP,PSTYPE)    ; return 1 if DEA check fails for this provider

 N DEAFLG,PSOI,TPKG

 S FAIL=0,TPKG=$P($G(^ORD(101.43,+$G(OI),0)),U,2)

 Q:TPKG'["PS"

 S PSOI=+TPKG Q:PSOI'>0

 I '$L($T(OIDEA^PSSUTLA1)) Q

 S DEAFLG=$$OIDEA^PSSUTLA1(PSOI,PSTYPE) Q:DEAFLG'>0

 I '$L($$DEA^XUSER(,+$G(ORNP))) S FAIL=1

 Q

FDEA1(FAIL,OI,OITYPE,ORNP) ; only be called for an outpaitent and IV dialog

 ;OI: IV Orderable Item

 ;OITYPE: A:ADDITIVE  S:SOLUTION

 N DEAFLG,PSOI,TKPG

 S FAIL=0,TPKG=$P($G(^ORD(101.43,+$G(OI),0)),U,2)

 Q:TPKG'["PS"

 S PSOI=+TPKG Q:PSOI'>0

 I '$L($T(IVDEA^PSSUTIL1)) Q

 S DEAFLG=$$IVDEA^PSSUTIL1(PSOI,OITYPE) Q:DEAFLG'>0

 I '$L($P($G(^VA(200,+$G(ORNP),"PS")),U,2)),'$L($P($G(^("PS")),U,3)) S FAIL=1

 Q

 ;

CHK94(VAL)      ; return 1 if patch 94 has been installed

 S VAL=0

 I $O(^ORD(101.41,"B","PS MEDS",0)) S VAL=1

 Q

LOCPICK(Y,LOC) ; return default Location level routing

 S Y=""

 S Y=$$GET^XPAR("LOC.`"_LOC_"^SYS","ORWDPS ROUTING DEFAULT",1,"I")

 I Y="C" S Y="C^in Clinic"

 I Y="M" S Y="M^by Mail"

 I Y="W" S Y="W^at Window"

 I Y="N" S Y=""

 Q

HASOIPI(Y,QOID) ; Check if QO put orderable item's PI into Sig

 N PIIEN,OIX

 S Y=0

 Q:'$D(^ORD(101.41,QOID,0))

 S PIIEN=$O(^ORD(101.41,"B","OR GTX PATIENT INSTRUCTIONS",0))

 Q:'PIIEN

 S OIX=0

 Q:'$D(^ORD(101.41,QOID,6,"D"))

 F  S OIX=$O(^ORD(101.41,+QOID,6,"D",OIX)) Q:'OIX  D

 . I OIX=PIIEN S Y=1 Q

 Q

HASROUTE(Y,QOID) ;Check if QO has a ROUTE defined

 N ROUTID

 S Y=0,ROUTID=0

 S ROUTID=$O(^ORD(101.41,"B","OR GTX ROUTING",0))

 Q:'ROUTID

 Q:'$D(^ORD(101.41,+QOID))

 I $D(^ORD(101.41,+QOID,6,"D",ROUTID)) S Y=1

 Q

QOCHECK(ORY,DIEN) ;

 N ARY,DG,FORMIEN,NAME,OI,OIIEN,ORDIALOG,ORPKG,TYPE

 S ORPKG=$$NMSP^ORCD($P($G(^ORD(101.41,DIEN,0)),U,7)) Q:ORPKG'["PS"

 S DG=$P(^ORD(101.41,DIEN,0),U,5)

 S NAME=$P(^ORD(100.98,DIEN,0),U)

 S TYPE=$S(NAME="INPATIENT MEDICATIONS":"I",NAME="OUTPATIENT MEDICATIONS":"O",1:"")

 I TYPE="" Q

 S ORDIALOG=$$DEFDLG^ORCD(DIEN) Q:ORDIALOG

 D GETDLG^ORCD(ORDIALOG),GETORDER^ORCD("^ORD(101.41,"_DIEN_",6)")

 I $D(ORDIALOG)'>0 Q

 S OI=$P($G(ORDIALOG("B","ORDERABLE")),U,2) Q:OI'>0

 S OIIEN=$G(ORDIALOG(OI,1)) Q:OIIEN'>0

 D FORMALT(.ARY,OIIEN,TYPE) I $D(ARY)'>0 Q

 S ORY=OIIEN

 Q

ORWDPS1   ; SLC/KCM/JLI - Pharmacy Calls for Windows Dialog; 03/10/2008

 +1       ;;3.0;ORDER ENTRY/RESULTS REPORTING;**85,132,141,163,215,255,243**;Dec 17, 1997;Build 242

 +2       ;

ODSLCT(LST,PSTYPE,DFN,LOC) ; return default lists for dialog

 +1       ; PSTYPE: pharmacy type (U=unit dose, F=IV fluids, O=outpatient)

 +2        NEW ILST

           SET ILST=0

 +3        SET ILST=ILST+1

           SET LST(ILST)="~Priority"

           DO PRIOR

 +4        SET ILST=ILST+1

           SET LST(ILST)="~DispMsg"

 +5        SET ILST=ILST+1

           SET LST(ILST)="d"_$$DISPMSG

 +6       ;

 +7       ; I PSTYPE="F" D  Q                           ; IV Fluids

 +8       ; . S ILST=ILST+1,LST(ILST)="~ShortList" D SHORT

 +9       ;

 +10      ; Outpatient

           IF PSTYPE="O"

               Begin DoDot:1

 +11               SET ILST=ILST+1

                   SET LST(ILST)="~Refills"

 +12               SET ILST=ILST+1

                   SET LST(ILST)="d0^0"

 +13               SET ILST=ILST+1

                   SET LST(ILST)="~Pickup"

 +14               SET ILST=ILST+1

                   SET LST(ILST)="d"_$$DEFPICK($GET(LOC))

 +15      ; S ILST=ILST+1,LST(ILST)="~Supply"

 +16      ; S ILST=ILST+1,LST(ILST)="d^"_$$DEFSPLY(DFN)

               End DoDot:1

 +17       QUIT 

PKI(ORY,OI,PSTYPE,ORVP,PKIACTIV) ; return DEA Schedule for drug

 +1        NEW ILST,ORDOSE,ORWPSOI,ORWDOSES,X1,X2,X

 +2        KILL ^TMP("PSJINS",$JOB),^TMP("PSJMR",$JOB),^TMP("PSJNOUN",$JOB),^TMP("PSJSCH",$JOB),^TMP("PSSDIN",$JOB)

 +3        SET ILST=0

 +4        SET ORWPSOI=0

 +5        IF +OI

               SET ORWPSOI=+$PIECE($GET(^ORD(101.43,+OI,0)),U,2)

 +6       ; dflt route, schedule, etc.

           DO START^PSSJORDF(ORWPSOI,$SELECT(PSTYPE="U":"I",1:"O"))

 +7       ; dflt doses

           IF '$LENGTH($TEXT(DOSE^PSSOPKI1))

               DO DOSE^PSSORUTL(.ORDOSE,ORWPSOI,PSTYPE,ORVP)

 +8       ; dflt doses NEW PKI CODE from pharmacy

           IF $LENGTH($TEXT(DOSE^PSSOPKI1))

               DO DOSE^PSSOPKI1(.ORDOSE,ORWPSOI,PSTYPE,ORVP)

 +9       ; nfi text

           DO EN^PSSDIN(ORWPSOI)

 +10      ;PKI

           SET ORY=""

 +11       IF $DATA(ORDOSE("DEA"))

               SET X=""

               SET X1=$PIECE(ORDOSE("DEA"),";")

               SET X2=$PIECE(ORDOSE("DEA"),";",2)

               Begin DoDot:1

 +12               IF '$LENGTH(X2)

                       QUIT 

 +13               IF $GET(PKIACTIV)

                       SET X=X2

               End DoDot:1

 +14       SET ORY=X

 +15       KILL ^TMP("PSJINS",$JOB),^TMP("PSJMR",$JOB),^TMP("PSJNOUN",$JOB),^TMP("PSJSCH",$JOB),^TMP("PSSDIN",$JOB)

 +16       QUIT 

PRIOR     ; from DLGSLCT, get list of allowed priorities

 +1        NEW X,XREF

 +2        SET XREF=$SELECT(PSTYPE="O":"S.PSO",1:"S.PSJ")

 +3        SET X=""

           FOR 

               SET X=$ORDER(^ORD(101.42,XREF,X))

               IF '$LENGTH(X)

                   QUIT 

               Begin DoDot:1

 +4                IF XREF["PSJ"

                       IF X'="ASAP"

                           IF X'="ROUTINE"

                               IF X'="STAT"

                                   QUIT 

 +5                SET ILST=ILST+1

                   SET LST(ILST)="i"_$ORDER(^ORD(101.42,XREF,X,0))_U_X

               End DoDot:1

 +6        SET ILST=ILST+1

           SET LST(ILST)="d"_$ORDER(^ORD(101.42,"B","ROUTINE",0))_U_"ROUTINE"

 +7        QUIT 

DEFPICK(LOC) ; return default routing

 +1        NEW X,DLG,PRMT

 +2        SET DLG=$ORDER(^ORD(101.41,"AB","PSO OERR",0))

           SET X=""

 +3        SET PRMT=$ORDER(^ORD(101.41,"AB","OR GTX ROUTING",0))

 +4        IF $DATA(^TMP("ORECALL",$JOB,+DLG,+PRMT,1))

               SET X=^(1)

 +5       ; EDITONLY used by default action

           IF X'=""

               SET EDITONLY=1

               QUIT X

 +6       ;

 +7       ;S X=$$GET^XPAR("ALL^"_"LOC.`"_LOC,"ORWDPS ROUTING DEFAULT",1,"I")

 +8        SET X=$$GET^XPAR("LOC.`"_LOC_"^SYS","ORWDPS ROUTING DEFAULT",1,"I")

 +9        IF X="C"

               SET X="C^in Clinic"

               GOTO XPICK

 +10       IF X="M"

               SET X="M^by Mail"

               GOTO XPICK

 +11       IF X="W"

               SET X="W^at Window"

               GOTO XPICK

 +12       IF X="N"

               SET X=""

               GOTO XPICK

 +13       IF X=""

               SET X=$SELECT($DATA(^PSX(550,"C")):"M^by Mail",1:"W^at Window")

XPICK      QUIT X

 +1       ;

DEFSPLY(DFN) ; return default days supply for this patient

 +1        NEW ORWX

 +2        SET ORWX("PATIENT")=DFN

 +3        DO DSUP^PSOSIGDS(.ORWX)

 +4        QUIT $GET(ORWX("DAYS SUPPLY"))

 +5       ;

DFLTSPLY(VAL,UPD,SCH,PAT,DRG) ; return days supply given quantity

 +1       ; VAL: default days supply

 +2        NEW ORWX,I

 +3        SET ORWX("PATIENT")=PAT

 +4        IF DRG

               SET ORWX("DRUG")=DRG

 +5        FOR I=1:1:$LENGTH(UPD,U)-1

               Begin DoDot:1

 +6                SET ORWX("DOSE ORDERED",I)=$PIECE(UPD,U,I)

 +7                SET ORWX("SCHEDULE",I)=$PIECE(SCH,U,I)

               End DoDot:1

 +8        DO DSUP^PSOSIGDS(.ORWX)

 +9        SET VAL=$GET(ORWX("DAYS SUPPLY"))

 +10       QUIT 

DISPMSG() ; return 1 to suppress dispense message

 +1        QUIT +$$GET^XPAR("ALL","ORWDPS SUPPRESS DISPENSE MSG",1,"I")

 +2       ;

DOWSCH(LST,DFN,LOCIEN) ; return all schedules

 +1        NEW CNT,FREQ,ILST,ORARRAY,WIEN

 +2        SET WIEN=$$WARDIEN^ORWDPS32(+$GET(LOCIEN))

 +3        DO SCHED^PSS51P1(WIEN,.ORARRAY)

 +4        SET ILST=0

 +5        SET CNT=0

           FOR 

               SET CNT=$ORDER(ORARRAY(CNT))

               IF CNT'>0

                   QUIT 

               Begin DoDot:1

 +6                SET NODE=$GET(ORARRAY(CNT))

 +7                IF $PIECE(NODE,U,4)="C"

                       Begin DoDot:2

 +8                        KILL ^TMP($JOB,"ORWDPS1 DOWSCH")

 +9                        DO ZERO^PSS51P1($PIECE(NODE,U),,,,"ORWDPS1 DOWSCH")

 +10                       SET FREQ=$GET(^TMP($JOB,"ORWDPS1 DOWSCH",$PIECE(NODE,U),2))

 +11                       KILL ^TMP($JOB,"ORWDPS1 DOWSCH")

 +12                       IF +FREQ=0

                               QUIT 

 +13                       IF +FREQ>1440

                               QUIT 

 +14                       SET ILST=ILST+1

                           SET LST(ILST)=$PIECE(ORARRAY(CNT),U,2,5)

                       End DoDot:2

               End DoDot:1

 +15       QUIT 

 +16      ;

SCHALL(LST,DFN,LOCIEN) ; return all schedules

 +1        NEW CNT,ILST,ORARRAY,WIEN

 +2        SET WIEN=$$WARDIEN^ORWDPS32(+$GET(LOCIEN))

 +3        DO SCHED^PSS51P1(WIEN,.ORARRAY)

 +4        SET ILST=0

 +5        SET CNT=0

           FOR 

               SET CNT=$ORDER(ORARRAY(CNT))

               IF CNT'>0

                   QUIT 

               Begin DoDot:1

 +6                SET ILST=ILST+1

                   SET LST(ILST)=$PIECE(ORARRAY(CNT),U,2,5)

               End DoDot:1

 +7        QUIT 

 +8       ;

FORMALT(ORLST,ORIEN,PSTYPE) ; return a list of formulary alternatives

 +1        NEW PSID,I

 +2        SET ORIEN=+$PIECE(^ORD(101.43,ORIEN,0),U,2)

 +3        DO EN1^PSSUTIL1(.ORIEN,PSTYPE)

 +4        SET PSID=0

           SET I=0

 +5        FOR 

               SET PSID=$ORDER(ORIEN(PSID))

               IF 'PSID

                   QUIT 

               Begin DoDot:1

 +6                SET OI=+$ORDER(^ORD(101.43,"ID",PSID_";99PSP",0))

 +7                IF OI

                       SET I=I+1

                       SET ORLST(I)=OI

                       SET $PIECE(ORLST(I),U,2)=$PIECE(^ORD(101.43,OI,0),U)

               End DoDot:1

 +8        QUIT 

DOSEALT(LST,DDRUG,CUROI,PSTYPE) ; return a list of formulary alternatives for dose

 +1        NEW I,OI,ORWLST,ILST

           SET ILST=0

 +2        DO ENRFA^PSJORUTL(DDRUG,PSTYPE,.ORWLST)

 +3        SET I=0

           FOR 

               SET I=$ORDER(ORWLST(I))

               IF 'I

                   QUIT 

               Begin DoDot:1

 +4                SET OI=+$ORDER(^ORD(101.43,"ID",+$PIECE(ORWLST(I),U,4)_";99PSP",0))

 +5                IF OI

                       IF OI'=CUROI

                           SET ILST=ILST+1

                           SET LST(ILST)=OI_U_$PIECE(^ORD(101.43,OI,0),U)

               End DoDot:1

 +6        QUIT 

QOMEDALT(ORY,ODIEN) ;

 +1        NEW ARRAY,IDIEN,ORDERID,PKG,PSTYPE,VALUE

 +2        SET ORY=0

           SET PKG=+$PIECE(^ORD(101.41,ODIEN,0),U,7)

 +3        SET PSTYPE=$SELECT($$GET1^DIQ(9.4,PKG_",",1)="PSO":"O",1:"I")

 +4        SET ORDERID=$ORDER(^ORD(101.41,"B","OR GTX ORDERABLE ITEM",""))

           IF ORDERID'>0

               QUIT 

 +5        SET IDIEN=$ORDER(^ORD(101.41,ODIEN,6,"D",ORDERID,""))

           IF IDIEN'>0

               QUIT 

 +6        SET VALUE=$GET(^ORD(101.41,ODIEN,6,IDIEN,1))

           IF VALUE'>0

               QUIT 

 +7        IF $PIECE($GET(^ORD(101.43,VALUE,"PS")),U,6)=1

               SET ORY=VALUE

 +8       ;D FORMALT(.ARRAY,VALUE,PSTYPE) I $D(ARRAY)>0 S ORY=VALUE

 +9       ;I ORY=0,$P($G(^ORD(101.43,VALUE,"PS")),U,6)=1 S ORY=VALUE

 +10       QUIT 

FAILDEA(FAIL,OI,ORNP,PSTYPE) ; return 1 if DEA check fails for this provider

 +1        NEW DEAFLG,PSOI,TPKG

 +2        SET FAIL=0

           SET TPKG=$PIECE($GET(^ORD(101.43,+$GET(OI),0)),U,2)

 +3        IF TPKG'["PS"

               QUIT 

 +4        SET PSOI=+TPKG

           IF PSOI'>0

               QUIT 

 +5        IF '$LENGTH($TEXT(OIDEA^PSSUTLA1))

               QUIT 

 +6        SET DEAFLG=$$OIDEA^PSSUTLA1(PSOI,PSTYPE)

           IF DEAFLG'>0

               QUIT 

 +7        IF '$LENGTH($$DEA^XUSER(,+$GET(ORNP)))

               SET FAIL=1

 +8        QUIT 

FDEA1(FAIL,OI,OITYPE,ORNP) ; only be called for an outpaitent and IV dialog

 +1       ;OI: IV Orderable Item

 +2       ;OITYPE: A:ADDITIVE  S:SOLUTION

 +3        NEW DEAFLG,PSOI,TKPG

 +4        SET FAIL=0

           SET TPKG=$PIECE($GET(^ORD(101.43,+$GET(OI),0)),U,2)

 +5        IF TPKG'["PS"

               QUIT 

 +6        SET PSOI=+TPKG

           IF PSOI'>0

               QUIT 

 +7        IF '$LENGTH($TEXT(IVDEA^PSSUTIL1))

               QUIT 

 +8        SET DEAFLG=$$IVDEA^PSSUTIL1(PSOI,OITYPE)

           IF DEAFLG'>0

               QUIT 

 +9        IF '$LENGTH($PIECE($GET(^VA(200,+$GET(ORNP),"PS")),U,2))

               IF '$LENGTH($PIECE($GET(^("PS")),U,3))

                   SET FAIL=1

 +10       QUIT 

 +11      ;

CHK94(VAL) ; return 1 if patch 94 has been installed

 +1        SET VAL=0

 +2        IF $ORDER(^ORD(101.41,"B","PS MEDS",0))

               SET VAL=1

 +3        QUIT 

LOCPICK(Y,LOC) ; return default Location level routing

 +1        SET Y=""

 +2        SET Y=$$GET^XPAR("LOC.`"_LOC_"^SYS","ORWDPS ROUTING DEFAULT",1,"I")

 +3        IF Y="C"

               SET Y="C^in Clinic"

 +4        IF Y="M"

               SET Y="M^by Mail"

 +5        IF Y="W"

               SET Y="W^at Window"

 +6        IF Y="N"

               SET Y=""

 +7        QUIT 

HASOIPI(Y,QOID) ; Check if QO put orderable item's PI into Sig

 +1        NEW PIIEN,OIX

 +2        SET Y=0

 +3        IF '$DATA(^ORD(101.41,QOID,0))

               QUIT 

 +4        SET PIIEN=$ORDER(^ORD(101.41,"B","OR GTX PATIENT INSTRUCTIONS",0))

 +5        IF 'PIIEN

               QUIT 

 +6        SET OIX=0

 +7        IF '$DATA(^ORD(101.41,QOID,6,"D"))

               QUIT 

 +8        FOR 

               SET OIX=$ORDER(^ORD(101.41,+QOID,6,"D",OIX))

               IF 'OIX

                   QUIT 

               Begin DoDot:1

 +9                IF OIX=PIIEN

                       SET Y=1

                       QUIT 

               End DoDot:1

 +10       QUIT 

HASROUTE(Y,QOID) ;Check if QO has a ROUTE defined

 +1        NEW ROUTID

 +2        SET Y=0

           SET ROUTID=0

 +3        SET ROUTID=$ORDER(^ORD(101.41,"B","OR GTX ROUTING",0))

 +4        IF 'ROUTID

               QUIT 

 +5        IF '$DATA(^ORD(101.41,+QOID))

               QUIT 

 +6        IF $DATA(^ORD(101.41,+QOID,6,"D",ROUTID))

               SET Y=1

 +7        QUIT 

QOCHECK(ORY,DIEN) ;

 +1        NEW ARY,DG,FORMIEN,NAME,OI,OIIEN,ORDIALOG,ORPKG,TYPE

 +2        SET ORPKG=$$NMSP^ORCD($PIECE($GET(^ORD(101.41,DIEN,0)),U,7))

           IF ORPKG'["PS"

               QUIT 

 +3        SET DG=$PIECE(^ORD(101.41,DIEN,0),U,5)

 +4        SET NAME=$PIECE(^ORD(100.98,DIEN,0),U)

 +5        SET TYPE=$SELECT(NAME="INPATIENT MEDICATIONS":"I",NAME="OUTPATIENT MEDICATIONS":"O",1:"")

 +6        IF TYPE=""

               QUIT 

 +7        SET ORDIALOG=$$DEFDLG^ORCD(DIEN)

           IF ORDIALOG

               QUIT 

 +8        DO GETDLG^ORCD(ORDIALOG)

           DO GETORDER^ORCD("^ORD(101.41,"_DIEN_",6)")

 +9        IF $DATA(ORDIALOG)'>0

               QUIT 

 +10       SET OI=$PIECE($GET(ORDIALOG("B","ORDERABLE")),U,2)

           IF OI'>0

               QUIT 

 +11       SET OIIEN=$GET(ORDIALOG(OI,1))

           IF OIIEN'>0

               QUIT 

 +12       DO FORMALT(.ARY,OIIEN,TYPE)

           IF $DATA(ARY)'>0

               QUIT 

 +13       SET ORY=OIIEN

 +14       QUIT