ORWDPS2 ; SLC/KCM/JLI - Pharmacy Calls for Windows Dialog;17-Jun-2013 10:14;PLS
;;3.0;ORDER ENTRY/RESULTS REPORTING;**85,116,125,131,132,148,141,195,215,258,243,1011**;Dec 17, 1997;Build 242
;
; Modified - IHS/MSC/PLS - 06/01/2013 - Line DISPLST+5
OISLCT(LST,OI,PSTYPE,ORVP,NEEDPI,PKIACTIV) ; return for defaults for pharmacy orderable item
N ILST,ORDOSE,ORWPSOI,ORWDOSES,X1,X2
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 ILST=ILST+1,LST(ILST)="~Medication"
S ILST=ILST+1,LST(ILST)="d"_OI_U_$S(+OI:$P(^ORD(101.43,OI,0),U),1:"")
S ILST=ILST+1,LST(ILST)="~Verb"
S ILST=ILST+1,LST(ILST)="d"_$P($G(ORDOSE("MISC")),U)
S ILST=ILST+1,LST(ILST)="~Preposition"
S ILST=ILST+1,LST(ILST)="d"_$P($G(ORDOSE("MISC")),U,2)
I $D(NEEDPI),(NEEDPI="Y") S ILST=ILST+1,LST(ILST)="~PtInstr" D PTINSTR
;S:NEEDPI="Y" ILST=ILST+1,LST(ILST)="~PtInstr" D PTINSTR
S ILST=ILST+1,LST(ILST)="~AllDoses" D ALLDOSE ; must do before DOSAGE
S ILST=ILST+1,LST(ILST)="~Dosage" D DOSAGE
S ILST=ILST+1,LST(ILST)="~Dispense" D DISPLST
S ILST=ILST+1,LST(ILST)="~Route" D ROUTE
S ILST=ILST+1,LST(ILST)="~Schedule" D SCHED
S ILST=ILST+1,LST(ILST)="~Guideline" D GUIDE
S ILST=ILST+1,LST(ILST)="~Message" D OIMSG
S ILST=ILST+1,LST(ILST)="~DEASchedule" ;PKI
;S ILST=ILST+1,LST(ILST)="d"_$P($G(ORDOSE("DEA")),U) ;PKI
S ILST=ILST+1,LST(ILST)="d" ;PKI
I $D(ORDOSE("DEA")) S X="",X1=$P(ORDOSE("DEA"),";"),X2=$P(ORDOSE("DEA"),";",2) D
. I '$L(X2) Q
. I $G(PKIACTIV)="Y" S X=X2
S LST(ILST)=LST(ILST)_X
I PSTYPE="U" D
. ; start, expires, next admin
I PSTYPE="O" D
. ; days supply, quantity, refills
K ^TMP("PSJINS",$J),^TMP("PSJMR",$J),^TMP("PSJNOUN",$J),^TMP("PSJSCH",$J),^TMP("PSSDIN",$J)
Q
;
PTINSTR ; from OISLCT, set up patient instructions
N I
S I=0 F S I=$O(ORDOSE("PI",I)) Q:I'>0 S ILST=ILST+1,LST(ILST)="t"_ORDOSE("PI",I)
Q
DOSAGE ; from OISLCT, set up the list of dosages
; LST(n)=iDrugName^Strength^NF^... (see BLDDOSE)
; must be called after ALLDOSE so ORWDOSES is set up
N I
S I=0 F S I=$O(ORWDOSES(I)) Q:I'>0 S ILST=ILST+1,LST(ILST)=ORWDOSES(I)
Q
DISPLST ; from OISLCT, set up list of dispense drugs
; DrugIEN^Strength^Units^Name^Split^Drug Long Name^Qty Qualifier
N DD
S DD=0 F S DD=$O(ORDOSE("DD",DD)) Q:'DD D
. S ILST=ILST+1
. ;IHS/MSC/PLS - 06/17/13
. ;S LST(ILST)="i"_DD_U_$P(ORDOSE("DD",DD),U,5,6)_U_$P(ORDOSE("DD",DD),U)_U_$P(ORDOSE("DD",DD),U,11)
. S LST(ILST)="i"_DD_U_$P(ORDOSE("DD",DD),U,5,6)_U_$P(ORDOSE("DD",DD),U)_U_$P(ORDOSE("DD",DD),U,11)_U_$$GET1^DIQ(50,DD,9999999.352)_U_$$QTYTXT^APSPES1(DD)
Q
ALLDOSE ; from OISLCT, set up a list of all possible doses
; LST(n)=iDrugName^Strength^NF^... (see BLDDOSE)
N I,J,CONJ,DD,DRUG,DDNM,LDOSE,TEXT,STREN,UD,COST,NF,ID,X
S CONJ=$P($G(ORDOSE("MISC")),U,3),ORWDOSES=0
S:$L(CONJ) CONJ=" "_CONJ_" " S:'$L(CONJ) CONJ=" "
S I=0 F S I=$O(ORDOSE(I)) Q:I'>0 D
. S X=$$BLDDOSE(ORDOSE(I))
. S ORWDOSES=ORWDOSES+1,ORWDOSES(ORWDOSES)=X
. S ILST=ILST+1
. S LST(ILST)="i"_$P(X,U,5)_U_$P($P(X,U,4),"&",6)_U_$P(X,U,4)
. S J=0 F S J=$O(ORDOSE(I,J)) Q:J'>0 D
. . S X=$$BLDDOSE(ORDOSE(I,J))
. . S ILST=ILST+1
. . S LST(ILST)="i"_$P(X,U,5)_U_$P($P(X,U,4),"&",6)_U_$P(X,U,4)
Q
BLDDOSE(X) ; build dose info where X is ORDOSE node
; from ALLDOSE
; X=TotalDose^Units^U/D^Noun^LocalDose^DispDrugIEN
; Y=iDrugName^Strength^NF^TDose&Units&U/D&Noun&LDose&Drug&Stren&Units^
; DoseText^CostText^MaxRefills^DispUnits^CanSplit
; DRUG=Name^Cost^NF^DispUnit^Strength^Units^DoseForm^MaxRefills^
; No TotalDose, use LocalDose
; TotalDose & Strength, use LocalDose+Conjunction+Strength+Units
; TotalDose, No Strength, use LocalDose+Conjunction+DispenseName
S DD=+$P(X,U,6),DRUG=ORDOSE("DD",DD),DDNM=$P(DRUG,U),ID=$P(X,U,1,6)
S LDOSE=$P(X,U,5),TEXT=LDOSE,STREN=$P(DRUG,U,5)_$P(DRUG,U,6)
S $P(ID,U,7)=$P(DRUG,U,5) S $P(ID,U,8)=$P(DRUG,U,6) ; add strength
I '$L($P(X,U)),$L($P(DRUG,U,5)) S TEXT=TEXT_CONJ_STREN
I '$L($P(X,U)),'$L($P(DRUG,U,5)) S TEXT=TEXT_CONJ_$P(DRUG,U)
S UD=$P(X,U,3),COST=$P(X,U,7),NF=$S($P(DRUG,U,3):"NF",1:"")
;I UD S COST="$"_$J(UD*$P(DRUG,U,2),1,3) ;_" per "_UD_" "_$P(X,U,4)
S Y="i"_DDNM_U_STREN_U_NF_U_$TR(ID,U,"&")_U_TEXT_U_COST_U_$P(DRUG,U,8)_U_$P(DRUG,U,4)
Q Y
ROUTE ; from OISLCT, get list of routes for the drug form
; ** NEED BOTH ABBREVIATION & NAME IN LIST BOX
N I,CNT,ABBR,IEN,ROUT,EXP,X
S I="" F S I=$O(^TMP("PSJMR",$J,I)) Q:I="" D
. S X=^TMP("PSJMR",$J,I)
. S ROUT=$P(X,U),ABBR=$P(X,U,2),IEN=$P(X,U,3),EXP=$P(X,U,4)
. S ILST=ILST+1,LST(ILST)="i"_IEN_U_ROUT_U_ABBR_U_EXP_U_$P(X,U,5)
. I $P(X,U,6)="D",IEN S ILST=ILST+1,LST(ILST)="d"_IEN_U_ROUT ;_U_ABBR ; assume first always default
; add abbreviations to list of routes, commented out for 15.5 on
; S I="" F S I=$O(^TMP("PSJMR",$J,I)) Q:I="" D
; . S X=^TMP("PSJMR",$J,I)
; . S ROUT=$P(X,U),ABBR=$P(X,U,2),IEN=$P(X,U,3),EXP=$P(X,U,4)
; . I $L(ABBR),(ABBR'=ROUT) S ILST=ILST+1,LST(ILST)="i"_IEN_U_ABBR_" ("_ROUT_")"_U_ABBR_U_EXP
Q
SCHED ; from OISLCT, get default schedule for this medication
I $L($G(^TMP("PSJSCH",$J))) S ILST=ILST+1,LST(ILST)="d"_^($J)
Q
GUIDE ; from OISLCT, get guidelines associated with this medication
N IEN,I
S IEN=0 F S IEN=$O(^TMP("PSSDIN",$J,"OI",ORWPSOI,IEN)) Q:'IEN D
. S I=0 F S I=$O(^TMP("PSSDIN",$J,"OI",ORWPSOI,IEN,I)) Q:'I D
. . S ILST=ILST+1,LST(ILST)="t"_^TMP("PSSDIN",$J,"OI",ORWPSOI,IEN,I)
Q
OIMSG ; from OISLCT, get the orderable item message for this medication
S I=0 F S I=$O(^ORD(101.43,OI,8,I)) Q:I'>0 S ILST=ILST+1,LST(ILST)="t"_^(I,0)
Q
ADMIN(REC,DFN,SCH,OI,LOC,ADMIN) ; return administration time info
; REC: StartText^StartTime^Duration^FirstAdmin
S OI=+$P($G(^ORD(101.43,+OI,0)),U,2)
S LOC=+$G(^SC(LOC,42)),REC=""
I $L($G(^DPT(DFN,.1))) S REC=$$FIRST^ORCDPS3(DFN,LOC,OI,SCH,"",$G(ADMIN))
Q
REQST(VAL,DFN,SCH,OI,LOC,TXT) ; return requested start time
; VAL: FirstAdmin time
S VAL=""
Q:'$L($G(SCH)) Q:'$G(OI)
S OI=+$P($G(^ORD(101.43,+OI,0)),U,2)
S LOC=+$G(^SC(LOC,42))
S VAL=$P($$RESOLVE^PSJORPOE(DFN,SCH,OI,TXT,LOC),U,2)
Q
DAY2QTY(VAL,DAY,UPD,SCH,DUR,PAT,DRG) ; return qty for days supply
; VAL: quantity
N ORWX,I,X,ADUR,ADURNM
S ORWX("DAYS SUPPLY")=DAY
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)
. S ADUR=$P(DUR,U,I),ADURNM=$P($P(ADUR," ",2),"~")
. S:ADURNM="MONTHS" X=+ADUR_"L"
. S:ADURNM'="MONTHS" X=+ADUR_$E($P(ADUR," ",2))
. I $L(X) S ORWX("DURATION",I)=X
. S X=$E($P(ADUR,"~",2))
. I $L(X) S ORWX("CONJUNCTION",I)=X
D QTYX^PSOSIG(.ORWX)
S VAL=$G(ORWX("QTY"))
Q
QTY2DAY(VAL,QTY,UPD,SCH,DUR,PAT,DRG) ; return days supply given quantity
; VAL: days supply
N ORWX,I,X,ADUR
S ORWX("QTY")=QTY
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)
. S ADUR=$P(DUR,U,I),X=+ADUR_$E($P(ADUR," ",2))
. I $L(X) S ORWX("DURATION",I)=X
. S X=$E($P(ADUR,"~",2))
. I $L(X) S ORWX("CONJUNCTION",I)=X
D QTYX^PSOSIG(.ORWX)
S VAL=$G(ORWX("DAYS SUPPLY"))
Q
MAXREF(VAL,PAT,DRG,SUP,OI,OUT) ; return the maximum number of refills
; PAT=Patient DFN, DRG=ptr50, SUP=days supply, OI=orderable item
; VAL: maximum refills allowed
N ORWX
S ORWX("PATIENT")=PAT
I $G(DRG) S ORWX("DRUG")=+DRG
I $G(SUP) S ORWX("DAYS SUPPLY")=SUP
I $G(OI) S ORWX("ITEM")=+$P(^ORD(101.43,+OI,0),U,2)
I $G(OUT) S ORWX("DISCHARGE")=1
D MAX^PSOSIGDS(.ORWX)
S VAL=$G(ORWX("MAX"))
Q
SCHREQ(VAL,OI,RTE,DRG) ; return 1 if schedule is required
; OI=orderable item, RTE=ptr route, DRG=ptr dispense drug
S VAL=1
Q:'$G(OI) Q:'$G(RTE)
S VAL=$$SCHREQ^PSJORPOE(RTE,OI,+$G(DRG))
Q
CHKPI(VAL,ODIFN) ; return pre-existing patient instruct
N IDNUM,IDPI
S (IDNUM,IDPI)=0,VAL=""
I '$D(^OR(100,ODIFN,4.5,"ID","PI")) S VAL="" Q
F S IDNUM=$O(^OR(100,ODIFN,4.5,"ID","PI",IDNUM)) Q:'IDNUM D
. F S IDPI=$O(^OR(100,ODIFN,4.5,IDNUM,2,IDPI)) Q:'IDPI D
.. S VAL=VAL_^OR(100,ODIFN,4.5,IDNUM,2,IDPI,0)
K IDNUM,IDPI
Q
CHKGRP(VAL,ORIFN) ;
;Inpatient Med Order Group or Clin Meds Group: return 1
;If order belong to Outpatient Med Order Grpoup: return 2
;Otherwise, return 0
S VAL=0
I '$L(ORIFN) Q
N UDGRP,IPGRP,OPGRP,ODGRP,ODID,CLMED
S ODID=+ORIFN
Q:ODID<1
S (UDGRP,IPGRP,OPGRP,ODGRP,CLMED)=0
S UDGRP=$O(^ORD(100.98,"B","UD RX",UDGRP))
S OPGRP=$O(^ORD(100.98,"B","OUTPATIENT MEDICATIONS",OPGRP))
S IPGRP=$O(^ORD(100.98,"B","INPATIENT MEDICATIONS",IPGRP))
S CLMED=$O(^ORD(100.98,"B","CLINIC ORDERS",CLMED))
S:IPGRP=0 IPGRP=$O(^ORD(100.98,"B","I RX",IPGRP))
I $L($G(^OR(100,ODID,0)))<1 Q
S ODGRP=$P(^OR(100,ODID,0),U,11)
I (UDGRP=ODGRP)!(CLMED=ODGRP) S VAL=1
I IPGRP=ODGRP S VAL=1
I OPGRP=ODGRP S VAL=2
K UDGRP,ODGRP,OPGRP,IPGRP,ODID,CLMED
Q
QOGRP(VAL,QOIFN) ;
;If quick order belong to Inpatient Med Order Group: return 1
;Otherwise, return 0
S VAL=0
I '$L(QOIFN) Q
N UDGRP,IPGRP,QOGRP,QOID,CLMED
S QOID=+QOIFN
Q:QOID<1
S (UDGRP,IPGRP,QOGRP,CLMED)=0
S UDGRP=$O(^ORD(100.98,"B","UD RX",UDGRP))
S IPGRP=$O(^ORD(100.98,"B","INPATIENT MEDICATIONS",IPGRP))
S CLMED=$O(^ORD(100.98,"B","CLINIC ORDERS",CLMED))
S:IPGRP=0 IPGRP=$O(^ORD(100.98,"B","I RX",IPGRP))
I $L($G(^ORD(101.41,QOID,0)))<1 Q
S QOGRP=$P(^ORD(101.41,QOID,0),U,5)
I UDGRP=QOGRP S VAL=1
I (IPGRP=QOGRP)!(CLMED=QOGRP) S VAL=1
K UDGRP,QOGRP,QOID,IPGRP,CLMED
Q
ORWDPS2 ; SLC/KCM/JLI - Pharmacy Calls for Windows Dialog;17-Jun-2013 10:14;PLS
+1 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**85,116,125,131,132,148,141,195,215,258,243,1011**;Dec 17, 1997;Build 242
+2 ;
+3 ; Modified - IHS/MSC/PLS - 06/01/2013 - Line DISPLST+5
OISLCT(LST,OI,PSTYPE,ORVP,NEEDPI,PKIACTIV) ; return for defaults for pharmacy orderable item
+1 NEW ILST,ORDOSE,ORWPSOI,ORWDOSES,X1,X2
+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 SET ILST=ILST+1
SET LST(ILST)="~Medication"
+11 SET ILST=ILST+1
SET LST(ILST)="d"_OI_U_$SELECT(+OI:$PIECE(^ORD(101.43,OI,0),U),1:"")
+12 SET ILST=ILST+1
SET LST(ILST)="~Verb"
+13 SET ILST=ILST+1
SET LST(ILST)="d"_$PIECE($GET(ORDOSE("MISC")),U)
+14 SET ILST=ILST+1
SET LST(ILST)="~Preposition"
+15 SET ILST=ILST+1
SET LST(ILST)="d"_$PIECE($GET(ORDOSE("MISC")),U,2)
+16 IF $DATA(NEEDPI)
IF (NEEDPI="Y")
SET ILST=ILST+1
SET LST(ILST)="~PtInstr"
DO PTINSTR
+17 ;S:NEEDPI="Y" ILST=ILST+1,LST(ILST)="~PtInstr" D PTINSTR
+18 ; must do before DOSAGE
SET ILST=ILST+1
SET LST(ILST)="~AllDoses"
DO ALLDOSE
+19 SET ILST=ILST+1
SET LST(ILST)="~Dosage"
DO DOSAGE
+20 SET ILST=ILST+1
SET LST(ILST)="~Dispense"
DO DISPLST
+21 SET ILST=ILST+1
SET LST(ILST)="~Route"
DO ROUTE
+22 SET ILST=ILST+1
SET LST(ILST)="~Schedule"
DO SCHED
+23 SET ILST=ILST+1
SET LST(ILST)="~Guideline"
DO GUIDE
+24 SET ILST=ILST+1
SET LST(ILST)="~Message"
DO OIMSG
+25 ;PKI
SET ILST=ILST+1
SET LST(ILST)="~DEASchedule"
+26 ;S ILST=ILST+1,LST(ILST)="d"_$P($G(ORDOSE("DEA")),U) ;PKI
+27 ;PKI
SET ILST=ILST+1
SET LST(ILST)="d"
+28 IF $DATA(ORDOSE("DEA"))
SET X=""
SET X1=$PIECE(ORDOSE("DEA"),";")
SET X2=$PIECE(ORDOSE("DEA"),";",2)
Begin DoDot:1
+29 IF '$LENGTH(X2)
QUIT
+30 IF $GET(PKIACTIV)="Y"
SET X=X2
End DoDot:1
+31 SET LST(ILST)=LST(ILST)_X
+32 IF PSTYPE="U"
Begin DoDot:1
+33 ; start, expires, next admin
End DoDot:1
+34 IF PSTYPE="O"
Begin DoDot:1
+35 ; days supply, quantity, refills
End DoDot:1
+36 KILL ^TMP("PSJINS",$JOB),^TMP("PSJMR",$JOB),^TMP("PSJNOUN",$JOB),^TMP("PSJSCH",$JOB),^TMP("PSSDIN",$JOB)
+37 QUIT
+38 ;
PTINSTR ; from OISLCT, set up patient instructions
+1 NEW I
+2 SET I=0
FOR
SET I=$ORDER(ORDOSE("PI",I))
IF I'>0
QUIT
SET ILST=ILST+1
SET LST(ILST)="t"_ORDOSE("PI",I)
+3 QUIT
DOSAGE ; from OISLCT, set up the list of dosages
+1 ; LST(n)=iDrugName^Strength^NF^... (see BLDDOSE)
+2 ; must be called after ALLDOSE so ORWDOSES is set up
+3 NEW I
+4 SET I=0
FOR
SET I=$ORDER(ORWDOSES(I))
IF I'>0
QUIT
SET ILST=ILST+1
SET LST(ILST)=ORWDOSES(I)
+5 QUIT
DISPLST ; from OISLCT, set up list of dispense drugs
+1 ; DrugIEN^Strength^Units^Name^Split^Drug Long Name^Qty Qualifier
+2 NEW DD
+3 SET DD=0
FOR
SET DD=$ORDER(ORDOSE("DD",DD))
IF 'DD
QUIT
Begin DoDot:1
+4 SET ILST=ILST+1
+5 ;IHS/MSC/PLS - 06/17/13
+6 ;S LST(ILST)="i"_DD_U_$P(ORDOSE("DD",DD),U,5,6)_U_$P(ORDOSE("DD",DD),U)_U_$P(ORDOSE("DD",DD),U,11)
+7 SET LST(ILST)="i"_DD_U_$PIECE(ORDOSE("DD",DD),U,5,6)_U_$PIECE(ORDOSE("DD",DD),U)_U_$PIECE(ORDOSE("DD",DD),U,11)_U_$$GET1^DIQ(50,DD,9999999.352)_U_$$QTYTXT^APSPES1(DD)
End DoDot:1
+8 QUIT
ALLDOSE ; from OISLCT, set up a list of all possible doses
+1 ; LST(n)=iDrugName^Strength^NF^... (see BLDDOSE)
+2 NEW I,J,CONJ,DD,DRUG,DDNM,LDOSE,TEXT,STREN,UD,COST,NF,ID,X
+3 SET CONJ=$PIECE($GET(ORDOSE("MISC")),U,3)
SET ORWDOSES=0
+4 IF $LENGTH(CONJ)
SET CONJ=" "_CONJ_" "
IF '$LENGTH(CONJ)
SET CONJ=" "
+5 SET I=0
FOR
SET I=$ORDER(ORDOSE(I))
IF I'>0
QUIT
Begin DoDot:1
+6 SET X=$$BLDDOSE(ORDOSE(I))
+7 SET ORWDOSES=ORWDOSES+1
SET ORWDOSES(ORWDOSES)=X
+8 SET ILST=ILST+1
+9 SET LST(ILST)="i"_$PIECE(X,U,5)_U_$PIECE($PIECE(X,U,4),"&",6)_U_$PIECE(X,U,4)
+10 SET J=0
FOR
SET J=$ORDER(ORDOSE(I,J))
IF J'>0
QUIT
Begin DoDot:2
+11 SET X=$$BLDDOSE(ORDOSE(I,J))
+12 SET ILST=ILST+1
+13 SET LST(ILST)="i"_$PIECE(X,U,5)_U_$PIECE($PIECE(X,U,4),"&",6)_U_$PIECE(X,U,4)
End DoDot:2
End DoDot:1
+14 QUIT
BLDDOSE(X) ; build dose info where X is ORDOSE node
+1 ; from ALLDOSE
+2 ; X=TotalDose^Units^U/D^Noun^LocalDose^DispDrugIEN
+3 ; Y=iDrugName^Strength^NF^TDose&Units&U/D&Noun&LDose&Drug&Stren&Units^
+4 ; DoseText^CostText^MaxRefills^DispUnits^CanSplit
+5 ; DRUG=Name^Cost^NF^DispUnit^Strength^Units^DoseForm^MaxRefills^
+6 ; No TotalDose, use LocalDose
+7 ; TotalDose & Strength, use LocalDose+Conjunction+Strength+Units
+8 ; TotalDose, No Strength, use LocalDose+Conjunction+DispenseName
+9 SET DD=+$PIECE(X,U,6)
SET DRUG=ORDOSE("DD",DD)
SET DDNM=$PIECE(DRUG,U)
SET ID=$PIECE(X,U,1,6)
+10 SET LDOSE=$PIECE(X,U,5)
SET TEXT=LDOSE
SET STREN=$PIECE(DRUG,U,5)_$PIECE(DRUG,U,6)
+11 ; add strength
SET $PIECE(ID,U,7)=$PIECE(DRUG,U,5)
SET $PIECE(ID,U,8)=$PIECE(DRUG,U,6)
+12 IF '$LENGTH($PIECE(X,U))
IF $LENGTH($PIECE(DRUG,U,5))
SET TEXT=TEXT_CONJ_STREN
+13 IF '$LENGTH($PIECE(X,U))
IF '$LENGTH($PIECE(DRUG,U,5))
SET TEXT=TEXT_CONJ_$PIECE(DRUG,U)
+14 SET UD=$PIECE(X,U,3)
SET COST=$PIECE(X,U,7)
SET NF=$SELECT($PIECE(DRUG,U,3):"NF",1:"")
+15 ;I UD S COST="$"_$J(UD*$P(DRUG,U,2),1,3) ;_" per "_UD_" "_$P(X,U,4)
+16 SET Y="i"_DDNM_U_STREN_U_NF_U_$TRANSLATE(ID,U,"&")_U_TEXT_U_COST_U_$PIECE(DRUG,U,8)_U_$PIECE(DRUG,U,4)
+17 QUIT Y
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,EXP,X
+3 SET I=""
FOR
SET I=$ORDER(^TMP("PSJMR",$JOB,I))
IF I=""
QUIT
Begin DoDot:1
+4 SET X=^TMP("PSJMR",$JOB,I)
+5 SET ROUT=$PIECE(X,U)
SET ABBR=$PIECE(X,U,2)
SET IEN=$PIECE(X,U,3)
SET EXP=$PIECE(X,U,4)
+6 SET ILST=ILST+1
SET LST(ILST)="i"_IEN_U_ROUT_U_ABBR_U_EXP_U_$PIECE(X,U,5)
+7 ;_U_ABBR ; assume first always default
IF $PIECE(X,U,6)="D"
IF IEN
SET ILST=ILST+1
SET LST(ILST)="d"_IEN_U_ROUT
End DoDot:1
+8 ; add abbreviations to list of routes, commented out for 15.5 on
+9 ; S I="" F S I=$O(^TMP("PSJMR",$J,I)) Q:I="" D
+10 ; . S X=^TMP("PSJMR",$J,I)
+11 ; . S ROUT=$P(X,U),ABBR=$P(X,U,2),IEN=$P(X,U,3),EXP=$P(X,U,4)
+12 ; . I $L(ABBR),(ABBR'=ROUT) S ILST=ILST+1,LST(ILST)="i"_IEN_U_ABBR_" ("_ROUT_")"_U_ABBR_U_EXP
+13 QUIT
SCHED ; from OISLCT, get default schedule for this medication
+1 IF $LENGTH($GET(^TMP("PSJSCH",$JOB)))
SET ILST=ILST+1
SET LST(ILST)="d"_^($JOB)
+2 QUIT
GUIDE ; from OISLCT, get guidelines associated with this medication
+1 NEW IEN,I
+2 SET IEN=0
FOR
SET IEN=$ORDER(^TMP("PSSDIN",$JOB,"OI",ORWPSOI,IEN))
IF 'IEN
QUIT
Begin DoDot:1
+3 SET I=0
FOR
SET I=$ORDER(^TMP("PSSDIN",$JOB,"OI",ORWPSOI,IEN,I))
IF 'I
QUIT
Begin DoDot:2
+4 SET ILST=ILST+1
SET LST(ILST)="t"_^TMP("PSSDIN",$JOB,"OI",ORWPSOI,IEN,I)
End DoDot:2
End DoDot:1
+5 QUIT
OIMSG ; from OISLCT, get the orderable item message for this medication
+1 SET I=0
FOR
SET I=$ORDER(^ORD(101.43,OI,8,I))
IF I'>0
QUIT
SET ILST=ILST+1
SET LST(ILST)="t"_^(I,0)
+2 QUIT
ADMIN(REC,DFN,SCH,OI,LOC,ADMIN) ; return administration time info
+1 ; REC: StartText^StartTime^Duration^FirstAdmin
+2 SET OI=+$PIECE($GET(^ORD(101.43,+OI,0)),U,2)
+3 SET LOC=+$GET(^SC(LOC,42))
SET REC=""
+4 IF $LENGTH($GET(^DPT(DFN,.1)))
SET REC=$$FIRST^ORCDPS3(DFN,LOC,OI,SCH,"",$GET(ADMIN))
+5 QUIT
REQST(VAL,DFN,SCH,OI,LOC,TXT) ; return requested start time
+1 ; VAL: FirstAdmin time
+2 SET VAL=""
+3 IF '$LENGTH($GET(SCH))
QUIT
IF '$GET(OI)
QUIT
+4 SET OI=+$PIECE($GET(^ORD(101.43,+OI,0)),U,2)
+5 SET LOC=+$GET(^SC(LOC,42))
+6 SET VAL=$PIECE($$RESOLVE^PSJORPOE(DFN,SCH,OI,TXT,LOC),U,2)
+7 QUIT
DAY2QTY(VAL,DAY,UPD,SCH,DUR,PAT,DRG) ; return qty for days supply
+1 ; VAL: quantity
+2 NEW ORWX,I,X,ADUR,ADURNM
+3 SET ORWX("DAYS SUPPLY")=DAY
+4 SET ORWX("PATIENT")=PAT
+5 IF DRG
SET ORWX("DRUG")=DRG
+6 FOR I=1:1:$LENGTH(UPD,U)-1
Begin DoDot:1
+7 SET ORWX("DOSE ORDERED",I)=$PIECE(UPD,U,I)
+8 SET ORWX("SCHEDULE",I)=$PIECE(SCH,U,I)
+9 SET ADUR=$PIECE(DUR,U,I)
SET ADURNM=$PIECE($PIECE(ADUR," ",2),"~")
+10 IF ADURNM="MONTHS"
SET X=+ADUR_"L"
+11 IF ADURNM'="MONTHS"
SET X=+ADUR_$EXTRACT($PIECE(ADUR," ",2))
+12 IF $LENGTH(X)
SET ORWX("DURATION",I)=X
+13 SET X=$EXTRACT($PIECE(ADUR,"~",2))
+14 IF $LENGTH(X)
SET ORWX("CONJUNCTION",I)=X
End DoDot:1
+15 DO QTYX^PSOSIG(.ORWX)
+16 SET VAL=$GET(ORWX("QTY"))
+17 QUIT
QTY2DAY(VAL,QTY,UPD,SCH,DUR,PAT,DRG) ; return days supply given quantity
+1 ; VAL: days supply
+2 NEW ORWX,I,X,ADUR
+3 SET ORWX("QTY")=QTY
+4 SET ORWX("PATIENT")=PAT
+5 IF DRG
SET ORWX("DRUG")=DRG
+6 FOR I=1:1:$LENGTH(UPD,U)-1
Begin DoDot:1
+7 SET ORWX("DOSE ORDERED",I)=$PIECE(UPD,U,I)
+8 SET ORWX("SCHEDULE",I)=$PIECE(SCH,U,I)
+9 SET ADUR=$PIECE(DUR,U,I)
SET X=+ADUR_$EXTRACT($PIECE(ADUR," ",2))
+10 IF $LENGTH(X)
SET ORWX("DURATION",I)=X
+11 SET X=$EXTRACT($PIECE(ADUR,"~",2))
+12 IF $LENGTH(X)
SET ORWX("CONJUNCTION",I)=X
End DoDot:1
+13 DO QTYX^PSOSIG(.ORWX)
+14 SET VAL=$GET(ORWX("DAYS SUPPLY"))
+15 QUIT
MAXREF(VAL,PAT,DRG,SUP,OI,OUT) ; return the maximum number of refills
+1 ; PAT=Patient DFN, DRG=ptr50, SUP=days supply, OI=orderable item
+2 ; VAL: maximum refills allowed
+3 NEW ORWX
+4 SET ORWX("PATIENT")=PAT
+5 IF $GET(DRG)
SET ORWX("DRUG")=+DRG
+6 IF $GET(SUP)
SET ORWX("DAYS SUPPLY")=SUP
+7 IF $GET(OI)
SET ORWX("ITEM")=+$PIECE(^ORD(101.43,+OI,0),U,2)
+8 IF $GET(OUT)
SET ORWX("DISCHARGE")=1
+9 DO MAX^PSOSIGDS(.ORWX)
+10 SET VAL=$GET(ORWX("MAX"))
+11 QUIT
SCHREQ(VAL,OI,RTE,DRG) ; return 1 if schedule is required
+1 ; OI=orderable item, RTE=ptr route, DRG=ptr dispense drug
+2 SET VAL=1
+3 IF '$GET(OI)
QUIT
IF '$GET(RTE)
QUIT
+4 SET VAL=$$SCHREQ^PSJORPOE(RTE,OI,+$GET(DRG))
+5 QUIT
CHKPI(VAL,ODIFN) ; return pre-existing patient instruct
+1 NEW IDNUM,IDPI
+2 SET (IDNUM,IDPI)=0
SET VAL=""
+3 IF '$DATA(^OR(100,ODIFN,4.5,"ID","PI"))
SET VAL=""
QUIT
+4 FOR
SET IDNUM=$ORDER(^OR(100,ODIFN,4.5,"ID","PI",IDNUM))
IF 'IDNUM
QUIT
Begin DoDot:1
+5 FOR
SET IDPI=$ORDER(^OR(100,ODIFN,4.5,IDNUM,2,IDPI))
IF 'IDPI
QUIT
Begin DoDot:2
+6 SET VAL=VAL_^OR(100,ODIFN,4.5,IDNUM,2,IDPI,0)
End DoDot:2
End DoDot:1
+7 KILL IDNUM,IDPI
+8 QUIT
CHKGRP(VAL,ORIFN) ;
+1 ;Inpatient Med Order Group or Clin Meds Group: return 1
+2 ;If order belong to Outpatient Med Order Grpoup: return 2
+3 ;Otherwise, return 0
+4 SET VAL=0
+5 IF '$LENGTH(ORIFN)
QUIT
+6 NEW UDGRP,IPGRP,OPGRP,ODGRP,ODID,CLMED
+7 SET ODID=+ORIFN
+8 IF ODID<1
QUIT
+9 SET (UDGRP,IPGRP,OPGRP,ODGRP,CLMED)=0
+10 SET UDGRP=$ORDER(^ORD(100.98,"B","UD RX",UDGRP))
+11 SET OPGRP=$ORDER(^ORD(100.98,"B","OUTPATIENT MEDICATIONS",OPGRP))
+12 SET IPGRP=$ORDER(^ORD(100.98,"B","INPATIENT MEDICATIONS",IPGRP))
+13 SET CLMED=$ORDER(^ORD(100.98,"B","CLINIC ORDERS",CLMED))
+14 IF IPGRP=0
SET IPGRP=$ORDER(^ORD(100.98,"B","I RX",IPGRP))
+15 IF $LENGTH($GET(^OR(100,ODID,0)))<1
QUIT
+16 SET ODGRP=$PIECE(^OR(100,ODID,0),U,11)
+17 IF (UDGRP=ODGRP)!(CLMED=ODGRP)
SET VAL=1
+18 IF IPGRP=ODGRP
SET VAL=1
+19 IF OPGRP=ODGRP
SET VAL=2
+20 KILL UDGRP,ODGRP,OPGRP,IPGRP,ODID,CLMED
+21 QUIT
QOGRP(VAL,QOIFN) ;
+1 ;If quick order belong to Inpatient Med Order Group: return 1
+2 ;Otherwise, return 0
+3 SET VAL=0
+4 IF '$LENGTH(QOIFN)
QUIT
+5 NEW UDGRP,IPGRP,QOGRP,QOID,CLMED
+6 SET QOID=+QOIFN
+7 IF QOID<1
QUIT
+8 SET (UDGRP,IPGRP,QOGRP,CLMED)=0
+9 SET UDGRP=$ORDER(^ORD(100.98,"B","UD RX",UDGRP))
+10 SET IPGRP=$ORDER(^ORD(100.98,"B","INPATIENT MEDICATIONS",IPGRP))
+11 SET CLMED=$ORDER(^ORD(100.98,"B","CLINIC ORDERS",CLMED))
+12 IF IPGRP=0
SET IPGRP=$ORDER(^ORD(100.98,"B","I RX",IPGRP))
+13 IF $LENGTH($GET(^ORD(101.41,QOID,0)))<1
QUIT
+14 SET QOGRP=$PIECE(^ORD(101.41,QOID,0),U,5)
+15 IF UDGRP=QOGRP
SET VAL=1
+16 IF (IPGRP=QOGRP)!(CLMED=QOGRP)
SET VAL=1
+17 KILL UDGRP,QOGRP,QOID,IPGRP,CLMED
+18 QUIT
