ORKPS ; slc/CLA - Order checking support procedures for medications ;12/29/17 11:58
;;3.0;ORDER ENTRY/RESULTS REPORTING;**6,32,74,94,123,141,190,232,316,272,346,345,382,469**;Dec 17, 1997;Build 0
Q
CHECK(YY,DFN,MED,OI,ORKDG,OROIL,ORSUPPLY,ORIVTYPE,ORIVRAN,ORDODSG) ; return drug order checks
;YY: returned array of data
;DFN: patient id
;MED: drug ien [file #50] ^ generic name [file #50]
;OI: orderable item ien [file #101.43]
;ORKDG: display group (should be PSI, PSIV, PSO or PSH)
;OROIL: list of items ordered
;ORSUPPLY: pharmacy orderable item ien [file #50.7] if it resolves to one or more supply items
; 0 if the pharmacy orderable item does not resolve to any supply items
;ORIVTYPE: the MED type as sent from Infusion Order Dialog
; A for additive
; B for base
;ORIVRAN: FLAG THAT DENOTES IF ALL COMPONENTS OF INFUSION ORDER HAVE ALREADY BEEN PROCESSED
; 1 FOR ALREADY PROCESSED
; EMPTY STRING FOR NOT YET PROCESSED
;ORDODSG: FLAG THAT DENOTES IF DOSAGE CHECKS SHOULD BE PERFORMED
; 1 FOR PERFORM DOSAGE CHECKS
; 0 FOR DO NOT PERFORM DOSAGE CHECKS
; returned info: varies for ^TMP($J x-ref - refer to listings below
N OR2CRITN,OR2CRITF,OR2CRITD,OR2SIGN,OR2SIGF,OR2SIGD,OR2DUPN,OR2DUPF,OR2DUPD,OR2DUPCN,OR2DUPCF,OR2DUPCD
N ORPHDG,ORKSOIA,ORDOCHKS
D PARAMS^ORKCHK6("CRITICAL DRUG INTERACTION",.OR2CRITN,.OR2CRITF,.OR2CRITD)
D PARAMS^ORKCHK6("SIGNIFICANT DRUG INTERACTION",.OR2SIGN,.OR2SIGF,.OR2SIGD)
D PARAMS^ORKCHK6("DUPLICATE DRUG THERAPY",.OR2DUPCN,.OR2DUPCF,.OR2DUPCD)
N ORDFN,ORKA,ORPTY,ORPHOI,OROILI,ORKAI S ORDFN=DFN
S ORPHOI=+$P($G(^ORD(101.43,+OI,0)),U,2)
S ORPTY=$S($G(ORKDG)="PSI":"I;",$G(ORKDG)="PSIV":"I;",$G(ORKDG)="PSO":"O;",$G(ORKDG)="PSH":"O;",1:"O;")
S ORPHDG=$S(ORKDG="PSI":"U",ORKDG="PSIV":"I",ORKDG="PSO":"O",ORKDG="PSH":"N",1:"")
I $G(ORIVTYPE)'="A" D Q:'ORDOCHKS ; Don't do checks if pharmacy does not want us to
.S ORDOCHKS=$$PRE^PSSDSAPK(ORPHOI,ORPHDG)
.S:'ORDODSG ORDODSG=ORDOCHKS
S:$G(ORIVTYPE)="A" ORDODSG=1
I +MED,('ORIVRAN) S ORKA(1)=MED_U_$$GETPSNM(+MED),ORKAI=1
;ADD ALL COMPONENTS OF IV ORDER SO WE ONLY HAVE TO DO A SINGLE PRE CALL
I ORKDG="PSIV",('ORIVRAN) D
.S ORIVRAN=1,OROILI=0 F S OROILI=$O(OROIL(OROILI)) Q:'OROILI D
..N OR2OI,OR2PSOI,OR2PHDG
..I 'OROIL(OROILI) Q
..I +OROIL(OROILI)=OI Q
..S OR2OI=+OROIL(OROILI)
..S OR2PSOI=+$P($G(^ORD(101.43,+OR2OI,0)),U,2)
..S OR2PHDG=$P(OROIL(OROILI),U,2)
..S OR2PHDG=$S(OR2PHDG="PSI":"U",OR2PHDG="PSIV":"I",OR2PHDG="PSO":"O",OR2PHDG="PSH":"N",1:"")
..Q:OR2PHDG'="I"
..I $P($P(OROIL(OROILI),U,3),";")="B",$$PRE^PSSDSAPK(OR2PSOI,OR2PHDG)=0 Q
..I $P($P(OROIL(OROILI),U,3),";")="B",$P($P(OROIL(OROILI),U,3),";",2)="",$G(ORREN)=1 D
...N ORVOLID,ORVOLVAL S ORVOLVAL="",ORVOLID=$O(^OR(100,+$G(ORIFN),4.5,"ID","VOLUME",""))
...I ORVOLID>0 S ORVOLVAL=$G(^OR(100,+$G(ORIFN),4.5,ORVOLID,1))
...S OROIL(OROILI)=OROIL(OROILI)_ORVOLVAL
..N ORUSID
..S ORUSID=$$USID^ORWDXC(OROIL(OROILI))
..S ORKAI=ORKAI+1,ORKA(ORKAI)=$P(ORUSID,U,4)_U_$$GETPSNM($P(ORUSID,U,4))
D:$D(ORKA) CPRS^PSODDPR4(ORDFN,"OROCOUT"_ORPTY,.ORKA,ORPTY_+$G(^OR(100,+$G(ORIFN),4)))
I +ORSUPPLY D
.S ORKSOIA(+ORSUPPLY)=$G(ORIFN)
.D CPRS^PSODDPR8(ORDFN,"OROCOUT"_ORPTY,.ORKSOIA,ORPHDG_";"_+$G(^OR(100,+$G(ORNUM),4)),$S($D(ORKA):1,1:""))
I $D(ORKA)!($D(ORKSOIA))!(ORIVRAN) D
.S:OR2CRITF_OR2SIGF_OR2DUPCF["E" ^TMP($J,"ORENHCHK")=1
.D PROCESS^ORKPS1(OI,ORDFN,ORKDG,+ORSUPPLY_U_+MED,"OROCOUT"_ORPTY)
Q
CHKSESS(YY,DFN,MED,OI,ORKPDATA,ORKDG,ORSUPPLY,ORIVTYPE) ; return drug order checks for session
;ORSUPPLY: pharmacy orderable item ien [file #50.7] if it resolves to one or more supply items
; 0 if the pharmacy orderable item does not resolve to any supply items
;ORIVTYPE: the MED type as sent from Infusion Order Dialog
; A for additive
; B for base
N ORKDGI,ORKDRUG,ORKDRUGA,ORKORN,HOR,SEQ,CNT,CNTX,ORKOI,ORPHOI
N ORKFLG,ORSESS,ORPSPKG,ORPSA,ORSNUM,ORNUM,DUPX,DUPORN,ORPTY
N ORKSOIA,ORRET,ORDFN,ORPHDG S ORDFN=DFN
S ORPTY=$S($G(ORKDG)="PSI":"I;",$G(ORKDG)="PSIV":"I;",$G(ORKDG)="PSO":"O;",$G(ORKDG)="PSH":"O;",1:"O;")
S ORPHDG=$S(ORKDG="PSI":"U",ORKDG="PSIV":"I",ORKDG="PSO":"O",ORKDG="PSH":"N",1:"")
I '$D(^TMP($J,"OROCOUT"_ORPTY)) D
.S ORKFLG=0
.S ORNUM=$P(ORKA,"|",5)
.S ORPHOI=+$P($G(^ORD(101.43,+OI,0)),U,2)
.I $G(ORIVTYPE)'="A",'$$PRE^PSSDSAPK(ORPHOI,ORPHDG) Q ; Don't do checks if pharmacy does not want us to
.;get unsigned medication orders:
.S HOR=0,SEQ=0
.S HOR=$O(^TMP("ORR",$J,HOR))
.I +$G(HOR)>0 D
..F S SEQ=$O(^TMP("ORR",$J,HOR,SEQ)) Q:+SEQ<1 D
...S ORKORN=+$P(^TMP("ORR",$J,HOR,SEQ),U),DUPORN=0
...Q:+$G(ORKORN)<1
...Q:+ORKORN=+ORNUM
...Q:$P(^OR(100,+ORKORN,8,$P(^OR(100,+ORKORN,8,0),U,3),0),U,2)="DC"
...Q:$P(^ORD(100.01,$P(^OR(100,+ORKORN,3),U,3),0),U)="DISCONTINUED"
...S ORKDRUG=$$VALUE^ORCSAVE2(+ORKORN,"DRUG") ;get disp drug for order
...S ORPSPKG=$$DGRX^ORQOR2(+ORKORN)
...S:ORPSPKG="CLINIC INFUSIONS" ORPSPKG="IV MEDICATIONS" ; OR*3*430
...S ORPSPKG=$S(ORPSPKG="UNIT DOSE MEDICATIONS":"PSI",ORPSPKG="OUTPATIENT MEDICATIONS":"PSO",ORPSPKG="IV MEDICATIONS":"PSIV",ORPSPKG="NON-VA MEDICATIONS":"PSH",1:"")
...S DUPX="" F S DUPX=$O(ORKDRUGA(DUPX)) Q:'DUPX!(DUPORN=1) D
....S:ORKORN=ORKDRUGA(DUPX) DUPORN=1
...Q:DUPORN=1 ;quit if already processed drug order
...I +$G(ORKDRUG)<1,$L(ORPSPKG)>0 D
....N OROI S OROI=$$OI^ORX8(+ORKORN)
....S ORRET=$$OI2DD(+OROI,$S($G(ORKDG)="PSI":"I",$G(ORKDG)="PSIV":"I",$G(ORKDG)="PSO":"O",$G(ORKDG)="PSH":"O",1:"O"),1)
....I +$P(ORRET,";",4) S ORKSOIA(+$P(ORRET,";",4))=ORKORN
....I +ORRET S ORKDRUG=+ORRET
...;only process vs. unsigned med order if disp drug is assoc w/order:
...Q:+$G(ORKDRUG)<1
...I ORPSPKG="PSIV" D
....;loop through each OI in the IV order
....N OR2I
....S OR2I=0 F S OR2I=$O(^OR(100,+ORKORN,4.5,"ID","ORDERABLE",OR2I)) Q:'OR2I D
.....N OR2OI,OR2DRUG
.....S OR2OI=$G(^OR(100,+ORKORN,4.5,OR2I,1))
.....Q:'OR2OI
.....;get the drug for each OI
.....S OR2DRUG=$$OI2DD(+OR2OI,"I",1)
.....;check if drug should be add it and add it if so
.....I $$IVADD(OR2DRUG,OR2OI) S ORKDRUGA(+OR2DRUG_";"_ORPSPKG_";"_ORKORN)=ORKORN_U_$$GETPSNM(+OR2DRUG)
...I ORPSPKG'="PSIV" S ORKDRUGA(+ORKDRUG_";"_ORPSPKG_";"_ORKORN)=ORKORN_U_$$GETPSNM(+ORKDRUG)
...; OR*3*469 - Load all components (solution and additive) of IV for order checking
... I ORPSPKG="PSIV" D
.... N ORX,ORRET S ORX=0 F S ORX=+$O(^OR(100,ORKORN,4.5,"ID","ORDERABLE",ORX)) Q:'ORX D
..... S ORRET=$$OI2DD(+$G(^OR(100,ORKORN,4.5,ORX,1)),"I",1) Q:'ORRET
..... I +$P(ORRET,";",4) S ORKSOIA(+$P(ORRET,";",4))=ORKORN
..... I '$D(ORKDRUGA(+ORRET_";PSIV;"_ORKORN)) S ORKDRUGA(+ORRET_";PSIV;"_ORKORN)=ORKORN_U_$$GETPSNM(+ORRET)
.... Q ; end of OR*3*469 change
.N ORPROSP,CNT
.S CNT=1
.S:+MED ORPROSP(CNT)=MED_U_$$GETPSNM(+MED)_U_+$G(ORNUM),CNT=CNT+1
.N I S I="" F S I=$O(ORKDRUGA(I)) Q:'I S ORPROSP(CNT)=+I_U_$P(ORKDRUGA(I),U,2)_U_U_$P(ORKDRUGA(I),U,1),CNT=CNT+1
.D SHRNKPR
.D CPRS^PSODDPR4(DFN,"OROCOUT"_ORPTY,.ORPROSP,ORPTY_+$G(^OR(100,+$G(ORNUM),4)))
.I +ORSUPPLY D
..S ORKSOIA(+ORSUPPLY)=$G(ORNUM)
..D:$D(ORKSOIA)>9 CPRS^PSODDPR8(DFN,"OROCOUT"_ORPTY,.ORKSOIA,ORPHDG_";"_+$G(^OR(100,+$G(ORNUM),4)),1)
D PROCESS^ORKPS1(OI,ORDFN,ORKDG,+ORSUPPLY_U_+MED,"OROCOUT"_ORPTY)
Q
IVADD(ORDRUG,OROI) ;RETURN YES OR NO IF SHOULD ADD THE IV ITEM
N ORRET
;default is yes to add it, will always be 1 for an additive
S ORRET=1
;check if drug is a base
K ^TMP($J,"ORBASECHECK")
D DRGIEN^PSS52P7(ORDRUG,,"ORBASECHECK")
I $P($G(^TMP($J,"ORBASECHECK",0),0),U)>0 D ;GOT A BASE HERE
.;if drug is a base, check if pharmacy says we can add it or not
.N ORPHOI
.S ORPHOI=+$P($G(^ORD(101.43,+OROI,0)),U,2)
.S ORRET=$$PRE^PSSDSAPK(ORPHOI,"I")
K ^TMP($J,"ORBASECHECK")
Q ORRET
SHRNKPR ;REMOVE DUPLICATS FROM PROSPECTIVE LIST
Q:'$D(ORPROSP)
N ORX,ORI S ORI=0 F S ORI=$O(ORPROSP(ORI)) Q:'ORI S ORX=ORPROSP(ORI) D
.N ORJ S ORJ=ORI F S ORJ=$O(ORPROSP(ORJ)) Q:'ORJ I ORX=ORPROSP(ORJ) K ORPROSP(ORJ)
Q
GETPSNM(ORIEN) ;GET THE FILE 50 .01 FIELD FROM A FILE 50 IEN
N RET K ^TMP($J,"ORRETNM")
D NDF^PSS50(ORIEN,,,,,"ORRETNM") S RET=$G(^TMP($J,"ORRETNM",ORIEN,.01))
K ^TMP($J,"ORRETNM")
Q RET
TAKEMED(ORKDFN,ORKMED) ;extrinsic function returns med orderable item if any
;active med patient is taking contains any piece of ORKMED
;ORKDFN patient DFN
;ORKMED meds to check vs. active med list in format MED1^MED2^MED3...
Q:'$L($G(ORKDFN)) "0^Patient not identified."
Q:'$L($G(ORKMED)) "0^Medication not identified."
N ORKARX,ORKY,ORI,ORJ,ORCNT,ORKMEDP,ORKRSLT
D LIST^ORQQPS(.ORKY,ORKDFN,"","")
Q:$P(ORKY(1),U)="" "0^No active meds found."
S ORKRSLT="0^No matching meds found."
S ORCNT=$L(ORKMED,U)
S ORI=0 F S ORI=$O(ORKY(ORI)) Q:ORI<1 D
.S ORKARX=$P(ORKY(ORI),U,2)
.F ORJ=1:1:ORCNT S ORKMEDP=$P(ORKMED,U,ORJ) D
..I $L(ORKMEDP),($$UP^XLFSTR(ORKARX)[ORKMEDP) S ORKRSLT="1^"_ORKARX ;DJE/VM *316 use uppercase in comparison
Q ORKRSLT
POLYRX(DFN) ;extrins funct rtns 1 if patient exceeds polypharmacy, 0 if not
N ORSLT,ORENT,ORLOC,ORPAR,ORMEDS
S ORSLT=0
Q:'$L(DFN) ORSLT
S VA200="" D OERR^VADPT
S ORLOC=+$G(^DIC(42,+VAIN(4),44))
K VA200,VAIN
S ORENT=+$G(ORLOC)_";SC(^DIV^SYS^PKG"
S ORPAR=$$GET^XPAR(ORENT,"ORK POLYPHARMACY",1,"I")
S ORMEDS=$$NUMRX(DFN)
I $G(ORMEDS)>$G(ORPAR) S ORSLT=1
Q ORSLT
GLCREAT(DFN) ;extrinsic function returns patient's (DFN) most recent serum
; creatinine within # of days from parameter ORK GLUCOPHAGE CREATININE
; results format: test id^result units flag ref range collect d/t^result
; used by order check GLUCOPHAGE-LAB RESULTS
N ORLOC,ORPAR,ORDAYS
N BDT,CDT,ORY,ORX,ORZ,TEST,ORI,ORJ,CREARSLT,LABFILE,SPECFILE,SPECIMEN,VAIN,VADM,RSLTS
Q:'$L(DFN) "0^"
S ORDAYS=$$GCDAYS(DFN)
Q:'$L(ORDAYS) "0^"
D NOW^%DTC
S BDT=$$FMADD^XLFDT(%,"-"_ORDAYS,"","","")
K %
Q:'$L($G(BDT)) "0^"
S LABFILE=$$TERMLKUP^ORB31(.ORY,"SERUM CREATININE")
Q:'$D(ORY) "0^" ;no link between SERUM CREATININE and local lab test
Q:$G(LABFILE)'=60 "0^"
S SPECFILE=$$TERMLKUP^ORB31(.ORX,"SERUM SPECIMEN")
Q:'$D(ORX) "0^" ;no link between SERUM SPECIMEN and local specimen
Q:$G(SPECFILE)'=61 "0^"
F ORI=1:1:ORY D
.S TEST=$P(ORY(ORI),U)
.Q:+$G(TEST)<1
.F ORJ=1:1:ORX D
..S SPECIMEN=$P(ORX(ORJ),U)
..Q:+$G(SPECIMEN)<1
..S ORZ=$$LOCL^ORQQLR1(DFN,TEST,SPECIMEN)
..Q:'$L($G(ORZ))
..S CDT=$P(ORZ,U,7)
..I CDT'<BDT S RSLTS(CDT)=ORZ,CREARSLT=1 ;*SMT Use RSLTS as array.
Q:+$G(CREARSLT)<1 "0^"
S CDT=$O(RSLTS(0)),ORZ=RSLTS(CDT) ;*SMT
Q $P(ORZ,U)_U_$P(ORZ,U,3)_" "_$P(ORZ,U,4)_" "_$P(ORZ,U,5)_" ("_$P(ORZ,U,6)_") "_$$FMTE^XLFDT(CDT,"2P")_U_$P(ORZ,U,3)
GCDAYS(DFN) ;extrinsic function to return number of days to look for
; glucophage serum creatinine result
Q:'$L(DFN) ""
N ORLOC,ORENT,ORDAYS
;get patient's location flag (INPATIENT ONLY - outpt locations cannot be
;reliably determined, and many simultaneous outpt locations can occur):
S VA200="" D OERR^VADPT
S ORLOC=+$G(^DIC(42,+VAIN(4),44))
K VA200,VAIN
S ORENT=+$G(ORLOC)_";SC(^DIV^SYS^PKG"
S ORDAYS=$$GET^XPAR(ORENT,"ORK GLUCOPHAGE CREATININE",1,"I")
Q:$L(ORDAYS) ORDAYS
Q ""
SUPPLY(OI) ;extrinsic function returns 1 (true) if the orderable item is
; a supply
Q:+$G(OI)<1 ""
N OITEXT
S OITEXT=$G(^ORD(101.43,OI,0))
Q:'$L(OITEXT) ""
S OITEXT=$P(OITEXT,U)
Q:$D(^ORD(101.43,"S.SPLY",OITEXT)) 1
Q ""
NUMRX(DFN) ;extrinsic funct returns number of active meds patient is taking
N NUMRX,ORPTYPE,ORX,ORY,ORS,ORNUM,ORPRENEW,VADMVT
S NUMRX=0
Q:+$G(DFN)<1 NUMRX
;check to determine if inpatient or outpatient:
D ADM^VADPT2
S ORPTYPE=$S(+$G(VADMVT)>0:"I",1:"O")
K ^TMP("PS",$J)
D OCL^PSOORRL(DFN,"","") ;if no date range, returns active meds for pt
N X
S X=0
F S X=$O(^TMP("PS",$J,X)) Q:X<1 D
.S ORX=$G(^TMP("PS",$J,X,0))
.S ORY=$P(ORX,U)
.S ORNUM=$P(ORX,U,8) ;order entry order number
.S ORS=$P(ORX,U,9) ;medication status from pharmacy
.S ORPRENEW=$P(ORX,U,14) ;pending renewal flag (1: pending renewal)
.Q:+ORX<1
.Q:$P(ORY,";",2)'=ORPTYPE ;quit if med is not pt type (inpt/outpt)
.;quit if status is a non-active type:
.Q:$G(ORS)="EXPIRED"
.Q:$G(ORS)["DISCONTINUE"
.Q:$G(ORS)="DELETED"
.Q:+$G(ORPRENEW)>0
.Q:$$SUPPLY($$OI^ORQOR2(ORNUM))=1 ;quit if a supply
.S NUMRX=NUMRX+1
K ^TMP("PS",$J)
Q NUMRX
OI2DD(OROI,ORPSPKG,ORCHKTYP) ;rtn dispense drugs for a PS OI
;ORCHKTYP: TYPE OF ORDER CHECK SYSTEM IS PERFORMING
; 1 FOR ENHANCED ORDER CHECKS
; 2 FOR DOSAGE ORDER CHECK
N PSOI,ORRET
Q:'$D(^ORD(101.43,OROI,0)) ""
S PSOI=+$P(^ORD(101.43,OROI,0),U,2)
Q:PSOI<1 ""
S:ORPSPKG="H" ORPSPKG="X" ;if non-va med need to pass api "X"
S ORRET=$$DRG^PSSDSAPM(PSOI,ORPSPKG,ORCHKTYP)
I ORCHKTYP=1,(+$P(ORRET,";",4)) S $P(ORRET,";",4)=PSOI
Q ORRET
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HORKPS 12964 printed Sep 23, 2025@20:07:29 Page 2
ORKPS ; slc/CLA - Order checking support procedures for medications ;12/29/17 11:58
+1 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**6,32,74,94,123,141,190,232,316,272,346,345,382,469**;Dec 17, 1997;Build 0
+2 QUIT
CHECK(YY,DFN,MED,OI,ORKDG,OROIL,ORSUPPLY,ORIVTYPE,ORIVRAN,ORDODSG) ; return drug order checks
+1 ;YY: returned array of data
+2 ;DFN: patient id
+3 ;MED: drug ien [file #50] ^ generic name [file #50]
+4 ;OI: orderable item ien [file #101.43]
+5 ;ORKDG: display group (should be PSI, PSIV, PSO or PSH)
+6 ;OROIL: list of items ordered
+7 ;ORSUPPLY: pharmacy orderable item ien [file #50.7] if it resolves to one or more supply items
+8 ; 0 if the pharmacy orderable item does not resolve to any supply items
+9 ;ORIVTYPE: the MED type as sent from Infusion Order Dialog
+10 ; A for additive
+11 ; B for base
+12 ;ORIVRAN: FLAG THAT DENOTES IF ALL COMPONENTS OF INFUSION ORDER HAVE ALREADY BEEN PROCESSED
+13 ; 1 FOR ALREADY PROCESSED
+14 ; EMPTY STRING FOR NOT YET PROCESSED
+15 ;ORDODSG: FLAG THAT DENOTES IF DOSAGE CHECKS SHOULD BE PERFORMED
+16 ; 1 FOR PERFORM DOSAGE CHECKS
+17 ; 0 FOR DO NOT PERFORM DOSAGE CHECKS
+18 ; returned info: varies for ^TMP($J x-ref - refer to listings below
+19 NEW OR2CRITN,OR2CRITF,OR2CRITD,OR2SIGN,OR2SIGF,OR2SIGD,OR2DUPN,OR2DUPF,OR2DUPD,OR2DUPCN,OR2DUPCF,OR2DUPCD
+20 NEW ORPHDG,ORKSOIA,ORDOCHKS
+21 DO PARAMS^ORKCHK6("CRITICAL DRUG INTERACTION",.OR2CRITN,.OR2CRITF,.OR2CRITD)
+22 DO PARAMS^ORKCHK6("SIGNIFICANT DRUG INTERACTION",.OR2SIGN,.OR2SIGF,.OR2SIGD)
+23 DO PARAMS^ORKCHK6("DUPLICATE DRUG THERAPY",.OR2DUPCN,.OR2DUPCF,.OR2DUPCD)
+24 NEW ORDFN,ORKA,ORPTY,ORPHOI,OROILI,ORKAI
SET ORDFN=DFN
+25 SET ORPHOI=+$PIECE($GET(^ORD(101.43,+OI,0)),U,2)
+26 SET ORPTY=$SELECT($GET(ORKDG)="PSI":"I;",$GET(ORKDG)="PSIV":"I;",$GET(ORKDG)="PSO":"O;",$GET(ORKDG)="PSH":"O;",1:"O;")
+27 SET ORPHDG=$SELECT(ORKDG="PSI":"U",ORKDG="PSIV":"I",ORKDG="PSO":"O",ORKDG="PSH":"N",1:"")
+28 ; Don't do checks if pharmacy does not want us to
IF $GET(ORIVTYPE)'="A"
Begin DoDot:1
+29 SET ORDOCHKS=$$PRE^PSSDSAPK(ORPHOI,ORPHDG)
+30 if 'ORDODSG
SET ORDODSG=ORDOCHKS
End DoDot:1
if 'ORDOCHKS
QUIT
+31 if $GET(ORIVTYPE)="A"
SET ORDODSG=1
+32 IF +MED
IF ('ORIVRAN)
SET ORKA(1)=MED_U_$$GETPSNM(+MED)
SET ORKAI=1
+33 ;ADD ALL COMPONENTS OF IV ORDER SO WE ONLY HAVE TO DO A SINGLE PRE CALL
+34 IF ORKDG="PSIV"
IF ('ORIVRAN)
Begin DoDot:1
+35 SET ORIVRAN=1
SET OROILI=0
FOR
SET OROILI=$ORDER(OROIL(OROILI))
if 'OROILI
QUIT
Begin DoDot:2
+36 NEW OR2OI,OR2PSOI,OR2PHDG
+37 IF 'OROIL(OROILI)
QUIT
+38 IF +OROIL(OROILI)=OI
QUIT
+39 SET OR2OI=+OROIL(OROILI)
+40 SET OR2PSOI=+$PIECE($GET(^ORD(101.43,+OR2OI,0)),U,2)
+41 SET OR2PHDG=$PIECE(OROIL(OROILI),U,2)
+42 SET OR2PHDG=$SELECT(OR2PHDG="PSI":"U",OR2PHDG="PSIV":"I",OR2PHDG="PSO":"O",OR2PHDG="PSH":"N",1:"")
+43 if OR2PHDG'="I"
QUIT
+44 IF $PIECE($PIECE(OROIL(OROILI),U,3),";")="B"
IF $$PRE^PSSDSAPK(OR2PSOI,OR2PHDG)=0
QUIT
+45 IF $PIECE($PIECE(OROIL(OROILI),U,3),";")="B"
IF $PIECE($PIECE(OROIL(OROILI),U,3),";",2)=""
IF $GET(ORREN)=1
Begin DoDot:3
+46 NEW ORVOLID,ORVOLVAL
SET ORVOLVAL=""
SET ORVOLID=$ORDER(^OR(100,+$GET(ORIFN),4.5,"ID","VOLUME",""))
+47 IF ORVOLID>0
SET ORVOLVAL=$GET(^OR(100,+$GET(ORIFN),4.5,ORVOLID,1))
+48 SET OROIL(OROILI)=OROIL(OROILI)_ORVOLVAL
End DoDot:3
+49 NEW ORUSID
+50 SET ORUSID=$$USID^ORWDXC(OROIL(OROILI))
+51 SET ORKAI=ORKAI+1
SET ORKA(ORKAI)=$PIECE(ORUSID,U,4)_U_$$GETPSNM($PIECE(ORUSID,U,4))
End DoDot:2
End DoDot:1
+52 if $DATA(ORKA)
DO CPRS^PSODDPR4(ORDFN,"OROCOUT"_ORPTY,.ORKA,ORPTY_+$GET(^OR(100,+$GET(ORIFN),4)))
+53 IF +ORSUPPLY
Begin DoDot:1
+54 SET ORKSOIA(+ORSUPPLY)=$GET(ORIFN)
+55 DO CPRS^PSODDPR8(ORDFN,"OROCOUT"_ORPTY,.ORKSOIA,ORPHDG_";"_+$GET(^OR(100,+$GET(ORNUM),4)),$SELECT($DATA(ORKA):1,1:""))
End DoDot:1
+56 IF $DATA(ORKA)!($DATA(ORKSOIA))!(ORIVRAN)
Begin DoDot:1
+57 if OR2CRITF_OR2SIGF_OR2DUPCF["E"
SET ^TMP($JOB,"ORENHCHK")=1
+58 DO PROCESS^ORKPS1(OI,ORDFN,ORKDG,+ORSUPPLY_U_+MED,"OROCOUT"_ORPTY)
End DoDot:1
+59 QUIT
CHKSESS(YY,DFN,MED,OI,ORKPDATA,ORKDG,ORSUPPLY,ORIVTYPE) ; return drug order checks for session
+1 ;ORSUPPLY: pharmacy orderable item ien [file #50.7] if it resolves to one or more supply items
+2 ; 0 if the pharmacy orderable item does not resolve to any supply items
+3 ;ORIVTYPE: the MED type as sent from Infusion Order Dialog
+4 ; A for additive
+5 ; B for base
+6 NEW ORKDGI,ORKDRUG,ORKDRUGA,ORKORN,HOR,SEQ,CNT,CNTX,ORKOI,ORPHOI
+7 NEW ORKFLG,ORSESS,ORPSPKG,ORPSA,ORSNUM,ORNUM,DUPX,DUPORN,ORPTY
+8 NEW ORKSOIA,ORRET,ORDFN,ORPHDG
SET ORDFN=DFN
+9 SET ORPTY=$SELECT($GET(ORKDG)="PSI":"I;",$GET(ORKDG)="PSIV":"I;",$GET(ORKDG)="PSO":"O;",$GET(ORKDG)="PSH":"O;",1:"O;")
+10 SET ORPHDG=$SELECT(ORKDG="PSI":"U",ORKDG="PSIV":"I",ORKDG="PSO":"O",ORKDG="PSH":"N",1:"")
+11 IF '$DATA(^TMP($JOB,"OROCOUT"_ORPTY))
Begin DoDot:1
+12 SET ORKFLG=0
+13 SET ORNUM=$PIECE(ORKA,"|",5)
+14 SET ORPHOI=+$PIECE($GET(^ORD(101.43,+OI,0)),U,2)
+15 ; Don't do checks if pharmacy does not want us to
IF $GET(ORIVTYPE)'="A"
IF '$$PRE^PSSDSAPK(ORPHOI,ORPHDG)
QUIT
+16 ;get unsigned medication orders:
+17 SET HOR=0
SET SEQ=0
+18 SET HOR=$ORDER(^TMP("ORR",$JOB,HOR))
+19 IF +$GET(HOR)>0
Begin DoDot:2
+20 FOR
SET SEQ=$ORDER(^TMP("ORR",$JOB,HOR,SEQ))
if +SEQ<1
QUIT
Begin DoDot:3
+21 SET ORKORN=+$PIECE(^TMP("ORR",$JOB,HOR,SEQ),U)
SET DUPORN=0
+22 if +$GET(ORKORN)<1
QUIT
+23 if +ORKORN=+ORNUM
QUIT
+24 if $PIECE(^OR(100,+ORKORN,8,$PIECE(^OR(100,+ORKORN,8,0),U,3),0),U,2)="DC"
QUIT
+25 if $PIECE(^ORD(100.01,$PIECE(^OR(100,+ORKORN,3),U,3),0),U)="DISCONTINUED"
QUIT
+26 ;get disp drug for order
SET ORKDRUG=$$VALUE^ORCSAVE2(+ORKORN,"DRUG")
+27 SET ORPSPKG=$$DGRX^ORQOR2(+ORKORN)
+28 ; OR*3*430
if ORPSPKG="CLINIC INFUSIONS"
SET ORPSPKG="IV MEDICATIONS"
+29 SET ORPSPKG=$SELECT(ORPSPKG="UNIT DOSE MEDICATIONS":"PSI",ORPSPKG="OUTPATIENT MEDICATIONS":"PSO",ORPSPKG="IV MEDICATIONS":"PSIV",ORPSPKG="NON-VA MEDICATIONS":"PSH",1:"")
+30 SET DUPX=""
FOR
SET DUPX=$ORDER(ORKDRUGA(DUPX))
if 'DUPX!(DUPORN=1)
QUIT
Begin DoDot:4
+31 if ORKORN=ORKDRUGA(DUPX)
SET DUPORN=1
End DoDot:4
+32 ;quit if already processed drug order
if DUPORN=1
QUIT
+33 IF +$GET(ORKDRUG)<1
IF $LENGTH(ORPSPKG)>0
Begin DoDot:4
+34 NEW OROI
SET OROI=$$OI^ORX8(+ORKORN)
+35 SET ORRET=$$OI2DD(+OROI,$SELECT($GET(ORKDG)="PSI":"I",$GET(ORKDG)="PSIV":"I",$GET(ORKDG)="PSO":"O",$GET(ORKDG)="PSH":"O",1:"O"),1)
+36 IF +$PIECE(ORRET,";",4)
SET ORKSOIA(+$PIECE(ORRET,";",4))=ORKORN
+37 IF +ORRET
SET ORKDRUG=+ORRET
End DoDot:4
+38 ;only process vs. unsigned med order if disp drug is assoc w/order:
+39 if +$GET(ORKDRUG)<1
QUIT
+40 IF ORPSPKG="PSIV"
Begin DoDot:4
+41 ;loop through each OI in the IV order
+42 NEW OR2I
+43 SET OR2I=0
FOR
SET OR2I=$ORDER(^OR(100,+ORKORN,4.5,"ID","ORDERABLE",OR2I))
if 'OR2I
QUIT
Begin DoDot:5
+44 NEW OR2OI,OR2DRUG
+45 SET OR2OI=$GET(^OR(100,+ORKORN,4.5,OR2I,1))
+46 if 'OR2OI
QUIT
+47 ;get the drug for each OI
+48 SET OR2DRUG=$$OI2DD(+OR2OI,"I",1)
+49 ;check if drug should be add it and add it if so
+50 IF $$IVADD(OR2DRUG,OR2OI)
SET ORKDRUGA(+OR2DRUG_";"_ORPSPKG_";"_ORKORN)=ORKORN_U_$$GETPSNM(+OR2DRUG)
End DoDot:5
End DoDot:4
+51 IF ORPSPKG'="PSIV"
SET ORKDRUGA(+ORKDRUG_";"_ORPSPKG_";"_ORKORN)=ORKORN_U_$$GETPSNM(+ORKDRUG)
+52 ; OR*3*469 - Load all components (solution and additive) of IV for order checking
+53 IF ORPSPKG="PSIV"
Begin DoDot:4
+54 NEW ORX,ORRET
SET ORX=0
FOR
SET ORX=+$ORDER(^OR(100,ORKORN,4.5,"ID","ORDERABLE",ORX))
if 'ORX
QUIT
Begin DoDot:5
+55 SET ORRET=$$OI2DD(+$GET(^OR(100,ORKORN,4.5,ORX,1)),"I",1)
if 'ORRET
QUIT
+56 IF +$PIECE(ORRET,";",4)
SET ORKSOIA(+$PIECE(ORRET,";",4))=ORKORN
+57 IF '$DATA(ORKDRUGA(+ORRET_";PSIV;"_ORKORN))
SET ORKDRUGA(+ORRET_";PSIV;"_ORKORN)=ORKORN_U_$$GETPSNM(+ORRET)
End DoDot:5
+58 ; end of OR*3*469 change
QUIT
End DoDot:4
End DoDot:3
End DoDot:2
+59 NEW ORPROSP,CNT
+60 SET CNT=1
+61 if +MED
SET ORPROSP(CNT)=MED_U_$$GETPSNM(+MED)_U_+$GET(ORNUM)
SET CNT=CNT+1
+62 NEW I
SET I=""
FOR
SET I=$ORDER(ORKDRUGA(I))
if 'I
QUIT
SET ORPROSP(CNT)=+I_U_$PIECE(ORKDRUGA(I),U,2)_U_U_$PIECE(ORKDRUGA(I),U,1)
SET CNT=CNT+1
+63 DO SHRNKPR
+64 DO CPRS^PSODDPR4(DFN,"OROCOUT"_ORPTY,.ORPROSP,ORPTY_+$GET(^OR(100,+$GET(ORNUM),4)))
+65 IF +ORSUPPLY
Begin DoDot:2
+66 SET ORKSOIA(+ORSUPPLY)=$GET(ORNUM)
+67 if $DATA(ORKSOIA)>9
DO CPRS^PSODDPR8(DFN,"OROCOUT"_ORPTY,.ORKSOIA,ORPHDG_";"_+$GET(^OR(100,+$GET(ORNUM),4)),1)
End DoDot:2
End DoDot:1
+68 DO PROCESS^ORKPS1(OI,ORDFN,ORKDG,+ORSUPPLY_U_+MED,"OROCOUT"_ORPTY)
+69 QUIT
IVADD(ORDRUG,OROI) ;RETURN YES OR NO IF SHOULD ADD THE IV ITEM
+1 NEW ORRET
+2 ;default is yes to add it, will always be 1 for an additive
+3 SET ORRET=1
+4 ;check if drug is a base
+5 KILL ^TMP($JOB,"ORBASECHECK")
+6 DO DRGIEN^PSS52P7(ORDRUG,,"ORBASECHECK")
+7 ;GOT A BASE HERE
IF $PIECE($GET(^TMP($JOB,"ORBASECHECK",0),0),U)>0
Begin DoDot:1
+8 ;if drug is a base, check if pharmacy says we can add it or not
+9 NEW ORPHOI
+10 SET ORPHOI=+$PIECE($GET(^ORD(101.43,+OROI,0)),U,2)
+11 SET ORRET=$$PRE^PSSDSAPK(ORPHOI,"I")
End DoDot:1
+12 KILL ^TMP($JOB,"ORBASECHECK")
+13 QUIT ORRET
SHRNKPR ;REMOVE DUPLICATS FROM PROSPECTIVE LIST
+1 if '$DATA(ORPROSP)
QUIT
+2 NEW ORX,ORI
SET ORI=0
FOR
SET ORI=$ORDER(ORPROSP(ORI))
if 'ORI
QUIT
SET ORX=ORPROSP(ORI)
Begin DoDot:1
+3 NEW ORJ
SET ORJ=ORI
FOR
SET ORJ=$ORDER(ORPROSP(ORJ))
if 'ORJ
QUIT
IF ORX=ORPROSP(ORJ)
KILL ORPROSP(ORJ)
End DoDot:1
+4 QUIT
GETPSNM(ORIEN) ;GET THE FILE 50 .01 FIELD FROM A FILE 50 IEN
+1 NEW RET
KILL ^TMP($JOB,"ORRETNM")
+2 DO NDF^PSS50(ORIEN,,,,,"ORRETNM")
SET RET=$GET(^TMP($JOB,"ORRETNM",ORIEN,.01))
+3 KILL ^TMP($JOB,"ORRETNM")
+4 QUIT RET
TAKEMED(ORKDFN,ORKMED) ;extrinsic function returns med orderable item if any
+1 ;active med patient is taking contains any piece of ORKMED
+2 ;ORKDFN patient DFN
+3 ;ORKMED meds to check vs. active med list in format MED1^MED2^MED3...
+4 if '$LENGTH($GET(ORKDFN))
QUIT "0^Patient not identified."
+5 if '$LENGTH($GET(ORKMED))
QUIT "0^Medication not identified."
+6 NEW ORKARX,ORKY,ORI,ORJ,ORCNT,ORKMEDP,ORKRSLT
+7 DO LIST^ORQQPS(.ORKY,ORKDFN,"","")
+8 if $PIECE(ORKY(1),U)=""
QUIT "0^No active meds found."
+9 SET ORKRSLT="0^No matching meds found."
+10 SET ORCNT=$LENGTH(ORKMED,U)
+11 SET ORI=0
FOR
SET ORI=$ORDER(ORKY(ORI))
if ORI<1
QUIT
Begin DoDot:1
+12 SET ORKARX=$PIECE(ORKY(ORI),U,2)
+13 FOR ORJ=1:1:ORCNT
SET ORKMEDP=$PIECE(ORKMED,U,ORJ)
Begin DoDot:2
+14 ;DJE/VM *316 use uppercase in comparison
IF $LENGTH(ORKMEDP)
IF ($$UP^XLFSTR(ORKARX)[ORKMEDP)
SET ORKRSLT="1^"_ORKARX
End DoDot:2
End DoDot:1
+15 QUIT ORKRSLT
POLYRX(DFN) ;extrins funct rtns 1 if patient exceeds polypharmacy, 0 if not
+1 NEW ORSLT,ORENT,ORLOC,ORPAR,ORMEDS
+2 SET ORSLT=0
+3 if '$LENGTH(DFN)
QUIT ORSLT
+4 SET VA200=""
DO OERR^VADPT
+5 SET ORLOC=+$GET(^DIC(42,+VAIN(4),44))
+6 KILL VA200,VAIN
+7 SET ORENT=+$GET(ORLOC)_";SC(^DIV^SYS^PKG"
+8 SET ORPAR=$$GET^XPAR(ORENT,"ORK POLYPHARMACY",1,"I")
+9 SET ORMEDS=$$NUMRX(DFN)
+10 IF $GET(ORMEDS)>$GET(ORPAR)
SET ORSLT=1
+11 QUIT ORSLT
GLCREAT(DFN) ;extrinsic function returns patient's (DFN) most recent serum
+1 ; creatinine within # of days from parameter ORK GLUCOPHAGE CREATININE
+2 ; results format: test id^result units flag ref range collect d/t^result
+3 ; used by order check GLUCOPHAGE-LAB RESULTS
+4 NEW ORLOC,ORPAR,ORDAYS
+5 NEW BDT,CDT,ORY,ORX,ORZ,TEST,ORI,ORJ,CREARSLT,LABFILE,SPECFILE,SPECIMEN,VAIN,VADM,RSLTS
+6 if '$LENGTH(DFN)
QUIT "0^"
+7 SET ORDAYS=$$GCDAYS(DFN)
+8 if '$LENGTH(ORDAYS)
QUIT "0^"
+9 DO NOW^%DTC
+10 SET BDT=$$FMADD^XLFDT(%,"-"_ORDAYS,"","","")
+11 KILL %
+12 if '$LENGTH($GET(BDT))
QUIT "0^"
+13 SET LABFILE=$$TERMLKUP^ORB31(.ORY,"SERUM CREATININE")
+14 ;no link between SERUM CREATININE and local lab test
if '$DATA(ORY)
QUIT "0^"
+15 if $GET(LABFILE)'=60
QUIT "0^"
+16 SET SPECFILE=$$TERMLKUP^ORB31(.ORX,"SERUM SPECIMEN")
+17 ;no link between SERUM SPECIMEN and local specimen
if '$DATA(ORX)
QUIT "0^"
+18 if $GET(SPECFILE)'=61
QUIT "0^"
+19 FOR ORI=1:1:ORY
Begin DoDot:1
+20 SET TEST=$PIECE(ORY(ORI),U)
+21 if +$GET(TEST)<1
QUIT
+22 FOR ORJ=1:1:ORX
Begin DoDot:2
+23 SET SPECIMEN=$PIECE(ORX(ORJ),U)
+24 if +$GET(SPECIMEN)<1
QUIT
+25 SET ORZ=$$LOCL^ORQQLR1(DFN,TEST,SPECIMEN)
+26 if '$LENGTH($GET(ORZ))
QUIT
+27 SET CDT=$PIECE(ORZ,U,7)
+28 ;*SMT Use RSLTS as array.
IF CDT'<BDT
SET RSLTS(CDT)=ORZ
SET CREARSLT=1
End DoDot:2
End DoDot:1
+29 if +$GET(CREARSLT)<1
QUIT "0^"
+30 ;*SMT
SET CDT=$ORDER(RSLTS(0))
SET ORZ=RSLTS(CDT)
+31 QUIT $PIECE(ORZ,U)_U_$PIECE(ORZ,U,3)_" "_$PIECE(ORZ,U,4)_" "_$PIECE(ORZ,U,5)_" ("_$PIECE(ORZ,U,6)_") "_$$FMTE^XLFDT(CDT,"2P")_U_$PIECE(ORZ,U,3)
GCDAYS(DFN) ;extrinsic function to return number of days to look for
+1 ; glucophage serum creatinine result
+2 if '$LENGTH(DFN)
QUIT ""
+3 NEW ORLOC,ORENT,ORDAYS
+4 ;get patient's location flag (INPATIENT ONLY - outpt locations cannot be
+5 ;reliably determined, and many simultaneous outpt locations can occur):
+6 SET VA200=""
DO OERR^VADPT
+7 SET ORLOC=+$GET(^DIC(42,+VAIN(4),44))
+8 KILL VA200,VAIN
+9 SET ORENT=+$GET(ORLOC)_";SC(^DIV^SYS^PKG"
+10 SET ORDAYS=$$GET^XPAR(ORENT,"ORK GLUCOPHAGE CREATININE",1,"I")
+11 if $LENGTH(ORDAYS)
QUIT ORDAYS
+12 QUIT ""
SUPPLY(OI) ;extrinsic function returns 1 (true) if the orderable item is
+1 ; a supply
+2 if +$GET(OI)<1
QUIT ""
+3 NEW OITEXT
+4 SET OITEXT=$GET(^ORD(101.43,OI,0))
+5 if '$LENGTH(OITEXT)
QUIT ""
+6 SET OITEXT=$PIECE(OITEXT,U)
+7 if $DATA(^ORD(101.43,"S.SPLY",OITEXT))
QUIT 1
+8 QUIT ""
NUMRX(DFN) ;extrinsic funct returns number of active meds patient is taking
+1 NEW NUMRX,ORPTYPE,ORX,ORY,ORS,ORNUM,ORPRENEW,VADMVT
+2 SET NUMRX=0
+3 if +$GET(DFN)<1
QUIT NUMRX
+4 ;check to determine if inpatient or outpatient:
+5 DO ADM^VADPT2
+6 SET ORPTYPE=$SELECT(+$GET(VADMVT)>0:"I",1:"O")
+7 KILL ^TMP("PS",$JOB)
+8 ;if no date range, returns active meds for pt
DO OCL^PSOORRL(DFN,"","")
+9 NEW X
+10 SET X=0
+11 FOR
SET X=$ORDER(^TMP("PS",$JOB,X))
if X<1
QUIT
Begin DoDot:1
+12 SET ORX=$GET(^TMP("PS",$JOB,X,0))
+13 SET ORY=$PIECE(ORX,U)
+14 ;order entry order number
SET ORNUM=$PIECE(ORX,U,8)
+15 ;medication status from pharmacy
SET ORS=$PIECE(ORX,U,9)
+16 ;pending renewal flag (1: pending renewal)
SET ORPRENEW=$PIECE(ORX,U,14)
+17 if +ORX<1
QUIT
+18 ;quit if med is not pt type (inpt/outpt)
if $PIECE(ORY,";",2)'=ORPTYPE
QUIT
+19 ;quit if status is a non-active type:
+20 if $GET(ORS)="EXPIRED"
QUIT
+21 if $GET(ORS)["DISCONTINUE"
QUIT
+22 if $GET(ORS)="DELETED"
QUIT
+23 if +$GET(ORPRENEW)>0
QUIT
+24 ;quit if a supply
if $$SUPPLY($$OI^ORQOR2(ORNUM))=1
QUIT
+25 SET NUMRX=NUMRX+1
End DoDot:1
+26 KILL ^TMP("PS",$JOB)
+27 QUIT NUMRX
OI2DD(OROI,ORPSPKG,ORCHKTYP) ;rtn dispense drugs for a PS OI
+1 ;ORCHKTYP: TYPE OF ORDER CHECK SYSTEM IS PERFORMING
+2 ; 1 FOR ENHANCED ORDER CHECKS
+3 ; 2 FOR DOSAGE ORDER CHECK
+4 NEW PSOI,ORRET
+5 if '$DATA(^ORD(101.43,OROI,0))
QUIT ""
+6 SET PSOI=+$PIECE(^ORD(101.43,OROI,0),U,2)
+7 if PSOI<1
QUIT ""
+8 ;if non-va med need to pass api "X"
if ORPSPKG="H"
SET ORPSPKG="X"
+9 SET ORRET=$$DRG^PSSDSAPM(PSOI,ORPSPKG,ORCHKTYP)
+10 IF ORCHKTYP=1
IF (+$PIECE(ORRET,";",4))
SET $PIECE(ORRET,";",4)=PSOI
+11 QUIT ORRET
