- Timestamp:
- Dec 4, 2009, 12:11:15 AM (14 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORBCMA32.m
r613 r623 1 ORBCMA32 ; SLC/JLI - Pharmacy Calls for GUI Dialog 02/11/2008 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**133,243**;Dec 17, 1997;Build 242 3 ;;BCMA ORDER V1.0 ;**133,243**;Jan 17, 2002 4 ; 5 NXT() ; -- returns next available index in return data array 6 S ILST=ILST+1 7 Q ILST 8 ; 9 DLGSLCT(LST,PSTYPE) ; return default lists for dialog 10 ; PSTYPE: pharmacy type (U=unit dose, F=IV fluids, O=outpatient) 11 N ILST S ILST=0 12 I PSTYPE="F" D Q ; IV Fluids 13 . S LST($$NXT)="~ShortList" D SHORT 14 . S LST($$NXT)="~Priorities" D PRIOR 15 ; 16 S LST($$NXT)="~ShortList" D SHORT ; Unit Dose & Outpatient 17 S LST($$NXT)="~Schedules" D SCHED 18 S LST($$NXT)="~Priorities" D PRIOR 19 I PSTYPE="O" D ; Outpatient 20 . S LST($$NXT)="~Pickup" D PICKUP 21 . S LST($$NXT)="~SCStatus" D SCLIST 22 Q 23 SHORT ; from DLGSLCT, get short list of med quick orders 24 N I,X,TMP 25 I PSTYPE="U" S X="UD RX" 26 I PSTYPE="F" S X="IV RX" 27 I PSTYPE="O" S X="O RX" 28 D GETQLST^ORWDXQ(.TMP,X,"iQ") 29 S I=0 F S I=$O(TMP(I)) Q:'I S LST($$NXT)=TMP(I) 30 Q 31 SCHED ; from DLGSLCT, get all pharmacy administration schedules 32 N X 33 K ^TMP($J,"ORBCMA32 SCHED") 34 D AP^PSS51P1("PSJ",,,,"ORBCMA32 SCHED") 35 S X="" F S X=$O(^TMP($J,"ORBCMA32 SCHED","APPSJ",X)) Q:X="" S LST($$NXT)="i"_X 36 K ^TMP($J,"ORBCMA32 SCHED") 37 Q 38 SCHEDA ; (similar to SCHED, but also returns administration times) 39 N X,IEN,SCH 40 K ^TMP($J,"ORBCMA32 SCHEDA") 41 D AP^PSS51P1("PSJ",,,,"ORBCMA32 SCHEDA") 42 S SCH="" F S SCH=$O(^TMP($J,"ORBCMA32 SCHEDA","APPSJ",SCH)) Q:SCH="" D 43 . S IEN=0 F S IEN=$O(^TMP($J,"ORBCMA32 SCHEDA","APPSJ",SCH,IEN)) Q:IEN'>0 D 44 . . S X=$S($L(^TMP($J,"ORBCMA32 SCHEDA",IEN,2)):" ("_^TMP($J,"ORBCMA32 SCHEDA",IEN,2)_")",1:"") 45 . . S LST($$NXT)="i"_IEN_U_SCH_X 46 Q 47 PRIOR ; from DLGSLCT, get list of allowed priorities 48 N X,XREF 49 S X=0 50 S X=$O(^ORD(101.42,"B","DONE",X)) 51 S LST($$NXT)="i"_X_U_$P(^ORD(101.42,X,0),U,2) 52 Q 53 PICKUP ; from DLGSLCT, get prescription routing 54 N X,EDITONLY 55 F X="W^at Window","M^by Mail","C^in Clinic" S LST($$NXT)="i"_X 56 S X=$$DEFPICK I $L(X) S LST($$NXT)="d"_X 57 Q 58 DEFPICK() ; return default routing 59 N X,DLG,PRMT 60 S DLG=$O(^ORD(101.41,"AB","PSO OERR",0)),X="" 61 S PRMT=$O(^ORD(101.41,"AB","OR GTX ROUTING",0)) 62 I $D(^TMP("ORECALL",$J,+DLG,+PRMT,1)) S X=^(1) 63 I X'="" S EDITONLY=1 Q X ; EDITONLY used by default action 64 ; 65 S X=$$GET^XPAR("ALL","ORWDPS ROUTING DEFAULT",1,"I") 66 I X="C" S X="C^in Clinic" G XPICK 67 I X="M" S X="M^by Mail" G XPICK 68 I X="W" S X="W^at Window" G XPICK 69 I X="N" S X="" G XPICK 70 I X="" S X=$S($D(^PSX(550,"C")):"M^by Mail",1:"W^at Window") 71 XPICK Q X 72 ; 73 SCLIST ; from DLGSLCT, get options for service connected 74 F X="0^No","1^Yes" S LST($$NXT)="i"_X 75 Q 76 ; 77 OISLCT(LST,OI,PSTYPE,ORVP) ; return for defaults for pharmacy orderable item 78 N ILST S ILST=0 79 K ^TMP("PSJINS",$J),^TMP("PSJMR",$J),^TMP("PSJNOUN",$J),^TMP("PSJSCH",$J) 80 S LST($$NXT)="~Dispense" D DISPDRG 81 S LST($$NXT)="~Instruct" D INSTRCT 82 S LST($$NXT)="~Route" D ROUTE 83 S LST($$NXT)="~Message" D MESSAGE 84 I $L($G(^TMP("PSJSCH",$J))) S LST($$NXT)="~DefSched",LST($$NXT)="d"_^($J) 85 K ^TMP("PSJINS",$J),^TMP("PSJMR",$J),^TMP("PSJNOUN",$J),^TMP("PSJSCH",$J) 86 Q 87 ; 88 DISPDRUG(LST,OI) ; list dispense drugs for an orderable item 89 N ILST,PSTYPE S ILST=0,PSTYPE="U" D DISPDRG 90 Q 91 ; 92 DISPDRG ; from OISLCT, get dispense drugs for this pharmacy orderable item 93 N I,ORTMP,ORX 94 S ORX=$T(ENDD^PSJORUTL),ORX=$L($P(ORX,";"),",") 95 I ORX>3 D ENDD^PSJORUTL("^^^"_+$P($G(^ORD(101.43,OI,0)),"^",2),PSTYPE,.ORTMP,+ORVP) 96 I ORX'>3 D ENDD^PSJORUTL("^^^"_+$P($G(^ORD(101.43,OI,0)),"^",2),PSTYPE,.ORTMP) 97 S I="" F S I=$O(ORTMP(I)) Q:I="" D 98 . I $P(ORTMP(I),U,4)="1" S $P(ORTMP(I),U,4)="NF" 99 . S $P(ORTMP(I),U,3)="$"_$P(ORTMP(I),U,3)_" per "_$P(ORTMP(I),U,5) 100 . S LST($$NXT)="i"_ORTMP(I) 101 Q 102 INSTRCT ; from OISLCT, get list of potential instructions (based on drug form) 103 N INOUN,NOUN,IINS,INS,VERB,INSREC 104 D START^PSSJORDF(+$P(^ORD(101.43,OI,0),U,2)) 105 I PSTYPE="U" Q ; don't use the instructions list for inpatients 106 S IINS=0 F S IINS=$O(^TMP("PSJINS",$J,IINS)) Q:'IINS D 107 . S INSREC=$G(^TMP("PSJINS",$J,IINS)) 108 . I '$D(VERB) S VERB=$P(INSREC,U) 109 . I $L($P(INSREC,U,2)) S LST($$NXT)="i"_$P(INSREC,U,2) 110 S LST($$NXT)="~Nouns" 111 S INOUN=0 F S INOUN=$O(^TMP("PSJNOUN",$J,INOUN)) Q:'INOUN D 112 . S LST($$NXT)="i"_$P(^TMP("PSJNOUN",$J,INOUN),U) 113 I $D(VERB) S LST($$NXT)="~Verb",LST($$NXT)="d"_VERB 114 ; 115 Q 116 MIXED(X) ; Return mixed case 117 Q X ;$E(X)_$TR($E(X,2,$L(X)),"ABCDEFGHIJKLMNOPQRSTUVWXYZ","abcdefghijklmnopqrstuvwxyz") 118 ; 119 ROUTE ; from OISLCT, get list of routes for the drug form 120 ; ** NEED BOTH ABBREVIATION & NAME IN LIST BOX 121 N I,CNT,ABBR,IEN,ROUT,X 122 S I="" F S I=$O(^TMP("PSJMR",$J,I)) Q:I="" D 123 . S ROUT=$P(^TMP("PSJMR",$J,I),U),ABBR=$P(^(I),U,2),IEN=$P(^(I),U,3) 124 . S LST($$NXT)="i"_IEN_U_ROUT_U_ABBR 125 . I I=1,IEN S LST($$NXT)="d"_IEN_U_ROUT ;_U_ABBR ; assume first always default 126 S I="" F S I=$O(^TMP("PSJMR",$J,I)) Q:I="" D 127 . S ROUT=$P(^TMP("PSJMR",$J,I),U),ABBR=$P(^(I),U,2),IEN=$P(^(I),U,3) 128 . I $L(ABBR),(ABBR'=ROUT) S LST($$NXT)="i"_IEN_U_ABBR_" ("_ROUT_")"_U_ABBR 129 Q 130 MESSAGE ; message 131 S I=0 F S I=$O(^ORD(101.43,OI,8,I)) Q:I'>0 S LST($$NXT)="t"_^(I,0) 132 Q 133 ALLROUTE(LST) ; returns a list of all available med routes 134 N I,X,ILST 135 S ILST=0 136 K ^TMP($J,"ORWDPS32 ALLROUTE") 137 D ALL^PSS51P2(,"??",,,"ORWDPS32 ALLROUTE") 138 S I=0 F S I=$O(^TMP($J,"ORWDPS32 ALLROUTE",I)) Q:'I D 139 . 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) 140 Q 141 VALROUTE(REC,X) ; validates route name & returns IEN + abbreviation 142 N ABBR,NAME,IEN 143 K ^TMP($J,"ORBCMA32 VALROUTE") 144 S X=$$UPPER(X) 145 D ALL^PSS51P2(,X,,1,"ORBCMA32 VALROUTE") 146 I $P(^TMP($J,"ORBCMA32 VALROUTE",0),U)=-1 K ^TMP($J,"ORBCMA32 VALROUTE") S REC=0 Q 147 S IEN=$O(^TMP($J,"ORBCMA32 VALROUTE","B",X,"")) 148 I IEN'>0 S IEN=$O(^TMP($J,"ORBCMA32 VALROUTE","C",X,"")) 149 I IEN'>0 S REC=0 Q 150 S NAME=$G(^TMP($J,"ORBCMA32 VALROUTE",IEN,.01)) 151 S ABBR=$G(^TMP($J,"ORBCMA32 VALROUTE",IEN,1)) 152 I '$L(ABBR) S ABBR=NAME 153 I ($$UPPER(NAME)'=X),($$UPPER(ABBR)'=X) S REC=0 K ^TMP($J,"ORBCMA32 VALROUTE") Q 154 S REC=IEN_U_ABBR 155 K ^TMP($J,"ORBCMA32 VALROUTE") 156 Q 157 AUTH(VAL,PRV) ; For inpatient meds, check restrictions 158 N NAME,AUTH,INACT,X S VAL=0 159 S NAME=$P($G(^VA(200,PRV,20)),U,2) S:'$L(NAME) NAME=$P(^(0),U) 160 S X=$G(^VA(200,PRV,"PS")),AUTH=$P(X,U),INACT=$P(X,U,4) 161 I 'AUTH!(INACT&(DT>INACT)) D Q 162 . S VAL="1^"_NAME_" is not authorized to write medication orders." 163 I $D(^XUSEC("OREMAS",DUZ)),'$$GET^XPAR("ALL","OR OREMAS MED ORDERS") D Q 164 . S VAL="1^OREMAS key holders may not enter medication orders." 165 Q 166 DRUGMSG(VAL,IEN) ; return any message associated with a dispense drug 167 N X S X=$$ENDCM^PSJORUTL(IEN) 168 S VAL=$P(X,U,2)_U_$P(X,U,4) 169 Q 170 MEDISIV(VAL,IEN) ; return true if orderable item is IV medication 171 S VAL=0 172 I $P($G(^ORD(101.43,IEN,"PS")),U)=2 S VAL=1 173 Q 174 ISSPLY(VAL,IEN) ; return true if orderable item is a supply 175 S VAL=0 176 I $P($G(^ORD(101.43,IEN,"PS")),U,5)=1 S VAL=1 177 Q 178 IVAMT(VAL,OI,ORWTYP) ; return UNITS^AMOUNT |^AMOUNT^AMOUNT...| for IV soln 179 N I,PSOI,ORWY,AMT,IVFLAG 180 S IVFLAG=$P(OI,U,2) 181 S PSOI=+$P($G(^ORD(101.43,+OI,0)),U,2)_ORWTYP,VAL="" 182 I IVFLAG="NF" D ENVOL2^PSJORUT2(PSOI,.ORWY) 183 I IVFLAG="" D ENVOL^PSJORUT2(PSOI,.ORWY) 184 I ORWTYP="B" D 185 . S I=0 F S I=$O(ORWY(I)) Q:I'>0 S AMT(+ORWY(I))="" 186 . S AMT=0,VAL="ML" F S AMT=$O(AMT(AMT)) Q:AMT'>0 S VAL=VAL_U_AMT 187 I ORWTYP="A" D 188 . S I=+$O(ORWY(0)) S VAL=$P($G(ORWY(I)),U,2) 189 . I '$L(VAL) S VAL="ML^LITER^MCG^MG^GM^UNITS^IU^MEQ^MM^MU^THOUU^MG-PE^NANOGRAM^MMOL" 190 Q 191 VALRATE(VAL,X) ; return "1" (true) if IV rate text is valid 192 I $E($RE($$UPPER(X)),1,5)="RH/LM" S X=$E(X,1,$L(X)-5) 193 S X=$$TRIM(X) 194 D ORINF^PSIVSP S VAL=$G(X) ;S OK=$S($D(X):1,1:0) 195 Q 196 UPPER(X) ; return uppercase 197 Q $TR(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ") 198 ; 199 TRIM(X) ; trim leading and trailing spaces 200 S X=$RE(X) F S:$E(X)=" " X=$E(X,2,999) Q:$E(X)'=" " Q:'$L(X) ;trail 201 S X=$RE(X) F S:$E(X)=" " X=$E(X,2,999) Q:$E(X)'=" " Q:'$L(X) ;lead 202 Q X 203 SCSTS(VAL,ORVP,ORDRUG) ; return service connected eligibility for patient 204 N ORWP94 S ORWP94=$O(^ORD(101.41,"AB","PS MEDS",0))>0 205 I $L($T(SC^PSOCP)),$$SC^PSOCP(+ORVP,+$G(ORDRUG)) S VAL=0 G XSCSTS 206 I 'ORWP94,(+$$RXST^IBARXEU(+ORVP)>0) S VAL=0 G XSCSTS 207 S VAL=1 208 XSCSTS Q 209 FORMALT(ORLST,IEN,PSTYPE) ; return a list of formulary alternatives 210 D ENRFA^PSJORUTL(IEN,PSTYPE,.ORLST) 211 S I=0 F S I=$O(ORLST(I)) Q:'I D 212 . S OI=+$O(^ORD(101.43,"ID",+$P(ORLST(I),U,4)_";99PSP",0)) 213 . S $P(ORLST(I),U,4)=OI I OI S $P(ORLST(I),U,5)=$P(^ORD(101.43,OI,0),U) 214 Q 215 VALSCH(OK,X,PSTYPE) ; validate a schedule, return 1 if valid, 0 if not 216 I '$L($T(EN^PSSGSGUI)) S OK=-1 Q 217 I $E($T(EN^PSSGSGUI),1,4)="EN(X" D 218 . N ORX S ORX=$G(X) D EN^PSSGSGUI(.ORX,$G(PSTYPE,"I")) 219 . K X S:$D(ORX) X=ORX 220 E D 221 . D EN^PSSGSGUI 222 S OK=$S($D(X):1,1:0) 223 Q 224 VALQTY(OK,X) ; validate a quantity, return 1 if valid, 0 if not 225 ; to be compatible with LM, make sure X is integer from 1 to 240 226 ; this is based on the input transform from 52,7 227 K:(+X'>0)!(+X>99999999)!(X'?.8N.1".".2N)!($L(X)>12) X 228 S OK=$S($D(X):1,1:0) 229 Q 230 DOSES(LST,OI) ; return doses for an orderable item - TEST ONLY 231 N ORTMP,ORI,ORJ,ILST,NDF,VAPN,X,PSTYPE S PSTYPE="O" 232 D ENDD^PSJORUTL("^^^"_+$P($G(^ORD(101.43,OI,0)),"^",2),PSTYPE,.ORTMP) 233 S ORI=0 F S ORI=$O(ORTMP(ORI)) Q:'ORI S ORWDRG=+ORTMP(ORI) D 234 . K ^TMP($J,"ORBCMA32 DRUG") 235 . D NDF^PSS50(+ORWDRG,,,,,"ORBCMA32 DRUG") 236 . S VAPN=$P($G(^TMP($J,"ORBCMA32 DRUG",+ORWDRG,22)),U),NDF=$P($G(^TMP($J,"ORBCMA32 DRUG",+ORWDRG,20)),U) 237 . S X=$$DFSU^PSNAPIS(NDF,VAPN) 238 . S LSTA($P(X,U,4),$P(X,U,6))="" 239 . I +$P(X,U,4)=$P(X,U,4) S LSTA($P(X,U,4)*2,$P(X,U,6))="" 240 K ^TMP($J,"ORBCMA32 DRUG") 241 S ORI="",ILST=0 F S ORI=$O(LSTA(ORI)) Q:ORI="" D 242 . S ORJ="" F S ORJ=$O(LSTA(ORI,ORJ)) Q:ORJ="" D 243 . . S ILST=ILST+1,LST(ILST)=ORI_" "_ORJ 244 Q 1 ORBCMA32 ; SLC/JLI - Pharmacy Calls for GUI Dialog ;01/17/02 2 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**133,237**;Dec 17, 1997 3 ;;BCMA ORDER V1.0 ;**133,237**;Jan 17, 2002 4 ; 5 NXT() ; -- returns next available index in return data array 6 S ILST=ILST+1 7 Q ILST 8 ; 9 DLGSLCT(LST,PSTYPE) ; return default lists for dialog 10 ; PSTYPE: pharmacy type (U=unit dose, F=IV fluids, O=outpatient) 11 N ILST S ILST=0 12 I PSTYPE="F" D Q ; IV Fluids 13 . S LST($$NXT)="~ShortList" D SHORT 14 . S LST($$NXT)="~Priorities" D PRIOR 15 ; 16 S LST($$NXT)="~ShortList" D SHORT ; Unit Dose & Outpatient 17 S LST($$NXT)="~Schedules" D SCHED 18 S LST($$NXT)="~Priorities" D PRIOR 19 I PSTYPE="O" D ; Outpatient 20 . S LST($$NXT)="~Pickup" D PICKUP 21 . S LST($$NXT)="~SCStatus" D SCLIST 22 Q 23 SHORT ; from DLGSLCT, get short list of med quick orders 24 ; !!! change this so that it uses the ORWDXQ call!!! 25 N I,X,TMP 26 I PSTYPE="U" S X="UD RX" 27 I PSTYPE="F" S X="IV RX" 28 I PSTYPE="O" S X="O RX" 29 D GETQLST^ORWDXQ(.TMP,X,"iQ") 30 S I=0 F S I=$O(TMP(I)) Q:'I S LST($$NXT)=TMP(I) 31 Q 32 SCHED ; from DLGSLCT, get all pharmacy administration schedules 33 N X 34 S X="" F S X=$O(^PS(51.1,"APPSJ",X)) Q:X="" S LST($$NXT)="i"_X 35 Q 36 SCHEDA ; (similar to SCHED, but also returns administration times) 37 N X,IEN,SCH 38 S SCH="" F S SCH=$O(^PS(51.1,"APPSJ",SCH)) Q:SCH="" D 39 . S IEN=0 F S IEN=$O(^PS(51.1,"APPSJ",SCH,IEN)) Q:IEN'>0 D 40 . . S X=^PS(51.1,IEN,0) S X=$S($L($P(X,U,2)):" ("_$P(X,U,2)_")",1:"") 41 . . S LST($$NXT)="i"_IEN_U_SCH_X 42 Q 43 PRIOR ; from DLGSLCT, get list of allowed priorities 44 N X,XREF 45 S X=0 46 S X=$O(^ORD(101.42,"B","DONE",X)) 47 S LST($$NXT)="i"_X_U_$P(^ORD(101.42,X,0),U,2) 48 Q 49 PICKUP ; from DLGSLCT, get prescription routing 50 N X,EDITONLY 51 F X="W^at Window","M^by Mail","C^in Clinic" S LST($$NXT)="i"_X 52 S X=$$DEFPICK I $L(X) S LST($$NXT)="d"_X 53 Q 54 DEFPICK() ; return default routing 55 N X,DLG,PRMT 56 S DLG=$O(^ORD(101.41,"AB","PSO OERR",0)),X="" 57 S PRMT=$O(^ORD(101.41,"AB","OR GTX ROUTING",0)) 58 I $D(^TMP("ORECALL",$J,+DLG,+PRMT,1)) S X=^(1) 59 I X'="" S EDITONLY=1 Q X ; EDITONLY used by default action 60 ; 61 S X=$$GET^XPAR("ALL","ORWDPS ROUTING DEFAULT",1,"I") 62 I X="C" S X="C^in Clinic" G XPICK 63 I X="M" S X="M^by Mail" G XPICK 64 I X="W" S X="W^at Window" G XPICK 65 I X="N" S X="" G XPICK 66 I X="" S X=$S($D(^PSX(550,"C")):"M^by Mail",1:"W^at Window") 67 XPICK Q X 68 ; 69 SCLIST ; from DLGSLCT, get options for service connected 70 F X="0^No","1^Yes" S LST($$NXT)="i"_X 71 Q 72 ; 73 OISLCT(LST,OI,PSTYPE,ORVP) ; return for defaults for pharmacy orderable item 74 N ILST S ILST=0 75 K ^TMP("PSJINS",$J),^TMP("PSJMR",$J),^TMP("PSJNOUN",$J),^TMP("PSJSCH",$J) 76 S LST($$NXT)="~Dispense" D DISPDRG 77 S LST($$NXT)="~Instruct" D INSTRCT 78 S LST($$NXT)="~Route" D ROUTE 79 S LST($$NXT)="~Message" D MESSAGE 80 I $L($G(^TMP("PSJSCH",$J))) S LST($$NXT)="~DefSched",LST($$NXT)="d"_^($J) 81 K ^TMP("PSJINS",$J),^TMP("PSJMR",$J),^TMP("PSJNOUN",$J),^TMP("PSJSCH",$J) 82 Q 83 ; 84 DISPDRUG(LST,OI) ; list dispense drugs for an orderable item 85 N ILST,PSTYPE S ILST=0,PSTYPE="U" D DISPDRG 86 Q 87 ; 88 DISPDRG ; from OISLCT, get dispense drugs for this pharmacy orderable item 89 N I,ORTMP,ORX 90 S ORX=$T(ENDD^PSJORUTL),ORX=$L($P(ORX,";"),",") 91 I ORX>3 D ENDD^PSJORUTL("^^^"_+$P($G(^ORD(101.43,OI,0)),"^",2),PSTYPE,.ORTMP,+ORVP) 92 I ORX'>3 D ENDD^PSJORUTL("^^^"_+$P($G(^ORD(101.43,OI,0)),"^",2),PSTYPE,.ORTMP) 93 S I="" F S I=$O(ORTMP(I)) Q:I="" D 94 . I $P(ORTMP(I),U,4)="1" S $P(ORTMP(I),U,4)="NF" 95 . S $P(ORTMP(I),U,3)="$"_$P(ORTMP(I),U,3)_" per "_$P(ORTMP(I),U,5) 96 . S LST($$NXT)="i"_ORTMP(I) 97 Q 98 INSTRCT ; from OISLCT, get list of potential instructions (based on drug form) 99 N INOUN,NOUN,IINS,INS,VERB,INSREC 100 D START^PSSJORDF(+$P(^ORD(101.43,OI,0),U,2)) 101 I PSTYPE="U" Q ; don't use the instructions list for inpatients 102 S IINS=0 F S IINS=$O(^TMP("PSJINS",$J,IINS)) Q:'IINS D 103 . S INSREC=$G(^TMP("PSJINS",$J,IINS)) 104 . I '$D(VERB) S VERB=$P(INSREC,U) 105 . I $L($P(INSREC,U,2)) S LST($$NXT)="i"_$P(INSREC,U,2) 106 S LST($$NXT)="~Nouns" 107 S INOUN=0 F S INOUN=$O(^TMP("PSJNOUN",$J,INOUN)) Q:'INOUN D 108 . S LST($$NXT)="i"_$P(^TMP("PSJNOUN",$J,INOUN),U) 109 I $D(VERB) S LST($$NXT)="~Verb",LST($$NXT)="d"_VERB 110 ; 111 Q 112 MIXED(X) ; Return mixed case 113 Q X ;$E(X)_$TR($E(X,2,$L(X)),"ABCDEFGHIJKLMNOPQRSTUVWXYZ","abcdefghijklmnopqrstuvwxyz") 114 ; 115 ROUTE ; from OISLCT, get list of routes for the drug form 116 ; ** NEED BOTH ABBREVIATION & NAME IN LIST BOX 117 N I,CNT,ABBR,IEN,ROUT,X 118 S I="" F S I=$O(^TMP("PSJMR",$J,I)) Q:I="" D 119 . S ROUT=$P(^TMP("PSJMR",$J,I),U),ABBR=$P(^(I),U,2),IEN=$P(^(I),U,3) 120 . S LST($$NXT)="i"_IEN_U_ROUT_U_ABBR 121 . I I=1,IEN S LST($$NXT)="d"_IEN_U_ROUT ;_U_ABBR ; assume first always default 122 S I="" F S I=$O(^TMP("PSJMR",$J,I)) Q:I="" D 123 . S ROUT=$P(^TMP("PSJMR",$J,I),U),ABBR=$P(^(I),U,2),IEN=$P(^(I),U,3) 124 . I $L(ABBR),(ABBR'=ROUT) S LST($$NXT)="i"_IEN_U_ABBR_" ("_ROUT_")"_U_ABBR 125 Q 126 MESSAGE ; message 127 S I=0 F S I=$O(^ORD(101.43,OI,8,I)) Q:I'>0 S LST($$NXT)="t"_^(I,0) 128 Q 129 ALLROUTE(LST) ; returns a list of all available med routes 130 N I,X,ILST S ILST=0 131 S I=0 F S I=$O(^PS(51.2,I)) Q:'I S X=^(I,0) D 132 . I $P(X,U,4) S LST($$NXT)=I_U_$P(X,U)_U_$P(X,U,3) 133 Q 134 VALROUTE(REC,X) ; validates route name & returns IEN + abbreviation 135 N ORLST,ABBR 136 D FIND^DIC(51.2,"",1,"MO",X,1,,"I $P(^(0),U,4)=1",,"ORLST") 137 I 'ORLST("DILIST",0) S REC=0 Q 138 S X=$$UPPER(X),ABBR=ORLST("DILIST","ID",1,1) 139 I '$L(ABBR) S ABBR=ORLST("DILIST",1,1) 140 I ($$UPPER(ORLST("DILIST",1,1))'=X),($$UPPER(ABBR)'=X) S REC=0 Q 141 S REC=ORLST("DILIST",2,1)_U_ABBR 142 Q 143 AUTH(VAL,PRV) ; For inpatient meds, check restrictions 144 N NAME,AUTH,INACT,X S VAL=0 145 S NAME=$P($G(^VA(200,PRV,20)),U,2) S:'$L(NAME) NAME=$P(^(0),U) 146 S X=$G(^VA(200,PRV,"PS")),AUTH=$P(X,U),INACT=$P(X,U,4) 147 I 'AUTH!(INACT&(DT>INACT)) D Q 148 . S VAL="1^"_NAME_" is not authorized to write medication orders." 149 I $D(^XUSEC("OREMAS",DUZ)),'$$GET^XPAR("ALL","OR OREMAS MED ORDERS") D Q 150 . S VAL="1^OREMAS key holders may not enter medication orders." 151 Q 152 DRUGMSG(VAL,IEN) ; return any message associated with a dispense drug 153 N X S X=$$ENDCM^PSJORUTL(IEN) 154 S VAL=$P(X,U,2)_U_$P(X,U,4) 155 Q 156 MEDISIV(VAL,IEN) ; return true if orderable item is IV medication 157 S VAL=0 158 I $P($G(^ORD(101.43,IEN,"PS")),U)=2 S VAL=1 159 Q 160 ISSPLY(VAL,IEN) ; return true if orderable item is a supply 161 S VAL=0 162 I $P($G(^ORD(101.43,IEN,"PS")),U,5)=1 S VAL=1 163 Q 164 IVAMT(VAL,OI,ORWTYP) ; return UNITS^AMOUNT |^AMOUNT^AMOUNT...| for IV soln 165 N I,PSOI,ORWY,AMT,IVFLAG 166 S IVFLAG=$P(OI,U,2) 167 S PSOI=+$P($G(^ORD(101.43,+OI,0)),U,2)_ORWTYP,VAL="" 168 I IVFLAG="NF" D ENVOL2^PSJORUT2(PSOI,.ORWY) 169 I IVFLAG="" D ENVOL^PSJORUT2(PSOI,.ORWY) 170 I ORWTYP="B" D 171 . S I=0 F S I=$O(ORWY(I)) Q:I'>0 S AMT(+ORWY(I))="" 172 . S AMT=0,VAL="ML" F S AMT=$O(AMT(AMT)) Q:AMT'>0 S VAL=VAL_U_AMT 173 I ORWTYP="A" D 174 . S I=+$O(ORWY(0)) S VAL=$P($G(ORWY(I)),U,2) 175 . I '$L(VAL) S VAL="ML^LITER^MCG^MG^GM^UNITS^IU^MEQ^MM^MU^THOUU^MG-PE^NANOGRAM" 176 Q 177 VALRATE(VAL,X) ; return "1" (true) if IV rate text is valid 178 I $E($RE($$UPPER(X)),1,5)="RH/LM" S X=$E(X,1,$L(X)-5) 179 S X=$$TRIM(X) 180 D ORINF^PSIVSP S VAL=$G(X) ;S OK=$S($D(X):1,1:0) 181 Q 182 UPPER(X) ; return uppercase 183 Q $TR(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ") 184 ; 185 TRIM(X) ; trim leading and trailing spaces 186 S X=$RE(X) F S:$E(X)=" " X=$E(X,2,999) Q:$E(X)'=" " Q:'$L(X) ;trail 187 S X=$RE(X) F S:$E(X)=" " X=$E(X,2,999) Q:$E(X)'=" " Q:'$L(X) ;lead 188 Q X 189 SCSTS(VAL,ORVP,ORDRUG) ; return service connected eligibility for patient 190 N ORWP94 S ORWP94=$O(^ORD(101.41,"AB","PS MEDS",0))>0 191 I $L($T(SC^PSOCP)),$$SC^PSOCP(+ORVP,+$G(ORDRUG)) S VAL=0 G XSCSTS 192 I 'ORWP94,(+$$RXST^IBARXEU(+ORVP)>0) S VAL=0 G XSCSTS 193 S VAL=1 194 XSCSTS Q 195 FORMALT(ORLST,IEN,PSTYPE) ; return a list of formulary alternatives 196 D ENRFA^PSJORUTL(IEN,PSTYPE,.ORLST) 197 S I=0 F S I=$O(ORLST(I)) Q:'I D 198 . S OI=+$O(^ORD(101.43,"ID",+$P(ORLST(I),U,4)_";99PSP",0)) 199 . S $P(ORLST(I),U,4)=OI I OI S $P(ORLST(I),U,5)=$P(^ORD(101.43,OI,0),U) 200 Q 201 VALSCH(OK,X,PSTYPE) ; validate a schedule, return 1 if valid, 0 if not 202 I '$L($T(EN^PSSGSGUI)) S OK=-1 Q 203 I $E($T(EN^PSSGSGUI),1,4)="EN(X" D 204 . N ORX S ORX=$G(X) D EN^PSSGSGUI(.ORX,$G(PSTYPE,"I")) 205 . K X S:$D(ORX) X=ORX 206 E D 207 . D EN^PSSGSGUI 208 S OK=$S($D(X):1,1:0) 209 Q 210 VALQTY(OK,X) ; validate a quantity, return 1 if valid, 0 if not 211 ; to be compatible with LM, make sure X is integer from 1 to 240 212 ; this is based on the input transform from 52,7 213 K:(+X'>0)!(+X>99999999)!(X'?.8N.1".".2N)!($L(X)>12) X 214 S OK=$S($D(X):1,1:0) 215 Q 216 DOSES(LST,OI) ; return doses for an orderable item - TEST ONLY 217 N ORTMP,ORI,ORJ,ILST,NDF,VAPN,X,PSTYPE S PSTYPE="O" 218 D ENDD^PSJORUTL("^^^"_+$P($G(^ORD(101.43,OI,0)),"^",2),PSTYPE,.ORTMP) 219 S ORI=0 F S ORI=$O(ORTMP(ORI)) Q:'ORI S ORWDRG=+ORTMP(ORI) D 220 . S NDF=$G(^PSDRUG(+ORWDRG,"ND")),VAPN=$P(NDF,U,3),NDF=+NDF 221 . S X=$$DFSU^PSNAPIS(NDF,VAPN) 222 . S LSTA($P(X,U,4),$P(X,U,6))="" 223 . I +$P(X,U,4)=$P(X,U,4) S LSTA($P(X,U,4)*2,$P(X,U,6))="" 224 S ORI="",ILST=0 F S ORI=$O(LSTA(ORI)) Q:ORI="" D 225 . S ORJ="" F S ORJ=$O(LSTA(ORI,ORJ)) Q:ORJ="" D 226 . . S ILST=ILST+1,LST(ILST)=ORI_" "_ORJ 227 Q
Note:
See TracChangeset
for help on using the changeset viewer.
