Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: ORBCMA32

ORBCMA32.m

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