PSSDSAPM ;BIR/RTR-Dose Check utilities routine ;09/13/10
;;1.0;PHARMACY DATA MANAGEMENT;**117,168,160,173,201,178**;9/30/97;Build 14
;
;
;DRG - returns best Dispense Drug to use for Order Checks when only the Orderable Item is available
;Input:
; PSSNBOI - Pharmacy orderable Item from #50.7
; PSSNBPK - package Use, I for Inpatient, O for Outpatient, X for Non-VA Meds
; PSSNBOR - defined only if being called from CPRS, 1 for Enhanced Order Checks, 2 for Dosing
;Output:
; nnn;nnn;nnnn - First piece is File 50 Internal Number, Second piece is VA Generic Internal number, Third piece
; will be the GCNSEQNO number. Piece 1 ';' is 0 if no drug found.
; Piece 2 will be null if drug not matched to National Drug File
; Piece 3 will be the GCNSEQNO number, if the NDF match has a GCNSEQNO number
; Piece 4 is returned as 1 if the call is from CPRS for enhanced order checks, and it indicates no drug was returned
; or a drug was returned, but there is an active supply tied to the Orderable Item, indicating CPRS should also do
; the duplicate supply check
; Piece 5 is returned as 1 if CPRS is getting a drug for the Enhanced Order Checks call, and they should
; display the error message for all order checks and not do the Dosing call
;
;
;hierarchy: (Drug must be active)
;1 - Exact Package Match, matched to NDF with GCNSEQNO
;2 - No package match, but second choice package exists, matched to NDF with GCNSEQNO
;3 - No package match, but third choice package exists, matched to NDF with GCNSEQNO
;4 - No package match, but fourth choice package exists, matched to NDF with GCNSEQNO
;5 - No package match, matched to NDF with GCNSEQNO
;6 - Exact Package Match, matched to NDF with no GCNSEQNO
;7 - No package match, but second choice package exists, matched to NDF with no GCNSEQNO
;8 - No package match, but third choice package exists, matched to NDF with no GCNSEQNO
;9 - No package match, but fourth choice package exists, matched to NDF with no GCNSEQNO
;10 - No package match, matched to NDF with no GCNSEQNO
;11 - Exact Package Match, not matched to NDF
;12 - No package match, but second choice package exists, not matched to NDF
;13 - No package match, but third choice package exists, not matched to NDF
;14 - No package match, but fourth choice package exists, not matched to NDF
;15 - No package match, package is null or some other package that is not one of the 4 primary packages (O, I U, X), matched to NDF
;16 - No package match, not matched to NDF, package is null or some other package that is not one of the 4 primary packages (O, I U, X)
;
;** CPRS and Inpatient always passes in "I" for PSSNBPK variable, so drugs with "I" and "U" application packages are
; evaluated as either or in the APP subroutine. In the hierarchy above 1 or 2, 6 or 7 and 11 or 12 are
; considered to be exact matches. Outpatient evaluates "I" and "U" separately.
;
;Second/Third Choice packages:
;Outpatient - U for Unit dose, I for IV, then X for Non-VA med
;Inpatient - O for outpatient then X
;Non-VA Meds - O, U then I
;
;PSNBLOW holds current number in array, only reset array entry if lower number is found
;PSSNBSTP stops the loop because you found the best possible drug, no need to set PSSNBLOW in this case
;
;
DRG(PSSNBOI,PSSNBPK,PSSNBOR) ;
I '$G(PSSNBOI) Q "0;;"_$S($G(PSSNBOR)=1&($G(PSSNBPK)="I"!($G(PSSNBPK)="U")):";1;1",$G(PSSNBOR)=1:";1",1:"")
I $G(PSSNBPK)'="O",$G(PSSNBPK)'="I",$G(PSSNBPK)'="U",$G(PSSNBPK)'="X" Q "0;;"_$S($G(PSSNBOR)=1:";1;1",1:"")
N PSSNB1,PSSNBRS,PSSNBSTP,PSSNBIN,PSSNBAPP,PSSNBLOW,PSSNBARR,PSSNBAP1,PSSNBARX,PSSNONE,PSSNS1,PSSNS2,PSSNS3,PSSNS4,PSSNBOF,PSSNBOD,PSSNBOL,PSSNBOA,PSSNBO3
S PSSNBSTP=0,PSSNBLOW=16
S PSSNBRS="0;;"
;package preference sequence defined
I PSSNBPK["O" S PSSNS1="O",PSSNS2="U",PSSNS3="I",PSSNS4="X"
I PSSNBPK["I" S PSSNS1="I",PSSNS2="U",PSSNS3="O",PSSNS4="X"
I PSSNBPK["U" S PSSNS1="U",PSSNS2="I",PSSNS3="O",PSSNS4="X"
I PSSNBPK["X" S PSSNS1="X",PSSNS2="O",PSSNS3="U",PSSNS4="I"
F PSSNB1=0:0 S PSSNB1=$O(^PSDRUG("ASP",PSSNBOI,PSSNB1)) Q:'PSSNB1!(PSSNBSTP) D:'$$DREX
.S PSSNBIN=$P($G(^PSDRUG(PSSNB1,"I")),"^") I PSSNBIN,PSSNBIN'>DT Q
.S PSSNBAPP=$P($G(^PSDRUG(PSSNB1,2)),"^",3)
.S PSSNBAP1=$$GCN
.D APP
S PSSNBARX=$O(PSSNBARR(0))
I PSSNBARX S PSSNBRS=$G(PSSNBARR(PSSNBARX))
I $G(PSSNBOR)=1 D
.I '$P(PSSNBRS,";") S $P(PSSNBRS,";",4)=1 Q
.S PSSNBOF=0 F PSSNBOL=0:0 S PSSNBOL=$O(^PSDRUG("ASP",PSSNBOI,PSSNBOL)) Q:'PSSNBOL!(PSSNBOF) D
..I '$$SUP^PSSDSAPI(PSSNBOL) Q
..S PSSNBO3=$P($G(^PSDRUG(PSSNBOL,2)),"^",3),PSSNBOA=$S(PSSNBPK["I"!(PSSNBPK["U"):1,1:0)
..I PSSNBOA,PSSNBO3'["I",PSSNBO3'["O" Q
..I 'PSSNBOA,PSSNBO3'["O",PSSNBO3'["X" Q
..S PSSNBOD=$P($G(^PSDRUG(PSSNBOL,"I")),"^") I PSSNBOD,PSSNBOD'>DT Q
..S $P(PSSNBRS,";",4)=1,PSSNBOF=1 Q
I $G(PSSNBOR)=1,'$P(PSSNBRS,";") I $$EMSY^PSSDSAPI S $P(PSSNBRS,";",5)=$$EMS I '$P(PSSNBRS,";",5) S $P(PSSNBRS,";",5)=$$EMSX
Q PSSNBRS
;
DREX() ;Quit if drug is exempt from order check
I $G(PSSINCFO)!($G(PSSNBOR)=2) Q $$EXMT^PSSDSAPI(PSSNB1)
Q $$SUP^PSSDSAPI(PSSNB1)
;
EMS() ;Sets piece 5 of output to 1 if CPRS needs to show error message and not do Dose check
I PSSNBPK'="U",PSSNBPK'="I" Q 0
I $$PRE^PSSDSAPK(PSSNBOI,"U")=1 Q 1
Q 0
;
EMSX() ;Sets piece 5 of output to 1 if no active drugs are tied to the orderable Item
N PSSKRC1,PSSKRC2,PSSKRC3,PSSKRC4,PSSKRC9
S (PSSKRC3,PSSKRC9,PSSKRC4)=0
F PSSKRC1=0:0 S PSSKRC1=$O(^PSDRUG("ASP",PSSNBOI,PSSKRC1)) Q:'PSSKRC1!(PSSKRC9) D
.S PSSKRC2=$P($G(^PSDRUG(PSSKRC1,"I")),"^") I PSSKRC2,PSSKRC2'>DT D:'PSSKRC4 Q
..I '$$SUP^PSSDSAPI(PSSKRC1) S PSSKRC4=1
.S PSSKRC3=1
.I '$$SUP^PSSDSAPI(PSSKRC1) S PSSKRC9=1
I 'PSSKRC3,PSSKRC4 S PSSKRC9=1
Q PSSKRC9
;
APP ;
I PSSNBAPP[PSSNS1,$P(PSSNBAP1,";",3) S PSSNBARR(1)=PSSNBAP1,PSSNBSTP=1 Q
Q:PSSNBLOW<2
I PSSNBAPP[PSSNS2,$P(PSSNBAP1,";",3) S PSSNBARR(2)=PSSNBAP1,PSSNBLOW=2 Q
I PSSNBAPP[PSSNS1!(PSSNBAPP[PSSNS2),$P(PSSNBAP1,";",3) S PSSNBARR(1)=PSSNBAP1,PSSNBSTP=1 Q
Q:PSSNBLOW<3
I PSSNBAPP[PSSNS3,$P(PSSNBAP1,";",3) S PSSNBARR(3)=PSSNBAP1,PSSNBLOW=3 Q
Q:PSSNBLOW<4
I PSSNBAPP[PSSNS4,$P(PSSNBAP1,";",3) S PSSNBARR(4)=PSSNBAP1,PSSNBLOW=4 Q
Q:PSSNBLOW<5
I $P(PSSNBAP1,";",3) S PSSNBARR(5)=PSSNBAP1,PSSNBLOW=5 Q
Q:PSSNBLOW<6
I PSSNBAPP[PSSNS1,PSSNBAP1 S PSSNBARR(6)=PSSNBAP1,PSSNBLOW=6 Q
Q:PSSNBLOW<7
I PSSNBAPP[PSSNS2,PSSNBAP1 S PSSNBARR(7)=PSSNBAP1,PSSNBLOW=7 Q
I PSSNBAPP[PSSNS1!(PSSNBAPP[PSSNS2),PSSNBAP1 S PSSNBARR(6)=PSSNBAP1,PSSNBLOW=6,PSSNBSTP=1 Q
Q:PSSNBLOW<8
I PSSNBAPP[PSSNS3,PSSNBAP1 S PSSNBARR(8)=PSSNBAP1,PSSNBLOW=8 Q
Q:PSSNBLOW<9
I PSSNBAPP[PSSNS4,PSSNBAP1 S PSSNBARR(9)=PSSNBAP1,PSSNBLOW=9 Q
Q:PSSNBLOW<10
I $P(PSSNBAP1,";",2) S PSSNBARR(10)=PSSNBAP1,PSSNBLOW=10 Q
Q:PSSNBLOW<11
I PSSNBAPP[PSSNS1 S PSSNBARR(11)=PSSNB1_";;",PSSNBLOW=11 Q
Q:PSSNBLOW<12
I PSSNBAPP[PSSNS2 S PSSNBARR(12)=PSSNB1_";;",PSSNBLOW=12 Q
I PSSNBAPP[PSSNS1!(PSSNBAPP[PSSNS2) S PSSNBARR(11)=PSSNB1_";;",PSSNBLOW=11,PSSNBSTP=1 Q
Q:PSSNBLOW<13
I PSSNBAPP[PSSNS3 S PSSNBARR(13)=PSSNB1_";;",PSSNBLOW=13 Q
Q:PSSNBLOW<14
I PSSNBAPP[PSSNS4 S PSSNBARR(14)=PSSNB1_";;",PSSNBLOW=14 Q
Q:PSSNBLOW<15
I PSSNBAP1 S PSSNBARR(15)=PSSNBAP1,PSSNBLOW=15 Q
Q:PSSNBLOW<16
S PSSNBARR(16)=PSSNB1_";;",PSSNBLOW=16
Q
;
GCN() ;Returns drug matching information
N PSSNBGC1,PSSNBGC3,PSSNBGRS
S PSSNBGC1=$P($G(^PSDRUG(PSSNB1,"ND")),"^"),PSSNBGC3=$P($G(^PSDRUG(PSSNB1,"ND")),"^",3)
I 'PSSNBGC1!('PSSNBGC3) Q 0
S PSSNBGRS=$$PROD0^PSNAPIS(PSSNBGC1,PSSNBGC3)
I $P(PSSNBGRS,"^",7) Q PSSNB1_";"_PSSNBGC1_";"_$P(PSSNBGRS,"^",7)
Q PSSNB1_";"_PSSNBGC1
;
;
MLT ;Multi Ingredient check called from PSSDSAPD
D ITEM^PSSDSAPK D:'PSSDBFAL NUM^PSSDSAPL D:'PSSDBFAL RANGE^PSSDSUTL
I 'PSSDBFAL,PSSDSLCT S PSSDSLCL=PSSDSLC1(PSSDSLCT),PSSDSLCT=PSSDSLCT-1 G MLT
I '$G(PSSDBIFG) Q
N PSSMLT1,PSSMLT2,PSSMLT3,DA
S PSSMLT1=$P($G(^PSDRUG(PSSDBIFG,"ND")),"^"),PSSMLT3=$P($G(^PSDRUG(PSSDBIFG,"ND")),"^",3)
I 'PSSMLT1!('PSSMLT3) D MLTS Q
I $G(PSSDBAR("UNIT"))'="",$G(PSSDBAR("AMN"))'="",'$$MLTOK^PSSDSUTL(PSSMLT1,PSSMLT3) Q
S PSSMLT2=$$TLS^PSSDSAPA(PSSMLT1,PSSMLT3) I PSSMLT2 D MLTS Q
Q
;
;
MLTS ;
K PSSDBAR("AMN"),PSSDBAR("UNIT")
S PSSDBCAZ(PSSDBFDB(PSSDBLP,"RX_NUM"),"MUING")=""
Q
;
;
MLTNO ;
I $D(PSSDBCAZ(PSSDBKLP,"MUING")) S $P(PSSDBCAR(PSSDBKLP),"^",7)=1
Q
;
;
MLTNP ;
I $D(PSSDBCAZ(PSSDBRLS,"MUING")) S $P(PSSDBCAR(PSSDBRLS),"^",7)=1
Q
;
;
FDRUG ; Find drug, called from PSSDSAPD
N PSSINCFO S PSSINCFO=1
S PSSDBIFL=1,PSSDBIFG=$$DRG^PSSDSAPK(PSSDBFDB("OI"),$G(PSSDBFDB("PACKAGE")),$G(PSSDBDS(PSSDBLP,"MR_IEN")),$G(PSSDBFDB("OI_USAGE")))
I 'PSSDBIFG S PSSDBIFG=$$DRG(PSSDBFDB("OI"),$G(PSSDBFDB("PACKAGE"))) S PSSDBCAZ(PSSDBFDB(PSSDBLP,"RX_NUM"),"NO_DRUG")="" S PSSDBIFG=$P(PSSDBIFG,";")
Q
;
;
INERR ;Set OI error
N PSSNOOIX
S PSSNOOIX=$G(PSSDBFDB(PSSDBLP,"OI_ERROR",PSSDBFDB(PSSDBLP,"DRUG_NM")))
I PSSNOOIX'="" S ^TMP($J,PSSDBASE,"IN","EXCEPTIONS","OI",PSSDBFDB(PSSDBLP,"DRUG_NM"))=$P(PSSNOOIX,"^")_"^"_$P(PSSNOOIX,"^",2),PSSENO=1 D STDB
Q
;
;
FRQE ;Set Frequency error called from PSSDSAPD
D INFERR^PSSDSAPK,FRDR^PSSDSAPK I $D(PSSDBFDB(PSSDBLP,"FRQ_ERROR")) S PSSDBCAZ(PSSDBFDB(PSSDBLP,"RX_NUM"),"FRQ_ERROR")=""
Q
;
;
INFUE ;Set Infusion rate error from PSSDSAPD
I $D(PSSDBFDB(PSSDBLP,"INF_ERROR")) S PSSDBCAZ(PSSDBFDB(PSSDBLP,"RX_NUM"),"INF_ERROR")=""
Q
;
;
ERST ;Set Dosing Sequences into error summary list
N PSSWSB1,PSSWSB2
F PSSDBEQ3=0:0 S PSSDBEQ3=$O(PSSDBEQ2(PSSDBEQ3)) Q:'PSSDBEQ3 S PSSDBCAX(PSSDBRLS,PSSDBEQ3)="" I $O(PSSDBXAX(PSSDBEQ3,""))'="",$E(PSSDBASE,1,3)'="PSJ" D
.S PSSWSB1="",PSSWSB2=0 F S PSSWSB1=$O(PSSDBXAX(PSSDBEQ3,PSSWSB1)) Q:PSSWSB1=""!($G(PSSDBCAX(PSSDBRLS,PSSDBEQ3))["All") S PSSWSB2=PSSWSB2+1 D
..I PSSDBEQ3=5!(PSSDBEQ3=6)!(PSSDBEQ3=8) S PSSDBCAX(PSSDBRLS,PSSDBEQ3)=" (All" Q
..I PSSWSB2=1 S PSSDBCAX(PSSDBRLS,PSSDBEQ3)=" (DOSE SEQ "_$P(PSSWSB1,";",4) Q
..S PSSDBCAX(PSSDBRLS,PSSDBEQ3)=PSSDBCAX(PSSDBRLS,PSSDBEQ3)_", "_$P(PSSWSB1,";",4)
.S PSSDBCAX(PSSDBRLS,PSSDBEQ3)=PSSDBCAX(PSSDBRLS,PSSDBEQ3)_")"
Q
;
;
PAT ;
N DFN,VADM,VAPTYP,VAHOW,VAROOT,VAERR,VA,X1,X2,X,%Y,PSSDBWT,PSSDBWTX,PSSDBHT,PSSDBHTX,GMRVSTR,PSSDBBSA,PSSDBATX
S DFN=PSSDBDFN,PSSDBATX=0
D DEM^VADPT
K X S X2=$P(VADM(3),"^"),X1=DT I X1,X2 D ^%DTC S PSSDBATX=X
S ^TMP($J,PSSDBASE,"IN","DOSE","AGE")=PSSDBATX
S DFN=PSSDBDFN
S (PSSDBWTX,PSSDBHTX,PSSDBBSA)=0
S GMRVSTR="WT" K X D EN6^GMRVUTL
S PSSDBWT=$P(X,"^",8) I PSSDBWT S PSSDBWTX=PSSDBWT/2.2
S ^TMP($J,PSSDBASE,"IN","DOSE","WT")=$G(PSSDBWTX)
S DFN=PSSDBDFN
S GMRVSTR="HT" K X D EN6^GMRVUTL
S PSSDBHT=$P(X,"^",8) I PSSDBHT S PSSDBHTX=.0254*PSSDBHT
;Using DuBios formula for BSA calculation, and sending in 2 decimal places
I $G(PSSDBWTX),$G(PSSDBHTX) S PSSDBBSA=.20247*(PSSDBHTX**.725)*(PSSDBWTX**.425)
;I $G(PSSDBWTX),$G(PSSDBHTX) S PSSDBBSA=$J((((PSSDBWTX*PSSDBHTX)/3600)**.5),0,2) Mosteller BSA Formula
S ^TMP($J,PSSDBASE,"IN","DOSE","BSA")=$G(PSSDBBSA)
Q
;
;
ADDCT ;Add counter to output globals so data appears in correct order for more than 9 Dosing Sequences
;I PSSDBASA D ADDCTA ;Remove comment when CPRS is ready to convert to new output, to show messages in Sequence order
I PSSDBASB D ADDCTB
Q
;
;
ADDCTA ;Add counter to CPRS global
;I '$D(^TMP($J,PSSDBASF)) Q
;N PSSJW1,PSSJW2,PSSJW3,PSSJW4,PSSJW5,PSSJW6
;K ^TMP($J,"PSSJWTM1") M ^TMP($J,"PSSJWTM1")=^TMP($J,PSSDBASF) K ^TMP($J,PSSDBASF)
;
;S PSSJW1="" F S PSSJW1=$O(^TMP($J,"PSSJWTM1","OUT","DOSE","ERROR",PSSJW1)) Q:PSSJW1="" D
;.S PSSJW2="" F S PSSJW2=$O(^TMP($J,"PSSJWTM1","OUT","DOSE","ERROR",PSSJW1,PSSJW2)) Q:PSSJW2="" D
;..S PSSJW3=$P(PSSJW1,";",4)
;..S PSSJW4=$G(^TMP($J,"PSSJWTM1","OUT","DOSE","ERROR",PSSJW1,PSSJW2,"MSG"))
;..S PSSJW5=$G(^TMP($J,"PSSJWTM1","OUT","DOSE","ERROR",PSSJW1,PSSJW2,"TEXT"))
;..I $D(^TMP($J,"PSSJWTM1","OUT","DOSE","ERROR",PSSJW1,PSSJW2,"MSG")) S ^TMP($J,PSSDBASF,"OUT","DOSE","ERROR",PSSJW3,PSSJW1,PSSJW2,"MSG")=PSSJW4
;..I $D(^TMP($J,"PSSJWTM1","OUT","DOSE","ERROR",PSSJW1,PSSJW2,"TEXT")) S ^TMP($J,PSSDBASF,"OUT","DOSE","ERROR",PSSJW3,PSSJW1,PSSJW2,"TEXT")=PSSJW5
;
;S PSSJW1="" F S PSSJW1=$O(^TMP($J,"PSSJWTM1","OUT","EXCEPTIONS","DOSE",PSSJW1)) Q:PSSJW1="" D
;.S PSSJW2="" F S PSSJW2=$O(^TMP($J,"PSSJWTM1","OUT","EXCEPTIONS","DOSE",PSSJW1,PSSJW2)) Q:PSSJW2="" D
;..S PSSJW3=$P(PSSJW1,";",4)
;..S PSSJW4=$G(^TMP($J,"PSSJWTM1","OUT","EXCEPTIONS","DOSE",PSSJW1,PSSJW2))
;..S ^TMP($J,PSSDBASF,"OUT","EXCEPTIONS","DOSE",PSSJW3,PSSJW1,PSSJW2)=PSSJW4
;
;S PSSJW1="" F S PSSJW1=$O(^TMP($J,"PSSJWTM1","OUT","DOSE",PSSJW1)) Q:PSSJW1="" I PSSJW1'="ERROR" D
;.S PSSJW2="" F S PSSJW2=$O(^TMP($J,"PSSJWTM1","OUT","DOSE",PSSJW1,PSSJW2)) Q:PSSJW2="" D
;..S PSSJW3="" F S PSSJW3=$O(^TMP($J,"PSSJWTM1","OUT","DOSE",PSSJW1,PSSJW2,PSSJW3)) Q:PSSJW3="" D
;...S PSSJW4="" F S PSSJW4=$O(^TMP($J,"PSSJWTM1","OUT","DOSE",PSSJW1,PSSJW2,PSSJW3,"MESSAGE",PSSJW4)) Q:PSSJW4="" D
;....S PSSJW5=$P(PSSJW1,";",4)
;....S PSSJW6=$G(^TMP($J,"PSSJWTM1","OUT","DOSE",PSSJW1,PSSJW2,PSSJW3,"MESSAGE",PSSJW4))
;....S ^TMP($J,PSSDBASF,"OUT","DOSE",PSSJW5,PSSJW1,PSSJW2,PSSJW3,"MESSAGE",PSSJW4)=PSSJW6
;
;K ^TMP($J,"PSSJWTM1")
;Q
;
;
ADDCTB ;Add counter to Pharmacy global
I '$D(^TMP($J,PSSDBASG)) Q
N PSSJW7,PSSJW8,PSSJW9,PSSJWNUM,PSSJWVAL,PSSJW56,PSSJW57
K ^TMP($J,"PSSJWTM2") M ^TMP($J,"PSSJWTM2")=^TMP($J,PSSDBASG) K ^TMP($J,PSSDBASG)
;
S PSSJW7="" F S PSSJW7=$O(^TMP($J,"PSSJWTM2","OUT",PSSJW7)) Q:PSSJW7="" D
.S PSSJWNUM=$P(PSSJW7,";",4)
.S PSSJW8="" F S PSSJW8=$O(^TMP($J,"PSSJWTM2","OUT",PSSJW7,"ERROR",PSSJW8)) Q:PSSJW8="" D
..I $D(^TMP($J,"PSSJWTM2","OUT",PSSJW7,"ERROR",PSSJW8,"MSG")) S ^TMP($J,PSSDBASG,"OUT",PSSJWNUM,PSSJW7,"ERROR",PSSJW8,"MSG")=$G(^TMP($J,"PSSJWTM2","OUT",PSSJW7,"ERROR",PSSJW8,"MSG"))
..I $D(^TMP($J,"PSSJWTM2","OUT",PSSJW7,"ERROR",PSSJW8,"TEXT")) S ^TMP($J,PSSDBASG,"OUT",PSSJWNUM,PSSJW7,"ERROR",PSSJW8,"TEXT")=$G(^TMP($J,"PSSJWTM2","OUT",PSSJW7,"ERROR",PSSJW8,"TEXT"))
..I $G(^TMP($J,"PSSJWTM2","OUT",PSSJW7,"ERROR",PSSJW8,"WARN"))="Warning" S ^TMP($J,PSSDBASG,"OUT",PSSJWNUM,PSSJW7,"ERROR",PSSJW8,"WARN")="Warning"
.;
.S PSSJW8="" F S PSSJW8=$O(^TMP($J,"PSSJWTM2","OUT",PSSJW7,"EXCEPTIONS",PSSJW8)) Q:PSSJW8="" D
..S PSSJW9=$G(^TMP($J,"PSSJWTM2","OUT",PSSJW7,"EXCEPTIONS",PSSJW8))
..S ^TMP($J,PSSDBASG,"OUT",PSSJWNUM,PSSJW7,"EXCEPTIONS",PSSJW8)=PSSJW9
.;
.S PSSJW8="" F S PSSJW8=$O(^TMP($J,"PSSJWTM2","OUT",PSSJW7,"MESSAGE",PSSJW8)) Q:PSSJW8="" D
..S PSSJW9="" F S PSSJW9=$O(^TMP($J,"PSSJWTM2","OUT",PSSJW7,"MESSAGE",PSSJW8,PSSJW9)) Q:PSSJW9="" D
...I +PSSJW8=3 D Q
....S PSSJW56="" F S PSSJW56=$O(^TMP($J,"PSSJWTM2","OUT",PSSJW7,"MESSAGE",PSSJW8,PSSJW9,PSSJW56)) Q:PSSJW56="" D
.....S PSSJW57=$G(^TMP($J,"PSSJWTM2","OUT",PSSJW7,"MESSAGE",PSSJW8,PSSJW9,PSSJW56))
.....S ^TMP($J,PSSDBASG,"OUT",PSSJWNUM,PSSJW7,"MESSAGE",PSSJW8,PSSJW9,PSSJW56)=PSSJW57
...S PSSJWVAL=$G(^TMP($J,"PSSJWTM2","OUT",PSSJW7,"MESSAGE",PSSJW8,PSSJW9))
...S ^TMP($J,PSSDBASG,"OUT",PSSJWNUM,PSSJW7,"MESSAGE",PSSJW8,PSSJW9)=PSSJWVAL
;
K ^TMP($J,"PSSJWTM2")
Q
;
;
DSP(PSSDBDS,PSSDBFDB) ;Return Dose and Dose Unit to Inpatient for complex order display
;Return value set into parameter 1 as "DRG_DISP"
N PSSDBAR,PSSINDSP,PSSIND1,PSSIND2,PSSIND3,PSSDSLCL,PSSDBNOD,PSSDBXP,PSSDBLPD,PSSDSXTD,PSSDBNT,PSSDBFAL,PSSDBLP,PSSDBIFL,PSSDSLCT,PSSDSLC1
S PSSDBLP="" F S PSSDBLP=$O(PSSDBDS(PSSDBLP)) Q:PSSDBLP="" D
.S PSSINDSP="",(PSSDBLPD,PSSDBFAL,PSSDBIFL,PSSDSLCT)=0 K PSSDBAR
.I $D(PSSDBFDB(PSSDBLP,"DOSE_AMT")),$D(PSSDBFDB(PSSDBLP,"DOSE_UNIT")) S PSSINDSP=PSSDBFDB(PSSDBLP,"DOSE_AMT")_"^"_PSSDBFDB(PSSDBLP,"DOSE_UNIT") D DSPL Q
.I $G(PSSDBDS(PSSDBLP,"DRG_AMT")),$G(PSSDBDS(PSSDBLP,"DRG_UNIT"))'="" D
..S PSSIND1=$S(PSSDBDS(PSSDBLP,"DRG_UNIT")["/":$P(PSSDBDS(PSSDBLP,"DRG_UNIT"),"/"),1:PSSDBDS(PSSDBLP,"DRG_UNIT"))
..S PSSIND1=$$UP^XLFSTR(PSSIND1)
..S PSSIND2=$$UNIT^PSSDSAPI(PSSIND1)
..I PSSIND2'="" S PSSINDSP=PSSDBDS(PSSDBLP,"DRG_AMT")_"^"_PSSIND2 D DSPL S PSSDBFAL=1
.I PSSDBFAL Q
.I '$G(PSSDBFDB(PSSDBLP,"DRUG_IEN")) S PSSDBDS(PSSDBLP,"DRG_DISP")="" Q
.;"DOSE" Node should only come from CPRS, for selected Local Possible Dosage
.S PSSDSLCL=$S($G(PSSDBDS(PSSDBLP,"DOSE"))'="":$P($G(PSSDBDS(PSSDBLP,"DOSE")),"&",5),1:$G(PSSDBDS(PSSDBLP,"DO")))
.I PSSDSLCL="" S PSSDBDS(PSSDBLP,"DRG_DISP")="" Q
.I PSSDSLCL["(" D PTH^PSSDSUTL
.D DSPRT
Q
;
DSPRT ;Line Tag added for retry if Free Text Dosage contains parenthesis
S PSSIND3=0
F PSSDBXP=0:0 S PSSDBXP=$O(^PSDRUG(PSSDBFDB(PSSDBLP,"DRUG_IEN"),"DOS2",PSSDBXP)) Q:'PSSDBXP!(PSSIND3) D
.S PSSDBNOD=$G(^PSDRUG(PSSDBFDB(PSSDBLP,"DRUG_IEN"),"DOS2",PSSDBXP,0))
.I $$MTCH^PSSDSAPK S PSSDBLPD=1 I $P(PSSDBNOD,"^",5),$P(PSSDBNOD,"^",6)'="" D
..S PSSDSXTD=+$P(PSSDBNOD,"^",5) I PSSDSXTD,$$SCREEN^XTID(51.24,.01,PSSDSXTD_",") Q
..S PSSDBNT=$P($G(^PS(51.24,+$P(PSSDBNOD,"^",5),0)),"^",2)
..I PSSDBNT'="" S PSSINDSP=$P(PSSDBNOD,"^",6)_"^"_PSSDBNT,(PSSIND3,PSSDBFAL)=1
I PSSDBFAL D DSPL Q
I PSSDBLPD D DPOP^PSSDSAPK I PSSDBFAL S PSSINDSP=PSSDBAR("AMN")_"^"_PSSDBAR("UNIT") D DSPL Q
D ITEM^PSSDSAPK I PSSDBFAL S PSSINDSP=PSSDBAR("AMN")_"^"_PSSDBAR("UNIT") D DSPL Q
D NUM^PSSDSAPL I PSSDBFAL S PSSINDSP=PSSDBAR("AMN")_"^"_PSSDBAR("UNIT") D DSPL Q
D RANGE^PSSDSUTL I PSSDBFAL S PSSINDSP=PSSDBAR("AMN")_"^"_PSSDBAR("UNIT") D DSPL Q
I 'PSSDBFAL,PSSDSLCT S PSSDSLCL=PSSDSLC1(PSSDSLCT),PSSDSLCT=PSSDSLCT-1,PSSDBLPD=0 G DSPRT
S PSSDBDS(PSSDBLP,"DRG_DISP")=""
Q
;
;
DSPL ;Add leading zero
I $E(PSSINDSP)="." S PSSINDSP="0"_PSSINDSP
S PSSDBDS(PSSDBLP,"DRG_DISP")=PSSINDSP
Q
;
;
NXDRUG ;No Drug found
I $G(PSSDBFDB("PACKAGE"))="X",$$DLTM^PSSDSAPI(PSSDBFDB("OI")) K ^TMP($J,PSSDBASE,"IN","EXCEPTIONS","OI",PSSDBFDB(PSSDBLP,"DRUG_NM")),PSSDBCAZ(PSSDBFDB(PSSDBLP,"RX_NUM"),"NO_DRUG") Q
I $D(^TMP($J,PSSDBASE,"IN","EXCEPTIONS","OI",PSSDBFDB(PSSDBLP,"DRUG_NM"))) D DPL^PSSDSAPK Q
I PSSDSIVF S ^TMP($J,PSSDBASE,"IN","EXCEPTIONS","OI",PSSDBFDB(PSSDBLP,"DRUG_NM"))="4^"_PSSDBFDB(PSSDBLP,"RX_NUM") D STDB Q
S ^TMP($J,PSSDBASE,"IN","EXCEPTIONS","DOSE",PSSDBFDB(PSSDBLP,"RX_NUM"))="1^"_PSSDBFDB(PSSDBLP,"DRUG_NM") D STDB
Q
;
;
STDB ;Set PSSDBCAR array for Input Exceptions
S PSSDBCAR(PSSDBFDB(PSSDBLP,"RX_NUM"))="B^"_PSSDBFDB(PSSDBLP,"DRUG_NM")
S $P(PSSDBCAR(PSSDBFDB(PSSDBLP,"RX_NUM")),"^",18)=1,$P(PSSDBCAR(PSSDBFDB(PSSDBLP,"RX_NUM")),"^",13)=1
;S PSSENHKZ(PSSDBFDB(PSSDBLP,"RX_NUM"))=1
D DPL^PSSDSAPK
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSSDSAPM 18635 printed Sep 23, 2025@20:06:49 Page 2
PSSDSAPM ;BIR/RTR-Dose Check utilities routine ;09/13/10
+1 ;;1.0;PHARMACY DATA MANAGEMENT;**117,168,160,173,201,178**;9/30/97;Build 14
+2 ;
+3 ;
+4 ;DRG - returns best Dispense Drug to use for Order Checks when only the Orderable Item is available
+5 ;Input:
+6 ; PSSNBOI - Pharmacy orderable Item from #50.7
+7 ; PSSNBPK - package Use, I for Inpatient, O for Outpatient, X for Non-VA Meds
+8 ; PSSNBOR - defined only if being called from CPRS, 1 for Enhanced Order Checks, 2 for Dosing
+9 ;Output:
+10 ; nnn;nnn;nnnn - First piece is File 50 Internal Number, Second piece is VA Generic Internal number, Third piece
+11 ; will be the GCNSEQNO number. Piece 1 ';' is 0 if no drug found.
+12 ; Piece 2 will be null if drug not matched to National Drug File
+13 ; Piece 3 will be the GCNSEQNO number, if the NDF match has a GCNSEQNO number
+14 ; Piece 4 is returned as 1 if the call is from CPRS for enhanced order checks, and it indicates no drug was returned
+15 ; or a drug was returned, but there is an active supply tied to the Orderable Item, indicating CPRS should also do
+16 ; the duplicate supply check
+17 ; Piece 5 is returned as 1 if CPRS is getting a drug for the Enhanced Order Checks call, and they should
+18 ; display the error message for all order checks and not do the Dosing call
+19 ;
+20 ;
+21 ;hierarchy: (Drug must be active)
+22 ;1 - Exact Package Match, matched to NDF with GCNSEQNO
+23 ;2 - No package match, but second choice package exists, matched to NDF with GCNSEQNO
+24 ;3 - No package match, but third choice package exists, matched to NDF with GCNSEQNO
+25 ;4 - No package match, but fourth choice package exists, matched to NDF with GCNSEQNO
+26 ;5 - No package match, matched to NDF with GCNSEQNO
+27 ;6 - Exact Package Match, matched to NDF with no GCNSEQNO
+28 ;7 - No package match, but second choice package exists, matched to NDF with no GCNSEQNO
+29 ;8 - No package match, but third choice package exists, matched to NDF with no GCNSEQNO
+30 ;9 - No package match, but fourth choice package exists, matched to NDF with no GCNSEQNO
+31 ;10 - No package match, matched to NDF with no GCNSEQNO
+32 ;11 - Exact Package Match, not matched to NDF
+33 ;12 - No package match, but second choice package exists, not matched to NDF
+34 ;13 - No package match, but third choice package exists, not matched to NDF
+35 ;14 - No package match, but fourth choice package exists, not matched to NDF
+36 ;15 - No package match, package is null or some other package that is not one of the 4 primary packages (O, I U, X), matched to NDF
+37 ;16 - No package match, not matched to NDF, package is null or some other package that is not one of the 4 primary packages (O, I U, X)
+38 ;
+39 ;** CPRS and Inpatient always passes in "I" for PSSNBPK variable, so drugs with "I" and "U" application packages are
+40 ; evaluated as either or in the APP subroutine. In the hierarchy above 1 or 2, 6 or 7 and 11 or 12 are
+41 ; considered to be exact matches. Outpatient evaluates "I" and "U" separately.
+42 ;
+43 ;Second/Third Choice packages:
+44 ;Outpatient - U for Unit dose, I for IV, then X for Non-VA med
+45 ;Inpatient - O for outpatient then X
+46 ;Non-VA Meds - O, U then I
+47 ;
+48 ;PSNBLOW holds current number in array, only reset array entry if lower number is found
+49 ;PSSNBSTP stops the loop because you found the best possible drug, no need to set PSSNBLOW in this case
+50 ;
+51 ;
DRG(PSSNBOI,PSSNBPK,PSSNBOR) ;
+1 IF '$GET(PSSNBOI)
QUIT "0;;"_$SELECT($GET(PSSNBOR)=1&($GET(PSSNBPK)="I"!($GET(PSSNBPK)="U")):";1;1",$GET(PSSNBOR)=1:";1",1:"")
+2 IF $GET(PSSNBPK)'="O"
IF $GET(PSSNBPK)'="I"
IF $GET(PSSNBPK)'="U"
IF $GET(PSSNBPK)'="X"
QUIT "0;;"_$SELECT($GET(PSSNBOR)=1:";1;1",1:"")
+3 NEW PSSNB1,PSSNBRS,PSSNBSTP,PSSNBIN,PSSNBAPP,PSSNBLOW,PSSNBARR,PSSNBAP1,PSSNBARX,PSSNONE,PSSNS1,PSSNS2,PSSNS3,PSSNS4,PSSNBOF,PSSNBOD,PSSNBOL,PSSNBOA,PSSNBO3
+4 SET PSSNBSTP=0
SET PSSNBLOW=16
+5 SET PSSNBRS="0;;"
+6 ;package preference sequence defined
+7 IF PSSNBPK["O"
SET PSSNS1="O"
SET PSSNS2="U"
SET PSSNS3="I"
SET PSSNS4="X"
+8 IF PSSNBPK["I"
SET PSSNS1="I"
SET PSSNS2="U"
SET PSSNS3="O"
SET PSSNS4="X"
+9 IF PSSNBPK["U"
SET PSSNS1="U"
SET PSSNS2="I"
SET PSSNS3="O"
SET PSSNS4="X"
+10 IF PSSNBPK["X"
SET PSSNS1="X"
SET PSSNS2="O"
SET PSSNS3="U"
SET PSSNS4="I"
+11 FOR PSSNB1=0:0
SET PSSNB1=$ORDER(^PSDRUG("ASP",PSSNBOI,PSSNB1))
if 'PSSNB1!(PSSNBSTP)
QUIT
if '$$DREX
Begin DoDot:1
+12 SET PSSNBIN=$PIECE($GET(^PSDRUG(PSSNB1,"I")),"^")
IF PSSNBIN
IF PSSNBIN'>DT
QUIT
+13 SET PSSNBAPP=$PIECE($GET(^PSDRUG(PSSNB1,2)),"^",3)
+14 SET PSSNBAP1=$$GCN
+15 DO APP
End DoDot:1
+16 SET PSSNBARX=$ORDER(PSSNBARR(0))
+17 IF PSSNBARX
SET PSSNBRS=$GET(PSSNBARR(PSSNBARX))
+18 IF $GET(PSSNBOR)=1
Begin DoDot:1
+19 IF '$PIECE(PSSNBRS,";")
SET $PIECE(PSSNBRS,";",4)=1
QUIT
+20 SET PSSNBOF=0
FOR PSSNBOL=0:0
SET PSSNBOL=$ORDER(^PSDRUG("ASP",PSSNBOI,PSSNBOL))
if 'PSSNBOL!(PSSNBOF)
QUIT
Begin DoDot:2
+21 IF '$$SUP^PSSDSAPI(PSSNBOL)
QUIT
+22 SET PSSNBO3=$PIECE($GET(^PSDRUG(PSSNBOL,2)),"^",3)
SET PSSNBOA=$SELECT(PSSNBPK["I"!(PSSNBPK["U"):1,1:0)
+23 IF PSSNBOA
IF PSSNBO3'["I"
IF PSSNBO3'["O"
QUIT
+24 IF 'PSSNBOA
IF PSSNBO3'["O"
IF PSSNBO3'["X"
QUIT
+25 SET PSSNBOD=$PIECE($GET(^PSDRUG(PSSNBOL,"I")),"^")
IF PSSNBOD
IF PSSNBOD'>DT
QUIT
+26 SET $PIECE(PSSNBRS,";",4)=1
SET PSSNBOF=1
QUIT
End DoDot:2
End DoDot:1
+27 IF $GET(PSSNBOR)=1
IF '$PIECE(PSSNBRS,";")
IF $$EMSY^PSSDSAPI
SET $PIECE(PSSNBRS,";",5)=$$EMS
IF '$PIECE(PSSNBRS,";",5)
SET $PIECE(PSSNBRS,";",5)=$$EMSX
+28 QUIT PSSNBRS
+29 ;
DREX() ;Quit if drug is exempt from order check
+1 IF $GET(PSSINCFO)!($GET(PSSNBOR)=2)
QUIT $$EXMT^PSSDSAPI(PSSNB1)
+2 QUIT $$SUP^PSSDSAPI(PSSNB1)
+3 ;
EMS() ;Sets piece 5 of output to 1 if CPRS needs to show error message and not do Dose check
+1 IF PSSNBPK'="U"
IF PSSNBPK'="I"
QUIT 0
+2 IF $$PRE^PSSDSAPK(PSSNBOI,"U")=1
QUIT 1
+3 QUIT 0
+4 ;
EMSX() ;Sets piece 5 of output to 1 if no active drugs are tied to the orderable Item
+1 NEW PSSKRC1,PSSKRC2,PSSKRC3,PSSKRC4,PSSKRC9
+2 SET (PSSKRC3,PSSKRC9,PSSKRC4)=0
+3 FOR PSSKRC1=0:0
SET PSSKRC1=$ORDER(^PSDRUG("ASP",PSSNBOI,PSSKRC1))
if 'PSSKRC1!(PSSKRC9)
QUIT
Begin DoDot:1
+4 SET PSSKRC2=$PIECE($GET(^PSDRUG(PSSKRC1,"I")),"^")
IF PSSKRC2
IF PSSKRC2'>DT
if 'PSSKRC4
Begin DoDot:2
+5 IF '$$SUP^PSSDSAPI(PSSKRC1)
SET PSSKRC4=1
End DoDot:2
QUIT
+6 SET PSSKRC3=1
+7 IF '$$SUP^PSSDSAPI(PSSKRC1)
SET PSSKRC9=1
End DoDot:1
+8 IF 'PSSKRC3
IF PSSKRC4
SET PSSKRC9=1
+9 QUIT PSSKRC9
+10 ;
APP ;
+1 IF PSSNBAPP[PSSNS1
IF $PIECE(PSSNBAP1,";",3)
SET PSSNBARR(1)=PSSNBAP1
SET PSSNBSTP=1
QUIT
+2 if PSSNBLOW<2
QUIT
+3 IF PSSNBAPP[PSSNS2
IF $PIECE(PSSNBAP1,";",3)
SET PSSNBARR(2)=PSSNBAP1
SET PSSNBLOW=2
QUIT
+4 IF PSSNBAPP[PSSNS1!(PSSNBAPP[PSSNS2)
IF $PIECE(PSSNBAP1,";",3)
SET PSSNBARR(1)=PSSNBAP1
SET PSSNBSTP=1
QUIT
+5 if PSSNBLOW<3
QUIT
+6 IF PSSNBAPP[PSSNS3
IF $PIECE(PSSNBAP1,";",3)
SET PSSNBARR(3)=PSSNBAP1
SET PSSNBLOW=3
QUIT
+7 if PSSNBLOW<4
QUIT
+8 IF PSSNBAPP[PSSNS4
IF $PIECE(PSSNBAP1,";",3)
SET PSSNBARR(4)=PSSNBAP1
SET PSSNBLOW=4
QUIT
+9 if PSSNBLOW<5
QUIT
+10 IF $PIECE(PSSNBAP1,";",3)
SET PSSNBARR(5)=PSSNBAP1
SET PSSNBLOW=5
QUIT
+11 if PSSNBLOW<6
QUIT
+12 IF PSSNBAPP[PSSNS1
IF PSSNBAP1
SET PSSNBARR(6)=PSSNBAP1
SET PSSNBLOW=6
QUIT
+13 if PSSNBLOW<7
QUIT
+14 IF PSSNBAPP[PSSNS2
IF PSSNBAP1
SET PSSNBARR(7)=PSSNBAP1
SET PSSNBLOW=7
QUIT
+15 IF PSSNBAPP[PSSNS1!(PSSNBAPP[PSSNS2)
IF PSSNBAP1
SET PSSNBARR(6)=PSSNBAP1
SET PSSNBLOW=6
SET PSSNBSTP=1
QUIT
+16 if PSSNBLOW<8
QUIT
+17 IF PSSNBAPP[PSSNS3
IF PSSNBAP1
SET PSSNBARR(8)=PSSNBAP1
SET PSSNBLOW=8
QUIT
+18 if PSSNBLOW<9
QUIT
+19 IF PSSNBAPP[PSSNS4
IF PSSNBAP1
SET PSSNBARR(9)=PSSNBAP1
SET PSSNBLOW=9
QUIT
+20 if PSSNBLOW<10
QUIT
+21 IF $PIECE(PSSNBAP1,";",2)
SET PSSNBARR(10)=PSSNBAP1
SET PSSNBLOW=10
QUIT
+22 if PSSNBLOW<11
QUIT
+23 IF PSSNBAPP[PSSNS1
SET PSSNBARR(11)=PSSNB1_";;"
SET PSSNBLOW=11
QUIT
+24 if PSSNBLOW<12
QUIT
+25 IF PSSNBAPP[PSSNS2
SET PSSNBARR(12)=PSSNB1_";;"
SET PSSNBLOW=12
QUIT
+26 IF PSSNBAPP[PSSNS1!(PSSNBAPP[PSSNS2)
SET PSSNBARR(11)=PSSNB1_";;"
SET PSSNBLOW=11
SET PSSNBSTP=1
QUIT
+27 if PSSNBLOW<13
QUIT
+28 IF PSSNBAPP[PSSNS3
SET PSSNBARR(13)=PSSNB1_";;"
SET PSSNBLOW=13
QUIT
+29 if PSSNBLOW<14
QUIT
+30 IF PSSNBAPP[PSSNS4
SET PSSNBARR(14)=PSSNB1_";;"
SET PSSNBLOW=14
QUIT
+31 if PSSNBLOW<15
QUIT
+32 IF PSSNBAP1
SET PSSNBARR(15)=PSSNBAP1
SET PSSNBLOW=15
QUIT
+33 if PSSNBLOW<16
QUIT
+34 SET PSSNBARR(16)=PSSNB1_";;"
SET PSSNBLOW=16
+35 QUIT
+36 ;
GCN() ;Returns drug matching information
+1 NEW PSSNBGC1,PSSNBGC3,PSSNBGRS
+2 SET PSSNBGC1=$PIECE($GET(^PSDRUG(PSSNB1,"ND")),"^")
SET PSSNBGC3=$PIECE($GET(^PSDRUG(PSSNB1,"ND")),"^",3)
+3 IF 'PSSNBGC1!('PSSNBGC3)
QUIT 0
+4 SET PSSNBGRS=$$PROD0^PSNAPIS(PSSNBGC1,PSSNBGC3)
+5 IF $PIECE(PSSNBGRS,"^",7)
QUIT PSSNB1_";"_PSSNBGC1_";"_$PIECE(PSSNBGRS,"^",7)
+6 QUIT PSSNB1_";"_PSSNBGC1
+7 ;
+8 ;
MLT ;Multi Ingredient check called from PSSDSAPD
+1 DO ITEM^PSSDSAPK
if 'PSSDBFAL
DO NUM^PSSDSAPL
if 'PSSDBFAL
DO RANGE^PSSDSUTL
+2 IF 'PSSDBFAL
IF PSSDSLCT
SET PSSDSLCL=PSSDSLC1(PSSDSLCT)
SET PSSDSLCT=PSSDSLCT-1
GOTO MLT
+3 IF '$GET(PSSDBIFG)
QUIT
+4 NEW PSSMLT1,PSSMLT2,PSSMLT3,DA
+5 SET PSSMLT1=$PIECE($GET(^PSDRUG(PSSDBIFG,"ND")),"^")
SET PSSMLT3=$PIECE($GET(^PSDRUG(PSSDBIFG,"ND")),"^",3)
+6 IF 'PSSMLT1!('PSSMLT3)
DO MLTS
QUIT
+7 IF $GET(PSSDBAR("UNIT"))'=""
IF $GET(PSSDBAR("AMN"))'=""
IF '$$MLTOK^PSSDSUTL(PSSMLT1,PSSMLT3)
QUIT
+8 SET PSSMLT2=$$TLS^PSSDSAPA(PSSMLT1,PSSMLT3)
IF PSSMLT2
DO MLTS
QUIT
+9 QUIT
+10 ;
+11 ;
MLTS ;
+1 KILL PSSDBAR("AMN"),PSSDBAR("UNIT")
+2 SET PSSDBCAZ(PSSDBFDB(PSSDBLP,"RX_NUM"),"MUING")=""
+3 QUIT
+4 ;
+5 ;
MLTNO ;
+1 IF $DATA(PSSDBCAZ(PSSDBKLP,"MUING"))
SET $PIECE(PSSDBCAR(PSSDBKLP),"^",7)=1
+2 QUIT
+3 ;
+4 ;
MLTNP ;
+1 IF $DATA(PSSDBCAZ(PSSDBRLS,"MUING"))
SET $PIECE(PSSDBCAR(PSSDBRLS),"^",7)=1
+2 QUIT
+3 ;
+4 ;
FDRUG ; Find drug, called from PSSDSAPD
+1 NEW PSSINCFO
SET PSSINCFO=1
+2 SET PSSDBIFL=1
SET PSSDBIFG=$$DRG^PSSDSAPK(PSSDBFDB("OI"),$GET(PSSDBFDB("PACKAGE")),$GET(PSSDBDS(PSSDBLP,"MR_IEN")),$GET(PSSDBFDB("OI_USAGE")))
+3 IF 'PSSDBIFG
SET PSSDBIFG=$$DRG(PSSDBFDB("OI"),$GET(PSSDBFDB("PACKAGE")))
SET PSSDBCAZ(PSSDBFDB(PSSDBLP,"RX_NUM"),"NO_DRUG")=""
SET PSSDBIFG=$PIECE(PSSDBIFG,";")
+4 QUIT
+5 ;
+6 ;
INERR ;Set OI error
+1 NEW PSSNOOIX
+2 SET PSSNOOIX=$GET(PSSDBFDB(PSSDBLP,"OI_ERROR",PSSDBFDB(PSSDBLP,"DRUG_NM")))
+3 IF PSSNOOIX'=""
SET ^TMP($JOB,PSSDBASE,"IN","EXCEPTIONS","OI",PSSDBFDB(PSSDBLP,"DRUG_NM"))=$PIECE(PSSNOOIX,"^")_"^"_$PIECE(PSSNOOIX,"^",2)
SET PSSENO=1
DO STDB
+4 QUIT
+5 ;
+6 ;
FRQE ;Set Frequency error called from PSSDSAPD
+1 DO INFERR^PSSDSAPK
DO FRDR^PSSDSAPK
IF $DATA(PSSDBFDB(PSSDBLP,"FRQ_ERROR"))
SET PSSDBCAZ(PSSDBFDB(PSSDBLP,"RX_NUM"),"FRQ_ERROR")=""
+2 QUIT
+3 ;
+4 ;
INFUE ;Set Infusion rate error from PSSDSAPD
+1 IF $DATA(PSSDBFDB(PSSDBLP,"INF_ERROR"))
SET PSSDBCAZ(PSSDBFDB(PSSDBLP,"RX_NUM"),"INF_ERROR")=""
+2 QUIT
+3 ;
+4 ;
ERST ;Set Dosing Sequences into error summary list
+1 NEW PSSWSB1,PSSWSB2
+2 FOR PSSDBEQ3=0:0
SET PSSDBEQ3=$ORDER(PSSDBEQ2(PSSDBEQ3))
if 'PSSDBEQ3
QUIT
SET PSSDBCAX(PSSDBRLS,PSSDBEQ3)=""
IF $ORDER(PSSDBXAX(PSSDBEQ3,""))'=""
IF $EXTRACT(PSSDBASE,1,3)'="PSJ"
Begin DoDot:1
+3 SET PSSWSB1=""
SET PSSWSB2=0
FOR
SET PSSWSB1=$ORDER(PSSDBXAX(PSSDBEQ3,PSSWSB1))
if PSSWSB1=""!($GET(PSSDBCAX(PSSDBRLS,PSSDBEQ3))["All")
QUIT
SET PSSWSB2=PSSWSB2+1
Begin DoDot:2
+4 IF PSSDBEQ3=5!(PSSDBEQ3=6)!(PSSDBEQ3=8)
SET PSSDBCAX(PSSDBRLS,PSSDBEQ3)=" (All"
QUIT
+5 IF PSSWSB2=1
SET PSSDBCAX(PSSDBRLS,PSSDBEQ3)=" (DOSE SEQ "_$PIECE(PSSWSB1,";",4)
QUIT
+6 SET PSSDBCAX(PSSDBRLS,PSSDBEQ3)=PSSDBCAX(PSSDBRLS,PSSDBEQ3)_", "_$PIECE(PSSWSB1,";",4)
End DoDot:2
+7 SET PSSDBCAX(PSSDBRLS,PSSDBEQ3)=PSSDBCAX(PSSDBRLS,PSSDBEQ3)_")"
End DoDot:1
+8 QUIT
+9 ;
+10 ;
PAT ;
+1 NEW DFN,VADM,VAPTYP,VAHOW,VAROOT,VAERR,VA,X1,X2,X,%Y,PSSDBWT,PSSDBWTX,PSSDBHT,PSSDBHTX,GMRVSTR,PSSDBBSA,PSSDBATX
+2 SET DFN=PSSDBDFN
SET PSSDBATX=0
+3 DO DEM^VADPT
+4 KILL X
SET X2=$PIECE(VADM(3),"^")
SET X1=DT
IF X1
IF X2
DO ^%DTC
SET PSSDBATX=X
+5 SET ^TMP($JOB,PSSDBASE,"IN","DOSE","AGE")=PSSDBATX
+6 SET DFN=PSSDBDFN
+7 SET (PSSDBWTX,PSSDBHTX,PSSDBBSA)=0
+8 SET GMRVSTR="WT"
KILL X
DO EN6^GMRVUTL
+9 SET PSSDBWT=$PIECE(X,"^",8)
IF PSSDBWT
SET PSSDBWTX=PSSDBWT/2.2
+10 SET ^TMP($JOB,PSSDBASE,"IN","DOSE","WT")=$GET(PSSDBWTX)
+11 SET DFN=PSSDBDFN
+12 SET GMRVSTR="HT"
KILL X
DO EN6^GMRVUTL
+13 SET PSSDBHT=$PIECE(X,"^",8)
IF PSSDBHT
SET PSSDBHTX=.0254*PSSDBHT
+14 ;Using DuBios formula for BSA calculation, and sending in 2 decimal places
+15 IF $GET(PSSDBWTX)
IF $GET(PSSDBHTX)
SET PSSDBBSA=.20247*(PSSDBHTX**.725)*(PSSDBWTX**.425)
+16 ;I $G(PSSDBWTX),$G(PSSDBHTX) S PSSDBBSA=$J((((PSSDBWTX*PSSDBHTX)/3600)**.5),0,2) Mosteller BSA Formula
+17 SET ^TMP($JOB,PSSDBASE,"IN","DOSE","BSA")=$GET(PSSDBBSA)
+18 QUIT
+19 ;
+20 ;
ADDCT ;Add counter to output globals so data appears in correct order for more than 9 Dosing Sequences
+1 ;I PSSDBASA D ADDCTA ;Remove comment when CPRS is ready to convert to new output, to show messages in Sequence order
+2 IF PSSDBASB
DO ADDCTB
+3 QUIT
+4 ;
+5 ;
ADDCTA ;Add counter to CPRS global
+1 ;I '$D(^TMP($J,PSSDBASF)) Q
+2 ;N PSSJW1,PSSJW2,PSSJW3,PSSJW4,PSSJW5,PSSJW6
+3 ;K ^TMP($J,"PSSJWTM1") M ^TMP($J,"PSSJWTM1")=^TMP($J,PSSDBASF) K ^TMP($J,PSSDBASF)
+4 ;
+5 ;S PSSJW1="" F S PSSJW1=$O(^TMP($J,"PSSJWTM1","OUT","DOSE","ERROR",PSSJW1)) Q:PSSJW1="" D
+6 ;.S PSSJW2="" F S PSSJW2=$O(^TMP($J,"PSSJWTM1","OUT","DOSE","ERROR",PSSJW1,PSSJW2)) Q:PSSJW2="" D
+7 ;..S PSSJW3=$P(PSSJW1,";",4)
+8 ;..S PSSJW4=$G(^TMP($J,"PSSJWTM1","OUT","DOSE","ERROR",PSSJW1,PSSJW2,"MSG"))
+9 ;..S PSSJW5=$G(^TMP($J,"PSSJWTM1","OUT","DOSE","ERROR",PSSJW1,PSSJW2,"TEXT"))
+10 ;..I $D(^TMP($J,"PSSJWTM1","OUT","DOSE","ERROR",PSSJW1,PSSJW2,"MSG")) S ^TMP($J,PSSDBASF,"OUT","DOSE","ERROR",PSSJW3,PSSJW1,PSSJW2,"MSG")=PSSJW4
+11 ;..I $D(^TMP($J,"PSSJWTM1","OUT","DOSE","ERROR",PSSJW1,PSSJW2,"TEXT")) S ^TMP($J,PSSDBASF,"OUT","DOSE","ERROR",PSSJW3,PSSJW1,PSSJW2,"TEXT")=PSSJW5
+12 ;
+13 ;S PSSJW1="" F S PSSJW1=$O(^TMP($J,"PSSJWTM1","OUT","EXCEPTIONS","DOSE",PSSJW1)) Q:PSSJW1="" D
+14 ;.S PSSJW2="" F S PSSJW2=$O(^TMP($J,"PSSJWTM1","OUT","EXCEPTIONS","DOSE",PSSJW1,PSSJW2)) Q:PSSJW2="" D
+15 ;..S PSSJW3=$P(PSSJW1,";",4)
+16 ;..S PSSJW4=$G(^TMP($J,"PSSJWTM1","OUT","EXCEPTIONS","DOSE",PSSJW1,PSSJW2))
+17 ;..S ^TMP($J,PSSDBASF,"OUT","EXCEPTIONS","DOSE",PSSJW3,PSSJW1,PSSJW2)=PSSJW4
+18 ;
+19 ;S PSSJW1="" F S PSSJW1=$O(^TMP($J,"PSSJWTM1","OUT","DOSE",PSSJW1)) Q:PSSJW1="" I PSSJW1'="ERROR" D
+20 ;.S PSSJW2="" F S PSSJW2=$O(^TMP($J,"PSSJWTM1","OUT","DOSE",PSSJW1,PSSJW2)) Q:PSSJW2="" D
+21 ;..S PSSJW3="" F S PSSJW3=$O(^TMP($J,"PSSJWTM1","OUT","DOSE",PSSJW1,PSSJW2,PSSJW3)) Q:PSSJW3="" D
+22 ;...S PSSJW4="" F S PSSJW4=$O(^TMP($J,"PSSJWTM1","OUT","DOSE",PSSJW1,PSSJW2,PSSJW3,"MESSAGE",PSSJW4)) Q:PSSJW4="" D
+23 ;....S PSSJW5=$P(PSSJW1,";",4)
+24 ;....S PSSJW6=$G(^TMP($J,"PSSJWTM1","OUT","DOSE",PSSJW1,PSSJW2,PSSJW3,"MESSAGE",PSSJW4))
+25 ;....S ^TMP($J,PSSDBASF,"OUT","DOSE",PSSJW5,PSSJW1,PSSJW2,PSSJW3,"MESSAGE",PSSJW4)=PSSJW6
+26 ;
+27 ;K ^TMP($J,"PSSJWTM1")
+28 ;Q
+29 ;
+30 ;
ADDCTB ;Add counter to Pharmacy global
+1 IF '$DATA(^TMP($JOB,PSSDBASG))
QUIT
+2 NEW PSSJW7,PSSJW8,PSSJW9,PSSJWNUM,PSSJWVAL,PSSJW56,PSSJW57
+3 KILL ^TMP($JOB,"PSSJWTM2")
MERGE ^TMP($JOB,"PSSJWTM2")=^TMP($JOB,PSSDBASG)
KILL ^TMP($JOB,PSSDBASG)
+4 ;
+5 SET PSSJW7=""
FOR
SET PSSJW7=$ORDER(^TMP($JOB,"PSSJWTM2","OUT",PSSJW7))
if PSSJW7=""
QUIT
Begin DoDot:1
+6 SET PSSJWNUM=$PIECE(PSSJW7,";",4)
+7 SET PSSJW8=""
FOR
SET PSSJW8=$ORDER(^TMP($JOB,"PSSJWTM2","OUT",PSSJW7,"ERROR",PSSJW8))
if PSSJW8=""
QUIT
Begin DoDot:2
+8 IF $DATA(^TMP($JOB,"PSSJWTM2","OUT",PSSJW7,"ERROR",PSSJW8,"MSG"))
SET ^TMP($JOB,PSSDBASG,"OUT",PSSJWNUM,PSSJW7,"ERROR",PSSJW8,"MSG")=$GET(^TMP($JOB,"PSSJWTM2","OUT",PSSJW7,"ERROR",PSSJW8,"MSG"))
+9 IF $DATA(^TMP($JOB,"PSSJWTM2","OUT",PSSJW7,"ERROR",PSSJW8,"TEXT"))
SET ^TMP($JOB,PSSDBASG,"OUT",PSSJWNUM,PSSJW7,"ERROR",PSSJW8,"TEXT")=$GET(^TMP($JOB,"PSSJWTM2","OUT",PSSJW7,"ERROR",PSSJW8,"TEXT"))
+10 IF $GET(^TMP($JOB,"PSSJWTM2","OUT",PSSJW7,"ERROR",PSSJW8,"WARN"))="Warning"
SET ^TMP($JOB,PSSDBASG,"OUT",PSSJWNUM,PSSJW7,"ERROR",PSSJW8,"WARN")="Warning"
End DoDot:2
+11 ;
+12 SET PSSJW8=""
FOR
SET PSSJW8=$ORDER(^TMP($JOB,"PSSJWTM2","OUT",PSSJW7,"EXCEPTIONS",PSSJW8))
if PSSJW8=""
QUIT
Begin DoDot:2
+13 SET PSSJW9=$GET(^TMP($JOB,"PSSJWTM2","OUT",PSSJW7,"EXCEPTIONS",PSSJW8))
+14 SET ^TMP($JOB,PSSDBASG,"OUT",PSSJWNUM,PSSJW7,"EXCEPTIONS",PSSJW8)=PSSJW9
End DoDot:2
+15 ;
+16 SET PSSJW8=""
FOR
SET PSSJW8=$ORDER(^TMP($JOB,"PSSJWTM2","OUT",PSSJW7,"MESSAGE",PSSJW8))
if PSSJW8=""
QUIT
Begin DoDot:2
+17 SET PSSJW9=""
FOR
SET PSSJW9=$ORDER(^TMP($JOB,"PSSJWTM2","OUT",PSSJW7,"MESSAGE",PSSJW8,PSSJW9))
if PSSJW9=""
QUIT
Begin DoDot:3
+18 IF +PSSJW8=3
Begin DoDot:4
+19 SET PSSJW56=""
FOR
SET PSSJW56=$ORDER(^TMP($JOB,"PSSJWTM2","OUT",PSSJW7,"MESSAGE",PSSJW8,PSSJW9,PSSJW56))
if PSSJW56=""
QUIT
Begin DoDot:5
+20 SET PSSJW57=$GET(^TMP($JOB,"PSSJWTM2","OUT",PSSJW7,"MESSAGE",PSSJW8,PSSJW9,PSSJW56))
+21 SET ^TMP($JOB,PSSDBASG,"OUT",PSSJWNUM,PSSJW7,"MESSAGE",PSSJW8,PSSJW9,PSSJW56)=PSSJW57
End DoDot:5
End DoDot:4
QUIT
+22 SET PSSJWVAL=$GET(^TMP($JOB,"PSSJWTM2","OUT",PSSJW7,"MESSAGE",PSSJW8,PSSJW9))
+23 SET ^TMP($JOB,PSSDBASG,"OUT",PSSJWNUM,PSSJW7,"MESSAGE",PSSJW8,PSSJW9)=PSSJWVAL
End DoDot:3
End DoDot:2
End DoDot:1
+24 ;
+25 KILL ^TMP($JOB,"PSSJWTM2")
+26 QUIT
+27 ;
+28 ;
DSP(PSSDBDS,PSSDBFDB) ;Return Dose and Dose Unit to Inpatient for complex order display
+1 ;Return value set into parameter 1 as "DRG_DISP"
+2 NEW PSSDBAR,PSSINDSP,PSSIND1,PSSIND2,PSSIND3,PSSDSLCL,PSSDBNOD,PSSDBXP,PSSDBLPD,PSSDSXTD,PSSDBNT,PSSDBFAL,PSSDBLP,PSSDBIFL,PSSDSLCT,PSSDSLC1
+3 SET PSSDBLP=""
FOR
SET PSSDBLP=$ORDER(PSSDBDS(PSSDBLP))
if PSSDBLP=""
QUIT
Begin DoDot:1
+4 SET PSSINDSP=""
SET (PSSDBLPD,PSSDBFAL,PSSDBIFL,PSSDSLCT)=0
KILL PSSDBAR
+5 IF $DATA(PSSDBFDB(PSSDBLP,"DOSE_AMT"))
IF $DATA(PSSDBFDB(PSSDBLP,"DOSE_UNIT"))
SET PSSINDSP=PSSDBFDB(PSSDBLP,"DOSE_AMT")_"^"_PSSDBFDB(PSSDBLP,"DOSE_UNIT")
DO DSPL
QUIT
+6 IF $GET(PSSDBDS(PSSDBLP,"DRG_AMT"))
IF $GET(PSSDBDS(PSSDBLP,"DRG_UNIT"))'=""
Begin DoDot:2
+7 SET PSSIND1=$SELECT(PSSDBDS(PSSDBLP,"DRG_UNIT")["/":$PIECE(PSSDBDS(PSSDBLP,"DRG_UNIT"),"/"),1:PSSDBDS(PSSDBLP,"DRG_UNIT"))
+8 SET PSSIND1=$$UP^XLFSTR(PSSIND1)
+9 SET PSSIND2=$$UNIT^PSSDSAPI(PSSIND1)
+10 IF PSSIND2'=""
SET PSSINDSP=PSSDBDS(PSSDBLP,"DRG_AMT")_"^"_PSSIND2
DO DSPL
SET PSSDBFAL=1
End DoDot:2
+11 IF PSSDBFAL
QUIT
+12 IF '$GET(PSSDBFDB(PSSDBLP,"DRUG_IEN"))
SET PSSDBDS(PSSDBLP,"DRG_DISP")=""
QUIT
+13 ;"DOSE" Node should only come from CPRS, for selected Local Possible Dosage
+14 SET PSSDSLCL=$SELECT($GET(PSSDBDS(PSSDBLP,"DOSE"))'="":$PIECE($GET(PSSDBDS(PSSDBLP,"DOSE")),"&",5),1:$GET(PSSDBDS(PSSDBLP,"DO")))
+15 IF PSSDSLCL=""
SET PSSDBDS(PSSDBLP,"DRG_DISP")=""
QUIT
+16 IF PSSDSLCL["("
DO PTH^PSSDSUTL
+17 DO DSPRT
End DoDot:1
+18 QUIT
+19 ;
DSPRT ;Line Tag added for retry if Free Text Dosage contains parenthesis
+1 SET PSSIND3=0
+2 FOR PSSDBXP=0:0
SET PSSDBXP=$ORDER(^PSDRUG(PSSDBFDB(PSSDBLP,"DRUG_IEN"),"DOS2",PSSDBXP))
if 'PSSDBXP!(PSSIND3)
QUIT
Begin DoDot:1
+3 SET PSSDBNOD=$GET(^PSDRUG(PSSDBFDB(PSSDBLP,"DRUG_IEN"),"DOS2",PSSDBXP,0))
+4 IF $$MTCH^PSSDSAPK
SET PSSDBLPD=1
IF $PIECE(PSSDBNOD,"^",5)
IF $PIECE(PSSDBNOD,"^",6)'=""
Begin DoDot:2
+5 SET PSSDSXTD=+$PIECE(PSSDBNOD,"^",5)
IF PSSDSXTD
IF $$SCREEN^XTID(51.24,.01,PSSDSXTD_",")
QUIT
+6 SET PSSDBNT=$PIECE($GET(^PS(51.24,+$PIECE(PSSDBNOD,"^",5),0)),"^",2)
+7 IF PSSDBNT'=""
SET PSSINDSP=$PIECE(PSSDBNOD,"^",6)_"^"_PSSDBNT
SET (PSSIND3,PSSDBFAL)=1
End DoDot:2
End DoDot:1
+8 IF PSSDBFAL
DO DSPL
QUIT
+9 IF PSSDBLPD
DO DPOP^PSSDSAPK
IF PSSDBFAL
SET PSSINDSP=PSSDBAR("AMN")_"^"_PSSDBAR("UNIT")
DO DSPL
QUIT
+10 DO ITEM^PSSDSAPK
IF PSSDBFAL
SET PSSINDSP=PSSDBAR("AMN")_"^"_PSSDBAR("UNIT")
DO DSPL
QUIT
+11 DO NUM^PSSDSAPL
IF PSSDBFAL
SET PSSINDSP=PSSDBAR("AMN")_"^"_PSSDBAR("UNIT")
DO DSPL
QUIT
+12 DO RANGE^PSSDSUTL
IF PSSDBFAL
SET PSSINDSP=PSSDBAR("AMN")_"^"_PSSDBAR("UNIT")
DO DSPL
QUIT
+13 IF 'PSSDBFAL
IF PSSDSLCT
SET PSSDSLCL=PSSDSLC1(PSSDSLCT)
SET PSSDSLCT=PSSDSLCT-1
SET PSSDBLPD=0
GOTO DSPRT
+14 SET PSSDBDS(PSSDBLP,"DRG_DISP")=""
+15 QUIT
+16 ;
+17 ;
DSPL ;Add leading zero
+1 IF $EXTRACT(PSSINDSP)="."
SET PSSINDSP="0"_PSSINDSP
+2 SET PSSDBDS(PSSDBLP,"DRG_DISP")=PSSINDSP
+3 QUIT
+4 ;
+5 ;
NXDRUG ;No Drug found
+1 IF $GET(PSSDBFDB("PACKAGE"))="X"
IF $$DLTM^PSSDSAPI(PSSDBFDB("OI"))
KILL ^TMP($JOB,PSSDBASE,"IN","EXCEPTIONS","OI",PSSDBFDB(PSSDBLP,"DRUG_NM")),PSSDBCAZ(PSSDBFDB(PSSDBLP,"RX_NUM"),"NO_DRUG")
QUIT
+2 IF $DATA(^TMP($JOB,PSSDBASE,"IN","EXCEPTIONS","OI",PSSDBFDB(PSSDBLP,"DRUG_NM")))
DO DPL^PSSDSAPK
QUIT
+3 IF PSSDSIVF
SET ^TMP($JOB,PSSDBASE,"IN","EXCEPTIONS","OI",PSSDBFDB(PSSDBLP,"DRUG_NM"))="4^"_PSSDBFDB(PSSDBLP,"RX_NUM")
DO STDB
QUIT
+4 SET ^TMP($JOB,PSSDBASE,"IN","EXCEPTIONS","DOSE",PSSDBFDB(PSSDBLP,"RX_NUM"))="1^"_PSSDBFDB(PSSDBLP,"DRUG_NM")
DO STDB
+5 QUIT
+6 ;
+7 ;
STDB ;Set PSSDBCAR array for Input Exceptions
+1 SET PSSDBCAR(PSSDBFDB(PSSDBLP,"RX_NUM"))="B^"_PSSDBFDB(PSSDBLP,"DRUG_NM")
+2 SET $PIECE(PSSDBCAR(PSSDBFDB(PSSDBLP,"RX_NUM")),"^",18)=1
SET $PIECE(PSSDBCAR(PSSDBFDB(PSSDBLP,"RX_NUM")),"^",13)=1
+3 ;S PSSENHKZ(PSSDBFDB(PSSDBLP,"RX_NUM"))=1
+4 DO DPL^PSSDSAPK
+5 QUIT
