ORWDPS1 ;SLC/KCM,JLI,TC - Pharmacy Calls for Windows Dialog ;Apr 05, 2018@07:01
;;3.0;ORDER ENTRY/RESULTS REPORTING;**85,132,141,163,215,255,243,306,350,435,377,405,499**;Dec 17, 1997;Build 165
;
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,ORX
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["PSO",X="DONE" Q
. I $D(^ORD(101.42,"B","ASAP")) S ORPRA=$O(^ORD(101.42,"B","ASAP",0))
. I '$D(^ORD(101.42,"B","ASAP")) S ORPRA=$$GET^XPAR("ALL","ORDER URGENCY ASAP ALTERNATIVE")
. S ORX=$P($G(^ORD(101.42,ORPRA,0)),U,1)
. I XREF["PSJ",X'=ORX,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
GETPRIOR(ORX) ; from RPC ORWDPS1 GETPRIOR gets sites alterative to "ASAP" if present
N ORPRA
I $D(^ORD(101.42,"B","ASAP")) S ORPRA=$O(^ORD(101.42,"B","ASAP",0))
I '$D(^ORD(101.42,"B","ASAP")) S ORPRA=$$GET^XPAR("ALL","ORDER URGENCY ASAP ALTERNATIVE")
S ORX=$P($G(^ORD(101.42,ORPRA,0)),U,1)
Q ORX
;
GETPRIEN(ORPRA) ; from RPC ORWDPS1 GETPRIEN gets sites alterative to "ASAP" IEN if present
I $D(^ORD(101.42,"B","ASAP")) S ORPRA=$O(^ORD(101.42,"B","ASAP",0))
I '$D(^ORD(101.42,"B","ASAP")) S ORPRA=$$GET^XPAR("ALL","ORDER URGENCY ASAP ALTERNATIVE")
Q ORPRA
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="P" S X="P^Park" G XPICK ;ADDED PAPI CODE
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,OI) ; return days supply given quantity
; VAL: default days supply
N ORWX,I,PSOI,TPKG
S ORWX("PATIENT")=PAT
I DRG S ORWX("DRUG")=DRG
I $D(OI) D
. S TPKG=$P($G(^ORD(101.43,+$G(OI),0)),U,2) Q:TPKG'["PS"
. S PSOI=+TPKG Q:PSOI'>0
. S ORWX("OI")=PSOI
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,RT,DETFLG,DETPRO
S FAIL=0,TPKG=$P($G(^ORD(101.43,+$G(OI),0)),U,2)
Q:TPKG'["PS"
S PSOI=+TPKG Q:PSOI'>0
S DETFLAG=$$OIDETOX^PSSOPKI(PSOI,PSTYPE)
S DETPRO=$$DETOX^XUSER(+$G(ORNP))
I DETFLAG,DETPRO="" S FAIL=3 Q
I DETFLAG,DETPRO>0 S Y=DETPRO X ^DD("DD") S FAIL="5^"_Y Q
S DEAFLG=$P($$OIDEA^PSSOPKI(PSOI,PSTYPE),";",2) Q:DEAFLG'>0
I DEAFLG=1 S FAIL=6 Q
S RT=$$SDEA^XUSER(1,+$G(ORNP),DEAFLG,,"I") I RT=1 S FAIL=1 ; OR*3*499-Default to the required "Use For Inpatient" DEA# until selection from list is enabled
I RT=2 S FAIL="2^"_$$UP^XLFSTR(DEAFLG)
I RT?1"4".E S FAIL=RT
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,RT,DETFLG,DETPRO
S FAIL=0,TPKG=$P($G(^ORD(101.43,+$G(OI),0)),U,2)
Q:TPKG'["PS"
S PSOI=+TPKG Q:PSOI'>0
S DETFLAG=$$OIDETOX^PSSOPKI(PSOI,"I")
S DETPRO=$$DETOX^XUSER(+$G(ORNP))
I DETFLAG,DETPRO="" S FAIL=3 Q
I DETFLAG,DETPRO>0 S Y=DETPRO X ^DD("DD") S FAIL="5^"_Y Q
S DEAFLG=$P($$IVDEA^PSSUTIL1(PSOI,OITYPE),";",2) Q:DEAFLG'>0
I DEAFLG=1 S FAIL=6 Q
S RT=$$SDEA^XUSER(,+$G(ORNP),DEAFLG) I RT=1 S FAIL=1
I RT=2 S FAIL="2^"_$$UP^XLFSTR(DEAFLG)
I RT?1"4".E S FAIL=RT
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="P" S Y="P^Park" ;ADDED PAPI CODE
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
MAXDS(ORY,ORDIEN,ORDRIEN) ;
; ORDIEN IS orderable item ien 101.43
; ORDRIEN IS the drug ien
; RETURN IS THE MAX DAYS SUPPLY FOR THE ORDERABLE ITEM
S ORY=90
I $L($T(MAXDS^PSSUTIL1))>0 D
.N ORARRAY
.I $G(ORDRIEN) D
..S ORARRAY("DRUG")=ORDRIEN
.S ORARRAY("OI")=ORDIEN
.I $G(ORDIEN) D
..N ORPSOI S ORPSOI=$P($G(^ORD(101.43,+ORDIEN,0)),U,2)
..S ORARRAY("PSOI")=+ORPSOI
.S ORY=$$MAXDS^PSSUTIL1(.ORARRAY)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HORWDPS1 9665 printed Sep 23, 2025@20:11:58 Page 2
ORWDPS1 ;SLC/KCM,JLI,TC - Pharmacy Calls for Windows Dialog ;Apr 05, 2018@07:01
+1 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**85,132,141,163,215,255,243,306,350,435,377,405,499**;Dec 17, 1997;Build 165
+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,ORX
+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["PSO"
IF X="DONE"
QUIT
+5 IF $DATA(^ORD(101.42,"B","ASAP"))
SET ORPRA=$ORDER(^ORD(101.42,"B","ASAP",0))
+6 IF '$DATA(^ORD(101.42,"B","ASAP"))
SET ORPRA=$$GET^XPAR("ALL","ORDER URGENCY ASAP ALTERNATIVE")
+7 SET ORX=$PIECE($GET(^ORD(101.42,ORPRA,0)),U,1)
+8 IF XREF["PSJ"
IF X'=ORX
IF X'="ROUTINE"
IF X'="STAT"
QUIT
+9 SET ILST=ILST+1
SET LST(ILST)="i"_$ORDER(^ORD(101.42,XREF,X,0))_U_X
End DoDot:1
+10 SET ILST=ILST+1
SET LST(ILST)="d"_$ORDER(^ORD(101.42,"B","ROUTINE",0))_U_"ROUTINE"
+11 QUIT
GETPRIOR(ORX) ; from RPC ORWDPS1 GETPRIOR gets sites alterative to "ASAP" if present
+1 NEW ORPRA
+2 IF $DATA(^ORD(101.42,"B","ASAP"))
SET ORPRA=$ORDER(^ORD(101.42,"B","ASAP",0))
+3 IF '$DATA(^ORD(101.42,"B","ASAP"))
SET ORPRA=$$GET^XPAR("ALL","ORDER URGENCY ASAP ALTERNATIVE")
+4 SET ORX=$PIECE($GET(^ORD(101.42,ORPRA,0)),U,1)
+5 QUIT ORX
+6 ;
GETPRIEN(ORPRA) ; from RPC ORWDPS1 GETPRIEN gets sites alterative to "ASAP" IEN if present
+1 IF $DATA(^ORD(101.42,"B","ASAP"))
SET ORPRA=$ORDER(^ORD(101.42,"B","ASAP",0))
+2 IF '$DATA(^ORD(101.42,"B","ASAP"))
SET ORPRA=$$GET^XPAR("ALL","ORDER URGENCY ASAP ALTERNATIVE")
+3 QUIT ORPRA
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 ;ADDED PAPI CODE
IF X="P"
SET X="P^Park"
GOTO XPICK
+13 IF X="N"
SET X=""
GOTO XPICK
+14 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,OI) ; return days supply given quantity
+1 ; VAL: default days supply
+2 NEW ORWX,I,PSOI,TPKG
+3 SET ORWX("PATIENT")=PAT
+4 IF DRG
SET ORWX("DRUG")=DRG
+5 IF $DATA(OI)
Begin DoDot:1
+6 SET TPKG=$PIECE($GET(^ORD(101.43,+$GET(OI),0)),U,2)
if TPKG'["PS"
QUIT
+7 SET PSOI=+TPKG
if PSOI'>0
QUIT
+8 SET ORWX("OI")=PSOI
End DoDot:1
+9 FOR I=1:1:$LENGTH(UPD,U)-1
Begin DoDot:1
+10 SET ORWX("DOSE ORDERED",I)=$PIECE(UPD,U,I)
+11 SET ORWX("SCHEDULE",I)=$PIECE(SCH,U,I)
End DoDot:1
+12 DO DSUP^PSOSIGDS(.ORWX)
+13 SET VAL=$GET(ORWX("DAYS SUPPLY"))
+14 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,RT,DETFLG,DETPRO
+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 SET DETFLAG=$$OIDETOX^PSSOPKI(PSOI,PSTYPE)
+6 SET DETPRO=$$DETOX^XUSER(+$GET(ORNP))
+7 IF DETFLAG
IF DETPRO=""
SET FAIL=3
QUIT
+8 IF DETFLAG
IF DETPRO>0
SET Y=DETPRO
XECUTE ^DD("DD")
SET FAIL="5^"_Y
QUIT
+9 SET DEAFLG=$PIECE($$OIDEA^PSSOPKI(PSOI,PSTYPE),";",2)
if DEAFLG'>0
QUIT
+10 IF DEAFLG=1
SET FAIL=6
QUIT
+11 ; OR*3*499-Default to the required "Use For Inpatient" DEA# until selection from list is enabled
SET RT=$$SDEA^XUSER(1,+$GET(ORNP),DEAFLG,,"I")
IF RT=1
SET FAIL=1
+12 IF RT=2
SET FAIL="2^"_$$UP^XLFSTR(DEAFLG)
+13 IF RT?1"4".E
SET FAIL=RT
+14 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,RT,DETFLG,DETPRO
+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 SET DETFLAG=$$OIDETOX^PSSOPKI(PSOI,"I")
+8 SET DETPRO=$$DETOX^XUSER(+$GET(ORNP))
+9 IF DETFLAG
IF DETPRO=""
SET FAIL=3
QUIT
+10 IF DETFLAG
IF DETPRO>0
SET Y=DETPRO
XECUTE ^DD("DD")
SET FAIL="5^"_Y
QUIT
+11 SET DEAFLG=$PIECE($$IVDEA^PSSUTIL1(PSOI,OITYPE),";",2)
if DEAFLG'>0
QUIT
+12 IF DEAFLG=1
SET FAIL=6
QUIT
+13 SET RT=$$SDEA^XUSER(,+$GET(ORNP),DEAFLG)
IF RT=1
SET FAIL=1
+14 IF RT=2
SET FAIL="2^"_$$UP^XLFSTR(DEAFLG)
+15 IF RT?1"4".E
SET FAIL=RT
+16 QUIT
+17 ;
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 ;ADDED PAPI CODE
IF Y="P"
SET Y="P^Park"
+7 IF Y="N"
SET Y=""
+8 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
MAXDS(ORY,ORDIEN,ORDRIEN) ;
+1 ; ORDIEN IS orderable item ien 101.43
+2 ; ORDRIEN IS the drug ien
+3 ; RETURN IS THE MAX DAYS SUPPLY FOR THE ORDERABLE ITEM
+4 SET ORY=90
+5 IF $LENGTH($TEXT(MAXDS^PSSUTIL1))>0
Begin DoDot:1
+6 NEW ORARRAY
+7 IF $GET(ORDRIEN)
Begin DoDot:2
+8 SET ORARRAY("DRUG")=ORDRIEN
End DoDot:2
+9 SET ORARRAY("OI")=ORDIEN
+10 IF $GET(ORDIEN)
Begin DoDot:2
+11 NEW ORPSOI
SET ORPSOI=$PIECE($GET(^ORD(101.43,+ORDIEN,0)),U,2)
+12 SET ORARRAY("PSOI")=+ORPSOI
End DoDot:2
+13 SET ORY=$$MAXDS^PSSUTIL1(.ORARRAY)
End DoDot:1
+14 QUIT
