source: WorldVistAEHR/trunk/r/ORDER_ENTRY_RESULTS_REPORTING-OR-OCX--ORRC--ORRJ/ORWDPS2.m@ 1111

ORWDPS2 ; SLC/KCM/JLI - Pharmacy Calls for Windows Dialog
 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**85,116,125,131,132,148,141,195,215,258**;Dec 17, 1997;Build 7
 ;
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
 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
 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) ; 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)
 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