ORWDPS2 ; SLC/KCM/JLI - Pharmacy Calls for Windows Dialog ;Feb 24, 2022@08:28:30
;;3.0;ORDER ENTRY/RESULTS REPORTING;**85,116,125,131,132,148,141,195,215,258,243,424,420,454,452,377,413,405**;Dec 17, 1997;Build 211
;
OISLCT(LST,OI,PSTYPE,ORVP,NEEDPI,PKIACTIV) ; return for defaults for pharmacy orderable item
I $D(NEEDPI),(NEEDPI="Y"),$G(^TMP($J,"ORWDX LOADRSP","QO SAVE")) D ;check if bug for Supply, Clin Med/IV for NEEDPI
.N ORQOIEN S ORQOIEN=$O(^ORD(101.41,"B","OR GTX ORDERABLE ITEM",0))
.N ORQOI S ORQOI=$O(^ORD(101.41,$G(^TMP($J,"ORWDX LOADRSP","QO SAVE")),6,"D",ORQOIEN,0)) Q:'ORQOI
.N ORQOOI S ORQOOI=$G(^ORD(101.41,$G(^TMP($J,"ORWDX LOADRSP","QO SAVE")),6,ORQOI,1)) Q:'ORQOOI
.I +OI=+ORQOOI D ;make sure QO orderable is the same as the orderable here
..N ORQOPIDA S ORQOPIDA=$O(^ORD(101.41,"B","OR GTX PATIENT INSTRUCTIONS",0))
..I '$D(^ORD(101.41,$G(^TMP($J,"ORWDX LOADRSP","QO SAVE")),6,"D",ORQOPIDA)) S NEEDPI="N"
K ^TMP($J,"ORWDX LOADRSP","QO SAVE")
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
S ILST=ILST+1,LST(ILST)="~Indication" D INDICAT
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)
;begin patch OR*3*420 MOD this supports the national drug message and lab test display in CPRS RTW
N CREATLST
S CREATLST=0 F S CREATLST=$O(LST(CREATLST)) Q:'CREATLST D
. I $G(LST(CREATLST))?1"t".E S ^TMP("OI",$J,CREATLST)=$G(LST(CREATLST))
;end patch OR*3*420 MOD ; RTW
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
N DD
S DD=0 F S DD=$O(ORDOSE("DD",DD)) Q:'DD D
. S ILST=ILST+1
. 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)
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
N Y,A,ORNOW
S ORNOW=$$NOW^XLFDT
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:"")
S A=$P($$CPTIER^PSNAPIS("",$P(ORNOW,"."),DD,1),"^")
S COST=$S(UD:$J(UD*$P(DRUG,U,2),1,3),1:COST) S:COST'="" COST="$"_COST S COST=COST_$E(" ",1,(15-$L(COST)))_"Tier "_A
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)
I $L($T(SL^ORWDPLM1)) D SL^ORWDPLM1 ;LAB monitor
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,TITR) ; return the maximum number of refills
; PAT=Patient DFN, DRG=ptr50, SUP=days supply, OI=orderable item, TITR=Titration Flag (1/0)
; 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
S ORWX("TITRATION")=+$G(TITR)
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,SPGRP,ODID
S ODID=+ORIFN
Q:ODID<1
S (UDGRP,IPGRP,OPGRP,ODGRP,SPGRP)=0
S SPGRP=$O(^ORD(100.98,"B","SUPPLIES/DEVICES",SPGRP))
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: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) S VAL=1
I IPGRP=ODGRP S VAL=1
I OPGRP=ODGRP S VAL=2
I SPGRP=ODGRP S VAL=2
K UDGRP,ODGRP,OPGRP,IPGRP,ODID
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
INDICAT ; from OISLCT return Indication for Use of Prescription or Medication Order
N G,IND,INDCAT
D INDCATN^PSS50P7(ORWPSOI,"ORWDPIND")
S G="" F S G=$O(^TMP($J,"ORWDPIND",G)) Q:'G D
.S INDCAT=$G(^TMP($J,"ORWDPIND",G))
.S IND=$S($P(INDCAT,"^",2)=1:"d"_$P(INDCAT,"^"),1:"i"_INDCAT)
.S ILST=ILST+1,LST(ILST)=IND
K ^TMP($J,"ORWDPIND")
Q
INDICAT2(LST,ORWPSOI) ; CPRS RPC return Indication for Use of Prescription
N G,IND,INDCAT,ILST
S ILST=0
D INDCATN^PSS50P7(ORWPSOI,"ORWDPIND")
S G="" F S G=$O(^TMP($J,"ORWDPIND",G)) Q:'G D
.S INDCAT=$G(^TMP($J,"ORWDPIND",G))
.S IND=$S($P(INDCAT,"^",2)=1:"d"_$P(INDCAT,"^"),1:"i"_INDCAT)
.S ILST=ILST+1,LST(ILST)=IND
K ^TMP($J,"ORWDPIND")
Q
INDICAT3(LST,ORIFN) ; CPRS RPC to return Indication for use previously selected for an Order
N X,LST
S X="" I $D(^OR(100,ORIFN,10)) S X=$P(^OR(100,ORIFN,10),U,2)
S LST(1)="~Indication selected"_X
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HORWDPS2 11969 printed Jan 18, 2025@03:36:50 Page 2
ORWDPS2 ; SLC/KCM/JLI - Pharmacy Calls for Windows Dialog ;Feb 24, 2022@08:28:30
+1 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**85,116,125,131,132,148,141,195,215,258,243,424,420,454,452,377,413,405**;Dec 17, 1997;Build 211
+2 ;
OISLCT(LST,OI,PSTYPE,ORVP,NEEDPI,PKIACTIV) ; return for defaults for pharmacy orderable item
+1 ;check if bug for Supply, Clin Med/IV for NEEDPI
IF $DATA(NEEDPI)
IF (NEEDPI="Y")
IF $GET(^TMP($JOB,"ORWDX LOADRSP","QO SAVE"))
Begin DoDot:1
+2 NEW ORQOIEN
SET ORQOIEN=$ORDER(^ORD(101.41,"B","OR GTX ORDERABLE ITEM",0))
+3 NEW ORQOI
SET ORQOI=$ORDER(^ORD(101.41,$GET(^TMP($JOB,"ORWDX LOADRSP","QO SAVE")),6,"D",ORQOIEN,0))
if 'ORQOI
QUIT
+4 NEW ORQOOI
SET ORQOOI=$GET(^ORD(101.41,$GET(^TMP($JOB,"ORWDX LOADRSP","QO SAVE")),6,ORQOI,1))
if 'ORQOOI
QUIT
+5 ;make sure QO orderable is the same as the orderable here
IF +OI=+ORQOOI
Begin DoDot:2
+6 NEW ORQOPIDA
SET ORQOPIDA=$ORDER(^ORD(101.41,"B","OR GTX PATIENT INSTRUCTIONS",0))
+7 IF '$DATA(^ORD(101.41,$GET(^TMP($JOB,"ORWDX LOADRSP","QO SAVE")),6,"D",ORQOPIDA))
SET NEEDPI="N"
End DoDot:2
End DoDot:1
+8 KILL ^TMP($JOB,"ORWDX LOADRSP","QO SAVE")
+9 NEW ILST,ORDOSE,ORWPSOI,ORWDOSES,X1,X2
+10 KILL ^TMP("PSJINS",$JOB),^TMP("PSJMR",$JOB),^TMP("PSJNOUN",$JOB),^TMP("PSJSCH",$JOB),^TMP("PSSDIN",$JOB)
+11 SET ILST=0
+12 SET ORWPSOI=0
+13 if +OI
SET ORWPSOI=+$PIECE($GET(^ORD(101.43,+OI,0)),U,2)
+14 ; dflt route, schedule, etc.
DO START^PSSJORDF(ORWPSOI,$SELECT(PSTYPE="U":"I",1:"O"))
+15 ; dflt doses
IF '$LENGTH($TEXT(DOSE^PSSOPKI1))
DO DOSE^PSSORUTL(.ORDOSE,ORWPSOI,PSTYPE,ORVP)
+16 ; dflt doses NEW PKI CODE from pharmacy
IF $LENGTH($TEXT(DOSE^PSSOPKI1))
DO DOSE^PSSOPKI1(.ORDOSE,ORWPSOI,PSTYPE,ORVP)
+17 ; nfi text
DO EN^PSSDIN(ORWPSOI)
+18 SET ILST=ILST+1
SET LST(ILST)="~Medication"
+19 SET ILST=ILST+1
SET LST(ILST)="d"_OI_U_$SELECT(+OI:$PIECE(^ORD(101.43,OI,0),U),1:"")
+20 SET ILST=ILST+1
SET LST(ILST)="~Verb"
+21 SET ILST=ILST+1
SET LST(ILST)="d"_$PIECE($GET(ORDOSE("MISC")),U)
+22 SET ILST=ILST+1
SET LST(ILST)="~Preposition"
+23 SET ILST=ILST+1
SET LST(ILST)="d"_$PIECE($GET(ORDOSE("MISC")),U,2)
+24 IF $DATA(NEEDPI)
IF (NEEDPI="Y")
SET ILST=ILST+1
SET LST(ILST)="~PtInstr"
DO PTINSTR
+25 ;S:NEEDPI="Y" ILST=ILST+1,LST(ILST)="~PtInstr" D PTINSTR
+26 ; must do before DOSAGE
SET ILST=ILST+1
SET LST(ILST)="~AllDoses"
DO ALLDOSE
+27 SET ILST=ILST+1
SET LST(ILST)="~Dosage"
DO DOSAGE
+28 SET ILST=ILST+1
SET LST(ILST)="~Dispense"
DO DISPLST
+29 SET ILST=ILST+1
SET LST(ILST)="~Route"
DO ROUTE
+30 SET ILST=ILST+1
SET LST(ILST)="~Schedule"
DO SCHED
+31 SET ILST=ILST+1
SET LST(ILST)="~Guideline"
DO GUIDE
+32 SET ILST=ILST+1
SET LST(ILST)="~Message"
DO OIMSG
+33 ;PKI
SET ILST=ILST+1
SET LST(ILST)="~DEASchedule"
+34 ;S ILST=ILST+1,LST(ILST)="d"_$P($G(ORDOSE("DEA")),U) ;PKI
+35 ;PKI
SET ILST=ILST+1
SET LST(ILST)="d"
+36 IF $DATA(ORDOSE("DEA"))
SET X=""
SET X1=$PIECE(ORDOSE("DEA"),";")
SET X2=$PIECE(ORDOSE("DEA"),";",2)
Begin DoDot:1
+37 IF '$LENGTH(X2)
QUIT
+38 IF $GET(PKIACTIV)="Y"
SET X=X2
End DoDot:1
+39 SET LST(ILST)=LST(ILST)_X
+40 SET ILST=ILST+1
SET LST(ILST)="~Indication"
DO INDICAT
+41 IF PSTYPE="U"
Begin DoDot:1
+42 ; start, expires, next admin
End DoDot:1
+43 IF PSTYPE="O"
Begin DoDot:1
+44 ; days supply, quantity, refills
End DoDot:1
+45 KILL ^TMP("PSJINS",$JOB),^TMP("PSJMR",$JOB),^TMP("PSJNOUN",$JOB),^TMP("PSJSCH",$JOB),^TMP("PSSDIN",$JOB)
+46 ;begin patch OR*3*420 MOD this supports the national drug message and lab test display in CPRS RTW
+47 NEW CREATLST
+48 SET CREATLST=0
FOR
SET CREATLST=$ORDER(LST(CREATLST))
if 'CREATLST
QUIT
Begin DoDot:1
+49 IF $GET(LST(CREATLST))?1"t".E
SET ^TMP("OI",$JOB,CREATLST)=$GET(LST(CREATLST))
End DoDot:1
+50 ;end patch OR*3*420 MOD ; RTW
+51 QUIT
+52 ;
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
+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 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)
End DoDot:1
+6 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 NEW Y,A,ORNOW
+10 SET ORNOW=$$NOW^XLFDT
+11 SET DD=+$PIECE(X,U,6)
SET DRUG=ORDOSE("DD",DD)
SET DDNM=$PIECE(DRUG,U)
SET ID=$PIECE(X,U,1,6)
+12 SET LDOSE=$PIECE(X,U,5)
SET TEXT=LDOSE
SET STREN=$PIECE(DRUG,U,5)_$PIECE(DRUG,U,6)
+13 ; add strength
SET $PIECE(ID,U,7)=$PIECE(DRUG,U,5)
SET $PIECE(ID,U,8)=$PIECE(DRUG,U,6)
+14 IF '$LENGTH($PIECE(X,U))
IF $LENGTH($PIECE(DRUG,U,5))
SET TEXT=TEXT_CONJ_STREN
+15 IF '$LENGTH($PIECE(X,U))
IF '$LENGTH($PIECE(DRUG,U,5))
SET TEXT=TEXT_CONJ_$PIECE(DRUG,U)
+16 SET UD=$PIECE(X,U,3)
SET COST=$PIECE(X,U,7)
SET NF=$SELECT($PIECE(DRUG,U,3):"NF",1:"")
+17 SET A=$PIECE($$CPTIER^PSNAPIS("",$PIECE(ORNOW,"."),DD,1),"^")
+18 SET COST=$SELECT(UD:$JUSTIFY(UD*$PIECE(DRUG,U,2),1,3),1:COST)
if COST'=""
SET COST="$"_COST
SET COST=COST_$EXTRACT(" ",1,(15-$LENGTH(COST)))_"Tier "_A
+19 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)
+20 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 ;LAB monitor
IF $LENGTH($TEXT(SL^ORWDPLM1))
DO SL^ORWDPLM1
+3 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,TITR) ; return the maximum number of refills
+1 ; PAT=Patient DFN, DRG=ptr50, SUP=days supply, OI=orderable item, TITR=Titration Flag (1/0)
+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 SET ORWX("TITRATION")=+$GET(TITR)
+10 DO MAX^PSOSIGDS(.ORWX)
+11 SET VAL=$GET(ORWX("MAX"))
+12 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,SPGRP,ODID
+7 SET ODID=+ORIFN
+8 if ODID<1
QUIT
+9 SET (UDGRP,IPGRP,OPGRP,ODGRP,SPGRP)=0
+10 SET SPGRP=$ORDER(^ORD(100.98,"B","SUPPLIES/DEVICES",SPGRP))
+11 SET UDGRP=$ORDER(^ORD(100.98,"B","UD RX",UDGRP))
+12 SET OPGRP=$ORDER(^ORD(100.98,"B","OUTPATIENT MEDICATIONS",OPGRP))
+13 SET IPGRP=$ORDER(^ORD(100.98,"B","INPATIENT MEDICATIONS",IPGRP))
+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)
SET VAL=1
+18 IF IPGRP=ODGRP
SET VAL=1
+19 IF OPGRP=ODGRP
SET VAL=2
+20 IF SPGRP=ODGRP
SET VAL=2
+21 KILL UDGRP,ODGRP,OPGRP,IPGRP,ODID
+22 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
INDICAT ; from OISLCT return Indication for Use of Prescription or Medication Order
+1 NEW G,IND,INDCAT
+2 DO INDCATN^PSS50P7(ORWPSOI,"ORWDPIND")
+3 SET G=""
FOR
SET G=$ORDER(^TMP($JOB,"ORWDPIND",G))
if 'G
QUIT
Begin DoDot:1
+4 SET INDCAT=$GET(^TMP($JOB,"ORWDPIND",G))
+5 SET IND=$SELECT($PIECE(INDCAT,"^",2)=1:"d"_$PIECE(INDCAT,"^"),1:"i"_INDCAT)
+6 SET ILST=ILST+1
SET LST(ILST)=IND
End DoDot:1
+7 KILL ^TMP($JOB,"ORWDPIND")
+8 QUIT
INDICAT2(LST,ORWPSOI) ; CPRS RPC return Indication for Use of Prescription
+1 NEW G,IND,INDCAT,ILST
+2 SET ILST=0
+3 DO INDCATN^PSS50P7(ORWPSOI,"ORWDPIND")
+4 SET G=""
FOR
SET G=$ORDER(^TMP($JOB,"ORWDPIND",G))
if 'G
QUIT
Begin DoDot:1
+5 SET INDCAT=$GET(^TMP($JOB,"ORWDPIND",G))
+6 SET IND=$SELECT($PIECE(INDCAT,"^",2)=1:"d"_$PIECE(INDCAT,"^"),1:"i"_INDCAT)
+7 SET ILST=ILST+1
SET LST(ILST)=IND
End DoDot:1
+8 KILL ^TMP($JOB,"ORWDPIND")
+9 QUIT
INDICAT3(LST,ORIFN) ; CPRS RPC to return Indication for use previously selected for an Order
+1 NEW X,LST
+2 SET X=""
IF $DATA(^OR(100,ORIFN,10))
SET X=$PIECE(^OR(100,ORIFN,10),U,2)
+3 SET LST(1)="~Indication selected"_X
+4 QUIT
