PSSDSAPK ;BIR/RTR - Miscellaneous APIs for Dose Call ; Sep 02, 2009@16:00
;;1.0;PHARMACY DATA MANAGEMENT;**117,168,160,178,254**;9/30/97;Build 109
;
;
;Disregard Package Use and Inactive Date in File 50, so you can still get General Dosing Guidelines
;Return Dispense Drug for Orderable Item
;PSSGTOI = Orderable Item
;PSSGTPK = Package O for Outpatient, N for Non-VA Med, I for Inpatient
;PSSGTRTE = Med Route Internal Entry Number
;PSSGTAB = String containing A for Additive, B for Solution
;PSSGTRES = result - 0 for No Drug found, or File 50 Internal Entry Number
DRG(PSSGTOI,PSSGTPK,PSSGTRTE,PSSGTAB) ;
I '$G(PSSGTOI) Q 0
I $G(PSSGTPK)'="O",$G(PSSGTPK)'="X",$G(PSSGTPK)'="I" Q 0
N PSSGTRES,PSSGTPM,PSSGT1,PSSGT2,PSSGT3,PSSGT4,PSSGT5,PSSGTHL1,PSSGTHL2
S PSSGTPM=$S(PSSGTPK="I":"U",1:PSSGTPK)
S (PSSGTRES,PSSGTHL1,PSSGTHL2)=0
I PSSGTPK="I",$G(PSSGTRTE),$P($G(^PS(51.2,PSSGTRTE,0)),"^",6)=1 I $G(PSSGTAB)["A"!($G(PSSGTAB)["B") G DRGINP
F PSSGT1=0:0 S PSSGT1=$O(^PSDRUG("ASP",PSSGTOI,PSSGT1)) Q:'PSSGT1!(PSSGTHL2) D
.S PSSGT3=$P($G(^PSDRUG(PSSGT1,"ND")),"^"),PSSGT4=$P($G(^PSDRUG(PSSGT1,"ND")),"^",3)
.I 'PSSGT3!('PSSGT4) Q
.S PSSGT5=$P($$PROD0^PSNAPIS(PSSGT3,PSSGT4),"^",7) I +$G(PSSGT5)'>0 Q
.I $$EXMT^PSSDSAPI(PSSGT1) Q
.S:'PSSGTHL1 PSSGTHL1=PSSGT1
.I $P($G(^PSDRUG(PSSGT1,2)),"^",3)'[PSSGTPM Q
.S PSSGT2=$P($G(^PSDRUG(PSSGT1,"I")),"^") I PSSGT2,PSSGT2<DT Q
.S PSSGTHL2=PSSGT1
S PSSGTRES=$S(PSSGTHL2:PSSGTHL2,PSSGTHL1:PSSGTHL1,1:0)
Q PSSGTRES
;
;
DRGINP ;Inpatient Order with IV Route
S PSSDSIVF=1 ;Added in 2.0 to set Input exception if no drug found
N PSSGT6,PSSGT7,PSSGT8,PSSGTN1,PSSGTN3,PSSGTN4
I PSSGTAB["A" D
.F PSSGT6=0:0 S PSSGT6=$O(^PS(52.6,"AOI",PSSGTOI,PSSGT6)) Q:'PSSGT6!(PSSGTRES) D
..S PSSGT7=$P($G(^PS(52.6,PSSGT6,"I")),"^") I PSSGT7,PSSGT7'>DT Q
..S PSSGT8=$P($G(^PS(52.6,PSSGT6,0)),"^",2) I 'PSSGT8 Q
..;Dispense Drug can be inactive, and no need to check package use
..S PSSGTN1=$P($G(^PSDRUG(PSSGT8,"ND")),"^"),PSSGTN3=$P($G(^PSDRUG(PSSGT8,"ND")),"^",3)
..I 'PSSGTN1!('PSSGTN3) Q
..S PSSGTN4=$P($$PROD0^PSNAPIS(PSSGTN1,PSSGTN3),"^",7) I +$G(PSSGTN4)'>0 Q
..I $$EXMT^PSSDSAPI(PSSGT8) Q
..S PSSGTRES=PSSGT8
I PSSGTRES Q PSSGTRES
I PSSGTAB["B" D
.F PSSGT6=0:0 S PSSGT6=$O(^PS(52.7,"AOI",PSSGTOI,PSSGT6)) Q:'PSSGT6!(PSSGTRES) D
..I $P($G(^PS(52.7,PSSGT6,0)),"^",14)'=1 Q
..S PSSGT7=$P($G(^PS(52.7,PSSGT6,"I")),"^") I PSSGT7,PSSGT7'>DT Q
..S PSSGT8=$P($G(^PS(52.7,PSSGT6,0)),"^",2) I 'PSSGT8 Q
..;Dispense Drug can be inactive, and no need to check package use
..S PSSGTN1=$P($G(^PSDRUG(PSSGT8,"ND")),"^"),PSSGTN3=$P($G(^PSDRUG(PSSGT8,"ND")),"^",3)
..I 'PSSGTN1!('PSSGTN3) Q
..S PSSGTN4=$P($$PROD0^PSNAPIS(PSSGTN1,PSSGTN3),"^",7) I +$G(PSSGTN4)'>0 Q
..I $$EXMT^PSSDSAPI(PSSGT8) Q
..S PSSGTRES=PSSGT8
Q PSSGTRES
;
;
PRE(PSSLGTOI,PSSDIAG) ;Determine if CPRS needs to do order checks
;PSSLGTOI = File 50.7 Internal Entry Number
;PSSDIAG = CPRS order dialog (U:Inpatient; I:IV Fluids; O:Outpatient; N:Non-VA Meds)
; If PSSDIAG is "I" then DO NOT use this call for additve entries.
;If 1 is returned then CPRS needs to do enhanced order checks. This means it is either a UD,
; Outpatient, Non-VA, additive, or a premix solution.
;If 0 is returned then enhanced order check is not needed to perform.
;
I '+$G(PSSLGTOI) Q 0
I $G(PSSDIAG)="" Q 1
I PSSDIAG="O" Q 1
I PSSDIAG="N" Q 1
I PSSDIAG="I" Q +$$SOL^PSSDSAPA(PSSLGTOI)
I PSSDIAG="U" Q $$IPM^PSSDSAPA(PSSLGTOI)
Q 1
;
;
CONV(PSSCVTVL) ;Convert hours into format for Dose API for Inpatient Medications
N PSSCVTRS,PSSCVT1,PSSCVT2,PSSCVT3
S PSSCVTRS=""
I '$G(PSSCVTVL) Q PSSCVTRS
S PSSCVT1=+PSSCVTVL
I PSSCVT1<1 S PSSCVT2=PSSCVT1*60 S PSSCVT3=1440/PSSCVT2 S PSSCVTRS=$J(PSSCVT3,0,0) S:PSSCVTRS=24 PSSCVTRS="Q1H" Q PSSCVTRS
S PSSCVT2=$J(PSSCVT1,0,0) S PSSCVTRS="Q"_PSSCVT2_"H"
Q PSSCVTRS
;
;
ITEM ;Only Orderable Item passed in, no Dispense Drug
N PSSDBI1,PSSDBI2,PSSDBI3,PSSDBI4,PSSDBI5,PSSDBI6,PSSDBI7,PSSDBI8,PSSDBI9,PSSDBI91,PSSDBI92,PSSDBI93,PSSDBI94
S PSSDBI1=$G(PSSDSLCL)
I $L(PSSDBI1)'>0 Q
S PSSDBI1=$$UP^XLFSTR(PSSDBI1)
;Strip out commas up until first character not a number or decimal
S PSSDBI6=0 F PSSDBI7=1:1:$L(PSSDBI1) Q:PSSDBI6 S PSSDBI8=$E(PSSDBI1,PSSDBI7) I PSSDBI8'?1N,PSSDBI8'?1".",PSSDBI8'?1"," S PSSDBI6=PSSDBI7
I PSSDBI6=1 Q
S PSSDBI9=$S('PSSDBI6:$L(PSSDBI1),1:(PSSDBI6-1))
S PSSDBI91=$E(PSSDBI1,1,PSSDBI9),PSSDBI92=$E(PSSDBI1,(PSSDBI9+1),$L(PSSDBI1))
S PSSDBI93=$TR(PSSDBI91,",","")
S PSSDBI1=PSSDBI93_PSSDBI92
I $E(PSSDBI1)=0 S PSSDBI1=$E(PSSDBI1,2,$L(PSSDBI1))
I $L(PSSDBI1)'>0 Q
S PSSDBI2=+PSSDBI1
I 'PSSDBI2!($L(PSSDBI2)=$L(PSSDBI1)) Q
S PSSDBI3=$E(PSSDBI1,($L(PSSDBI2)+1),$L(PSSDBI1))
S PSSDBI4=$S($E(PSSDBI3)=" ":$E(PSSDBI3,2,$L(PSSDBI3)),1:PSSDBI3)
I PSSDBI4="" Q
I PSSDBIFL S PSSDBI5=$$UNITD^PSSDSAPI(PSSDBI4)
I 'PSSDBIFL S PSSDBI5=$$UNIT^PSSDSAPI(PSSDBI4)
I PSSDBI5="" Q
S PSSDBAR("AMN")=PSSDBI2,PSSDBAR("UNIT")=PSSDBI5,PSSDBFAL=1
Q
;
;
FRCON(PSSCFQ1) ;Convert frequency into a number for complex dose additions
N PSSCFQRS,PSSCFQ2,PSSCFQ3,PSSCFQ4
S PSSCFQRS=0
I PSSCFQ1?1N.N!(PSSCFQ1?1N.N1"."1N.N) S PSSCFQRS=PSSCFQ1 Q PSSCFQRS
I PSSCFQ1?1"Q"1N.N1"H" D Q PSSCFQRS
.S PSSCFQ2=$E(PSSCFQ1,2,($L(PSSCFQ1)-1))
.S PSSCFQ3=60*PSSCFQ2
.S PSSCFQRS=1440/PSSCFQ3
I PSSCFQ1?1"Q"1N.N1"D" D Q PSSCFQRS
.S PSSCFQ2=$E(PSSCFQ1,2,($L(PSSCFQ1)-1))
.S PSSCFQRS=1/PSSCFQ2 I PSSCFQRS["." S PSSCFQRS=$J(PSSCFQRS,0,4)
I PSSCFQ1?1"Q"1N.N1"W" D Q PSSCFQRS
.S PSSCFQ2=$E(PSSCFQ1,2,($L(PSSCFQ1)-1))
.S PSSCFQ3=7*PSSCFQ2
.S PSSCFQ4=PSSCFQ3*1440
.S PSSCFQRS=1440/PSSCFQ4 I PSSCFQRS["." S PSSCFQRS=$J(PSSCFQRS,0,4)
I PSSCFQ1?1"Q"1N.N1"L" D Q PSSCFQRS
.S PSSCFQ2=$E(PSSCFQ1,2,($L(PSSCFQ1)-1))
.S PSSCFQ3=30*PSSCFQ2
.S PSSCFQ4=PSSCFQ3*1440
.S PSSCFQRS=1440/PSSCFQ4 I PSSCFQRS["." S PSSCFQRS=$J(PSSCFQRS,0,4)
I PSSCFQ1?1N.N1"XD" D Q PSSCFQRS
.S (PSSCFQ2,PSSCFQRS)=+PSSCFQ1
.I PSSCFQRS["." S PSSCFQRS=$J(PSSCFQRS,0,4)
I PSSCFQ1?1N.N1"XW" D Q PSSCFQRS
.S PSSCFQ2=+PSSCFQ1,PSSCFQRS=PSSCFQ2/7
.I PSSCFQRS["." S PSSCFQRS=$J(PSSCFQRS,0,4)
I PSSCFQ1?1N.N1"XL" D Q PSSCFQRS
.S PSSCFQ2=+PSSCFQ1,PSSCFQRS=PSSCFQ2/30
.I PSSCFQRS["." S PSSCFQRS=$J(PSSCFQRS,0,4)
I PSSCFQ1="QOD" S PSSCFQRS=.5 Q PSSCFQRS
Q 0
;
;
SING ;
S $P(PSSDBCAR(PSSDBEB1),"^")="S"
S $P(^TMP($J,PSSDBASE,"IN","DOSE",PSSDBEB1),"^",8)=1
S $P(^TMP($J,PSSDBASE,"IN","DOSE",PSSDBEB1),"^",9)=1
S $P(^TMP($J,PSSDBASE,"IN","DOSE",PSSDBEB1),"^",10)=$P(^TMP($J,PSSDBASE,"IN","DOSE",PSSDBEB1),"^",7)
S $P(PSSDBCAR(PSSDBEB1),"^",7)=1
Q
;
;
DOWN ;
S:PSSDBASA ^TMP($J,PSSDBASF,"OUT",0)=^TMP($J,PSSDBASE,"OUT",0) S:PSSDBASB ^TMP($J,PSSDBASG,"OUT",0)=^TMP($J,PSSDBASE,"OUT",0)
Q
;
;
BDOSE ;Missing Numeric Dose or Dose Unit
I 'PSSDBEB3!($P(PSSDBEB2,"^",11)="") D EXCPS^PSSDSAPD(1) D:$D(PSSDBCAZ(PSSDBEB1,"FRQ_ERROR")) EXCPS^PSSDSAPD(2) S PSSDBDGO=1 Q
S $P(PSSDBCAR(PSSDBEB1),"^",20)=1 I '$P(PSSDBCAR(PSSDBEB1),"^",5) D EXCPS^PSSDSAPD(1) D:$D(PSSDBCAZ(PSSDBEB1,"FRQ_ERROR")) EXCPS^PSSDSAPD(2) S PSSDBFTX(PSSDBEB1,"FTX_ERROR")="" Q
S PSSDBDGO=1
D EXCPS^PSSDSAPD(1)
I $D(PSSDBCAZ(PSSDBEB1,"FRQ_ERROR")) D EXCPS^PSSDSAPD(2)
S $P(^TMP($J,PSSDBASE,"IN","DOSE",PSSDBEB1),"^",5)=1
S $P(^TMP($J,PSSDBASE,"IN","DOSE",PSSDBEB1),"^",8)=1
S $P(^TMP($J,PSSDBASE,"IN","DOSE",PSSDBEB1),"^",9)=1
S $P(^TMP($J,PSSDBASE,"IN","DOSE",PSSDBEB1),"^",7)="DAY"
S $P(^TMP($J,PSSDBASE,"IN","DOSE",PSSDBEB1),"^",10)="DAY"
S $P(^TMP($J,PSSDBASE,"IN","DOSE",PSSDBEB1),"^",6)=$$DUNIT^PSSDSAPA S PSSDBAR("UNIT")=$P(^TMP($J,PSSDBASE,"IN","DOSE",PSSDBEB1),"^",6) S $P(^TMP($J,PSSDBASE,"IN","DOSE",PSSDBEB1),"^",14)=$$DFM^PSSDSEXC
S $P(PSSDBCAR(PSSDBEB1),"^",6)=1 S $P(PSSDBCAR(PSSDBEB1),"^",10)=1
; -- in 2.1 set Dummy Data flag
S $P(PSSDBCAR(PSSDBEB1),"^",33)=1
Q
;
;
FTX ;Pull Dosing sequences out of Input for complex orders where Free Text Dosage could not be evaluated
N PSSDTX1
S PSSDTX1="" F S PSSDTX1=$O(PSSDBFTX(PSSDTX1)) Q:PSSDTX1="" D
.S PSSDBFTX(PSSDTX1,"NODE1")=$G(^TMP($J,PSSDBASE,"IN","DOSE",PSSDTX1))
.S PSSDBFTX(PSSDTX1,"NODE2")=$G(^TMP($J,PSSDBASE,"IN","PROSPECTIVE",PSSDTX1))
.K ^TMP($J,PSSDBASE,"IN","DOSE",PSSDTX1)
.K ^TMP($J,PSSDBASE,"IN","PROSPECTIVE",PSSDTX1)
Q
;
;
FTXRS ;Reset input globals that were pulled because of invalid dosage
N PSSDTX2
S PSSDTX2="" F S PSSDTX2=$O(PSSDBFTX(PSSDTX2)) Q:PSSDTX2="" D
.S ^TMP($J,PSSDBASE,"IN","DOSE",PSSDTX2)=PSSDBFTX(PSSDTX2,"NODE1")
.S ^TMP($J,PSSDBASE,"IN","PROSPECTIVE",PSSDTX2)=PSSDBFTX(PSSDTX2,"NODE2")
Q
;
;
ERR1() ;Screen out Daily Dose errors for Single Dose Sequences, unless New Daily Dose created based on previous Dosing sequences
;Called from PSSDSEXC
N PSSERS,PSSERSU
S PSSERS=$G(^TMP($J,PSSDBASE,"OUT","DOSE","ERROR",PSSDWLP,PSSDWL1,"MSG"))
S PSSERSU=$$UP^XLFSTR(PSSERS)
I PSSERSU["DAILY DOSE",$P($G(PSSDBCAR(PSSDWLP)),"^",15) Q 1 ; 2.1 change to not show Daily Dose is Schedule indicates so
I $P($G(PSSDBCAR(PSSDWLP)),"^")'="S"!($P($G(PSSDBCAR(PSSDWLP)),"^",11)) Q 0
I PSSERSU'["DAILY DOSE" Q 0
Q 1
;
;
ERR2() ;Screen out Frequency errors if Dosing Sequence is flagged for Single Dose only
;Called from PSSDSEXC
N PSSERH,PSSERHU,PSSERHRS
S PSSERHRS=0
I $P($G(PSSDBCAR(PSSDWE1)),"^",12)!($P($G(PSSDBCAR(PSSDWE1)),"^",5)=0) D
.S PSSERH=PSSDWEGC
.S PSSERHU=$$UP^XLFSTR(PSSERH)
.I PSSERHU["UNDEFINED FREQUENCY"!(PSSERHU["FREQUENCY GREATER") S PSSERHRS=1
Q PSSERHRS
;
;
INFERR ;Infusion Rate Height and Weight Errors
I $D(PSSDBFDB(PSSDBLP,"HT_ERROR")) S PSSDBCAZ(PSSDBFDB(PSSDBLP,"RX_NUM"),"HT_ERROR")=""
I $D(PSSDBFDB(PSSDBLP,"WT_ERROR")) S PSSDBCAZ(PSSDBFDB(PSSDBLP,"RX_NUM"),"WT_ERROR")=""
Q
;
;
INFERRS ;
I '$D(PSSDBCAZ(PSSDBEB1,"HT_ERROR")),'$D(PSSDBCAZ(PSSDBEB1,"WT_ERROR")) Q
I $D(PSSDBCAZ(PSSDBEB1,"WT_ERROR")),$D(PSSDBCAZ(PSSDBEB1,"HT_ERROR")) D EXCPS^PSSDSAPD(14) Q
I '$D(PSSDBCAZ(PSSDBEB1,"HT_ERROR")) D EXCPS^PSSDSAPD(13) Q
D EXCPS^PSSDSAPD(12)
Q
;
;
GENERRX ;Set General Dosing Guidelines exception
;This code, not being used, was moved from PSSDSEXC to have a record of old functionality, in case we need it again
Q
;
N PSSDWF1,PSSDWF2,PSSDWF3,PSSDWF4
S PSSDWF2=0 F PSSDWF1=0:0 S PSSDWF1=$O(^TMP($J,PSSDBASE,"OUT","EXCEPTIONS","DOSE",PSSDWE5,PSSDWF1)) Q:'PSSDWF1 S PSSDWF2=PSSDWF1
I 'PSSDWF2 D Q
.I PSSDBASA S ^TMP($J,PSSDBASF,"OUT","EXCEPTIONS","DOSE",PSSDWE5,1)="Dosing Checks could not be performed for Drug: "_$P(PSSDBCAR(PSSDWE5),"^",2)
.I PSSDBASB S ^TMP($J,PSSDBASG,"OUT",PSSDWE5,"EXCEPTIONS",1)="Dosing Checks could not be performed for Drug: "_$P(PSSDBCAR(PSSDWE5),"^",2)
.I PSSDBASA S ^TMP($J,PSSDBASF,"OUT","EXCEPTIONS","DOSE",PSSDWE5,2)=" General Dosing guidelines are not available"
.I PSSDBASB S ^TMP($J,PSSDBASG,"OUT",PSSDWE5,"EXCEPTIONS",2)=" General Dosing guidelines are not available"
.S ^TMP($J,PSSDBASE,"OUT","EXCEPTIONS","DOSE",PSSDWE5,1)="^^^^^^Dosing Checks could not be performed for Drug: "_$P(PSSDBCAR(PSSDWE5),"^",2)_"^^^"_"General Dosing guidelines are not available"
S PSSDWF2=PSSDWF2+1
S ^TMP($J,PSSDBASE,"OUT","EXCEPTIONS","DOSE",PSSDWE5,PSSDWF2)="^^^^^^Dosing Checks could not be performed for Drug: "_$P(PSSDBCAR(PSSDWE5),"^",2)_"^^^"_"General Dosing guidelines are not available"
I PSSDBASA D
.S PSSDWF3=0
.F PSSDWF4=0:0 S PSSDWF4=$O(^TMP($J,PSSDBASF,"OUT","EXCEPTIONS","DOSE",PSSDWE5,PSSDWF4)) Q:'PSSDWF4 S PSSDWF3=PSSDWF4
.S PSSDWF3=PSSDWF3+1
.S ^TMP($J,PSSDBASF,"OUT","EXCEPTIONS","DOSE",PSSDWE5,PSSDWF3)=" General Dosing guidelines are not available"
I PSSDBASB D
.S PSSDWF3=0
.F PSSDWF4=0:0 S PSSDWF4=$O(^TMP($J,PSSDBASG,"OUT",PSSDWE5,"EXCEPTIONS",PSSDWF4)) Q:'PSSDWF4 S PSSDWF3=PSSDWF4
.S PSSDWF3=PSSDWF3+1
.S ^TMP($J,PSSDBASG,"OUT",PSSDWE5,"EXCEPTIONS",PSSDWF3)=" General Dosing guidelines are not available"
Q
;
;
MTCH() ;Called from PSSDSAPD, looking for Local Possible Dosages Match
N PSSDSLTM
I $P(PSSDBNOD,"^")=PSSDSLCL Q 1
I $E(PSSDSLCL)=0 S PSSDSLTM=$E(PSSDSLCL,2,$L(PSSDSLCL)) I $L(PSSDSLTM)>0,PSSDSLTM=$P(PSSDBNOD,"^") Q 1
I $E(PSSDSLCL)'=0 S PSSDSLTM=0_PSSDSLCL I PSSDSLTM=$P(PSSDBNOD,"^") Q 1
Q 0
;
;
DPOP ;Use Pre release logic to find Dose unit and Numeric Dose
N PSSDDPOP,PSSDSLPO
S PSSDDPOP=$$EN^PSSDSBBP(PSSDBFDB(PSSDBLP,"DRUG_IEN"),PSSDSLCL)
I PSSDDPOP S PSSDBAR("AMN")=$P(PSSDDPOP,"^",2),PSSDBAR("UNIT")=$P($G(^PS(51.24,+$P(PSSDDPOP,"^"),0)),"^",2) S PSSDBFAL=1 Q
I $E(PSSDSLCL)=0 S PSSDSLPO=$E(PSSDSLCL,2,$L(PSSDSLCL)) I $L(PSSDSLPO)>0 D I PSSDDPOP S PSSDBAR("AMN")=$P(PSSDDPOP,"^",2),PSSDBAR("UNIT")=$P($G(^PS(51.24,+$P(PSSDDPOP,"^"),0)),"^",2) S PSSDBFAL=1 Q
.S PSSDDPOP=$$EN^PSSDSBBP(PSSDBFDB(PSSDBLP,"DRUG_IEN"),PSSDSLPO)
I $E(PSSDSLCL)'=0 S PSSDSLPO=0_PSSDSLCL D I PSSDDPOP S PSSDBAR("AMN")=$P(PSSDDPOP,"^",2),PSSDBAR("UNIT")=$P($G(^PS(51.24,+$P(PSSDDPOP,"^"),0)),"^",2) S PSSDBFAL=1 Q
.S PSSDDPOP=$$EN^PSSDSBBP(PSSDBFDB(PSSDBLP,"DRUG_IEN"),PSSDSLPO)
Q
;
;
FRDR ;Check if Duration exists, and is less than Duration of Schedule
I $G(PSSDBAR("TYPE"))="SINGLE DOSE" Q
N PSSDRSC1,PSSDRSC2,PSSDRSC3,PSSDRSC4,PSSDRSC5
S PSSDRSC1=PSSDBFRB(PSSDBFDB(PSSDBLP,"RX_NUM"),"DRATE") I PSSDRSC1="" Q
S PSSDRSC3=$$DRT^PSSDSAPD(PSSDRSC1) I PSSDRSC3'>0 Q
S PSSDRSC4=1440/PSSDRSC3
S PSSDRSC5=$S($P($G(PSSDBAR("FREQZZ")),"^",2)'="":$P(PSSDBAR("FREQZZ"),"^",2),1:PSSDBAR("FREQ"))
I PSSDRSC5="" Q
S PSSDRSC2=$$FRCON(PSSDRSC5)
I PSSDRSC2,PSSDRSC4,PSSDRSC4>PSSDRSC2 D
.S PSSDBCAZ(PSSDBFDB(PSSDBLP,"RX_NUM"),"FRQD_ERROR")=""
.S PSSDBCAZ(PSSDBFDB(PSSDBLP,"RX_NUM"),"FRQ_ERROR")=""
Q
;
;
NOEXP ;Don't show any exceptions for a drug level error
N PSSNOE1,PSSNOE2
F PSSNOE1=0:0 S PSSNOE1=$O(^TMP($J,PSSDBASE,"OUT","EXCEPTIONS","DOSE",PSSDWE1,PSSNOE1)) Q:'PSSNOE1 D
.S PSSNOE2=$P($G(^TMP($J,PSSDBASE,"OUT","EXCEPTIONS","DOSE",PSSDWE1,PSSNOE1)),"^",10)
.I PSSNOE2["Invalid or Undefined Frequency" D NOEXPF^PSSDSAPB Q
.I PSSNOE2=""!(PSSNOE2["GCNSEQNO") S PSSNOE9(PSSDWE1)="" D NOEXPG Q
.I PSSNOE2["Drug not matched to NDF"!(PSSNOE2["No active IV Additive/Solution marked for IV fluid order entry") S PSSNOE9(PSSDWE1)="" D NOEXPS
Q
;
;
NOEXPS ;Set Drug level error
I PSSNOE2["Drug not matched to NDF" S PSSENHKZ(PSSDWE1)=1
I PSSDBASA D
.S ^TMP($J,PSSDBASF,"OUT","EXCEPTIONS","DOSE",PSSDWE1,1)=$P($G(^TMP($J,PSSDBASE,"OUT","EXCEPTIONS","DOSE",PSSDWE1,PSSNOE1)),"^",7)
.S ^TMP($J,PSSDBASF,"OUT","EXCEPTIONS","DOSE",PSSDWE1,2)=" Reason(s): "_$P($G(^TMP($J,PSSDBASE,"OUT","EXCEPTIONS","DOSE",PSSDWE1,PSSNOE1)),"^",10)
I PSSDBASB D
.S ^TMP($J,PSSDBASG,"OUT",PSSDWE1,"EXCEPTIONS",1)=$P($G(^TMP($J,PSSDBASE,"OUT","EXCEPTIONS","DOSE",PSSDWE1,PSSNOE1)),"^",7)
.S ^TMP($J,PSSDBASG,"OUT",PSSDWE1,"EXCEPTIONS",2)=" Reason(s): "_$P($G(^TMP($J,PSSDBASE,"OUT","EXCEPTIONS","DOSE",PSSDWE1,PSSNOE1)),"^",10)
Q
;
;
NOEXPG ;Set GCNSEQNO exception
S PSSENHKZ(PSSDWE1)=1
I PSSDBASA D
.S ^TMP($J,PSSDBASF,"OUT","EXCEPTIONS","DOSE",PSSDWE1,1)=$P($G(^TMP($J,PSSDBASE,"OUT","EXCEPTIONS","DOSE",PSSDWE1,PSSNOE1)),"^",7)
I PSSDBASB D
.S ^TMP($J,PSSDBASG,"OUT",PSSDWE1,"EXCEPTIONS",1)=$P($G(^TMP($J,PSSDBASE,"OUT","EXCEPTIONS","DOSE",PSSDWE1,PSSNOE1)),"^",7)
Q
;
;
DPL ;Set Dose display text, called from PSSDSAPD
S PSSDSDPL(PSSDBFDB(PSSDBLP,"RX_NUM"))=""
I $D(PSSDBFDB(PSSDBLP,"DOSE_AMT")),$D(PSSDBFDB(PSSDBLP,"DOSE_UNIT")) S PSSDSDPL(PSSDBFDB(PSSDBLP,"RX_NUM"))=PSSDBFDB(PSSDBLP,"DOSE_AMT")_" "_PSSDBFDB(PSSDBLP,"DOSE_UNIT") D DPLZ Q
I $G(PSSDBDS(PSSDBLP,"DRG_AMT")),$G(PSSDBDS(PSSDBLP,"DRG_UNIT"))'="" S PSSDSDPL(PSSDBFDB(PSSDBLP,"RX_NUM"))=$G(PSSDBDS(PSSDBLP,"DRG_AMT"))_" "_$G(PSSDBDS(PSSDBLP,"DRG_UNIT")) D DPLZ Q
S PSSDSDPL(PSSDBFDB(PSSDBLP,"RX_NUM"))=$S($G(PSSDBDS(PSSDBLP,"DOSE"))'="":$P($G(PSSDBDS(PSSDBLP,"DOSE")),"&",5),1:$G(PSSDBDS(PSSDBLP,"DO")))
Q
;
;
DPLZ ;
I $E(PSSDSDPL(PSSDBFDB(PSSDBLP,"RX_NUM")))="." S PSSDSDPL(PSSDBFDB(PSSDBLP,"RX_NUM"))="0"_PSSDSDPL(PSSDBFDB(PSSDBLP,"RX_NUM"))
Q
;
;The following line at DRG+12 was commented out, but needed to uncomment for CCR 4971, but other changes seemed to
;resolve this issue
;.S:'PSSGTHL1 PSSGTHL1=PSSGT1
;Original reason for comment:
;Commented the Package Use and Inactive Date check out in 2.0 because of the logic failure of a Drug Level error from
;CPRS, we check the Drug level error and don't return to error to CPRS if the enhanced order check was shown, to avoid
;duplicate "dosing" error messages. But we need to restore in 2.1 to get General Dosing Guidelines, and look at another
;way to handle the duplicate "dosing" drug level error messages.
Q
;
;
CKWRN ;Set flag indicating a warning exists
N PSSWAF1,PSSWAF2,PSSWAF3
S PSSWAF3=0 F PSSWAF1=0:0 S PSSWAF1=$O(^TMP($J,PSSDBASE,"OUT","DOSE","ERROR",PSSDWLP,PSSWAF1)) Q:'PSSWAF1!(PSSWAF3) D
.I $G(^TMP($J,PSSDBASE,"OUT","DOSE","ERROR",PSSDWLP,PSSWAF1,"TEXT"))'="" D
..S PSSWAF2=$S($G(^TMP($J,PSSDBASE,"OUT","DOSE","ERROR",PSSDWLP,PSSWAF1,"SEV"))="Warning":0,1:1)
..I 'PSSWAF2 S $P(PSSDBCAR(PSSDWLP),"^",22)=1,PSSWAF3=1
Q
;
;
ADOSE ;Add DOSE subscript to any EXCEPTION from interface without DOSE subscript
I '$O(^TMP($J,PSSDBASE,"OUT","EXCEPTIONS",PSSDWEX3,"")) Q
N PSSDWEZ4,PSSDWEZ5,PSSDWEZ6,PSSDWEZ7
S PSSDWEZ4=0 F PSSDWEZ7=0:0 S PSSDWEZ7=$O(^TMP($J,PSSDBASE,"OUT","EXCEPTIONS","DOSE",PSSDWEX3,PSSDWEZ7)) Q:'PSSDWEZ7 S PSSDWEZ4=PSSDWEZ7
S PSSDWEZ4=PSSDWEZ4+1
F PSSDWEZ5=0:0 S PSSDWEZ5=$O(^TMP($J,PSSDBASE,"OUT","EXCEPTIONS",PSSDWEX3,PSSDWEZ5)) Q:'PSSDWEZ5 D
.S PSSDWEZ6=^TMP($J,PSSDBASE,"OUT","EXCEPTIONS",PSSDWEX3,PSSDWEZ5)
.S ^TMP($J,PSSDBASE,"OUT","EXCEPTIONS","DOSE",PSSDWEX3,PSSDWEZ4)=PSSDWEZ6
.I $P(PSSDWEZ6,"^",10)'="" S $P(^TMP($J,PSSDBASE,"OUT","EXCEPTIONS","DOSE",PSSDWEX3,PSSDWEZ4),"^",7)="Maximum Single Dose Check could not be performed for Drug: "_$P(PSSDBCAR(PSSDWEX3),"^",2) ;Changed for 2.0
.S PSSDWEZ4=PSSDWEZ4+1
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSSDSAPK 17970 printed Sep 23, 2025@20:06:47 Page 2
PSSDSAPK ;BIR/RTR - Miscellaneous APIs for Dose Call ; Sep 02, 2009@16:00
+1 ;;1.0;PHARMACY DATA MANAGEMENT;**117,168,160,178,254**;9/30/97;Build 109
+2 ;
+3 ;
+4 ;Disregard Package Use and Inactive Date in File 50, so you can still get General Dosing Guidelines
+5 ;Return Dispense Drug for Orderable Item
+6 ;PSSGTOI = Orderable Item
+7 ;PSSGTPK = Package O for Outpatient, N for Non-VA Med, I for Inpatient
+8 ;PSSGTRTE = Med Route Internal Entry Number
+9 ;PSSGTAB = String containing A for Additive, B for Solution
+10 ;PSSGTRES = result - 0 for No Drug found, or File 50 Internal Entry Number
DRG(PSSGTOI,PSSGTPK,PSSGTRTE,PSSGTAB) ;
+1 IF '$GET(PSSGTOI)
QUIT 0
+2 IF $GET(PSSGTPK)'="O"
IF $GET(PSSGTPK)'="X"
IF $GET(PSSGTPK)'="I"
QUIT 0
+3 NEW PSSGTRES,PSSGTPM,PSSGT1,PSSGT2,PSSGT3,PSSGT4,PSSGT5,PSSGTHL1,PSSGTHL2
+4 SET PSSGTPM=$SELECT(PSSGTPK="I":"U",1:PSSGTPK)
+5 SET (PSSGTRES,PSSGTHL1,PSSGTHL2)=0
+6 IF PSSGTPK="I"
IF $GET(PSSGTRTE)
IF $PIECE($GET(^PS(51.2,PSSGTRTE,0)),"^",6)=1
IF $GET(PSSGTAB)["A"!($GET(PSSGTAB)["B")
GOTO DRGINP
+7 FOR PSSGT1=0:0
SET PSSGT1=$ORDER(^PSDRUG("ASP",PSSGTOI,PSSGT1))
if 'PSSGT1!(PSSGTHL2)
QUIT
Begin DoDot:1
+8 SET PSSGT3=$PIECE($GET(^PSDRUG(PSSGT1,"ND")),"^")
SET PSSGT4=$PIECE($GET(^PSDRUG(PSSGT1,"ND")),"^",3)
+9 IF 'PSSGT3!('PSSGT4)
QUIT
+10 SET PSSGT5=$PIECE($$PROD0^PSNAPIS(PSSGT3,PSSGT4),"^",7)
IF +$GET(PSSGT5)'>0
QUIT
+11 IF $$EXMT^PSSDSAPI(PSSGT1)
QUIT
+12 if 'PSSGTHL1
SET PSSGTHL1=PSSGT1
+13 IF $PIECE($GET(^PSDRUG(PSSGT1,2)),"^",3)'[PSSGTPM
QUIT
+14 SET PSSGT2=$PIECE($GET(^PSDRUG(PSSGT1,"I")),"^")
IF PSSGT2
IF PSSGT2<DT
QUIT
+15 SET PSSGTHL2=PSSGT1
End DoDot:1
+16 SET PSSGTRES=$SELECT(PSSGTHL2:PSSGTHL2,PSSGTHL1:PSSGTHL1,1:0)
+17 QUIT PSSGTRES
+18 ;
+19 ;
DRGINP ;Inpatient Order with IV Route
+1 ;Added in 2.0 to set Input exception if no drug found
SET PSSDSIVF=1
+2 NEW PSSGT6,PSSGT7,PSSGT8,PSSGTN1,PSSGTN3,PSSGTN4
+3 IF PSSGTAB["A"
Begin DoDot:1
+4 FOR PSSGT6=0:0
SET PSSGT6=$ORDER(^PS(52.6,"AOI",PSSGTOI,PSSGT6))
if 'PSSGT6!(PSSGTRES)
QUIT
Begin DoDot:2
+5 SET PSSGT7=$PIECE($GET(^PS(52.6,PSSGT6,"I")),"^")
IF PSSGT7
IF PSSGT7'>DT
QUIT
+6 SET PSSGT8=$PIECE($GET(^PS(52.6,PSSGT6,0)),"^",2)
IF 'PSSGT8
QUIT
+7 ;Dispense Drug can be inactive, and no need to check package use
+8 SET PSSGTN1=$PIECE($GET(^PSDRUG(PSSGT8,"ND")),"^")
SET PSSGTN3=$PIECE($GET(^PSDRUG(PSSGT8,"ND")),"^",3)
+9 IF 'PSSGTN1!('PSSGTN3)
QUIT
+10 SET PSSGTN4=$PIECE($$PROD0^PSNAPIS(PSSGTN1,PSSGTN3),"^",7)
IF +$GET(PSSGTN4)'>0
QUIT
+11 IF $$EXMT^PSSDSAPI(PSSGT8)
QUIT
+12 SET PSSGTRES=PSSGT8
End DoDot:2
End DoDot:1
+13 IF PSSGTRES
QUIT PSSGTRES
+14 IF PSSGTAB["B"
Begin DoDot:1
+15 FOR PSSGT6=0:0
SET PSSGT6=$ORDER(^PS(52.7,"AOI",PSSGTOI,PSSGT6))
if 'PSSGT6!(PSSGTRES)
QUIT
Begin DoDot:2
+16 IF $PIECE($GET(^PS(52.7,PSSGT6,0)),"^",14)'=1
QUIT
+17 SET PSSGT7=$PIECE($GET(^PS(52.7,PSSGT6,"I")),"^")
IF PSSGT7
IF PSSGT7'>DT
QUIT
+18 SET PSSGT8=$PIECE($GET(^PS(52.7,PSSGT6,0)),"^",2)
IF 'PSSGT8
QUIT
+19 ;Dispense Drug can be inactive, and no need to check package use
+20 SET PSSGTN1=$PIECE($GET(^PSDRUG(PSSGT8,"ND")),"^")
SET PSSGTN3=$PIECE($GET(^PSDRUG(PSSGT8,"ND")),"^",3)
+21 IF 'PSSGTN1!('PSSGTN3)
QUIT
+22 SET PSSGTN4=$PIECE($$PROD0^PSNAPIS(PSSGTN1,PSSGTN3),"^",7)
IF +$GET(PSSGTN4)'>0
QUIT
+23 IF $$EXMT^PSSDSAPI(PSSGT8)
QUIT
+24 SET PSSGTRES=PSSGT8
End DoDot:2
End DoDot:1
+25 QUIT PSSGTRES
+26 ;
+27 ;
PRE(PSSLGTOI,PSSDIAG) ;Determine if CPRS needs to do order checks
+1 ;PSSLGTOI = File 50.7 Internal Entry Number
+2 ;PSSDIAG = CPRS order dialog (U:Inpatient; I:IV Fluids; O:Outpatient; N:Non-VA Meds)
+3 ; If PSSDIAG is "I" then DO NOT use this call for additve entries.
+4 ;If 1 is returned then CPRS needs to do enhanced order checks. This means it is either a UD,
+5 ; Outpatient, Non-VA, additive, or a premix solution.
+6 ;If 0 is returned then enhanced order check is not needed to perform.
+7 ;
+8 IF '+$GET(PSSLGTOI)
QUIT 0
+9 IF $GET(PSSDIAG)=""
QUIT 1
+10 IF PSSDIAG="O"
QUIT 1
+11 IF PSSDIAG="N"
QUIT 1
+12 IF PSSDIAG="I"
QUIT +$$SOL^PSSDSAPA(PSSLGTOI)
+13 IF PSSDIAG="U"
QUIT $$IPM^PSSDSAPA(PSSLGTOI)
+14 QUIT 1
+15 ;
+16 ;
CONV(PSSCVTVL) ;Convert hours into format for Dose API for Inpatient Medications
+1 NEW PSSCVTRS,PSSCVT1,PSSCVT2,PSSCVT3
+2 SET PSSCVTRS=""
+3 IF '$GET(PSSCVTVL)
QUIT PSSCVTRS
+4 SET PSSCVT1=+PSSCVTVL
+5 IF PSSCVT1<1
SET PSSCVT2=PSSCVT1*60
SET PSSCVT3=1440/PSSCVT2
SET PSSCVTRS=$JUSTIFY(PSSCVT3,0,0)
if PSSCVTRS=24
SET PSSCVTRS="Q1H"
QUIT PSSCVTRS
+6 SET PSSCVT2=$JUSTIFY(PSSCVT1,0,0)
SET PSSCVTRS="Q"_PSSCVT2_"H"
+7 QUIT PSSCVTRS
+8 ;
+9 ;
ITEM ;Only Orderable Item passed in, no Dispense Drug
+1 NEW PSSDBI1,PSSDBI2,PSSDBI3,PSSDBI4,PSSDBI5,PSSDBI6,PSSDBI7,PSSDBI8,PSSDBI9,PSSDBI91,PSSDBI92,PSSDBI93,PSSDBI94
+2 SET PSSDBI1=$GET(PSSDSLCL)
+3 IF $LENGTH(PSSDBI1)'>0
QUIT
+4 SET PSSDBI1=$$UP^XLFSTR(PSSDBI1)
+5 ;Strip out commas up until first character not a number or decimal
+6 SET PSSDBI6=0
FOR PSSDBI7=1:1:$LENGTH(PSSDBI1)
if PSSDBI6
QUIT
SET PSSDBI8=$EXTRACT(PSSDBI1,PSSDBI7)
IF PSSDBI8'?1N
IF PSSDBI8'?1"."
IF PSSDBI8'?1","
SET PSSDBI6=PSSDBI7
+7 IF PSSDBI6=1
QUIT
+8 SET PSSDBI9=$SELECT('PSSDBI6:$LENGTH(PSSDBI1),1:(PSSDBI6-1))
+9 SET PSSDBI91=$EXTRACT(PSSDBI1,1,PSSDBI9)
SET PSSDBI92=$EXTRACT(PSSDBI1,(PSSDBI9+1),$LENGTH(PSSDBI1))
+10 SET PSSDBI93=$TRANSLATE(PSSDBI91,",","")
+11 SET PSSDBI1=PSSDBI93_PSSDBI92
+12 IF $EXTRACT(PSSDBI1)=0
SET PSSDBI1=$EXTRACT(PSSDBI1,2,$LENGTH(PSSDBI1))
+13 IF $LENGTH(PSSDBI1)'>0
QUIT
+14 SET PSSDBI2=+PSSDBI1
+15 IF 'PSSDBI2!($LENGTH(PSSDBI2)=$LENGTH(PSSDBI1))
QUIT
+16 SET PSSDBI3=$EXTRACT(PSSDBI1,($LENGTH(PSSDBI2)+1),$LENGTH(PSSDBI1))
+17 SET PSSDBI4=$SELECT($EXTRACT(PSSDBI3)=" ":$EXTRACT(PSSDBI3,2,$LENGTH(PSSDBI3)),1:PSSDBI3)
+18 IF PSSDBI4=""
QUIT
+19 IF PSSDBIFL
SET PSSDBI5=$$UNITD^PSSDSAPI(PSSDBI4)
+20 IF 'PSSDBIFL
SET PSSDBI5=$$UNIT^PSSDSAPI(PSSDBI4)
+21 IF PSSDBI5=""
QUIT
+22 SET PSSDBAR("AMN")=PSSDBI2
SET PSSDBAR("UNIT")=PSSDBI5
SET PSSDBFAL=1
+23 QUIT
+24 ;
+25 ;
FRCON(PSSCFQ1) ;Convert frequency into a number for complex dose additions
+1 NEW PSSCFQRS,PSSCFQ2,PSSCFQ3,PSSCFQ4
+2 SET PSSCFQRS=0
+3 IF PSSCFQ1?1N.N!(PSSCFQ1?1N.N1"."1N.N)
SET PSSCFQRS=PSSCFQ1
QUIT PSSCFQRS
+4 IF PSSCFQ1?1"Q"1N.N1"H"
Begin DoDot:1
+5 SET PSSCFQ2=$EXTRACT(PSSCFQ1,2,($LENGTH(PSSCFQ1)-1))
+6 SET PSSCFQ3=60*PSSCFQ2
+7 SET PSSCFQRS=1440/PSSCFQ3
End DoDot:1
QUIT PSSCFQRS
+8 IF PSSCFQ1?1"Q"1N.N1"D"
Begin DoDot:1
+9 SET PSSCFQ2=$EXTRACT(PSSCFQ1,2,($LENGTH(PSSCFQ1)-1))
+10 SET PSSCFQRS=1/PSSCFQ2
IF PSSCFQRS["."
SET PSSCFQRS=$JUSTIFY(PSSCFQRS,0,4)
End DoDot:1
QUIT PSSCFQRS
+11 IF PSSCFQ1?1"Q"1N.N1"W"
Begin DoDot:1
+12 SET PSSCFQ2=$EXTRACT(PSSCFQ1,2,($LENGTH(PSSCFQ1)-1))
+13 SET PSSCFQ3=7*PSSCFQ2
+14 SET PSSCFQ4=PSSCFQ3*1440
+15 SET PSSCFQRS=1440/PSSCFQ4
IF PSSCFQRS["."
SET PSSCFQRS=$JUSTIFY(PSSCFQRS,0,4)
End DoDot:1
QUIT PSSCFQRS
+16 IF PSSCFQ1?1"Q"1N.N1"L"
Begin DoDot:1
+17 SET PSSCFQ2=$EXTRACT(PSSCFQ1,2,($LENGTH(PSSCFQ1)-1))
+18 SET PSSCFQ3=30*PSSCFQ2
+19 SET PSSCFQ4=PSSCFQ3*1440
+20 SET PSSCFQRS=1440/PSSCFQ4
IF PSSCFQRS["."
SET PSSCFQRS=$JUSTIFY(PSSCFQRS,0,4)
End DoDot:1
QUIT PSSCFQRS
+21 IF PSSCFQ1?1N.N1"XD"
Begin DoDot:1
+22 SET (PSSCFQ2,PSSCFQRS)=+PSSCFQ1
+23 IF PSSCFQRS["."
SET PSSCFQRS=$JUSTIFY(PSSCFQRS,0,4)
End DoDot:1
QUIT PSSCFQRS
+24 IF PSSCFQ1?1N.N1"XW"
Begin DoDot:1
+25 SET PSSCFQ2=+PSSCFQ1
SET PSSCFQRS=PSSCFQ2/7
+26 IF PSSCFQRS["."
SET PSSCFQRS=$JUSTIFY(PSSCFQRS,0,4)
End DoDot:1
QUIT PSSCFQRS
+27 IF PSSCFQ1?1N.N1"XL"
Begin DoDot:1
+28 SET PSSCFQ2=+PSSCFQ1
SET PSSCFQRS=PSSCFQ2/30
+29 IF PSSCFQRS["."
SET PSSCFQRS=$JUSTIFY(PSSCFQRS,0,4)
End DoDot:1
QUIT PSSCFQRS
+30 IF PSSCFQ1="QOD"
SET PSSCFQRS=.5
QUIT PSSCFQRS
+31 QUIT 0
+32 ;
+33 ;
SING ;
+1 SET $PIECE(PSSDBCAR(PSSDBEB1),"^")="S"
+2 SET $PIECE(^TMP($JOB,PSSDBASE,"IN","DOSE",PSSDBEB1),"^",8)=1
+3 SET $PIECE(^TMP($JOB,PSSDBASE,"IN","DOSE",PSSDBEB1),"^",9)=1
+4 SET $PIECE(^TMP($JOB,PSSDBASE,"IN","DOSE",PSSDBEB1),"^",10)=$PIECE(^TMP($JOB,PSSDBASE,"IN","DOSE",PSSDBEB1),"^",7)
+5 SET $PIECE(PSSDBCAR(PSSDBEB1),"^",7)=1
+6 QUIT
+7 ;
+8 ;
DOWN ;
+1 if PSSDBASA
SET ^TMP($JOB,PSSDBASF,"OUT",0)=^TMP($JOB,PSSDBASE,"OUT",0)
if PSSDBASB
SET ^TMP($JOB,PSSDBASG,"OUT",0)=^TMP($JOB,PSSDBASE,"OUT",0)
+2 QUIT
+3 ;
+4 ;
BDOSE ;Missing Numeric Dose or Dose Unit
+1 IF 'PSSDBEB3!($PIECE(PSSDBEB2,"^",11)="")
DO EXCPS^PSSDSAPD(1)
if $DATA(PSSDBCAZ(PSSDBEB1,"FRQ_ERROR"))
DO EXCPS^PSSDSAPD(2)
SET PSSDBDGO=1
QUIT
+2 SET $PIECE(PSSDBCAR(PSSDBEB1),"^",20)=1
IF '$PIECE(PSSDBCAR(PSSDBEB1),"^",5)
DO EXCPS^PSSDSAPD(1)
if $DATA(PSSDBCAZ(PSSDBEB1,"FRQ_ERROR"))
DO EXCPS^PSSDSAPD(2)
SET PSSDBFTX(PSSDBEB1,"FTX_ERROR")=""
QUIT
+3 SET PSSDBDGO=1
+4 DO EXCPS^PSSDSAPD(1)
+5 IF $DATA(PSSDBCAZ(PSSDBEB1,"FRQ_ERROR"))
DO EXCPS^PSSDSAPD(2)
+6 SET $PIECE(^TMP($JOB,PSSDBASE,"IN","DOSE",PSSDBEB1),"^",5)=1
+7 SET $PIECE(^TMP($JOB,PSSDBASE,"IN","DOSE",PSSDBEB1),"^",8)=1
+8 SET $PIECE(^TMP($JOB,PSSDBASE,"IN","DOSE",PSSDBEB1),"^",9)=1
+9 SET $PIECE(^TMP($JOB,PSSDBASE,"IN","DOSE",PSSDBEB1),"^",7)="DAY"
+10 SET $PIECE(^TMP($JOB,PSSDBASE,"IN","DOSE",PSSDBEB1),"^",10)="DAY"
+11 SET $PIECE(^TMP($JOB,PSSDBASE,"IN","DOSE",PSSDBEB1),"^",6)=$$DUNIT^PSSDSAPA
SET PSSDBAR("UNIT")=$PIECE(^TMP($JOB,PSSDBASE,"IN","DOSE",PSSDBEB1),"^",6)
SET $PIECE(^TMP($JOB,PSSDBASE,"IN","DOSE",PSSDBEB1),"^",14)=$$DFM^PSSDSEXC
+12 SET $PIECE(PSSDBCAR(PSSDBEB1),"^",6)=1
SET $PIECE(PSSDBCAR(PSSDBEB1),"^",10)=1
+13 ; -- in 2.1 set Dummy Data flag
+14 SET $PIECE(PSSDBCAR(PSSDBEB1),"^",33)=1
+15 QUIT
+16 ;
+17 ;
FTX ;Pull Dosing sequences out of Input for complex orders where Free Text Dosage could not be evaluated
+1 NEW PSSDTX1
+2 SET PSSDTX1=""
FOR
SET PSSDTX1=$ORDER(PSSDBFTX(PSSDTX1))
if PSSDTX1=""
QUIT
Begin DoDot:1
+3 SET PSSDBFTX(PSSDTX1,"NODE1")=$GET(^TMP($JOB,PSSDBASE,"IN","DOSE",PSSDTX1))
+4 SET PSSDBFTX(PSSDTX1,"NODE2")=$GET(^TMP($JOB,PSSDBASE,"IN","PROSPECTIVE",PSSDTX1))
+5 KILL ^TMP($JOB,PSSDBASE,"IN","DOSE",PSSDTX1)
+6 KILL ^TMP($JOB,PSSDBASE,"IN","PROSPECTIVE",PSSDTX1)
End DoDot:1
+7 QUIT
+8 ;
+9 ;
FTXRS ;Reset input globals that were pulled because of invalid dosage
+1 NEW PSSDTX2
+2 SET PSSDTX2=""
FOR
SET PSSDTX2=$ORDER(PSSDBFTX(PSSDTX2))
if PSSDTX2=""
QUIT
Begin DoDot:1
+3 SET ^TMP($JOB,PSSDBASE,"IN","DOSE",PSSDTX2)=PSSDBFTX(PSSDTX2,"NODE1")
+4 SET ^TMP($JOB,PSSDBASE,"IN","PROSPECTIVE",PSSDTX2)=PSSDBFTX(PSSDTX2,"NODE2")
End DoDot:1
+5 QUIT
+6 ;
+7 ;
ERR1() ;Screen out Daily Dose errors for Single Dose Sequences, unless New Daily Dose created based on previous Dosing sequences
+1 ;Called from PSSDSEXC
+2 NEW PSSERS,PSSERSU
+3 SET PSSERS=$GET(^TMP($JOB,PSSDBASE,"OUT","DOSE","ERROR",PSSDWLP,PSSDWL1,"MSG"))
+4 SET PSSERSU=$$UP^XLFSTR(PSSERS)
+5 ; 2.1 change to not show Daily Dose is Schedule indicates so
IF PSSERSU["DAILY DOSE"
IF $PIECE($GET(PSSDBCAR(PSSDWLP)),"^",15)
QUIT 1
+6 IF $PIECE($GET(PSSDBCAR(PSSDWLP)),"^")'="S"!($PIECE($GET(PSSDBCAR(PSSDWLP)),"^",11))
QUIT 0
+7 IF PSSERSU'["DAILY DOSE"
QUIT 0
+8 QUIT 1
+9 ;
+10 ;
ERR2() ;Screen out Frequency errors if Dosing Sequence is flagged for Single Dose only
+1 ;Called from PSSDSEXC
+2 NEW PSSERH,PSSERHU,PSSERHRS
+3 SET PSSERHRS=0
+4 IF $PIECE($GET(PSSDBCAR(PSSDWE1)),"^",12)!($PIECE($GET(PSSDBCAR(PSSDWE1)),"^",5)=0)
Begin DoDot:1
+5 SET PSSERH=PSSDWEGC
+6 SET PSSERHU=$$UP^XLFSTR(PSSERH)
+7 IF PSSERHU["UNDEFINED FREQUENCY"!(PSSERHU["FREQUENCY GREATER")
SET PSSERHRS=1
End DoDot:1
+8 QUIT PSSERHRS
+9 ;
+10 ;
INFERR ;Infusion Rate Height and Weight Errors
+1 IF $DATA(PSSDBFDB(PSSDBLP,"HT_ERROR"))
SET PSSDBCAZ(PSSDBFDB(PSSDBLP,"RX_NUM"),"HT_ERROR")=""
+2 IF $DATA(PSSDBFDB(PSSDBLP,"WT_ERROR"))
SET PSSDBCAZ(PSSDBFDB(PSSDBLP,"RX_NUM"),"WT_ERROR")=""
+3 QUIT
+4 ;
+5 ;
INFERRS ;
+1 IF '$DATA(PSSDBCAZ(PSSDBEB1,"HT_ERROR"))
IF '$DATA(PSSDBCAZ(PSSDBEB1,"WT_ERROR"))
QUIT
+2 IF $DATA(PSSDBCAZ(PSSDBEB1,"WT_ERROR"))
IF $DATA(PSSDBCAZ(PSSDBEB1,"HT_ERROR"))
DO EXCPS^PSSDSAPD(14)
QUIT
+3 IF '$DATA(PSSDBCAZ(PSSDBEB1,"HT_ERROR"))
DO EXCPS^PSSDSAPD(13)
QUIT
+4 DO EXCPS^PSSDSAPD(12)
+5 QUIT
+6 ;
+7 ;
GENERRX ;Set General Dosing Guidelines exception
+1 ;This code, not being used, was moved from PSSDSEXC to have a record of old functionality, in case we need it again
+2 QUIT
+3 ;
+4 NEW PSSDWF1,PSSDWF2,PSSDWF3,PSSDWF4
+5 SET PSSDWF2=0
FOR PSSDWF1=0:0
SET PSSDWF1=$ORDER(^TMP($JOB,PSSDBASE,"OUT","EXCEPTIONS","DOSE",PSSDWE5,PSSDWF1))
if 'PSSDWF1
QUIT
SET PSSDWF2=PSSDWF1
+6 IF 'PSSDWF2
Begin DoDot:1
+7 IF PSSDBASA
SET ^TMP($JOB,PSSDBASF,"OUT","EXCEPTIONS","DOSE",PSSDWE5,1)="Dosing Checks could not be performed for Drug: "_$PIECE(PSSDBCAR(PSSDWE5),"^",2)
+8 IF PSSDBASB
SET ^TMP($JOB,PSSDBASG,"OUT",PSSDWE5,"EXCEPTIONS",1)="Dosing Checks could not be performed for Drug: "_$PIECE(PSSDBCAR(PSSDWE5),"^",2)
+9 IF PSSDBASA
SET ^TMP($JOB,PSSDBASF,"OUT","EXCEPTIONS","DOSE",PSSDWE5,2)=" General Dosing guidelines are not available"
+10 IF PSSDBASB
SET ^TMP($JOB,PSSDBASG,"OUT",PSSDWE5,"EXCEPTIONS",2)=" General Dosing guidelines are not available"
+11 SET ^TMP($JOB,PSSDBASE,"OUT","EXCEPTIONS","DOSE",PSSDWE5,1)="^^^^^^Dosing Checks could not be performed for Drug: "_$PIECE(PSSDBCAR(PSSDWE5),"^",2)_"^^^"_"General Dosing guidelines are not available"
End DoDot:1
QUIT
+12 SET PSSDWF2=PSSDWF2+1
+13 SET ^TMP($JOB,PSSDBASE,"OUT","EXCEPTIONS","DOSE",PSSDWE5,PSSDWF2)="^^^^^^Dosing Checks could not be performed for Drug: "_$PIECE(PSSDBCAR(PSSDWE5),"^",2)_"^^^"_"General Dosing guidelines are not available"
+14 IF PSSDBASA
Begin DoDot:1
+15 SET PSSDWF3=0
+16 FOR PSSDWF4=0:0
SET PSSDWF4=$ORDER(^TMP($JOB,PSSDBASF,"OUT","EXCEPTIONS","DOSE",PSSDWE5,PSSDWF4))
if 'PSSDWF4
QUIT
SET PSSDWF3=PSSDWF4
+17 SET PSSDWF3=PSSDWF3+1
+18 SET ^TMP($JOB,PSSDBASF,"OUT","EXCEPTIONS","DOSE",PSSDWE5,PSSDWF3)=" General Dosing guidelines are not available"
End DoDot:1
+19 IF PSSDBASB
Begin DoDot:1
+20 SET PSSDWF3=0
+21 FOR PSSDWF4=0:0
SET PSSDWF4=$ORDER(^TMP($JOB,PSSDBASG,"OUT",PSSDWE5,"EXCEPTIONS",PSSDWF4))
if 'PSSDWF4
QUIT
SET PSSDWF3=PSSDWF4
+22 SET PSSDWF3=PSSDWF3+1
+23 SET ^TMP($JOB,PSSDBASG,"OUT",PSSDWE5,"EXCEPTIONS",PSSDWF3)=" General Dosing guidelines are not available"
End DoDot:1
+24 QUIT
+25 ;
+26 ;
MTCH() ;Called from PSSDSAPD, looking for Local Possible Dosages Match
+1 NEW PSSDSLTM
+2 IF $PIECE(PSSDBNOD,"^")=PSSDSLCL
QUIT 1
+3 IF $EXTRACT(PSSDSLCL)=0
SET PSSDSLTM=$EXTRACT(PSSDSLCL,2,$LENGTH(PSSDSLCL))
IF $LENGTH(PSSDSLTM)>0
IF PSSDSLTM=$PIECE(PSSDBNOD,"^")
QUIT 1
+4 IF $EXTRACT(PSSDSLCL)'=0
SET PSSDSLTM=0_PSSDSLCL
IF PSSDSLTM=$PIECE(PSSDBNOD,"^")
QUIT 1
+5 QUIT 0
+6 ;
+7 ;
DPOP ;Use Pre release logic to find Dose unit and Numeric Dose
+1 NEW PSSDDPOP,PSSDSLPO
+2 SET PSSDDPOP=$$EN^PSSDSBBP(PSSDBFDB(PSSDBLP,"DRUG_IEN"),PSSDSLCL)
+3 IF PSSDDPOP
SET PSSDBAR("AMN")=$PIECE(PSSDDPOP,"^",2)
SET PSSDBAR("UNIT")=$PIECE($GET(^PS(51.24,+$PIECE(PSSDDPOP,"^"),0)),"^",2)
SET PSSDBFAL=1
QUIT
+4 IF $EXTRACT(PSSDSLCL)=0
SET PSSDSLPO=$EXTRACT(PSSDSLCL,2,$LENGTH(PSSDSLCL))
IF $LENGTH(PSSDSLPO)>0
Begin DoDot:1
+5 SET PSSDDPOP=$$EN^PSSDSBBP(PSSDBFDB(PSSDBLP,"DRUG_IEN"),PSSDSLPO)
End DoDot:1
IF PSSDDPOP
SET PSSDBAR("AMN")=$PIECE(PSSDDPOP,"^",2)
SET PSSDBAR("UNIT")=$PIECE($GET(^PS(51.24,+$PIECE(PSSDDPOP,"^"),0)),"^",2)
SET PSSDBFAL=1
QUIT
+6 IF $EXTRACT(PSSDSLCL)'=0
SET PSSDSLPO=0_PSSDSLCL
Begin DoDot:1
+7 SET PSSDDPOP=$$EN^PSSDSBBP(PSSDBFDB(PSSDBLP,"DRUG_IEN"),PSSDSLPO)
End DoDot:1
IF PSSDDPOP
SET PSSDBAR("AMN")=$PIECE(PSSDDPOP,"^",2)
SET PSSDBAR("UNIT")=$PIECE($GET(^PS(51.24,+$PIECE(PSSDDPOP,"^"),0)),"^",2)
SET PSSDBFAL=1
QUIT
+8 QUIT
+9 ;
+10 ;
FRDR ;Check if Duration exists, and is less than Duration of Schedule
+1 IF $GET(PSSDBAR("TYPE"))="SINGLE DOSE"
QUIT
+2 NEW PSSDRSC1,PSSDRSC2,PSSDRSC3,PSSDRSC4,PSSDRSC5
+3 SET PSSDRSC1=PSSDBFRB(PSSDBFDB(PSSDBLP,"RX_NUM"),"DRATE")
IF PSSDRSC1=""
QUIT
+4 SET PSSDRSC3=$$DRT^PSSDSAPD(PSSDRSC1)
IF PSSDRSC3'>0
QUIT
+5 SET PSSDRSC4=1440/PSSDRSC3
+6 SET PSSDRSC5=$SELECT($PIECE($GET(PSSDBAR("FREQZZ")),"^",2)'="":$PIECE(PSSDBAR("FREQZZ"),"^",2),1:PSSDBAR("FREQ"))
+7 IF PSSDRSC5=""
QUIT
+8 SET PSSDRSC2=$$FRCON(PSSDRSC5)
+9 IF PSSDRSC2
IF PSSDRSC4
IF PSSDRSC4>PSSDRSC2
Begin DoDot:1
+10 SET PSSDBCAZ(PSSDBFDB(PSSDBLP,"RX_NUM"),"FRQD_ERROR")=""
+11 SET PSSDBCAZ(PSSDBFDB(PSSDBLP,"RX_NUM"),"FRQ_ERROR")=""
End DoDot:1
+12 QUIT
+13 ;
+14 ;
NOEXP ;Don't show any exceptions for a drug level error
+1 NEW PSSNOE1,PSSNOE2
+2 FOR PSSNOE1=0:0
SET PSSNOE1=$ORDER(^TMP($JOB,PSSDBASE,"OUT","EXCEPTIONS","DOSE",PSSDWE1,PSSNOE1))
if 'PSSNOE1
QUIT
Begin DoDot:1
+3 SET PSSNOE2=$PIECE($GET(^TMP($JOB,PSSDBASE,"OUT","EXCEPTIONS","DOSE",PSSDWE1,PSSNOE1)),"^",10)
+4 IF PSSNOE2["Invalid or Undefined Frequency"
DO NOEXPF^PSSDSAPB
QUIT
+5 IF PSSNOE2=""!(PSSNOE2["GCNSEQNO")
SET PSSNOE9(PSSDWE1)=""
DO NOEXPG
QUIT
+6 IF PSSNOE2["Drug not matched to NDF"!(PSSNOE2["No active IV Additive/Solution marked for IV fluid order entry")
SET PSSNOE9(PSSDWE1)=""
DO NOEXPS
End DoDot:1
+7 QUIT
+8 ;
+9 ;
NOEXPS ;Set Drug level error
+1 IF PSSNOE2["Drug not matched to NDF"
SET PSSENHKZ(PSSDWE1)=1
+2 IF PSSDBASA
Begin DoDot:1
+3 SET ^TMP($JOB,PSSDBASF,"OUT","EXCEPTIONS","DOSE",PSSDWE1,1)=$PIECE($GET(^TMP($JOB,PSSDBASE,"OUT","EXCEPTIONS","DOSE",PSSDWE1,PSSNOE1)),"^",7)
+4 SET ^TMP($JOB,PSSDBASF,"OUT","EXCEPTIONS","DOSE",PSSDWE1,2)=" Reason(s): "_$PIECE($GET(^TMP($JOB,PSSDBASE,"OUT","EXCEPTIONS","DOSE",PSSDWE1,PSSNOE1)),"^",10)
End DoDot:1
+5 IF PSSDBASB
Begin DoDot:1
+6 SET ^TMP($JOB,PSSDBASG,"OUT",PSSDWE1,"EXCEPTIONS",1)=$PIECE($GET(^TMP($JOB,PSSDBASE,"OUT","EXCEPTIONS","DOSE",PSSDWE1,PSSNOE1)),"^",7)
+7 SET ^TMP($JOB,PSSDBASG,"OUT",PSSDWE1,"EXCEPTIONS",2)=" Reason(s): "_$PIECE($GET(^TMP($JOB,PSSDBASE,"OUT","EXCEPTIONS","DOSE",PSSDWE1,PSSNOE1)),"^",10)
End DoDot:1
+8 QUIT
+9 ;
+10 ;
NOEXPG ;Set GCNSEQNO exception
+1 SET PSSENHKZ(PSSDWE1)=1
+2 IF PSSDBASA
Begin DoDot:1
+3 SET ^TMP($JOB,PSSDBASF,"OUT","EXCEPTIONS","DOSE",PSSDWE1,1)=$PIECE($GET(^TMP($JOB,PSSDBASE,"OUT","EXCEPTIONS","DOSE",PSSDWE1,PSSNOE1)),"^",7)
End DoDot:1
+4 IF PSSDBASB
Begin DoDot:1
+5 SET ^TMP($JOB,PSSDBASG,"OUT",PSSDWE1,"EXCEPTIONS",1)=$PIECE($GET(^TMP($JOB,PSSDBASE,"OUT","EXCEPTIONS","DOSE",PSSDWE1,PSSNOE1)),"^",7)
End DoDot:1
+6 QUIT
+7 ;
+8 ;
DPL ;Set Dose display text, called from PSSDSAPD
+1 SET PSSDSDPL(PSSDBFDB(PSSDBLP,"RX_NUM"))=""
+2 IF $DATA(PSSDBFDB(PSSDBLP,"DOSE_AMT"))
IF $DATA(PSSDBFDB(PSSDBLP,"DOSE_UNIT"))
SET PSSDSDPL(PSSDBFDB(PSSDBLP,"RX_NUM"))=PSSDBFDB(PSSDBLP,"DOSE_AMT")_" "_PSSDBFDB(PSSDBLP,"DOSE_UNIT")
DO DPLZ
QUIT
+3 IF $GET(PSSDBDS(PSSDBLP,"DRG_AMT"))
IF $GET(PSSDBDS(PSSDBLP,"DRG_UNIT"))'=""
SET PSSDSDPL(PSSDBFDB(PSSDBLP,"RX_NUM"))=$GET(PSSDBDS(PSSDBLP,"DRG_AMT"))_" "_$GET(PSSDBDS(PSSDBLP,"DRG_UNIT"))
DO DPLZ
QUIT
+4 SET PSSDSDPL(PSSDBFDB(PSSDBLP,"RX_NUM"))=$SELECT($GET(PSSDBDS(PSSDBLP,"DOSE"))'="":$PIECE($GET(PSSDBDS(PSSDBLP,"DOSE")),"&",5),1:$GET(PSSDBDS(PSSDBLP,"DO")))
+5 QUIT
+6 ;
+7 ;
DPLZ ;
+1 IF $EXTRACT(PSSDSDPL(PSSDBFDB(PSSDBLP,"RX_NUM")))="."
SET PSSDSDPL(PSSDBFDB(PSSDBLP,"RX_NUM"))="0"_PSSDSDPL(PSSDBFDB(PSSDBLP,"RX_NUM"))
+2 QUIT
+3 ;
+1 ;The following line at DRG+12 was commented out, but needed to uncomment for CCR 4971, but other changes seemed to
+2 ;resolve this issue
+3 ;.S:'PSSGTHL1 PSSGTHL1=PSSGT1
+4 ;Original reason for comment:
+5 ;Commented the Package Use and Inactive Date check out in 2.0 because of the logic failure of a Drug Level error from
+6 ;CPRS, we check the Drug level error and don't return to error to CPRS if the enhanced order check was shown, to avoid
+7 ;duplicate "dosing" error messages. But we need to restore in 2.1 to get General Dosing Guidelines, and look at another
+8 ;way to handle the duplicate "dosing" drug level error messages.
+9 QUIT
+10 ;
+11 ;
CKWRN ;Set flag indicating a warning exists
+1 NEW PSSWAF1,PSSWAF2,PSSWAF3
+2 SET PSSWAF3=0
FOR PSSWAF1=0:0
SET PSSWAF1=$ORDER(^TMP($JOB,PSSDBASE,"OUT","DOSE","ERROR",PSSDWLP,PSSWAF1))
if 'PSSWAF1!(PSSWAF3)
QUIT
Begin DoDot:1
+3 IF $GET(^TMP($JOB,PSSDBASE,"OUT","DOSE","ERROR",PSSDWLP,PSSWAF1,"TEXT"))'=""
Begin DoDot:2
+4 SET PSSWAF2=$SELECT($GET(^TMP($JOB,PSSDBASE,"OUT","DOSE","ERROR",PSSDWLP,PSSWAF1,"SEV"))="Warning":0,1:1)
+5 IF 'PSSWAF2
SET $PIECE(PSSDBCAR(PSSDWLP),"^",22)=1
SET PSSWAF3=1
End DoDot:2
End DoDot:1
+6 QUIT
+7 ;
+8 ;
ADOSE ;Add DOSE subscript to any EXCEPTION from interface without DOSE subscript
+1 IF '$ORDER(^TMP($JOB,PSSDBASE,"OUT","EXCEPTIONS",PSSDWEX3,""))
QUIT
+2 NEW PSSDWEZ4,PSSDWEZ5,PSSDWEZ6,PSSDWEZ7
+3 SET PSSDWEZ4=0
FOR PSSDWEZ7=0:0
SET PSSDWEZ7=$ORDER(^TMP($JOB,PSSDBASE,"OUT","EXCEPTIONS","DOSE",PSSDWEX3,PSSDWEZ7))
if 'PSSDWEZ7
QUIT
SET PSSDWEZ4=PSSDWEZ7
+4 SET PSSDWEZ4=PSSDWEZ4+1
+5 FOR PSSDWEZ5=0:0
SET PSSDWEZ5=$ORDER(^TMP($JOB,PSSDBASE,"OUT","EXCEPTIONS",PSSDWEX3,PSSDWEZ5))
if 'PSSDWEZ5
QUIT
Begin DoDot:1
+6 SET PSSDWEZ6=^TMP($JOB,PSSDBASE,"OUT","EXCEPTIONS",PSSDWEX3,PSSDWEZ5)
+7 SET ^TMP($JOB,PSSDBASE,"OUT","EXCEPTIONS","DOSE",PSSDWEX3,PSSDWEZ4)=PSSDWEZ6
+8 ;Changed for 2.0
IF $PIECE(PSSDWEZ6,"^",10)'=""
SET $PIECE(^TMP($JOB,PSSDBASE,"OUT","EXCEPTIONS","DOSE",PSSDWEX3,PSSDWEZ4),"^",7)="Maximum Single Dose Check could not be performed for Drug: "_$PIECE(PSSDBCAR(PSSDWEX3),"^",2)
+9 SET PSSDWEZ4=PSSDWEZ4+1
End DoDot:1
+10 QUIT
