ORBCMA32 ; SLC/JLI - Pharmacy Calls for GUI Dialog 02/11/2008
;;3.0;ORDER ENTRY/RESULTS REPORTING;**133,243**;Dec 17, 1997;Build 242
;;BCMA ORDER V1.0 ;**133,243**;Jan 17, 2002
;
NXT() ; -- returns next available index in return data array
S ILST=ILST+1
Q ILST
;
DLGSLCT(LST,PSTYPE) ; return default lists for dialog
; PSTYPE: pharmacy type (U=unit dose, F=IV fluids, O=outpatient)
N ILST S ILST=0
I PSTYPE="F" D Q ; IV Fluids
. S LST($$NXT)="~ShortList" D SHORT
. S LST($$NXT)="~Priorities" D PRIOR
;
S LST($$NXT)="~ShortList" D SHORT ; Unit Dose & Outpatient
S LST($$NXT)="~Schedules" D SCHED
S LST($$NXT)="~Priorities" D PRIOR
I PSTYPE="O" D ; Outpatient
. S LST($$NXT)="~Pickup" D PICKUP
. S LST($$NXT)="~SCStatus" D SCLIST
Q
SHORT ; from DLGSLCT, get short list of med quick orders
N I,X,TMP
I PSTYPE="U" S X="UD RX"
I PSTYPE="F" S X="IV RX"
I PSTYPE="O" S X="O RX"
D GETQLST^ORWDXQ(.TMP,X,"iQ")
S I=0 F S I=$O(TMP(I)) Q:'I S LST($$NXT)=TMP(I)
Q
SCHED ; from DLGSLCT, get all pharmacy administration schedules
N X
K ^TMP($J,"ORBCMA32 SCHED")
D AP^PSS51P1("PSJ",,,,"ORBCMA32 SCHED")
S X="" F S X=$O(^TMP($J,"ORBCMA32 SCHED","APPSJ",X)) Q:X="" S LST($$NXT)="i"_X
K ^TMP($J,"ORBCMA32 SCHED")
Q
SCHEDA ; (similar to SCHED, but also returns administration times)
N X,IEN,SCH
K ^TMP($J,"ORBCMA32 SCHEDA")
D AP^PSS51P1("PSJ",,,,"ORBCMA32 SCHEDA")
S SCH="" F S SCH=$O(^TMP($J,"ORBCMA32 SCHEDA","APPSJ",SCH)) Q:SCH="" D
. S IEN=0 F S IEN=$O(^TMP($J,"ORBCMA32 SCHEDA","APPSJ",SCH,IEN)) Q:IEN'>0 D
. . S X=$S($L(^TMP($J,"ORBCMA32 SCHEDA",IEN,2)):" ("_^TMP($J,"ORBCMA32 SCHEDA",IEN,2)_")",1:"")
. . S LST($$NXT)="i"_IEN_U_SCH_X
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 LST($$NXT)="i"_X_U_$P(^ORD(101.42,X,0),U,2)
Q
PICKUP ; from DLGSLCT, get prescription routing
N X,EDITONLY
F X="W^at Window","M^by Mail","C^in Clinic" S LST($$NXT)="i"_X
S X=$$DEFPICK I $L(X) S LST($$NXT)="d"_X
Q
DEFPICK() ; 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","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
;
SCLIST ; from DLGSLCT, get options for service connected
F X="0^No","1^Yes" S LST($$NXT)="i"_X
Q
;
OISLCT(LST,OI,PSTYPE,ORVP) ; return for defaults for pharmacy orderable item
N ILST S ILST=0
K ^TMP("PSJINS",$J),^TMP("PSJMR",$J),^TMP("PSJNOUN",$J),^TMP("PSJSCH",$J)
S LST($$NXT)="~Dispense" D DISPDRG
S LST($$NXT)="~Instruct" D INSTRCT
S LST($$NXT)="~Route" D ROUTE
S LST($$NXT)="~Message" D MESSAGE
I $L($G(^TMP("PSJSCH",$J))) S LST($$NXT)="~DefSched",LST($$NXT)="d"_^($J)
K ^TMP("PSJINS",$J),^TMP("PSJMR",$J),^TMP("PSJNOUN",$J),^TMP("PSJSCH",$J)
Q
;
DISPDRUG(LST,OI) ; list dispense drugs for an orderable item
N ILST,PSTYPE S ILST=0,PSTYPE="U" D DISPDRG
Q
;
DISPDRG ; from OISLCT, get dispense drugs for this pharmacy orderable item
N I,ORTMP,ORX
S ORX=$T(ENDD^PSJORUTL),ORX=$L($P(ORX,";"),",")
I ORX>3 D ENDD^PSJORUTL("^^^"_+$P($G(^ORD(101.43,OI,0)),"^",2),PSTYPE,.ORTMP,+ORVP)
I ORX'>3 D ENDD^PSJORUTL("^^^"_+$P($G(^ORD(101.43,OI,0)),"^",2),PSTYPE,.ORTMP)
S I="" F S I=$O(ORTMP(I)) Q:I="" D
. I $P(ORTMP(I),U,4)="1" S $P(ORTMP(I),U,4)="NF"
. S $P(ORTMP(I),U,3)="$"_$P(ORTMP(I),U,3)_" per "_$P(ORTMP(I),U,5)
. S LST($$NXT)="i"_ORTMP(I)
Q
INSTRCT ; from OISLCT, get list of potential instructions (based on drug form)
N INOUN,NOUN,IINS,INS,VERB,INSREC
D START^PSSJORDF(+$P(^ORD(101.43,OI,0),U,2))
I PSTYPE="U" Q ; don't use the instructions list for inpatients
S IINS=0 F S IINS=$O(^TMP("PSJINS",$J,IINS)) Q:'IINS D
. S INSREC=$G(^TMP("PSJINS",$J,IINS))
. I '$D(VERB) S VERB=$P(INSREC,U)
. I $L($P(INSREC,U,2)) S LST($$NXT)="i"_$P(INSREC,U,2)
S LST($$NXT)="~Nouns"
S INOUN=0 F S INOUN=$O(^TMP("PSJNOUN",$J,INOUN)) Q:'INOUN D
. S LST($$NXT)="i"_$P(^TMP("PSJNOUN",$J,INOUN),U)
I $D(VERB) S LST($$NXT)="~Verb",LST($$NXT)="d"_VERB
;
Q
MIXED(X) ; Return mixed case
Q X ;$E(X)_$TR($E(X,2,$L(X)),"ABCDEFGHIJKLMNOPQRSTUVWXYZ","abcdefghijklmnopqrstuvwxyz")
;
ROUTE ; from OISLCT, get list of routes for the drug form
; ** NEED BOTH ABBREVIATION & NAME IN LIST BOX
N I,CNT,ABBR,IEN,ROUT,X
S I="" F S I=$O(^TMP("PSJMR",$J,I)) Q:I="" D
. S ROUT=$P(^TMP("PSJMR",$J,I),U),ABBR=$P(^(I),U,2),IEN=$P(^(I),U,3)
. S LST($$NXT)="i"_IEN_U_ROUT_U_ABBR
. I I=1,IEN S LST($$NXT)="d"_IEN_U_ROUT ;_U_ABBR ; assume first always default
S I="" F S I=$O(^TMP("PSJMR",$J,I)) Q:I="" D
. S ROUT=$P(^TMP("PSJMR",$J,I),U),ABBR=$P(^(I),U,2),IEN=$P(^(I),U,3)
. I $L(ABBR),(ABBR'=ROUT) S LST($$NXT)="i"_IEN_U_ABBR_" ("_ROUT_")"_U_ABBR
Q
MESSAGE ; message
S I=0 F S I=$O(^ORD(101.43,OI,8,I)) Q:I'>0 S LST($$NXT)="t"_^(I,0)
Q
ALLROUTE(LST) ; returns a list of all available med routes
N I,X,ILST
S ILST=0
K ^TMP($J,"ORWDPS32 ALLROUTE")
D ALL^PSS51P2(,"??",,,"ORWDPS32 ALLROUTE")
S I=0 F S I=$O(^TMP($J,"ORWDPS32 ALLROUTE",I)) Q:'I D
. I +$P(^TMP($J,"ORWDPS32 ALLROUTE",I,3),U)>0 S LST($$NXT)=I_U_^TMP($J,"ORWDPS32 ALLROUTE",I,.01)_U_^TMP($J,"ORWDPS32 ALLROUTE",I,1)
Q
VALROUTE(REC,X) ; validates route name & returns IEN + abbreviation
N ABBR,NAME,IEN
K ^TMP($J,"ORBCMA32 VALROUTE")
S X=$$UPPER(X)
D ALL^PSS51P2(,X,,1,"ORBCMA32 VALROUTE")
I $P(^TMP($J,"ORBCMA32 VALROUTE",0),U)=-1 K ^TMP($J,"ORBCMA32 VALROUTE") S REC=0 Q
S IEN=$O(^TMP($J,"ORBCMA32 VALROUTE","B",X,""))
I IEN'>0 S IEN=$O(^TMP($J,"ORBCMA32 VALROUTE","C",X,""))
I IEN'>0 S REC=0 Q
S NAME=$G(^TMP($J,"ORBCMA32 VALROUTE",IEN,.01))
S ABBR=$G(^TMP($J,"ORBCMA32 VALROUTE",IEN,1))
I '$L(ABBR) S ABBR=NAME
I ($$UPPER(NAME)'=X),($$UPPER(ABBR)'=X) S REC=0 K ^TMP($J,"ORBCMA32 VALROUTE") Q
S REC=IEN_U_ABBR
K ^TMP($J,"ORBCMA32 VALROUTE")
Q
AUTH(VAL,PRV) ; For inpatient meds, check restrictions
N NAME,AUTH,INACT,X S VAL=0
S NAME=$P($G(^VA(200,PRV,20)),U,2) S:'$L(NAME) NAME=$P(^(0),U)
S X=$G(^VA(200,PRV,"PS")),AUTH=$P(X,U),INACT=$P(X,U,4)
I 'AUTH!(INACT&(DT>INACT)) D Q
. S VAL="1^"_NAME_" is not authorized to write medication orders."
I $D(^XUSEC("OREMAS",DUZ)),'$$GET^XPAR("ALL","OR OREMAS MED ORDERS") D Q
. S VAL="1^OREMAS key holders may not enter medication orders."
Q
DRUGMSG(VAL,IEN) ; return any message associated with a dispense drug
N X S X=$$ENDCM^PSJORUTL(IEN)
S VAL=$P(X,U,2)_U_$P(X,U,4)
Q
MEDISIV(VAL,IEN) ; return true if orderable item is IV medication
S VAL=0
I $P($G(^ORD(101.43,IEN,"PS")),U)=2 S VAL=1
Q
ISSPLY(VAL,IEN) ; return true if orderable item is a supply
S VAL=0
I $P($G(^ORD(101.43,IEN,"PS")),U,5)=1 S VAL=1
Q
IVAMT(VAL,OI,ORWTYP) ; return UNITS^AMOUNT |^AMOUNT^AMOUNT...| for IV soln
N I,PSOI,ORWY,AMT,IVFLAG
S IVFLAG=$P(OI,U,2)
S PSOI=+$P($G(^ORD(101.43,+OI,0)),U,2)_ORWTYP,VAL=""
I IVFLAG="NF" D ENVOL2^PSJORUT2(PSOI,.ORWY)
I IVFLAG="" D ENVOL^PSJORUT2(PSOI,.ORWY)
I ORWTYP="B" D
. S I=0 F S I=$O(ORWY(I)) Q:I'>0 S AMT(+ORWY(I))=""
. S AMT=0,VAL="ML" F S AMT=$O(AMT(AMT)) Q:AMT'>0 S VAL=VAL_U_AMT
I ORWTYP="A" D
. S I=+$O(ORWY(0)) S VAL=$P($G(ORWY(I)),U,2)
. I '$L(VAL) S VAL="ML^LITER^MCG^MG^GM^UNITS^IU^MEQ^MM^MU^THOUU^MG-PE^NANOGRAM^MMOL"
Q
VALRATE(VAL,X) ; return "1" (true) if IV rate text is valid
I $E($RE($$UPPER(X)),1,5)="RH/LM" S X=$E(X,1,$L(X)-5)
S X=$$TRIM(X)
D ORINF^PSIVSP S VAL=$G(X) ;S OK=$S($D(X):1,1:0)
Q
UPPER(X) ; return uppercase
Q $TR(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
;
TRIM(X) ; trim leading and trailing spaces
S X=$RE(X) F S:$E(X)=" " X=$E(X,2,999) Q:$E(X)'=" " Q:'$L(X) ;trail
S X=$RE(X) F S:$E(X)=" " X=$E(X,2,999) Q:$E(X)'=" " Q:'$L(X) ;lead
Q X
SCSTS(VAL,ORVP,ORDRUG) ; return service connected eligibility for patient
N ORWP94 S ORWP94=$O(^ORD(101.41,"AB","PS MEDS",0))>0
I $L($T(SC^PSOCP)),$$SC^PSOCP(+ORVP,+$G(ORDRUG)) S VAL=0 G XSCSTS
I 'ORWP94,(+$$RXST^IBARXEU(+ORVP)>0) S VAL=0 G XSCSTS
S VAL=1
XSCSTS Q
FORMALT(ORLST,IEN,PSTYPE) ; return a list of formulary alternatives
D ENRFA^PSJORUTL(IEN,PSTYPE,.ORLST)
S I=0 F S I=$O(ORLST(I)) Q:'I D
. S OI=+$O(^ORD(101.43,"ID",+$P(ORLST(I),U,4)_";99PSP",0))
. S $P(ORLST(I),U,4)=OI I OI S $P(ORLST(I),U,5)=$P(^ORD(101.43,OI,0),U)
Q
VALSCH(OK,X,PSTYPE) ; validate a schedule, return 1 if valid, 0 if not
I '$L($T(EN^PSSGSGUI)) S OK=-1 Q
I $E($T(EN^PSSGSGUI),1,4)="EN(X" D
. N ORX S ORX=$G(X) D EN^PSSGSGUI(.ORX,$G(PSTYPE,"I"))
. K X S:$D(ORX) X=ORX
E D
. D EN^PSSGSGUI
S OK=$S($D(X):1,1:0)
Q
VALQTY(OK,X) ; validate a quantity, return 1 if valid, 0 if not
; to be compatible with LM, make sure X is integer from 1 to 240
; this is based on the input transform from 52,7
K:(+X'>0)!(+X>99999999)!(X'?.8N.1".".2N)!($L(X)>12) X
S OK=$S($D(X):1,1:0)
Q
DOSES(LST,OI) ; return doses for an orderable item - TEST ONLY
N ORTMP,ORI,ORJ,ILST,NDF,VAPN,X,PSTYPE S PSTYPE="O"
D ENDD^PSJORUTL("^^^"_+$P($G(^ORD(101.43,OI,0)),"^",2),PSTYPE,.ORTMP)
S ORI=0 F S ORI=$O(ORTMP(ORI)) Q:'ORI S ORWDRG=+ORTMP(ORI) D
. K ^TMP($J,"ORBCMA32 DRUG")
. D NDF^PSS50(+ORWDRG,,,,,"ORBCMA32 DRUG")
. S VAPN=$P($G(^TMP($J,"ORBCMA32 DRUG",+ORWDRG,22)),U),NDF=$P($G(^TMP($J,"ORBCMA32 DRUG",+ORWDRG,20)),U)
. S X=$$DFSU^PSNAPIS(NDF,VAPN)
. S LSTA($P(X,U,4),$P(X,U,6))=""
. I +$P(X,U,4)=$P(X,U,4) S LSTA($P(X,U,4)*2,$P(X,U,6))=""
K ^TMP($J,"ORBCMA32 DRUG")
S ORI="",ILST=0 F S ORI=$O(LSTA(ORI)) Q:ORI="" D
. S ORJ="" F S ORJ=$O(LSTA(ORI,ORJ)) Q:ORJ="" D
. . S ILST=ILST+1,LST(ILST)=ORI_" "_ORJ
Q
ORBCMA32 ; SLC/JLI - Pharmacy Calls for GUI Dialog 02/11/2008
+1 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**133,243**;Dec 17, 1997;Build 242
+2 ;;BCMA ORDER V1.0 ;**133,243**;Jan 17, 2002
+3 ;
NXT() ; -- returns next available index in return data array
+1 SET ILST=ILST+1
+2 QUIT ILST
+3 ;
DLGSLCT(LST,PSTYPE) ; return default lists for dialog
+1 ; PSTYPE: pharmacy type (U=unit dose, F=IV fluids, O=outpatient)
+2 NEW ILST
SET ILST=0
+3 ; IV Fluids
IF PSTYPE="F"
Begin DoDot:1
+4 SET LST($$NXT)="~ShortList"
DO SHORT
+5 SET LST($$NXT)="~Priorities"
DO PRIOR
End DoDot:1
QUIT
+6 ;
+7 ; Unit Dose & Outpatient
SET LST($$NXT)="~ShortList"
DO SHORT
+8 SET LST($$NXT)="~Schedules"
DO SCHED
+9 SET LST($$NXT)="~Priorities"
DO PRIOR
+10 ; Outpatient
IF PSTYPE="O"
Begin DoDot:1
+11 SET LST($$NXT)="~Pickup"
DO PICKUP
+12 SET LST($$NXT)="~SCStatus"
DO SCLIST
End DoDot:1
+13 QUIT
SHORT ; from DLGSLCT, get short list of med quick orders
+1 NEW I,X,TMP
+2 IF PSTYPE="U"
SET X="UD RX"
+3 IF PSTYPE="F"
SET X="IV RX"
+4 IF PSTYPE="O"
SET X="O RX"
+5 DO GETQLST^ORWDXQ(.TMP,X,"iQ")
+6 SET I=0
FOR
SET I=$ORDER(TMP(I))
IF 'I
QUIT
SET LST($$NXT)=TMP(I)
+7 QUIT
SCHED ; from DLGSLCT, get all pharmacy administration schedules
+1 NEW X
+2 KILL ^TMP($JOB,"ORBCMA32 SCHED")
+3 DO AP^PSS51P1("PSJ",,,,"ORBCMA32 SCHED")
+4 SET X=""
FOR
SET X=$ORDER(^TMP($JOB,"ORBCMA32 SCHED","APPSJ",X))
IF X=""
QUIT
SET LST($$NXT)="i"_X
+5 KILL ^TMP($JOB,"ORBCMA32 SCHED")
+6 QUIT
SCHEDA ; (similar to SCHED, but also returns administration times)
+1 NEW X,IEN,SCH
+2 KILL ^TMP($JOB,"ORBCMA32 SCHEDA")
+3 DO AP^PSS51P1("PSJ",,,,"ORBCMA32 SCHEDA")
+4 SET SCH=""
FOR
SET SCH=$ORDER(^TMP($JOB,"ORBCMA32 SCHEDA","APPSJ",SCH))
IF SCH=""
QUIT
Begin DoDot:1
+5 SET IEN=0
FOR
SET IEN=$ORDER(^TMP($JOB,"ORBCMA32 SCHEDA","APPSJ",SCH,IEN))
IF IEN'>0
QUIT
Begin DoDot:2
+6 SET X=$SELECT($LENGTH(^TMP($JOB,"ORBCMA32 SCHEDA",IEN,2)):" ("_^TMP($JOB,"ORBCMA32 SCHEDA",IEN,2)_")",1:"")
+7 SET LST($$NXT)="i"_IEN_U_SCH_X
End DoDot:2
End DoDot:1
+8 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 LST($$NXT)="i"_X_U_$P(^ORD(101.42,X,0),U,2)
+5 QUIT
PICKUP ; from DLGSLCT, get prescription routing
+1 NEW X,EDITONLY
+2 FOR X="W^at Window","M^by Mail","C^in Clinic"
SET LST($$NXT)="i"_X
+3 SET X=$$DEFPICK
IF $LENGTH(X)
SET LST($$NXT)="d"_X
+4 QUIT
DEFPICK() ; 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","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 ;
SCLIST ; from DLGSLCT, get options for service connected
+1 FOR X="0^No","1^Yes"
SET LST($$NXT)="i"_X
+2 QUIT
+3 ;
OISLCT(LST,OI,PSTYPE,ORVP) ; return for defaults for pharmacy orderable item
+1 NEW ILST
SET ILST=0
+2 KILL ^TMP("PSJINS",$JOB),^TMP("PSJMR",$JOB),^TMP("PSJNOUN",$JOB),^TMP("PSJSCH",$JOB)
+3 SET LST($$NXT)="~Dispense"
DO DISPDRG
+4 SET LST($$NXT)="~Instruct"
DO INSTRCT
+5 SET LST($$NXT)="~Route"
DO ROUTE
+6 SET LST($$NXT)="~Message"
DO MESSAGE
+7 IF $LENGTH($GET(^TMP("PSJSCH",$JOB)))
SET LST($$NXT)="~DefSched"
SET LST($$NXT)="d"_^($JOB)
+8 KILL ^TMP("PSJINS",$JOB),^TMP("PSJMR",$JOB),^TMP("PSJNOUN",$JOB),^TMP("PSJSCH",$JOB)
+9 QUIT
+10 ;
DISPDRUG(LST,OI) ; list dispense drugs for an orderable item
+1 NEW ILST,PSTYPE
SET ILST=0
SET PSTYPE="U"
DO DISPDRG
+2 QUIT
+3 ;
DISPDRG ; from OISLCT, get dispense drugs for this pharmacy orderable item
+1 NEW I,ORTMP,ORX
+2 SET ORX=$TEXT(ENDD^PSJORUTL)
SET ORX=$LENGTH($PIECE(ORX,";"),",")
+3 IF ORX>3
DO ENDD^PSJORUTL("^^^"_+$PIECE($GET(^ORD(101.43,OI,0)),"^",2),PSTYPE,.ORTMP,+ORVP)
+4 IF ORX'>3
DO ENDD^PSJORUTL("^^^"_+$PIECE($GET(^ORD(101.43,OI,0)),"^",2),PSTYPE,.ORTMP)
+5 SET I=""
FOR
SET I=$ORDER(ORTMP(I))
IF I=""
QUIT
Begin DoDot:1
+6 IF $PIECE(ORTMP(I),U,4)="1"
SET $PIECE(ORTMP(I),U,4)="NF"
+7 SET $PIECE(ORTMP(I),U,3)="$"_$PIECE(ORTMP(I),U,3)_" per "_$PIECE(ORTMP(I),U,5)
+8 SET LST($$NXT)="i"_ORTMP(I)
End DoDot:1
+9 QUIT
INSTRCT ; from OISLCT, get list of potential instructions (based on drug form)
+1 NEW INOUN,NOUN,IINS,INS,VERB,INSREC
+2 DO START^PSSJORDF(+$PIECE(^ORD(101.43,OI,0),U,2))
+3 ; don't use the instructions list for inpatients
IF PSTYPE="U"
QUIT
+4 SET IINS=0
FOR
SET IINS=$ORDER(^TMP("PSJINS",$JOB,IINS))
IF 'IINS
QUIT
Begin DoDot:1
+5 SET INSREC=$GET(^TMP("PSJINS",$JOB,IINS))
+6 IF '$DATA(VERB)
SET VERB=$PIECE(INSREC,U)
+7 IF $LENGTH($PIECE(INSREC,U,2))
SET LST($$NXT)="i"_$P(INSREC,U,2)
End DoDot:1
+8 SET LST($$NXT)="~Nouns"
+9 SET INOUN=0
FOR
SET INOUN=$ORDER(^TMP("PSJNOUN",$JOB,INOUN))
IF 'INOUN
QUIT
Begin DoDot:1
+10 SET LST($$NXT)="i"_$P(^TMP("PSJNOUN",$JOB,INOUN),U)
End DoDot:1
+11 IF $DATA(VERB)
SET LST($$NXT)="~Verb"
SET LST($$NXT)="d"_VERB
+12 ;
+13 QUIT
MIXED(X) ; Return mixed case
+1 ;$E(X)_$TR($E(X,2,$L(X)),"ABCDEFGHIJKLMNOPQRSTUVWXYZ","abcdefghijklmnopqrstuvwxyz")
QUIT X
+2 ;
ROUTE ; from OISLCT, get list of routes for the drug form
+1 ; ** NEED BOTH ABBREVIATION & NAME IN LIST BOX
+2 NEW I,CNT,ABBR,IEN,ROUT,X
+3 SET I=""
FOR
SET I=$ORDER(^TMP("PSJMR",$JOB,I))
IF I=""
QUIT
Begin DoDot:1
+4 SET ROUT=$PIECE(^TMP("PSJMR",$JOB,I),U)
SET ABBR=$PIECE(^(I),U,2)
SET IEN=$PIECE(^(I),U,3)
+5 SET LST($$NXT)="i"_IEN_U_ROUT_U_ABBR
+6 ;_U_ABBR ; assume first always default
IF I=1
IF IEN
SET LST($$NXT)="d"_IEN_U_ROUT
End DoDot:1
+7 SET I=""
FOR
SET I=$ORDER(^TMP("PSJMR",$JOB,I))
IF I=""
QUIT
Begin DoDot:1
+8 SET ROUT=$PIECE(^TMP("PSJMR",$JOB,I),U)
SET ABBR=$PIECE(^(I),U,2)
SET IEN=$PIECE(^(I),U,3)
+9 IF $LENGTH(ABBR)
IF (ABBR'=ROUT)
SET LST($$NXT)="i"_IEN_U_ABBR_" ("_ROUT_")"_U_ABBR
End DoDot:1
+10 QUIT
MESSAGE ; message
+1 SET I=0
FOR
SET I=$ORDER(^ORD(101.43,OI,8,I))
IF I'>0
QUIT
SET LST($$NXT)="t"_^(I,0)
+2 QUIT
ALLROUTE(LST) ; returns a list of all available med routes
+1 NEW I,X,ILST
+2 SET ILST=0
+3 KILL ^TMP($JOB,"ORWDPS32 ALLROUTE")
+4 DO ALL^PSS51P2(,"??",,,"ORWDPS32 ALLROUTE")
+5 SET I=0
FOR
SET I=$ORDER(^TMP($JOB,"ORWDPS32 ALLROUTE",I))
IF 'I
QUIT
Begin DoDot:1
+6 IF +$PIECE(^TMP($JOB,"ORWDPS32 ALLROUTE",I,3),U)>0
SET LST($$NXT)=I_U_^TMP($JOB,"ORWDPS32 ALLROUTE",I,.01)_U_^TMP($JOB,"ORWDPS32 ALLROUTE",I,1)
End DoDot:1
+7 QUIT
VALROUTE(REC,X) ; validates route name & returns IEN + abbreviation
+1 NEW ABBR,NAME,IEN
+2 KILL ^TMP($JOB,"ORBCMA32 VALROUTE")
+3 SET X=$$UPPER(X)
+4 DO ALL^PSS51P2(,X,,1,"ORBCMA32 VALROUTE")
+5 IF $PIECE(^TMP($JOB,"ORBCMA32 VALROUTE",0),U)=-1
KILL ^TMP($JOB,"ORBCMA32 VALROUTE")
SET REC=0
QUIT
+6 SET IEN=$ORDER(^TMP($JOB,"ORBCMA32 VALROUTE","B",X,""))
+7 IF IEN'>0
SET IEN=$ORDER(^TMP($JOB,"ORBCMA32 VALROUTE","C",X,""))
+8 IF IEN'>0
SET REC=0
QUIT
+9 SET NAME=$GET(^TMP($JOB,"ORBCMA32 VALROUTE",IEN,.01))
+10 SET ABBR=$GET(^TMP($JOB,"ORBCMA32 VALROUTE",IEN,1))
+11 IF '$LENGTH(ABBR)
SET ABBR=NAME
+12 IF ($$UPPER(NAME)'=X)
IF ($$UPPER(ABBR)'=X)
SET REC=0
KILL ^TMP($JOB,"ORBCMA32 VALROUTE")
QUIT
+13 SET REC=IEN_U_ABBR
+14 KILL ^TMP($JOB,"ORBCMA32 VALROUTE")
+15 QUIT
AUTH(VAL,PRV) ; For inpatient meds, check restrictions
+1 NEW NAME,AUTH,INACT,X
SET VAL=0
+2 SET NAME=$PIECE($GET(^VA(200,PRV,20)),U,2)
IF '$LENGTH(NAME)
SET NAME=$PIECE(^(0),U)
+3 SET X=$GET(^VA(200,PRV,"PS"))
SET AUTH=$PIECE(X,U)
SET INACT=$PIECE(X,U,4)
+4 IF 'AUTH!(INACT&(DT>INACT))
Begin DoDot:1
+5 SET VAL="1^"_NAME_" is not authorized to write medication orders."
End DoDot:1
QUIT
+6 IF $DATA(^XUSEC("OREMAS",DUZ))
IF '$$GET^XPAR("ALL","OR OREMAS MED ORDERS")
Begin DoDot:1
+7 SET VAL="1^OREMAS key holders may not enter medication orders."
End DoDot:1
QUIT
+8 QUIT
DRUGMSG(VAL,IEN) ; return any message associated with a dispense drug
+1 NEW X
SET X=$$ENDCM^PSJORUTL(IEN)
+2 SET VAL=$PIECE(X,U,2)_U_$PIECE(X,U,4)
+3 QUIT
MEDISIV(VAL,IEN) ; return true if orderable item is IV medication
+1 SET VAL=0
+2 IF $PIECE($GET(^ORD(101.43,IEN,"PS")),U)=2
SET VAL=1
+3 QUIT
ISSPLY(VAL,IEN) ; return true if orderable item is a supply
+1 SET VAL=0
+2 IF $PIECE($GET(^ORD(101.43,IEN,"PS")),U,5)=1
SET VAL=1
+3 QUIT
IVAMT(VAL,OI,ORWTYP) ; return UNITS^AMOUNT |^AMOUNT^AMOUNT...| for IV soln
+1 NEW I,PSOI,ORWY,AMT,IVFLAG
+2 SET IVFLAG=$PIECE(OI,U,2)
+3 SET PSOI=+$PIECE($GET(^ORD(101.43,+OI,0)),U,2)_ORWTYP
SET VAL=""
+4 IF IVFLAG="NF"
DO ENVOL2^PSJORUT2(PSOI,.ORWY)
+5 IF IVFLAG=""
DO ENVOL^PSJORUT2(PSOI,.ORWY)
+6 IF ORWTYP="B"
Begin DoDot:1
+7 SET I=0
FOR
SET I=$ORDER(ORWY(I))
IF I'>0
QUIT
SET AMT(+ORWY(I))=""
+8 SET AMT=0
SET VAL="ML"
FOR
SET AMT=$ORDER(AMT(AMT))
IF AMT'>0
QUIT
SET VAL=VAL_U_AMT
End DoDot:1
+9 IF ORWTYP="A"
Begin DoDot:1
+10 SET I=+$ORDER(ORWY(0))
SET VAL=$PIECE($GET(ORWY(I)),U,2)
+11 IF '$LENGTH(VAL)
SET VAL="ML^LITER^MCG^MG^GM^UNITS^IU^MEQ^MM^MU^THOUU^MG-PE^NANOGRAM^MMOL"
End DoDot:1
+12 QUIT
VALRATE(VAL,X) ; return "1" (true) if IV rate text is valid
+1 IF $EXTRACT($REVERSE($$UPPER(X)),1,5)="RH/LM"
SET X=$EXTRACT(X,1,$LENGTH(X)-5)
+2 SET X=$$TRIM(X)
+3 ;S OK=$S($D(X):1,1:0)
DO ORINF^PSIVSP
SET VAL=$GET(X)
+4 QUIT
UPPER(X) ; return uppercase
+1 QUIT $TRANSLATE(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
+2 ;
TRIM(X) ; trim leading and trailing spaces
+1 ;trail
SET X=$REVERSE(X)
FOR
IF $EXTRACT(X)=" "
SET X=$EXTRACT(X,2,999)
IF $EXTRACT(X)'=" "
QUIT
IF '$LENGTH(X)
QUIT
+2 ;lead
SET X=$REVERSE(X)
FOR
IF $EXTRACT(X)=" "
SET X=$EXTRACT(X,2,999)
IF $EXTRACT(X)'=" "
QUIT
IF '$LENGTH(X)
QUIT
+3 QUIT X
SCSTS(VAL,ORVP,ORDRUG) ; return service connected eligibility for patient
+1 NEW ORWP94
SET ORWP94=$ORDER(^ORD(101.41,"AB","PS MEDS",0))>0
+2 IF $LENGTH($TEXT(SC^PSOCP))
IF $$SC^PSOCP(+ORVP,+$GET(ORDRUG))
SET VAL=0
GOTO XSCSTS
+3 IF 'ORWP94
IF (+$$RXST^IBARXEU(+ORVP)>0)
SET VAL=0
GOTO XSCSTS
+4 SET VAL=1
XSCSTS QUIT
FORMALT(ORLST,IEN,PSTYPE) ; return a list of formulary alternatives
+1 DO ENRFA^PSJORUTL(IEN,PSTYPE,.ORLST)
+2 SET I=0
FOR
SET I=$ORDER(ORLST(I))
IF 'I
QUIT
Begin DoDot:1
+3 SET OI=+$ORDER(^ORD(101.43,"ID",+$PIECE(ORLST(I),U,4)_";99PSP",0))
+4 SET $PIECE(ORLST(I),U,4)=OI
IF OI
SET $PIECE(ORLST(I),U,5)=$PIECE(^ORD(101.43,OI,0),U)
End DoDot:1
+5 QUIT
VALSCH(OK,X,PSTYPE) ; validate a schedule, return 1 if valid, 0 if not
+1 IF '$LENGTH($TEXT(EN^PSSGSGUI))
SET OK=-1
QUIT
+2 IF $EXTRACT($TEXT(EN^PSSGSGUI),1,4)="EN(X"
Begin DoDot:1
+3 NEW ORX
SET ORX=$GET(X)
DO EN^PSSGSGUI(.ORX,$GET(PSTYPE,"I"))
+4 KILL X
IF $DATA(ORX)
SET X=ORX
End DoDot:1
+5 IF '$TEST
Begin DoDot:1
+6 DO EN^PSSGSGUI
End DoDot:1
+7 SET OK=$SELECT($DATA(X):1,1:0)
+8 QUIT
VALQTY(OK,X) ; validate a quantity, return 1 if valid, 0 if not
+1 ; to be compatible with LM, make sure X is integer from 1 to 240
+2 ; this is based on the input transform from 52,7
+3 IF (+X'>0)!(+X>99999999)!(X'?.8N.1".".2N)!($LENGTH(X)>12)
KILL X
+4 SET OK=$SELECT($DATA(X):1,1:0)
+5 QUIT
DOSES(LST,OI) ; return doses for an orderable item - TEST ONLY
+1 NEW ORTMP,ORI,ORJ,ILST,NDF,VAPN,X,PSTYPE
SET PSTYPE="O"
+2 DO ENDD^PSJORUTL("^^^"_+$PIECE($GET(^ORD(101.43,OI,0)),"^",2),PSTYPE,.ORTMP)
+3 SET ORI=0
FOR
SET ORI=$ORDER(ORTMP(ORI))
IF 'ORI
QUIT
SET ORWDRG=+ORTMP(ORI)
Begin DoDot:1
+4 KILL ^TMP($JOB,"ORBCMA32 DRUG")
+5 DO NDF^PSS50(+ORWDRG,,,,,"ORBCMA32 DRUG")
+6 SET VAPN=$PIECE($GET(^TMP($JOB,"ORBCMA32 DRUG",+ORWDRG,22)),U)
SET NDF=$PIECE($GET(^TMP($JOB,"ORBCMA32 DRUG",+ORWDRG,20)),U)
+7 SET X=$$DFSU^PSNAPIS(NDF,VAPN)
+8 SET LSTA($PIECE(X,U,4),$PIECE(X,U,6))=""
+9 IF +$PIECE(X,U,4)=$PIECE(X,U,4)
SET LSTA($PIECE(X,U,4)*2,$PIECE(X,U,6))=""
End DoDot:1
+10 KILL ^TMP($JOB,"ORBCMA32 DRUG")
+11 SET ORI=""
SET ILST=0
FOR
SET ORI=$ORDER(LSTA(ORI))
IF ORI=""
QUIT
Begin DoDot:1
+12 SET ORJ=""
FOR
SET ORJ=$ORDER(LSTA(ORI,ORJ))
IF ORJ=""
QUIT
Begin DoDot:2
+13 SET ILST=ILST+1
SET LST(ILST)=ORI_" "_ORJ
End DoDot:2
End DoDot:1
+14 QUIT
