PSJBLDOC ;BIR/MV - API to build ^TMP for prospective and PSJ profile drugs ;03 Aug 98 / 8:42 AM
;;5.0;INPATIENT MEDICATIONS ;**181,263,260,295,252,257,299,281,347**;16 DEC 97;Build 6
;
; Reference to ^PS(52.6 is supported by DBIA# 1231.
; Reference to ^PS(52.7 is supported by DBIA# 2173.
; Reference to ^PS(55 is supported by DBIA 2191.
; Reference to ^PSDRUG( is supported by DBIA# 2192.
; Reference to ^PSSDSAPI is supported by DBIA# 5425.
; Reference to ^PSSDSAPM is supported by DBIA# 5570.
;
IN(DFN,LIST,PDRG,PTYP) ;
;Build the IPM profiles and the prospective drugs list for both PSO & PSJ if PDRG is passed in.
;DFN - PATIENT DFN
;LIST - BASE
;PDRG - Drug array in format of PDRG(n)=IEN (#50) ^ Drug name
; Where n is a sequential number. Drug name can be OI, Generic name from #50 or Additive/sol name
;PTYP - P1;P2 where P1="I" for Inpatient & "O" for Outpatient, P2= PSJ order#
NEW PSJONCNT,PSJDCNT,PSJDRGND,PSJWON
S PSJONCNT=0
S PSJWON=$P($G(PTYP),";",2)
D PROFILE(DFN,PSJWON,PTYP)
K ^TMP($J,"PSJPRE","CLINIC")
Q
PROFILE(DFN,PSJWON,PTYP) ;Setup ^TMP for the active meds to be on the OC profile list.
;DFN: Patient internal entry number
;PSJWON: The current order number being working on. It can be null.
; It is the order being work on (RN, FN..) and should be on the prospective list.
;Output: ^TMP($J,"ORDERS",PSJINX)=DRUG CLASS^NATIONAL DRUG FILE ENTRY
; _"A"_PSNDFA PRODUCT NAME ENTRY_DISPENSE DRUG NAME^OE/RR #
; _ORDER NUMBER(P/I/V)_";I"
;
NEW BDT,COD,DDRUG,DDRUGND,EDT,F,ON,ON1,PST,WBDT,X,PSJORIEN,%,PSJCLCOD,PSJCLINF,PSJCLIND,PSJTYPCL
S PSJWON=$G(PSJWON),PSJCLCOD=""
;
;Must display any DC/Expired clinic orders within largest number of days defined for whichever clinic has the oldest date defined for ORDER CHECK DC/EXPIRED DAYS field
;under the CLINIC DEFINITION file (#53.46)
;Active, non-verified, pending, hold clinic orders must be displayed in the clinic display format.
D CLINICS^PSJCLNOC(DFN) ;get clinic orders for this patient and set ^TMP($J,"PSJPRE","CLINIC",IEN,FILE_TYPE)=""
I $D(^TMP($J,"PSJPRE","CLINIC")) D
.S (PSJTYPCL,ON)="" F S ON=$O(^TMP($J,"PSJPRE","CLINIC",ON)) Q:ON="" F S PSJTYPCL=$O(^TMP($J,"PSJPRE","CLINIC",ON,PSJTYPCL)) Q:PSJTYPCL="" D
..S F="^PS(55,DFN,5,"
..I PSJTYPCL["55U" S COD=ON_"U",PSJCLCOD=2 D:COD'=PSJWON UD Q
..I PSJTYPCL["55I" S COD=ON_"V" S PSJCLCOD=1 D:COD'=PSJWON IV Q
..S F="^PS(53.1,"
..S COD=ON_"P" Q:COD=PSJWON!($D(PSJVFF)&(COD=$G(PSJORD)))
..I $G(PSJCOM),($G(PSJWON)["P") Q:$D(^PS(53.1,"ACX",PSJCOM,+ON))
..I $O(^PS(53.1,+ON,"AD",0))!$O(^PS(53.1,+ON,"SOL",0)) S PSJCLCOD=3 D PIV Q
..;PSJ*5*347
..S PSJCLCOD=4
..I $$GET1^DIQ(53.1,+ON,4,"I")="I" S PSJCLCOD=5
..;S PSJCLCOD=4 D UD
..D UD
;
D NOW^%DTC S (BDT,WBDT)=%,EDT=9999999 ; WBDT SET THIS WAY BEFORE CLINIC OC DISPLAY ADDED
S F="^PS(55,DFN,5," F S WBDT=$O(^PS(55,DFN,5,"AUS",WBDT)) Q:'WBDT F ON=0:0 S ON=$O(^PS(55,DFN,5,"AUS",WBDT,ON)) Q:'ON I '$D(^TMP($J,"PSJPRE","CLINIC",ON)) S COD=ON_"U",PSJCLCOD=2 D:COD'=PSJWON UD
S WBDT=BDT,F="^PS(53.1,",PSJCLCOD="" F PST="P","N" F ON=0:0 S ON=$O(^PS(53.1,"AS",PST,DFN,ON)) Q:'ON I '$D(^TMP($J,"PSJPRE","CLINIC",ON)) D
. S COD=ON_"P" Q:COD=PSJWON!($D(PSJVFF)&(COD=$G(PSJORD)))
. I $G(PSJCOM),($G(PSJWON)["P") Q:$D(^PS(53.1,"ACX",PSJCOM,+ON))
. I $O(^PS(53.1,+ON,"AD",0))!$O(^PS(53.1,+ON,"SOL",0)) S PSJCLCOD=3 D PIV Q
. S PSJCLCOD=4
. I $$GET1^DIQ(53.1,+ON,4,"I")="I" S PSJCLCOD=5
. D UD
S WBDT=BDT F S WBDT=$O(^PS(55,DFN,"IV","AIS",WBDT)) Q:'WBDT F ON=0:0 S ON=$O(^PS(55,DFN,"IV","AIS",WBDT,ON)) Q:'ON I '$D(^TMP($J,"PSJPRE","CLINIC",ON)) S COD=ON_"V" S PSJCLCOD=1 D:COD'=PSJWON IV
K PSJWON
Q
UD ;Get the dispense drugs for the Unit Dose orders.
NEW X,PSJQUIT,PSJCNT,DDRUG,DDRUGN,PSJX,PSJOI,PSJEXPDD,PSJUTMP,PSJEDOVR,PSJCLNX,PSJCLDAT,PSJCLDAY,PSJSTOP
S X=@(F_ON_",0)")
Q:$P(X,U,9)="R"
S (PSJEDOVR,PSJCLINF,PSJCLNX,PSJCLDAY,PSJSTOP)=0,PSJCLDAT="",PSJCLNX=$P(X,U,9)
I $D(^TMP($J,"PSJPRE","CLINIC",+ON,$S(PSJCLCOD=5:"531I",PSJCLCOD=2:"55U",1:"531U"))) S PSJCLINF=1
I PSJCLCOD=4!(PSJCLCOD=5) Q:PSJCLINF&($P(X,U,9)'="P"&($P(X,U,9)'="N"))
Q:$P($G(PTYP),";",1)="O"&('$G(PSJCLINF))
Q:$P(X,U,9)["D"&('PSJCLINF)
Q:$P(X,U,9)="E"&('PSJCLINF)
S PSJORIEN=$P(X,U,21),DDRUG=0
;
;Use the first active DD within the order. If >1 DD, use OI_Dosage form for display name
S ON1=0,PSJCNT=0 F S ON1=$O(@(F_ON_",1,"_ON1_")")) Q:'ON1 S PSJCNT=PSJCNT+1
S PSJOI=+$G(@(F_ON_",.2)"))
S ON1=0,PSJQUIT=0 F S ON1=$O(@(F_ON_",1,"_ON1_")")) Q:'+ON1!PSJQUIT S DDRUG=@(F_ON_",1,"_ON1_",0)") D
. Q:'+DDRUG
. S PSJX=$P(DDRUG,U,3)
. I 'PSJCLINF,PSJX]"",(PSJX'>BDT) Q
. D SETIN("PROFILE",$S(PSJCNT>1:$$OIDF^PSJLMUT1(+$G(PSJOI)),1:$P($G(^PSDRUG(DDRUG,0)),U)),+DDRUG,COD,PTYP,PSJCLCOD,PSJCLINF) S PSJQUIT=1
;Quit when an active DD within the order if found
Q:+$G(PSJQUIT)
;
;No DD found from the order. Get one from the OI
I '+PSJOI D SETIN("PROFILE","NOT FOUND: "_COD,"",COD,1,PSJCLCOD,PSJCLINF) Q
S DDRUG=$P($$DRG^PSSDSAPM(+PSJOI,"I"),U)
I +DDRUG D SETIN("PROFILE",$S(PSJCNT>1:$$OIDF^PSJLMUT1(+$G(PSJOI)),1:$P($G(^PSDRUG(DDRUG,0)),U)),+DDRUG,COD,PTYP,PSJCLCOD,PSJCLINF) Q
;
;Get the first DD from OI (CCR5665 - set exception if pending order has no DD assigned and none is active. PSJ*5*252 t9)
I ($G(COD)'["P"),('+DDRUG) S DDRUG=$O(^PSDRUG("ASP",PSJOI,0)) I +DDRUG D SETIN("PROFILE",$S(PSJCNT>1:$$OIDF^PSJLMUT1(+$G(PSJOI)),1:$P($G(^PSDRUG(DDRUG,0)),U)),+DDRUG,COD,PTYP,PSJCLCOD,PSJCLINF) Q
;
;Set exception when no DD found
I '+DDRUG D SETIN("PROFILE",$$OIDF^PSJLMUT1(+$G(PSJOI)),"",COD,1,PSJCLCOD,PSJCLINF) Q
Q
PIV ;Get the dispense drugs for the Pending IV orders.
NEW PSJ0,PSJX,DDRUG,PSJNM,PSJCLNTY,PSJDDNM
S PSJX=^PS(53.1,+ON,0),PSJORIEN=$P(PSJX,U,21) Q:$P(PSJX,U,27)="R"
S (PSJEDOVR,PSJCLINF,PSJCLNTY)=0,PSJCLNTY=$$GET1^DIQ(53.1,+ON,4,"I")
S:$D(^TMP($J,"PSJPRE","CLINIC",+ON,531_PSJCLNTY)) PSJCLINF=1
Q:$P($G(PTYP),";",1)="O"&('$G(PSJCLINF))
S ON1=0 F S ON1=$O(^PS(53.1,+ON,"AD",ON1)) Q:'ON1 D
. S PSJX=^PS(53.1,+ON,"AD",ON1,0),PSJ0=$$IV0("AD",+PSJX)
. S PSJNM=$P(PSJ0,U)_" "_$P(PSJX,U,2),DDRUG=$P(PSJ0,U,2)
. I '+DDRUG D SETIN("PROFILE",PSJNM,"",COD,4,PSJCLCOD,PSJCLINF) Q
. D SETIN("PROFILE",$P(PSJ0,U)_" "_$P(PSJX,U,2),$P(PSJ0,U,2),COD,PTYP,PSJCLCOD,PSJCLINF)
S ON1=0 F S ON1=$O(^PS(53.1,+ON,"SOL",ON1)) Q:'ON1 D
. S PSJX=^PS(53.1,+ON,"SOL",ON1,0)
. S PSJ0=$$IV0("",+PSJX)
. S PSJNM=$P(PSJ0,U)_" "_$P(PSJX,U,2),DDRUG=$P(PSJ0,U,2)
. I $$PREMIX^PSJMISC(+PSJX) D Q
.. I '+DDRUG D SETIN("PROFILE",PSJNM,"",COD,4,PSJCLCOD,PSJCLINF) Q
.. D SETIN("PROFILE",$P(PSJ0,U)_" "_$P(PSJX,U,2),$P(PSJ0,U,2),COD,PTYP,PSJCLCOD,PSJCLINF)
. ;Do allergy check for non-premix as well
. I $G(PSJDGCK) D
.. S PSJDDNM=$P($G(^PSDRUG(+DDRUG,0)),U)
.. S:$G(PSJDDNM)]"" PSJALLGY("Z",PSJDDNM,DDRUG)=""
Q
IV ;Get the dispense drugs for the IV orders.
NEW PSJ0,PSJX,DDRUG,PSJNM,PSJCLNX,PSJSTOP,PSJDDNM
S PSJX=^PS(55,DFN,"IV",ON,0),PSJORIEN=$P(PSJX,U,21),(PSJCLINF,PSJCLNX)=0,PSJCLNX=$P(PSJX,U,17)
Q:$P(PSJX,U,17)="R"
I $D(^TMP($J,"PSJPRE","CLINIC",+ON,"55I")) S PSJCLINF=1
I PSJCLCOD=4!(PSJCLCOD=5) Q:PSJCLINF&($P(PSJX,U,17)'="P"&($P(PSJX,U,17)'="N"))
Q:$P($G(PTYP),";",1)="O"&('$G(PSJCLINF))
Q:$P(PSJX,U,17)["D"&('PSJCLINF)
Q:$P(PSJX,U,17)="E"&('PSJCLINF)
S ON1=0 F S ON1=$O(^PS(55,DFN,"IV",ON,"AD",ON1)) Q:'ON1 D
. S PSJX=^PS(55,DFN,"IV",ON,"AD",ON1,0),PSJ0=$$IV0("AD",+PSJX)
. S PSJNM=$P(PSJ0,U)_" "_$P(PSJX,U,2),DDRUG=$P(PSJ0,U,2)
. I '+DDRUG D SETIN("PROFILE",PSJNM,"",COD,4,PSJCLCOD,PSJCLINF) Q
. D SETIN("PROFILE",PSJNM,DDRUG,COD,PTYP,PSJCLCOD,PSJCLINF)
; Only include Pre-mix in the OC.
S ON1=0 F S ON1=$O(^PS(55,DFN,"IV",ON,"SOL",ON1)) Q:'ON1 D
. S PSJX=^PS(55,DFN,"IV",ON,"SOL",ON1,0)
. S PSJ0=$$IV0("",+PSJX)
. S PSJNM=$P(PSJ0,U)_" "_$P(PSJX,U,2),DDRUG=$P(PSJ0,U,2)
. I $$PREMIX^PSJMISC(+PSJX) D Q
.. I '+DDRUG D SETIN("PROFILE",PSJNM,"",COD,4,PSJCLCOD,PSJCLINF) Q
.. D SETIN("PROFILE",PSJNM,DDRUG,COD,PTYP,PSJCLCOD,PSJCLINF)
. ;Do allergy check for non-premix as well
. I $G(PSJDGCK) D
.. S PSJDDNM=$P($G(^PSDRUG(+DDRUG,0)),U)
.. S:$G(PSJDDNM)]"" PSJALLGY("Z",PSJDDNM,DDRUG)=""
Q
SETIN(PSJFLG,PSJNM,DDRUG,ON,PSJCODE,PSJCLCOD,PSJCLINF) ;Set ^TMP($J,"PSJPRE,"IN" arrays.
;ON = ON with "U/V/P"
;PSJFLG = "PROSPECTIVE" or "PROFILE"
;PSJNM = This should be the AD/SOL print name or IV order. Use Dispense drug name if U/D order
;PSJPON = 4 piece pharmacy order #
NEW PSJPON
Q:$G(PSJFLG)=""
;S:$G(PSJDGCK) PSJFLG="PROSPECTIVE" ;when using CK hidden action
S PSJONCNT=$G(PSJONCNT)+1
S PSJPON=$S(PSJCLINF:"C"_PSJCLCOD_";",1:"I;")_ON_";"_PSJFLG_";"_PSJONCNT
I $P(PSJCODE,";")="O" S PSJPON="C"_PSJCLCOD_";"_+ON_";"_PSJFLG_";"_PSJONCNT
I '+$G(DDRUG) D Q
. I +$G(PSJCODE) D NODD($G(PSJCODE),PSJNM,PSJPON,LIST)
Q:$$SUP^PSSDSAPI(+DDRUG)
I $G(PSJNM)="" S PSJNM=$P($G(^PSDRUG(+DDRUG,0)),U)
S PSJFLG=$S($G(PSJDGCK):"PROSPECTIVE",1:"PROFILE") ;when using CK hidden action
S ^TMP($J,LIST,"IN",PSJFLG,PSJPON)=+$$GCN^PSJMISC(+DDRUG)_U_$$GTVUID^PSJMISC(+DDRUG)_U_+DDRUG_U_PSJNM_U_$G(PSJORIEN)_U_"I"_U_PSJCLCOD_";"_PSJCLINF
Q
IV0(PSJAD,PSIVIEN) ;Return ad/sol zero node
;PSJAD = "AD" is passed in if it additive, otherwise it's null
I PSJAD="AD" Q $G(^PS(52.6,+$G(PSIVIEN),0))
I $G(PSJAD)="" Q $G(^PS(52.7,+$G(PSIVIEN),0))
Q ""
NODD(PSJCODE,PSJOIDF,PSJPON,PSJBASE) ;Set ^TMP for OI without a dispense drug
;PSJCODE - A numeric code to trigger the appropriate exception message
;PSJOIDF - Orderable Item name_Dose form (can be CPRS OI)
;PSJPON - Pharmacy order #
;PSJBASE - Base subscript
Q:$G(PSJOIDF)=""
Q:$G(PSJBASE)=""
Q:'+$G(PSJCODE)
;S PSJIV("OI_ERROR",PSJOIDF)=$G(PSJCODE)_U_$G(PSJPON)
S ^TMP($J,PSJBASE,"IN","EXCEPTIONS","OI",PSJOIDF)=PSJCODE_U_$G(PSJPON)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSJBLDOC 9879 printed Apr 09, 2024@21:03:53 Page 2
PSJBLDOC ;BIR/MV - API to build ^TMP for prospective and PSJ profile drugs ;03 Aug 98 / 8:42 AM
+1 ;;5.0;INPATIENT MEDICATIONS ;**181,263,260,295,252,257,299,281,347**;16 DEC 97;Build 6
+2 ;
+3 ; Reference to ^PS(52.6 is supported by DBIA# 1231.
+4 ; Reference to ^PS(52.7 is supported by DBIA# 2173.
+5 ; Reference to ^PS(55 is supported by DBIA 2191.
+6 ; Reference to ^PSDRUG( is supported by DBIA# 2192.
+7 ; Reference to ^PSSDSAPI is supported by DBIA# 5425.
+8 ; Reference to ^PSSDSAPM is supported by DBIA# 5570.
+9 ;
IN(DFN,LIST,PDRG,PTYP) ;
+1 ;Build the IPM profiles and the prospective drugs list for both PSO & PSJ if PDRG is passed in.
+2 ;DFN - PATIENT DFN
+3 ;LIST - BASE
+4 ;PDRG - Drug array in format of PDRG(n)=IEN (#50) ^ Drug name
+5 ; Where n is a sequential number. Drug name can be OI, Generic name from #50 or Additive/sol name
+6 ;PTYP - P1;P2 where P1="I" for Inpatient & "O" for Outpatient, P2= PSJ order#
+7 NEW PSJONCNT,PSJDCNT,PSJDRGND,PSJWON
+8 SET PSJONCNT=0
+9 SET PSJWON=$PIECE($GET(PTYP),";",2)
+10 DO PROFILE(DFN,PSJWON,PTYP)
+11 KILL ^TMP($JOB,"PSJPRE","CLINIC")
+12 QUIT
PROFILE(DFN,PSJWON,PTYP) ;Setup ^TMP for the active meds to be on the OC profile list.
+1 ;DFN: Patient internal entry number
+2 ;PSJWON: The current order number being working on. It can be null.
+3 ; It is the order being work on (RN, FN..) and should be on the prospective list.
+4 ;Output: ^TMP($J,"ORDERS",PSJINX)=DRUG CLASS^NATIONAL DRUG FILE ENTRY
+5 ; _"A"_PSNDFA PRODUCT NAME ENTRY_DISPENSE DRUG NAME^OE/RR #
+6 ; _ORDER NUMBER(P/I/V)_";I"
+7 ;
+8 NEW BDT,COD,DDRUG,DDRUGND,EDT,F,ON,ON1,PST,WBDT,X,PSJORIEN,%,PSJCLCOD,PSJCLINF,PSJCLIND,PSJTYPCL
+9 SET PSJWON=$GET(PSJWON)
SET PSJCLCOD=""
+10 ;
+11 ;Must display any DC/Expired clinic orders within largest number of days defined for whichever clinic has the oldest date defined for ORDER CHECK DC/EXPIRED DAYS field
+12 ;under the CLINIC DEFINITION file (#53.46)
+13 ;Active, non-verified, pending, hold clinic orders must be displayed in the clinic display format.
+14 ;get clinic orders for this patient and set ^TMP($J,"PSJPRE","CLINIC",IEN,FILE_TYPE)=""
DO CLINICS^PSJCLNOC(DFN)
+15 IF $DATA(^TMP($JOB,"PSJPRE","CLINIC"))
Begin DoDot:1
+16 SET (PSJTYPCL,ON)=""
FOR
SET ON=$ORDER(^TMP($JOB,"PSJPRE","CLINIC",ON))
if ON=""
QUIT
FOR
SET PSJTYPCL=$ORDER(^TMP($JOB,"PSJPRE","CLINIC",ON,PSJTYPCL))
if PSJTYPCL=""
QUIT
Begin DoDot:2
+17 SET F="^PS(55,DFN,5,"
+18 IF PSJTYPCL["55U"
SET COD=ON_"U"
SET PSJCLCOD=2
if COD'=PSJWON
DO UD
QUIT
+19 IF PSJTYPCL["55I"
SET COD=ON_"V"
SET PSJCLCOD=1
if COD'=PSJWON
DO IV
QUIT
+20 SET F="^PS(53.1,"
+21 SET COD=ON_"P"
if COD=PSJWON!($DATA(PSJVFF)&(COD=$GET(PSJORD)))
QUIT
+22 IF $GET(PSJCOM)
IF ($GET(PSJWON)["P")
if $DATA(^PS(53.1,"ACX",PSJCOM,+ON))
QUIT
+23 IF $ORDER(^PS(53.1,+ON,"AD",0))!$ORDER(^PS(53.1,+ON,"SOL",0))
SET PSJCLCOD=3
DO PIV
QUIT
+24 ;PSJ*5*347
+25 SET PSJCLCOD=4
+26 IF $$GET1^DIQ(53.1,+ON,4,"I")="I"
SET PSJCLCOD=5
+27 ;S PSJCLCOD=4 D UD
+28 DO UD
End DoDot:2
End DoDot:1
+29 ;
+30 ; WBDT SET THIS WAY BEFORE CLINIC OC DISPLAY ADDED
DO NOW^%DTC
SET (BDT,WBDT)=%
SET EDT=9999999
+31 SET F="^PS(55,DFN,5,"
FOR
SET WBDT=$ORDER(^PS(55,DFN,5,"AUS",WBDT))
if 'WBDT
QUIT
FOR ON=0:0
SET ON=$ORDER(^PS(55,DFN,5,"AUS",WBDT,ON))
if 'ON
QUIT
IF '$DATA(^TMP($JOB,"PSJPRE","CLINIC",ON))
SET COD=ON_"U"
SET PSJCLCOD=2
if COD'=PSJWON
DO UD
+32 SET WBDT=BDT
SET F="^PS(53.1,"
SET PSJCLCOD=""
FOR PST="P","N"
FOR ON=0:0
SET ON=$ORDER(^PS(53.1,"AS",PST,DFN,ON))
if 'ON
QUIT
IF '$DATA(^TMP($JOB,"PSJPRE","CLINIC",ON))
Begin DoDot:1
+33 SET COD=ON_"P"
if COD=PSJWON!($DATA(PSJVFF)&(COD=$GET(PSJORD)))
QUIT
+34 IF $GET(PSJCOM)
IF ($GET(PSJWON)["P")
if $DATA(^PS(53.1,"ACX",PSJCOM,+ON))
QUIT
+35 IF $ORDER(^PS(53.1,+ON,"AD",0))!$ORDER(^PS(53.1,+ON,"SOL",0))
SET PSJCLCOD=3
DO PIV
QUIT
+36 SET PSJCLCOD=4
+37 IF $$GET1^DIQ(53.1,+ON,4,"I")="I"
SET PSJCLCOD=5
+38 DO UD
End DoDot:1
+39 SET WBDT=BDT
FOR
SET WBDT=$ORDER(^PS(55,DFN,"IV","AIS",WBDT))
if 'WBDT
QUIT
FOR ON=0:0
SET ON=$ORDER(^PS(55,DFN,"IV","AIS",WBDT,ON))
if 'ON
QUIT
IF '$DATA(^TMP($JOB,"PSJPRE","CLINIC",ON))
SET COD=ON_"V"
SET PSJCLCOD=1
if COD'=PSJWON
DO IV
+40 KILL PSJWON
+41 QUIT
UD ;Get the dispense drugs for the Unit Dose orders.
+1 NEW X,PSJQUIT,PSJCNT,DDRUG,DDRUGN,PSJX,PSJOI,PSJEXPDD,PSJUTMP,PSJEDOVR,PSJCLNX,PSJCLDAT,PSJCLDAY,PSJSTOP
+2 SET X=@(F_ON_",0)")
+3 if $PIECE(X,U,9)="R"
QUIT
+4 SET (PSJEDOVR,PSJCLINF,PSJCLNX,PSJCLDAY,PSJSTOP)=0
SET PSJCLDAT=""
SET PSJCLNX=$PIECE(X,U,9)
+5 IF $DATA(^TMP($JOB,"PSJPRE","CLINIC",+ON,$SELECT(PSJCLCOD=5:"531I",PSJCLCOD=2:"55U",1:"531U")))
SET PSJCLINF=1
+6 IF PSJCLCOD=4!(PSJCLCOD=5)
if PSJCLINF&($PIECE(X,U,9)'="P"&($PIECE(X,U,9)'="N"))
QUIT
+7 if $PIECE($GET(PTYP),";",1)="O"&('$GET(PSJCLINF))
QUIT
+8 if $PIECE(X,U,9)["D"&('PSJCLINF)
QUIT
+9 if $PIECE(X,U,9)="E"&('PSJCLINF)
QUIT
+10 SET PSJORIEN=$PIECE(X,U,21)
SET DDRUG=0
+11 ;
+12 ;Use the first active DD within the order. If >1 DD, use OI_Dosage form for display name
+13 SET ON1=0
SET PSJCNT=0
FOR
SET ON1=$ORDER(@(F_ON_",1,"_ON1_")"))
if 'ON1
QUIT
SET PSJCNT=PSJCNT+1
+14 SET PSJOI=+$GET(@(F_ON_",.2)"))
+15 SET ON1=0
SET PSJQUIT=0
FOR
SET ON1=$ORDER(@(F_ON_",1,"_ON1_")"))
if '+ON1!PSJQUIT
QUIT
SET DDRUG=@(F_ON_",1,"_ON1_",0)")
Begin DoDot:1
+16 if '+DDRUG
QUIT
+17 SET PSJX=$PIECE(DDRUG,U,3)
+18 IF 'PSJCLINF
IF PSJX]""
IF (PSJX'>BDT)
QUIT
+19 DO SETIN("PROFILE",$SELECT(PSJCNT>1:$$OIDF^PSJLMUT1(+$GET(PSJOI)),1:$PIECE($GET(^PSDRUG(DDRUG,0)),U)),+DDRUG,COD,PTYP,PSJCLCOD,PSJCLINF)
SET PSJQUIT=1
End DoDot:1
+20 ;Quit when an active DD within the order if found
+21 if +$GET(PSJQUIT)
QUIT
+22 ;
+23 ;No DD found from the order. Get one from the OI
+24 IF '+PSJOI
DO SETIN("PROFILE","NOT FOUND: "_COD,"",COD,1,PSJCLCOD,PSJCLINF)
QUIT
+25 SET DDRUG=$PIECE($$DRG^PSSDSAPM(+PSJOI,"I"),U)
+26 IF +DDRUG
DO SETIN("PROFILE",$SELECT(PSJCNT>1:$$OIDF^PSJLMUT1(+$GET(PSJOI)),1:$PIECE($GET(^PSDRUG(DDRUG,0)),U)),+DDRUG,COD,PTYP,PSJCLCOD,PSJCLINF)
QUIT
+27 ;
+28 ;Get the first DD from OI (CCR5665 - set exception if pending order has no DD assigned and none is active. PSJ*5*252 t9)
+29 IF ($GET(COD)'["P")
IF ('+DDRUG)
SET DDRUG=$ORDER(^PSDRUG("ASP",PSJOI,0))
IF +DDRUG
DO SETIN("PROFILE",$SELECT(PSJCNT>1:$$OIDF^PSJLMUT1(+$GET(PSJOI)),1:$PIECE($GET(^PSDRUG(DDRUG,0)),U)),+DDRUG,COD,PTYP,PSJCLCOD,PSJCLINF)
QUIT
+30 ;
+31 ;Set exception when no DD found
+32 IF '+DDRUG
DO SETIN("PROFILE",$$OIDF^PSJLMUT1(+$GET(PSJOI)),"",COD,1,PSJCLCOD,PSJCLINF)
QUIT
+33 QUIT
PIV ;Get the dispense drugs for the Pending IV orders.
+1 NEW PSJ0,PSJX,DDRUG,PSJNM,PSJCLNTY,PSJDDNM
+2 SET PSJX=^PS(53.1,+ON,0)
SET PSJORIEN=$PIECE(PSJX,U,21)
if $PIECE(PSJX,U,27)="R"
QUIT
+3 SET (PSJEDOVR,PSJCLINF,PSJCLNTY)=0
SET PSJCLNTY=$$GET1^DIQ(53.1,+ON,4,"I")
+4 if $DATA(^TMP($JOB,"PSJPRE","CLINIC",+ON,531_PSJCLNTY))
SET PSJCLINF=1
+5 if $PIECE($GET(PTYP),";",1)="O"&('$GET(PSJCLINF))
QUIT
+6 SET ON1=0
FOR
SET ON1=$ORDER(^PS(53.1,+ON,"AD",ON1))
if 'ON1
QUIT
Begin DoDot:1
+7 SET PSJX=^PS(53.1,+ON,"AD",ON1,0)
SET PSJ0=$$IV0("AD",+PSJX)
+8 SET PSJNM=$PIECE(PSJ0,U)_" "_$PIECE(PSJX,U,2)
SET DDRUG=$PIECE(PSJ0,U,2)
+9 IF '+DDRUG
DO SETIN("PROFILE",PSJNM,"",COD,4,PSJCLCOD,PSJCLINF)
QUIT
+10 DO SETIN("PROFILE",$PIECE(PSJ0,U)_" "_$PIECE(PSJX,U,2),$PIECE(PSJ0,U,2),COD,PTYP,PSJCLCOD,PSJCLINF)
End DoDot:1
+11 SET ON1=0
FOR
SET ON1=$ORDER(^PS(53.1,+ON,"SOL",ON1))
if 'ON1
QUIT
Begin DoDot:1
+12 SET PSJX=^PS(53.1,+ON,"SOL",ON1,0)
+13 SET PSJ0=$$IV0("",+PSJX)
+14 SET PSJNM=$PIECE(PSJ0,U)_" "_$PIECE(PSJX,U,2)
SET DDRUG=$PIECE(PSJ0,U,2)
+15 IF $$PREMIX^PSJMISC(+PSJX)
Begin DoDot:2
+16 IF '+DDRUG
DO SETIN("PROFILE",PSJNM,"",COD,4,PSJCLCOD,PSJCLINF)
QUIT
+17 DO SETIN("PROFILE",$PIECE(PSJ0,U)_" "_$PIECE(PSJX,U,2),$PIECE(PSJ0,U,2),COD,PTYP,PSJCLCOD,PSJCLINF)
End DoDot:2
QUIT
+18 ;Do allergy check for non-premix as well
+19 IF $GET(PSJDGCK)
Begin DoDot:2
+20 SET PSJDDNM=$PIECE($GET(^PSDRUG(+DDRUG,0)),U)
+21 if $GET(PSJDDNM)]""
SET PSJALLGY("Z",PSJDDNM,DDRUG)=""
End DoDot:2
End DoDot:1
+22 QUIT
IV ;Get the dispense drugs for the IV orders.
+1 NEW PSJ0,PSJX,DDRUG,PSJNM,PSJCLNX,PSJSTOP,PSJDDNM
+2 SET PSJX=^PS(55,DFN,"IV",ON,0)
SET PSJORIEN=$PIECE(PSJX,U,21)
SET (PSJCLINF,PSJCLNX)=0
SET PSJCLNX=$PIECE(PSJX,U,17)
+3 if $PIECE(PSJX,U,17)="R"
QUIT
+4 IF $DATA(^TMP($JOB,"PSJPRE","CLINIC",+ON,"55I"))
SET PSJCLINF=1
+5 IF PSJCLCOD=4!(PSJCLCOD=5)
if PSJCLINF&($PIECE(PSJX,U,17)'="P"&($PIECE(PSJX,U,17)'="N"))
QUIT
+6 if $PIECE($GET(PTYP),";",1)="O"&('$GET(PSJCLINF))
QUIT
+7 if $PIECE(PSJX,U,17)["D"&('PSJCLINF)
QUIT
+8 if $PIECE(PSJX,U,17)="E"&('PSJCLINF)
QUIT
+9 SET ON1=0
FOR
SET ON1=$ORDER(^PS(55,DFN,"IV",ON,"AD",ON1))
if 'ON1
QUIT
Begin DoDot:1
+10 SET PSJX=^PS(55,DFN,"IV",ON,"AD",ON1,0)
SET PSJ0=$$IV0("AD",+PSJX)
+11 SET PSJNM=$PIECE(PSJ0,U)_" "_$PIECE(PSJX,U,2)
SET DDRUG=$PIECE(PSJ0,U,2)
+12 IF '+DDRUG
DO SETIN("PROFILE",PSJNM,"",COD,4,PSJCLCOD,PSJCLINF)
QUIT
+13 DO SETIN("PROFILE",PSJNM,DDRUG,COD,PTYP,PSJCLCOD,PSJCLINF)
End DoDot:1
+14 ; Only include Pre-mix in the OC.
+15 SET ON1=0
FOR
SET ON1=$ORDER(^PS(55,DFN,"IV",ON,"SOL",ON1))
if 'ON1
QUIT
Begin DoDot:1
+16 SET PSJX=^PS(55,DFN,"IV",ON,"SOL",ON1,0)
+17 SET PSJ0=$$IV0("",+PSJX)
+18 SET PSJNM=$PIECE(PSJ0,U)_" "_$PIECE(PSJX,U,2)
SET DDRUG=$PIECE(PSJ0,U,2)
+19 IF $$PREMIX^PSJMISC(+PSJX)
Begin DoDot:2
+20 IF '+DDRUG
DO SETIN("PROFILE",PSJNM,"",COD,4,PSJCLCOD,PSJCLINF)
QUIT
+21 DO SETIN("PROFILE",PSJNM,DDRUG,COD,PTYP,PSJCLCOD,PSJCLINF)
End DoDot:2
QUIT
+22 ;Do allergy check for non-premix as well
+23 IF $GET(PSJDGCK)
Begin DoDot:2
+24 SET PSJDDNM=$PIECE($GET(^PSDRUG(+DDRUG,0)),U)
+25 if $GET(PSJDDNM)]""
SET PSJALLGY("Z",PSJDDNM,DDRUG)=""
End DoDot:2
End DoDot:1
+26 QUIT
SETIN(PSJFLG,PSJNM,DDRUG,ON,PSJCODE,PSJCLCOD,PSJCLINF) ;Set ^TMP($J,"PSJPRE,"IN" arrays.
+1 ;ON = ON with "U/V/P"
+2 ;PSJFLG = "PROSPECTIVE" or "PROFILE"
+3 ;PSJNM = This should be the AD/SOL print name or IV order. Use Dispense drug name if U/D order
+4 ;PSJPON = 4 piece pharmacy order #
+5 NEW PSJPON
+6 if $GET(PSJFLG)=""
QUIT
+7 ;S:$G(PSJDGCK) PSJFLG="PROSPECTIVE" ;when using CK hidden action
+8 SET PSJONCNT=$GET(PSJONCNT)+1
+9 SET PSJPON=$SELECT(PSJCLINF:"C"_PSJCLCOD_";",1:"I;")_ON_";"_PSJFLG_";"_PSJONCNT
+10 IF $PIECE(PSJCODE,";")="O"
SET PSJPON="C"_PSJCLCOD_";"_+ON_";"_PSJFLG_";"_PSJONCNT
+11 IF '+$GET(DDRUG)
Begin DoDot:1
+12 IF +$GET(PSJCODE)
DO NODD($GET(PSJCODE),PSJNM,PSJPON,LIST)
End DoDot:1
QUIT
+13 if $$SUP^PSSDSAPI(+DDRUG)
QUIT
+14 IF $GET(PSJNM)=""
SET PSJNM=$PIECE($GET(^PSDRUG(+DDRUG,0)),U)
+15 ;when using CK hidden action
SET PSJFLG=$SELECT($GET(PSJDGCK):"PROSPECTIVE",1:"PROFILE")
+16 SET ^TMP($JOB,LIST,"IN",PSJFLG,PSJPON)=+$$GCN^PSJMISC(+DDRUG)_U_$$GTVUID^PSJMISC(+DDRUG)_U_+DDRUG_U_PSJNM_U_$GET(PSJORIEN)_U_"I"_U_PSJCLCOD_";"_PSJCLINF
+17 QUIT
IV0(PSJAD,PSIVIEN) ;Return ad/sol zero node
+1 ;PSJAD = "AD" is passed in if it additive, otherwise it's null
+2 IF PSJAD="AD"
QUIT $GET(^PS(52.6,+$GET(PSIVIEN),0))
+3 IF $GET(PSJAD)=""
QUIT $GET(^PS(52.7,+$GET(PSIVIEN),0))
+4 QUIT ""
NODD(PSJCODE,PSJOIDF,PSJPON,PSJBASE) ;Set ^TMP for OI without a dispense drug
+1 ;PSJCODE - A numeric code to trigger the appropriate exception message
+2 ;PSJOIDF - Orderable Item name_Dose form (can be CPRS OI)
+3 ;PSJPON - Pharmacy order #
+4 ;PSJBASE - Base subscript
+5 if $GET(PSJOIDF)=""
QUIT
+6 if $GET(PSJBASE)=""
QUIT
+7 if '+$GET(PSJCODE)
QUIT
+8 ;S PSJIV("OI_ERROR",PSJOIDF)=$G(PSJCODE)_U_$G(PSJPON)
+9 SET ^TMP($JOB,PSJBASE,"IN","EXCEPTIONS","OI",PSJOIDF)=PSJCODE_U_$GET(PSJPON)
+10 QUIT
