ORBCMA1 ; SLC/JLI - Pharmacy Calls for Windows Dialog [ 3/7/2006 ]
;;3.0;ORDER ENTRY/RESULTS REPORTING;**133,243,499**;Dec 17, 1997;Build 165
;;OR BCMA ORDER COM V1.0 ;**133**; Jan 19, 2002
;
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
PRIOR ; from DLGSLCT, get list of allowed priorities
N X,XREF
S X=0
S X=$O(^ORD(101.42,"B","DONE",X))
S ILST=ILST+1,LST(ILST)="d"_X_U_$P(^ORD(101.42,X,0),U,2)
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")
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")
;
SCHALL(LST) ; return all schedules
N ILST,SCH,IEN,EXP,TYP,X0
K ^TMP($J,"ORBCMA1 SCHALL")
D AP^PSS51P1("PSJ",,,,"ORBCMA1 SCHALL")
S ILST=0,SCH=""
F S SCH=$O(^TMP($J,"ORBCMA1 SCHALL","APPSJ",SCH)) Q:SCH="" D
. I (SCH="STAT")!(SCH="NOW") D
.. S IEN=$O(^TMP($J,"ORBCMA1 SCHALL","APPSJ",SCH,""))
.. S EXP=$G(^TMP($J,"ORBCMA1 SCHALL",SCH,8))
.. S TYP=$P($G(^TMP($J,"ORBCMA1 SCHALL",SCH,5)),U)
.. S ILST=ILST+1,LST(ILST)=SCH_U_EXP_U_TYP
K ^TMP($J,"ORBCMA1 SCHALL")
Q
FORMALT(ORLST,IEN,PSTYPE) ; return a list of formulary alternatives
N PSID,I
S IEN=+$P(^ORD(101.43,IEN,0),U,2)
D EN1^PSSUTIL1(.IEN,PSTYPE)
S PSID=0,I=0
F S PSID=$O(IEN(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
FAILDEA(FAIL,OI,ORNP,PSTYPE) ; return 1 if DEA check fails for this provider
N DEAFLG,PSOI,ORDEA
S FAIL=0,PSOI=+$P($G(^ORD(101.43,+$G(OI),0)),U,2) Q:PSOI'>0
I '$L($T(OIDEA^PSSUTLA1)) Q
S DEAFLG=$$OIDEA^PSSUTLA1(PSOI,PSTYPE) Q:DEAFLG'>0
;*499 introduces multiple dea's for provider
S ORDEA=$$PRDEA^XUSER(ORNP) I '$L(ORDEA),'$L($P($G(^VA(200,+ORNP,"PS")),U,3)) S FAIL=1
;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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HORBCMA1 3967 printed Apr 09, 2024@21:35:25 Page 2
ORBCMA1 ; SLC/JLI - Pharmacy Calls for Windows Dialog [ 3/7/2006 ]
+1 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**133,243,499**;Dec 17, 1997;Build 165
+2 ;;OR BCMA ORDER COM V1.0 ;**133**; Jan 19, 2002
+3 ;
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
PRIOR ; from DLGSLCT, get list of allowed priorities
+1 NEW X,XREF
+2 SET X=0
+3 SET X=$ORDER(^ORD(101.42,"B","DONE",X))
+4 SET ILST=ILST+1
SET LST(ILST)="d"_X_U_$PIECE(^ORD(101.42,X,0),U,2)
+5 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 SET X=$$GET^XPAR("ALL^"_"LOC.`"_LOC,"ORWDPS ROUTING DEFAULT",1,"I")
+8 IF X="C"
SET X="C^in Clinic"
GOTO XPICK
+9 IF X="M"
SET X="M^by Mail"
GOTO XPICK
+10 IF X="W"
SET X="W^at Window"
GOTO XPICK
+11 IF X="N"
SET X=""
GOTO XPICK
+12 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 ;
SCHALL(LST) ; return all schedules
+1 NEW ILST,SCH,IEN,EXP,TYP,X0
+2 KILL ^TMP($JOB,"ORBCMA1 SCHALL")
+3 DO AP^PSS51P1("PSJ",,,,"ORBCMA1 SCHALL")
+4 SET ILST=0
SET SCH=""
+5 FOR
SET SCH=$ORDER(^TMP($JOB,"ORBCMA1 SCHALL","APPSJ",SCH))
if SCH=""
QUIT
Begin DoDot:1
+6 IF (SCH="STAT")!(SCH="NOW")
Begin DoDot:2
+7 SET IEN=$ORDER(^TMP($JOB,"ORBCMA1 SCHALL","APPSJ",SCH,""))
+8 SET EXP=$GET(^TMP($JOB,"ORBCMA1 SCHALL",SCH,8))
+9 SET TYP=$PIECE($GET(^TMP($JOB,"ORBCMA1 SCHALL",SCH,5)),U)
+10 SET ILST=ILST+1
SET LST(ILST)=SCH_U_EXP_U_TYP
End DoDot:2
End DoDot:1
+11 KILL ^TMP($JOB,"ORBCMA1 SCHALL")
+12 QUIT
FORMALT(ORLST,IEN,PSTYPE) ; return a list of formulary alternatives
+1 NEW PSID,I
+2 SET IEN=+$PIECE(^ORD(101.43,IEN,0),U,2)
+3 DO EN1^PSSUTIL1(.IEN,PSTYPE)
+4 SET PSID=0
SET I=0
+5 FOR
SET PSID=$ORDER(IEN(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
FAILDEA(FAIL,OI,ORNP,PSTYPE) ; return 1 if DEA check fails for this provider
+1 NEW DEAFLG,PSOI,ORDEA
+2 SET FAIL=0
SET PSOI=+$PIECE($GET(^ORD(101.43,+$GET(OI),0)),U,2)
if PSOI'>0
QUIT
+3 IF '$LENGTH($TEXT(OIDEA^PSSUTLA1))
QUIT
+4 SET DEAFLG=$$OIDEA^PSSUTLA1(PSOI,PSTYPE)
if DEAFLG'>0
QUIT
+5 ;*499 introduces multiple dea's for provider
+6 SET ORDEA=$$PRDEA^XUSER(ORNP)
IF '$LENGTH(ORDEA)
IF '$LENGTH($PIECE($GET(^VA(200,+ORNP,"PS")),U,3))
SET FAIL=1
+7 ;I '$L($P($G(^VA(200,+$G(ORNP),"PS")),U,2)),'$L($P($G(^("PS")),U,3)) S FAIL=1
+8 QUIT
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
