PSSDSAPA ;BIR/RTR,TMK-Dose Check APIs routine (continued) ;27 Oct 2009 12:22 PM
;;1.0;PHARMACY DATA MANAGEMENT;**151,160,173,178**;9/30/97;Build 14
;
IV(PSSADFOI) ;Return Additive Frequency default to CPRS, Forum DBIA 5504 ; 27 Oct 2009 12:16 PM
;PSSADFOI = File 50.7 Internal Entry Number
N PSSADFRS,PSSADFIN,PSSADFLP,PSSADFXX,PSSADFHD,PSSADFLD,PSSADFNN,PSSADFER,PSSADFCT
S PSSADFRS="",(PSSADFXX,PSSADFCT)=0
I '$G(PSSADFOI) Q PSSADFRS
F PSSADFLP=0:0 S PSSADFLP=$O(^PS(52.6,"AOI",PSSADFOI,PSSADFLP)) Q:'PSSADFLP!(PSSADFXX) D
. ; Get INACTIVATION DATE and ADDITIVE FREQUENCY
.S PSSADFNN=PSSADFLP_"," K PSSADFER,PSSADFLD
.D GETS^DIQ(52.6,PSSADFNN,"12;18","I","PSSADFLD","PSSADFER")
.I $G(PSSADFER("DIERR")) Q ; Error(s) returned
.S PSSADFIN=$G(PSSADFLD(52.6,PSSADFNN,12,"I")),PSSADFHD=$G(PSSADFLD(52.6,PSSADFNN,18,"I"))
. ; Only consider if not inactive as of today
.I PSSADFIN,PSSADFIN'>DT Q
. ; If no frequency returned, set error flag, look no further
.I PSSADFHD="" S PSSADFXX=1 Q
. ; Save first non-null value found
.I 'PSSADFCT S PSSADFRS=PSSADFHD,PSSADFCT=1 Q
. ; Second or later match found and isn't the same value
. ; as first match value, set error flag, quit
.I PSSADFHD'=PSSADFRS S PSSADFXX=1
; If error found, return null
I PSSADFXX S PSSADFRS=""
Q PSSADFRS
;
;
RESET ;Reset array to set flag to show General Dosing Guideline for last unique combination of Drug and Route
N PSSDBCD1,PSSDBCD2,PSSDBCD3,PSSDBCD4
S PSSDBCD1="" F S PSSDBCD1=$O(PSSDBCDA(PSSDBCD1)) Q:PSSDBCD1="" D
.S PSSDBCD2="" F S PSSDBCD2=$O(PSSDBCDA(PSSDBCD1,PSSDBCD2)) Q:PSSDBCD2="" D
..S PSSDBCD3=PSSDBCDA(PSSDBCD1,PSSDBCD2)
..I PSSDBCD3'="" S PSSDBCDP(PSSDBRLS,PSSDBCD3)=""
Q
;
;
SGEN ;General Dosing Guidelines for last dosing sequence of a complex order when there is an error
N PSSDBCD5,PSSDBCD6,PSSDBCD7,PSSDBCD8
S PSSDBCD6=1
S PSSDBCD5="" F S PSSDBCD5=$O(PSSDBCDP(PSSDWE5,PSSDBCD5)) Q:PSSDBCD5="" D SGENA
Q
;
;
SGENA ;
S PSSDBCD7=$P($G(PSSDBCAR(PSSDBCD5)),"^",2),PSSDBCD8=$P($G(PSSDBCAR(PSSDBCD5)),"^",3)
I PSSDBCD7=""!(PSSDBCD8="") Q
I $G(^TMP($J,PSSDBASE,"OUT","DOSE",PSSDBCD5,PSSDBCD7,"GENERAL","MESSAGE",PSSDBCD8))'="" D S PSSDBCD6=PSSDBCD6+1 Q
.I PSSDBASA S ^TMP($J,PSSDBASF,"OUT","DOSE",PSSDWE5,PSSDBCD7,"3_GENERAL","MESSAGE",PSSDBCD8,PSSDBCD6)=^TMP($J,PSSDBASE,"OUT","DOSE",PSSDBCD5,PSSDBCD7,"GENERAL","MESSAGE",PSSDBCD8)
.I PSSDBASB S ^TMP($J,PSSDBASG,"OUT",PSSDWE5,"MESSAGE","3_GENERAL",PSSDBCD8,PSSDBCD6)=^TMP($J,PSSDBASE,"OUT","DOSE",PSSDBCD5,PSSDBCD7,"GENERAL","MESSAGE",PSSDBCD8)
Q
;
;
REM ;Remove certian output globals to comply with 2.1 requirements
N PSSRMV1,PSSRMV2,PSSRMV3,PSSRMV4,PSSRMV5,PSSRMV6,PSSRMV7,PSSRMV8,PSSRMV9,PSSRMVX,PSSPERR
;
I PSSDBASB D
.S PSSRMV1="" F S PSSRMV1=$O(^TMP($J,PSSDBASG,"OUT",PSSRMV1)) Q:PSSRMV1="" D
..S PSSRMV2="" F S PSSRMV2=$O(^TMP($J,PSSDBASG,"OUT",PSSRMV1,PSSRMV2)) Q:PSSRMV2="" D
...I $P(PSSDBCAR(PSSRMV2),"^",14) K ^TMP($J,PSSDBASG,"OUT",PSSRMV1,PSSRMV2) Q
...S PSSRMV7="" F S PSSRMV7=$O(^TMP($J,PSSDBASG,"OUT",PSSRMV1,PSSRMV2,"ERROR",PSSRMV7)) Q:PSSRMV7="" D
....I $G(^TMP($J,PSSDBASG,"OUT",PSSRMV1,PSSRMV2,"ERROR",PSSRMV7,"WARN"))="Warning",'$P(PSSRMV2,";",5) K ^TMP($J,PSSDBASG,"OUT",PSSRMV1,PSSRMV2,"ERROR",PSSRMV7,"WARN") S $P(PSSDBCAR(PSSRMV2),"^",13)="" Q
....Q ;2.0 Change to now show specific errors
....K ^TMP($J,PSSDBASG,"OUT",PSSRMV1,PSSRMV2,"ERROR",PSSRMV7,"MSG")
....K ^TMP($J,PSSDBASG,"OUT",PSSRMV1,PSSRMV2,"ERROR",PSSRMV7,"TEXT")
...I $P(PSSDBCAR(PSSRMV2),"^",15)!($P(PSSDBCAR(PSSRMV2),"^",16))!($P(PSSRMV2,";",5)) K ^TMP($J,PSSDBASG,"OUT",PSSRMV1,PSSRMV2,"MESSAGE","2_RANGE") ;2.1 added piece 15 and 16 check
...; -- 2.1 added - if Max Single Dose and Max Daily Dose Order Check messages are the same only show one
...N PSSDWIEN
...S PSSDWIEN=+$P(PSSDBCAR(PSSRMV2),"^",3)
...I $G(^TMP($J,PSSDBASG,"OUT",PSSRMV1,PSSRMV2,"MESSAGE","1_SINGLE",PSSDWIEN))]"",($G(^(PSSDWIEN)))=$G(^TMP($J,PSSDBASG,"OUT",PSSRMV1,PSSRMV2,"MESSAGE","2_RANGE",PSSDWIEN)) D
....S ^TMP($J,PSSDBASG,"OUT",PSSRMV1,PSSRMV2,"MESSAGE","1_SINGLE_RANGE",PSSDWIEN)=$G(^TMP($J,PSSDBASG,"OUT",PSSRMV1,PSSRMV2,"MESSAGE","1_SINGLE",PSSDWIEN))
....K ^TMP($J,PSSDBASG,"OUT",PSSRMV1,PSSRMV2,"MESSAGE","1_SINGLE")
....K ^TMP($J,PSSDBASG,"OUT",PSSRMV1,PSSRMV2,"MESSAGE","2_RANGE")
...I $O(^TMP($J,PSSDBASG,"OUT",PSSRMV1,PSSRMV2,"MESSAGE",""))'="" D
....S PSSPERR=$P(PSSDBCAR(PSSRMV2),"^",9) I PSSPERR="OTIC"!(PSSPERR="OPHTHALMIC")!(PSSPERR="INTRANASAL") D
.....S ^TMP($J,PSSDBASG,"OUT",PSSRMV1,PSSRMV2,"MESSAGE",".1_INTRO")="Dosing Information provided is PER "_$S(PSSPERR="OTIC":"EAR:",PSSPERR="OPHTHALMIC":"EYE:",1:"NOSTRIL:")
;
; -- in 2.1 if max daily dose frequency out of range flag=1 for custom frequency message
I PSSDBASB D
. N PSSDADO
. S PSSDADO="" F S PSSDADO=$O(PSSDBCAR(PSSDADO)) Q:PSSDADO="" I $P(PSSDBCAR(PSSDADO),"^",29) D CHKCFREQ^PSSDSUTA(PSSDADO,PSSDBASE,PSSDBASG,.PSSDBCAR)
;
I PSSDBASA D UPCPRS^PSSDSUTL
;
S PSSRMV8="" F S PSSRMV8=$O(PSSDBCAR(PSSRMV8)) Q:PSSRMV8="" I $P(PSSDBCAR(PSSRMV8),"^",13),$D(PSSDSDPL(PSSRMV8)),'$P(PSSDBCAR(PSSRMV8),"^",14) D
.S PSSRMVX=$S('$P(PSSDBCAR(PSSRMV8),"^",15)&('$P(PSSDBCAR(PSSRMV8),"^",16)):"Dosing Checks",1:"Maximum Single Dose Check")
.I PSSDBASB,$P(PSSDBCAR(PSSRMV8),"^",17) D
..S ^TMP($J,PSSDBASG,"OUT",$P(PSSRMV8,";",4),PSSRMV8,"EXCEPTIONS",1)=PSSRMVX_" could not be performed for Drug: "_$P(PSSDBCAR(PSSRMV8),"^",2)_", please complete a manual check for appropriate Dosing."
Q
;
;
SQX(PSSQBSS) ;returns Dosage check exclusion information based on Schedule
N PSSQBA1,PSSQBA2,PSSQBA3,PSSQBA4,PSSQBA5,PSSQBA6,PSSQBARS,PSSQBFLG,PSSQBSTM,PSSQBSTP
S PSSQBARS="",PSSQBFLG=0
I $G(PSSQBSS)="" Q PSSQBARS
S PSSQBSTM=PSSQBSS D SQXLP I PSSQBFLG Q PSSQBARS
S PSSQBA3=$L(PSSQBSS) I PSSQBA3>4 S PSSQBA4=$E(PSSQBSS,(PSSQBA3-3),PSSQBA3) S PSSQBA4=$$UP^XLFSTR(PSSQBA4) I PSSQBA4=" PRN" S PSSQBSTM=$E(PSSQBSS,1,(PSSQBA3-4)) D SQXLP I PSSQBFLG Q PSSQBARS
I PSSQBSS'["@" Q PSSQBARS
S PSSQBA5=$L(PSSQBSS),PSSQBA6=$F(PSSQBSS,"@") I PSSQBA6>PSSQBA5 Q PSSQBARS
S (PSSQBSTM,PSSQBSTP)=$E(PSSQBSS,PSSQBA6,PSSQBA5) D SQXLP I PSSQBFLG Q PSSQBARS
S PSSQBA3=$L(PSSQBSTP) I PSSQBA3>4 S PSSQBA4=$E(PSSQBSTP,(PSSQBA3-3),PSSQBA3) S PSSQBA4=$$UP^XLFSTR(PSSQBA4) I PSSQBA4=" PRN" S PSSQBSTM=$E(PSSQBSTP,1,(PSSQBA3-4)) D SQXLP
Q PSSQBARS
;
;
SQXLP ;
F PSSQBA1=0:0 S PSSQBA1=$O(^PS(51.1,"APPSJ",PSSQBSTM,PSSQBA1)) Q:'PSSQBA1!(PSSQBFLG) D
.S PSSQBA2=$G(^PS(51.1,PSSQBA1,0)) I PSSQBA2="" Q
.S PSSQBARS=$P(PSSQBA2,"^",9)_"^"_$P(PSSQBA2,"^",10),PSSQBFLG=1
Q
;
;
SXCL ;Set exclusion fields in PSSDBCAR array
N PSSQBGR,PSSQBGT
S PSSQBGR=$G(PSSDBFRC(PSSDBKLP,"SCHEDULE")) I PSSQBGR="" Q
S PSSQBGT=$$SQX(PSSQBGR)
S:$P(PSSQBGT,"^") $P(PSSDBCAR(PSSDBKLP),"^",14)=1
S:$P(PSSQBGT,"^",2) $P(PSSDBCAR(PSSDBKLP),"^",15)=1
Q
;
;
NOTS ;Set flag for not screened
N PSSNSCRE,PSSNSCRU
S PSSNSCRE=$G(^TMP($J,PSSDBASE,"OUT","DOSE","ERROR",PSSDWLP,PSSDWL1,"SEV"))
S PSSNSCRU=$$UP^XLFSTR(PSSNSCRE)
I PSSNSCRU["NOTSCREENED" S $P(PSSDBCAR(PSSDWLP),"^",13)=1
Q
;
;
SOL(PSSLGTOI) ;
;Return 1 for premix solution
;Return 0 for solution not marked for premix
;The second piece is 0 if there is no active solution found
;If no active solution found and at least 1 premix then consider it's a premix
NEW PSSLGT1,PSSLGT2,PSSLGT3,PSSSOL,PSSPRE
I '+$G(PSSLGTOI) Q 0_U_0
S PSSINADT=$P($G(^PS(50.7,PSSLGTOI,0)),U,4)
I PSSINADT,(PSSINADT'>DT) Q 0_U_0
S PSSLGT2=0,PSSSOL=0,PSSPRE=0
F PSSLGT1=0:0 S PSSLGT1=$O(^PS(52.7,"AOI",PSSLGTOI,PSSLGT1)) Q:'PSSLGT1!(PSSLGT2) D
.I $P($G(^PS(52.7,PSSLGT1,0)),"^",14)=1 S PSSPRE=1
.S PSSLGT3=$P($G(^PS(52.7,PSSLGT1,"I")),"^") I PSSLGT3,(PSSLGT3'>DT) Q
.S:PSSPRE PSSLGT2=1
.S PSSSOL=1
I 'PSSSOL,PSSPRE Q PSSPRE_U_PSSSOL
Q PSSLGT2_U_PSSSOL
;
;
IPM(PSSLGTOI) ;
;Return 1 if it's a UD, additive, or a premix solution
NEW PSSINADT,PSSIEN,PSSUD,PSSAD,PSSSOL
I '+$G(PSSLGTOI) Q 0
S (PSSUD,PSSAD,PSSSOL)=0
S PSSINADT=$P($G(^PS(50.7,PSSLGTOI,0)),U,4)
I PSSINADT,(PSSINADT'>DT) Q 0
F PSSIEN=0:0 S PSSIEN=$O(^PSDRUG("ASP",PSSLGTOI,PSSIEN)) Q:'PSSIEN!PSSUD D
. S PSSINADT=$P($G(^PSDRUG(PSSIEN,"I")),U)
. I PSSINADT,(PSSINADT'>DT) Q
. I $P($G(^PSDRUG(PSSIEN,2)),U,3)["U" S PSSUD=1 Q
I PSSUD Q 1
F PSSIEN=0:0 S PSSIEN=$O(^PS(52.6,"AOI",PSSLGTOI,PSSIEN)) Q:'PSSIEN!PSSAD D
. S PSSAD=1 Q
I PSSAD Q 1
S PSSSOL=$$SOL(PSSLGTOI)
;If the is an active solution, $P(PSSSOL,U) is 1 if it's marked for premix
Q $P(PSSSOL,U)
;
;
ONT ;Look for one to one relationship from Dispense Drug to Orderable Item for application
N PSSOTOD,PSSOTOI,PSSOTOL,PSSOTOF,PSSOTOA,PSSOTON,PSSOTOB1,PSSOTOB2,PSSOTOB3,PSSOTOB4
S PSSOTOF=0
S PSSOTOI=$P($G(^PSDRUG(+PSSDBIFG,2)),"^") I 'PSSOTOI Q
F PSSOTOL=0:0 S PSSOTOL=$O(^PSDRUG("ASP",PSSOTOI,PSSOTOL)) Q:'PSSOTOL!(PSSOTOF) D:PSSOTOL'=+PSSDBIFG
.I $$EXMT^PSSDSAPI(PSSOTOL) Q
.S PSSOTOD=$P($G(^PSDRUG(PSSOTOL,"I")),"^") I PSSOTOD,PSSOTOD'>DT Q
.S PSSOTOA=$P($G(^PSDRUG(PSSOTOL,2)),"^",3),PSSOTOA=$TR(PSSOTOA,"U","I")
.I PSSOTOA'[$G(PSSDBFDB("PACKAGE")) Q
.S PSSOTOB2=$G(^PSDRUG(PSSOTOL,"ND")),PSSOTOB1=$P(PSSOTOB2,"^"),PSSOTOB3=$P(PSSOTOB2,"^",3) I 'PSSOTOB1!('PSSOTOB3) Q
.S PSSOTOB4=$$PROD0^PSNAPIS(PSSOTOB1,PSSOTOB3) I '$P(PSSOTOB4,"^",7) Q
.S PSSOTOF=1
Q:PSSOTOF
S PSSDBIFL=0,PSSOTON=$P($G(^PSDRUG(+PSSDBIFG,0)),"^")
S PSSDBFDB(PSSDBLP,"DRUG_NM")=$S(PSSOTON'="":PSSOTON,1:"UNKNOWN DRUG NAME")
S PSSDBFDB(PSSDBLP,"DRUG_IEN")=+PSSDBIFG
Q
;
;
TLS(PSSTLS1,PSSTLS2) ;
N PSSTLS5,PSSTLS6,PSSTLS7
S PSSTLS5=$$DFSU^PSNAPIS(PSSTLS1,PSSTLS2)
S PSSTLS6=$P(PSSTLS5,"^",4),PSSTLS7=$P(PSSTLS5,"^",5)
I 'PSSTLS7!(PSSTLS6="") Q 1
I '$D(^PS(50.607,PSSTLS7,0)) Q 1
I PSSTLS6'?.N&(PSSTLS6'?.N1".".N) Q 1
Q 0
;
;
INRATE ;Infusion Rate error, default data already set in Inpatient
;N PSSDBEC1
I 'PSSDBEB3 Q
I $P(PSSDBEB2,"^",5)=""!($P(PSSDBEB2,"^",6)="") D EXCPS^PSSDSAPD(1)
;S PSSDBEC1=$P(PSSDBEB2,"^",11) S PSSDBEC1=$$UP^XLFSTR(PSSDBEC1) I $E(PSSDBEC1,1,4)'="CONT" Q
S $P(PSSDBCAR(PSSDBEB1),"^",21)=1
D EXCPS^PSSDSAPD(3) D INFERRS^PSSDSAPK
I $D(PSSDBCAZ(PSSDBEB1,"FRQ_ERROR")) D EXCPS^PSSDSAPD(2)
I $P(PSSDBCAR(PSSDBEB1),"^",5) S $P(PSSDBCAR(PSSDBEB1),"^",6)=1 S $P(PSSDBCAR(PSSDBEB1),"^",10)=1 Q ;Maintenance Dose
;Single Dose, code should never be invoked, because we don't send Continuous infusions
S $P(PSSDBCAR(PSSDBEB1),"^")="S"
S $P(PSSDBCAR(PSSDBEB1),"^",7)=1
Q
;
;
INFRQ ;Frequency error
I 'PSSDBEB3 Q
I $P(PSSDBEB2,"^",11)="" Q
;I '$P(PSSDBCAR(PSSDBEB1),"^",5) Q
D EXCPS^PSSDSAPD(2)
S $P(PSSDBCAR(PSSDBEB1),"^")="S"
I $P(PSSDBCAR(PSSDBEB1),"^",5) S $P(PSSDBCAR(PSSDBEB1),"^",8)=1 S $P(PSSDBCAR(PSSDBEB1),"^",10)=1
;Inpatient may already be setting next 3, because this applies to Outpatient and IV
S $P(^TMP($J,PSSDBASE,"IN","DOSE",PSSDBEB1),"^",8)=1,$P(^TMP($J,PSSDBASE,"IN","DOSE",PSSDBEB1),"^",9)=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)
; -- in 2.1 set Dummy Data flag
S $P(PSSDBCAR(PSSDBEB1),"^",33)=1
Q
;
;
DUNIT() ;Find unit
;Piece 3 of PSSDBCAR must be a File 50 IEN
N PSSDBEG1,PSSDBEG2,PSSDBEG3,PSSDBEG4,PSSDBEG5,PSSDBEG6,PSSDBEG7,X,Y
S PSSDBEG4=""
S PSSDBEG1=$P(PSSDBCAR(PSSDBEB1),"^",3)
I PSSDBEG1 D I PSSDBEG4'="" Q PSSDBEG4
.S PSSDBEG2=$P($G(^PSDRUG(PSSDBEG1,"ND")),"^"),PSSDBEG3=$P($G(^PSDRUG(PSSDBEG1,"ND")),"^",3)
.I 'PSSDBEG2!('PSSDBEG3) Q
.S PSSDBEG5=$$DFSU^PSNAPIS(PSSDBEG2,PSSDBEG3)
.S PSSDBEG6=$P(PSSDBEG5,"^",6)
.I PSSDBEG6'="" S PSSDBEG7=$$UNIT^PSSDSAPI(PSSDBEG6) I PSSDBEG7'="" S PSSDBEG4=PSSDBEG7
I PSSDBEG1 F PSSDBEG2=0:0 S PSSDBEG2=$O(^PSDRUG(PSSDBEG1,"DOS2",PSSDBEG2)) Q:'PSSDBEG2!(PSSDBEG4'="") D
.S PSSDBEG3=$P($G(^PSDRUG(PSSDBEG1,"DOS2",PSSDBEG2,0)),"^",5)
.I PSSDBEG3,$P($G(^PS(51.24,PSSDBEG3,0)),"^",2)'="" S PSSDBEG4=$P(^PS(51.24,PSSDBEG3,0),"^",2)
I PSSDBEG4'="" Q PSSDBEG4
I PSSDBEG1 S PSSDBEG2=$P($G(^PSDRUG(PSSDBEG1,2)),"^") I PSSDBEG2 D
.S PSSDBEG3=$P($G(^PS(50.7,PSSDBEG2,0)),"^",2) I PSSDBEG3 D
..F PSSDBEG5=0:0 S PSSDBEG5=$O(^PS(50.606,PSSDBEG3,"NOUN",PSSDBEG5)) Q:'PSSDBEG5!(PSSDBEG4'="") D
...S PSSDBEG6=$P($G(^PS(50.606,PSSDBEG3,"NOUN",PSSDBEG5,0)),"^")
...I PSSDBEG6'="" S PSSDBEG7=$$UNIT^PSSDSAPI(PSSDBEG6) I PSSDBEG7'="" S PSSDBEG4=PSSDBEG7
I PSSDBEG4'="" Q PSSDBEG4
Q "EACH"
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSSDSAPA 12487 printed Oct 16, 2024@18:31:45 Page 2
PSSDSAPA ;BIR/RTR,TMK-Dose Check APIs routine (continued) ;27 Oct 2009 12:22 PM
+1 ;;1.0;PHARMACY DATA MANAGEMENT;**151,160,173,178**;9/30/97;Build 14
+2 ;
IV(PSSADFOI) ;Return Additive Frequency default to CPRS, Forum DBIA 5504 ; 27 Oct 2009 12:16 PM
+1 ;PSSADFOI = File 50.7 Internal Entry Number
+2 NEW PSSADFRS,PSSADFIN,PSSADFLP,PSSADFXX,PSSADFHD,PSSADFLD,PSSADFNN,PSSADFER,PSSADFCT
+3 SET PSSADFRS=""
SET (PSSADFXX,PSSADFCT)=0
+4 IF '$GET(PSSADFOI)
QUIT PSSADFRS
+5 FOR PSSADFLP=0:0
SET PSSADFLP=$ORDER(^PS(52.6,"AOI",PSSADFOI,PSSADFLP))
if 'PSSADFLP!(PSSADFXX)
QUIT
Begin DoDot:1
+6 ; Get INACTIVATION DATE and ADDITIVE FREQUENCY
+7 SET PSSADFNN=PSSADFLP_","
KILL PSSADFER,PSSADFLD
+8 DO GETS^DIQ(52.6,PSSADFNN,"12;18","I","PSSADFLD","PSSADFER")
+9 ; Error(s) returned
IF $GET(PSSADFER("DIERR"))
QUIT
+10 SET PSSADFIN=$GET(PSSADFLD(52.6,PSSADFNN,12,"I"))
SET PSSADFHD=$GET(PSSADFLD(52.6,PSSADFNN,18,"I"))
+11 ; Only consider if not inactive as of today
+12 IF PSSADFIN
IF PSSADFIN'>DT
QUIT
+13 ; If no frequency returned, set error flag, look no further
+14 IF PSSADFHD=""
SET PSSADFXX=1
QUIT
+15 ; Save first non-null value found
+16 IF 'PSSADFCT
SET PSSADFRS=PSSADFHD
SET PSSADFCT=1
QUIT
+17 ; Second or later match found and isn't the same value
+18 ; as first match value, set error flag, quit
+19 IF PSSADFHD'=PSSADFRS
SET PSSADFXX=1
End DoDot:1
+20 ; If error found, return null
+21 IF PSSADFXX
SET PSSADFRS=""
+22 QUIT PSSADFRS
+23 ;
+24 ;
RESET ;Reset array to set flag to show General Dosing Guideline for last unique combination of Drug and Route
+1 NEW PSSDBCD1,PSSDBCD2,PSSDBCD3,PSSDBCD4
+2 SET PSSDBCD1=""
FOR
SET PSSDBCD1=$ORDER(PSSDBCDA(PSSDBCD1))
if PSSDBCD1=""
QUIT
Begin DoDot:1
+3 SET PSSDBCD2=""
FOR
SET PSSDBCD2=$ORDER(PSSDBCDA(PSSDBCD1,PSSDBCD2))
if PSSDBCD2=""
QUIT
Begin DoDot:2
+4 SET PSSDBCD3=PSSDBCDA(PSSDBCD1,PSSDBCD2)
+5 IF PSSDBCD3'=""
SET PSSDBCDP(PSSDBRLS,PSSDBCD3)=""
End DoDot:2
End DoDot:1
+6 QUIT
+7 ;
+8 ;
SGEN ;General Dosing Guidelines for last dosing sequence of a complex order when there is an error
+1 NEW PSSDBCD5,PSSDBCD6,PSSDBCD7,PSSDBCD8
+2 SET PSSDBCD6=1
+3 SET PSSDBCD5=""
FOR
SET PSSDBCD5=$ORDER(PSSDBCDP(PSSDWE5,PSSDBCD5))
if PSSDBCD5=""
QUIT
DO SGENA
+4 QUIT
+5 ;
+6 ;
SGENA ;
+1 SET PSSDBCD7=$PIECE($GET(PSSDBCAR(PSSDBCD5)),"^",2)
SET PSSDBCD8=$PIECE($GET(PSSDBCAR(PSSDBCD5)),"^",3)
+2 IF PSSDBCD7=""!(PSSDBCD8="")
QUIT
+3 IF $GET(^TMP($JOB,PSSDBASE,"OUT","DOSE",PSSDBCD5,PSSDBCD7,"GENERAL","MESSAGE",PSSDBCD8))'=""
Begin DoDot:1
+4 IF PSSDBASA
SET ^TMP($JOB,PSSDBASF,"OUT","DOSE",PSSDWE5,PSSDBCD7,"3_GENERAL","MESSAGE",PSSDBCD8,PSSDBCD6)=^TMP($JOB,PSSDBASE,"OUT","DOSE",PSSDBCD5,PSSDBCD7,"GENERAL","MESSAGE",PSSDBCD8)
+5 IF PSSDBASB
SET ^TMP($JOB,PSSDBASG,"OUT",PSSDWE5,"MESSAGE","3_GENERAL",PSSDBCD8,PSSDBCD6)=^TMP($JOB,PSSDBASE,"OUT","DOSE",PSSDBCD5,PSSDBCD7,"GENERAL","MESSAGE",PSSDBCD8)
End DoDot:1
SET PSSDBCD6=PSSDBCD6+1
QUIT
+6 QUIT
+7 ;
+8 ;
REM ;Remove certian output globals to comply with 2.1 requirements
+1 NEW PSSRMV1,PSSRMV2,PSSRMV3,PSSRMV4,PSSRMV5,PSSRMV6,PSSRMV7,PSSRMV8,PSSRMV9,PSSRMVX,PSSPERR
+2 ;
+3 IF PSSDBASB
Begin DoDot:1
+4 SET PSSRMV1=""
FOR
SET PSSRMV1=$ORDER(^TMP($JOB,PSSDBASG,"OUT",PSSRMV1))
if PSSRMV1=""
QUIT
Begin DoDot:2
+5 SET PSSRMV2=""
FOR
SET PSSRMV2=$ORDER(^TMP($JOB,PSSDBASG,"OUT",PSSRMV1,PSSRMV2))
if PSSRMV2=""
QUIT
Begin DoDot:3
+6 IF $PIECE(PSSDBCAR(PSSRMV2),"^",14)
KILL ^TMP($JOB,PSSDBASG,"OUT",PSSRMV1,PSSRMV2)
QUIT
+7 SET PSSRMV7=""
FOR
SET PSSRMV7=$ORDER(^TMP($JOB,PSSDBASG,"OUT",PSSRMV1,PSSRMV2,"ERROR",PSSRMV7))
if PSSRMV7=""
QUIT
Begin DoDot:4
+8 IF $GET(^TMP($JOB,PSSDBASG,"OUT",PSSRMV1,PSSRMV2,"ERROR",PSSRMV7,"WARN"))="Warning"
IF '$PIECE(PSSRMV2,";",5)
KILL ^TMP($JOB,PSSDBASG,"OUT",PSSRMV1,PSSRMV2,"ERROR",PSSRMV7,"WARN")
SET $PIECE(PSSDBCAR(PSSRMV2),"^",13)=""
QUIT
+9 ;2.0 Change to now show specific errors
QUIT
+10 KILL ^TMP($JOB,PSSDBASG,"OUT",PSSRMV1,PSSRMV2,"ERROR",PSSRMV7,"MSG")
+11 KILL ^TMP($JOB,PSSDBASG,"OUT",PSSRMV1,PSSRMV2,"ERROR",PSSRMV7,"TEXT")
End DoDot:4
+12 ;2.1 added piece 15 and 16 check
IF $PIECE(PSSDBCAR(PSSRMV2),"^",15)!($PIECE(PSSDBCAR(PSSRMV2),"^",16))!($PIECE(PSSRMV2,";",5))
KILL ^TMP($JOB,PSSDBASG,"OUT",PSSRMV1,PSSRMV2,"MESSAGE","2_RANGE")
+13 ; -- 2.1 added - if Max Single Dose and Max Daily Dose Order Check messages are the same only show one
+14 NEW PSSDWIEN
+15 SET PSSDWIEN=+$PIECE(PSSDBCAR(PSSRMV2),"^",3)
+16 IF $GET(^TMP($JOB,PSSDBASG,"OUT",PSSRMV1,PSSRMV2,"MESSAGE","1_SINGLE",PSSDWIEN))]""
IF ($GET(^(PSSDWIEN)))=$GET(^TMP($JOB,PSSDBASG,"OUT",PSSRMV1,PSSRMV2,"MESSAGE","2_RANGE",PSSDWIEN))
Begin DoDot:4
+17 SET ^TMP($JOB,PSSDBASG,"OUT",PSSRMV1,PSSRMV2,"MESSAGE","1_SINGLE_RANGE",PSSDWIEN)=$GET(^TMP($JOB,PSSDBASG,"OUT",PSSRMV1,PSSRMV2,"MESSAGE","1_SINGLE",PSSDWIEN))
+18 KILL ^TMP($JOB,PSSDBASG,"OUT",PSSRMV1,PSSRMV2,"MESSAGE","1_SINGLE")
+19 KILL ^TMP($JOB,PSSDBASG,"OUT",PSSRMV1,PSSRMV2,"MESSAGE","2_RANGE")
End DoDot:4
+20 IF $ORDER(^TMP($JOB,PSSDBASG,"OUT",PSSRMV1,PSSRMV2,"MESSAGE",""))'=""
Begin DoDot:4
+21 SET PSSPERR=$PIECE(PSSDBCAR(PSSRMV2),"^",9)
IF PSSPERR="OTIC"!(PSSPERR="OPHTHALMIC")!(PSSPERR="INTRANASAL")
Begin DoDot:5
+22 SET ^TMP($JOB,PSSDBASG,"OUT",PSSRMV1,PSSRMV2,"MESSAGE",".1_INTRO")="Dosing Information provided is PER "_$SELECT(PSSPERR="OTIC":"EAR:",PSSPERR="OPHTHALMIC":"EYE:",1:"NOSTRIL:")
End DoDot:5
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+23 ;
+24 ; -- in 2.1 if max daily dose frequency out of range flag=1 for custom frequency message
+25 IF PSSDBASB
Begin DoDot:1
+26 NEW PSSDADO
+27 SET PSSDADO=""
FOR
SET PSSDADO=$ORDER(PSSDBCAR(PSSDADO))
if PSSDADO=""
QUIT
IF $PIECE(PSSDBCAR(PSSDADO),"^",29)
DO CHKCFREQ^PSSDSUTA(PSSDADO,PSSDBASE,PSSDBASG,.PSSDBCAR)
End DoDot:1
+28 ;
+29 IF PSSDBASA
DO UPCPRS^PSSDSUTL
+30 ;
+31 SET PSSRMV8=""
FOR
SET PSSRMV8=$ORDER(PSSDBCAR(PSSRMV8))
if PSSRMV8=""
QUIT
IF $PIECE(PSSDBCAR(PSSRMV8),"^",13)
IF $DATA(PSSDSDPL(PSSRMV8))
IF '$PIECE(PSSDBCAR(PSSRMV8),"^",14)
Begin DoDot:1
+32 SET PSSRMVX=$SELECT('$PIECE(PSSDBCAR(PSSRMV8),"^",15)&('$PIECE(PSSDBCAR(PSSRMV8),"^",16)):"Dosing Checks",1:"Maximum Single Dose Check")
+33 IF PSSDBASB
IF $PIECE(PSSDBCAR(PSSRMV8),"^",17)
Begin DoDot:2
+34 SET ^TMP($JOB,PSSDBASG,"OUT",$PIECE(PSSRMV8,";",4),PSSRMV8,"EXCEPTIONS",1)=PSSRMVX_" could not be performed for Drug: "_$PIECE(PSSDBCAR(PSSRMV8),"^",2)_", please complete a manual check for appropriate Dosing."
End DoDot:2
End DoDot:1
+35 QUIT
+36 ;
+37 ;
SQX(PSSQBSS) ;returns Dosage check exclusion information based on Schedule
+1 NEW PSSQBA1,PSSQBA2,PSSQBA3,PSSQBA4,PSSQBA5,PSSQBA6,PSSQBARS,PSSQBFLG,PSSQBSTM,PSSQBSTP
+2 SET PSSQBARS=""
SET PSSQBFLG=0
+3 IF $GET(PSSQBSS)=""
QUIT PSSQBARS
+4 SET PSSQBSTM=PSSQBSS
DO SQXLP
IF PSSQBFLG
QUIT PSSQBARS
+5 SET PSSQBA3=$LENGTH(PSSQBSS)
IF PSSQBA3>4
SET PSSQBA4=$EXTRACT(PSSQBSS,(PSSQBA3-3),PSSQBA3)
SET PSSQBA4=$$UP^XLFSTR(PSSQBA4)
IF PSSQBA4=" PRN"
SET PSSQBSTM=$EXTRACT(PSSQBSS,1,(PSSQBA3-4))
DO SQXLP
IF PSSQBFLG
QUIT PSSQBARS
+6 IF PSSQBSS'["@"
QUIT PSSQBARS
+7 SET PSSQBA5=$LENGTH(PSSQBSS)
SET PSSQBA6=$FIND(PSSQBSS,"@")
IF PSSQBA6>PSSQBA5
QUIT PSSQBARS
+8 SET (PSSQBSTM,PSSQBSTP)=$EXTRACT(PSSQBSS,PSSQBA6,PSSQBA5)
DO SQXLP
IF PSSQBFLG
QUIT PSSQBARS
+9 SET PSSQBA3=$LENGTH(PSSQBSTP)
IF PSSQBA3>4
SET PSSQBA4=$EXTRACT(PSSQBSTP,(PSSQBA3-3),PSSQBA3)
SET PSSQBA4=$$UP^XLFSTR(PSSQBA4)
IF PSSQBA4=" PRN"
SET PSSQBSTM=$EXTRACT(PSSQBSTP,1,(PSSQBA3-4))
DO SQXLP
+10 QUIT PSSQBARS
+11 ;
+12 ;
SQXLP ;
+1 FOR PSSQBA1=0:0
SET PSSQBA1=$ORDER(^PS(51.1,"APPSJ",PSSQBSTM,PSSQBA1))
if 'PSSQBA1!(PSSQBFLG)
QUIT
Begin DoDot:1
+2 SET PSSQBA2=$GET(^PS(51.1,PSSQBA1,0))
IF PSSQBA2=""
QUIT
+3 SET PSSQBARS=$PIECE(PSSQBA2,"^",9)_"^"_$PIECE(PSSQBA2,"^",10)
SET PSSQBFLG=1
End DoDot:1
+4 QUIT
+5 ;
+6 ;
SXCL ;Set exclusion fields in PSSDBCAR array
+1 NEW PSSQBGR,PSSQBGT
+2 SET PSSQBGR=$GET(PSSDBFRC(PSSDBKLP,"SCHEDULE"))
IF PSSQBGR=""
QUIT
+3 SET PSSQBGT=$$SQX(PSSQBGR)
+4 if $PIECE(PSSQBGT,"^")
SET $PIECE(PSSDBCAR(PSSDBKLP),"^",14)=1
+5 if $PIECE(PSSQBGT,"^",2)
SET $PIECE(PSSDBCAR(PSSDBKLP),"^",15)=1
+6 QUIT
+7 ;
+8 ;
NOTS ;Set flag for not screened
+1 NEW PSSNSCRE,PSSNSCRU
+2 SET PSSNSCRE=$GET(^TMP($JOB,PSSDBASE,"OUT","DOSE","ERROR",PSSDWLP,PSSDWL1,"SEV"))
+3 SET PSSNSCRU=$$UP^XLFSTR(PSSNSCRE)
+4 IF PSSNSCRU["NOTSCREENED"
SET $PIECE(PSSDBCAR(PSSDWLP),"^",13)=1
+5 QUIT
+6 ;
+7 ;
SOL(PSSLGTOI) ;
+1 ;Return 1 for premix solution
+2 ;Return 0 for solution not marked for premix
+3 ;The second piece is 0 if there is no active solution found
+4 ;If no active solution found and at least 1 premix then consider it's a premix
+5 NEW PSSLGT1,PSSLGT2,PSSLGT3,PSSSOL,PSSPRE
+6 IF '+$GET(PSSLGTOI)
QUIT 0_U_0
+7 SET PSSINADT=$PIECE($GET(^PS(50.7,PSSLGTOI,0)),U,4)
+8 IF PSSINADT
IF (PSSINADT'>DT)
QUIT 0_U_0
+9 SET PSSLGT2=0
SET PSSSOL=0
SET PSSPRE=0
+10 FOR PSSLGT1=0:0
SET PSSLGT1=$ORDER(^PS(52.7,"AOI",PSSLGTOI,PSSLGT1))
if 'PSSLGT1!(PSSLGT2)
QUIT
Begin DoDot:1
+11 IF $PIECE($GET(^PS(52.7,PSSLGT1,0)),"^",14)=1
SET PSSPRE=1
+12 SET PSSLGT3=$PIECE($GET(^PS(52.7,PSSLGT1,"I")),"^")
IF PSSLGT3
IF (PSSLGT3'>DT)
QUIT
+13 if PSSPRE
SET PSSLGT2=1
+14 SET PSSSOL=1
End DoDot:1
+15 IF 'PSSSOL
IF PSSPRE
QUIT PSSPRE_U_PSSSOL
+16 QUIT PSSLGT2_U_PSSSOL
+17 ;
+18 ;
IPM(PSSLGTOI) ;
+1 ;Return 1 if it's a UD, additive, or a premix solution
+2 NEW PSSINADT,PSSIEN,PSSUD,PSSAD,PSSSOL
+3 IF '+$GET(PSSLGTOI)
QUIT 0
+4 SET (PSSUD,PSSAD,PSSSOL)=0
+5 SET PSSINADT=$PIECE($GET(^PS(50.7,PSSLGTOI,0)),U,4)
+6 IF PSSINADT
IF (PSSINADT'>DT)
QUIT 0
+7 FOR PSSIEN=0:0
SET PSSIEN=$ORDER(^PSDRUG("ASP",PSSLGTOI,PSSIEN))
if 'PSSIEN!PSSUD
QUIT
Begin DoDot:1
+8 SET PSSINADT=$PIECE($GET(^PSDRUG(PSSIEN,"I")),U)
+9 IF PSSINADT
IF (PSSINADT'>DT)
QUIT
+10 IF $PIECE($GET(^PSDRUG(PSSIEN,2)),U,3)["U"
SET PSSUD=1
QUIT
End DoDot:1
+11 IF PSSUD
QUIT 1
+12 FOR PSSIEN=0:0
SET PSSIEN=$ORDER(^PS(52.6,"AOI",PSSLGTOI,PSSIEN))
if 'PSSIEN!PSSAD
QUIT
Begin DoDot:1
+13 SET PSSAD=1
QUIT
End DoDot:1
+14 IF PSSAD
QUIT 1
+15 SET PSSSOL=$$SOL(PSSLGTOI)
+16 ;If the is an active solution, $P(PSSSOL,U) is 1 if it's marked for premix
+17 QUIT $PIECE(PSSSOL,U)
+18 ;
+19 ;
ONT ;Look for one to one relationship from Dispense Drug to Orderable Item for application
+1 NEW PSSOTOD,PSSOTOI,PSSOTOL,PSSOTOF,PSSOTOA,PSSOTON,PSSOTOB1,PSSOTOB2,PSSOTOB3,PSSOTOB4
+2 SET PSSOTOF=0
+3 SET PSSOTOI=$PIECE($GET(^PSDRUG(+PSSDBIFG,2)),"^")
IF 'PSSOTOI
QUIT
+4 FOR PSSOTOL=0:0
SET PSSOTOL=$ORDER(^PSDRUG("ASP",PSSOTOI,PSSOTOL))
if 'PSSOTOL!(PSSOTOF)
QUIT
if PSSOTOL'=+PSSDBIFG
Begin DoDot:1
+5 IF $$EXMT^PSSDSAPI(PSSOTOL)
QUIT
+6 SET PSSOTOD=$PIECE($GET(^PSDRUG(PSSOTOL,"I")),"^")
IF PSSOTOD
IF PSSOTOD'>DT
QUIT
+7 SET PSSOTOA=$PIECE($GET(^PSDRUG(PSSOTOL,2)),"^",3)
SET PSSOTOA=$TRANSLATE(PSSOTOA,"U","I")
+8 IF PSSOTOA'[$GET(PSSDBFDB("PACKAGE"))
QUIT
+9 SET PSSOTOB2=$GET(^PSDRUG(PSSOTOL,"ND"))
SET PSSOTOB1=$PIECE(PSSOTOB2,"^")
SET PSSOTOB3=$PIECE(PSSOTOB2,"^",3)
IF 'PSSOTOB1!('PSSOTOB3)
QUIT
+10 SET PSSOTOB4=$$PROD0^PSNAPIS(PSSOTOB1,PSSOTOB3)
IF '$PIECE(PSSOTOB4,"^",7)
QUIT
+11 SET PSSOTOF=1
End DoDot:1
+12 if PSSOTOF
QUIT
+13 SET PSSDBIFL=0
SET PSSOTON=$PIECE($GET(^PSDRUG(+PSSDBIFG,0)),"^")
+14 SET PSSDBFDB(PSSDBLP,"DRUG_NM")=$SELECT(PSSOTON'="":PSSOTON,1:"UNKNOWN DRUG NAME")
+15 SET PSSDBFDB(PSSDBLP,"DRUG_IEN")=+PSSDBIFG
+16 QUIT
+17 ;
+18 ;
TLS(PSSTLS1,PSSTLS2) ;
+1 NEW PSSTLS5,PSSTLS6,PSSTLS7
+2 SET PSSTLS5=$$DFSU^PSNAPIS(PSSTLS1,PSSTLS2)
+3 SET PSSTLS6=$PIECE(PSSTLS5,"^",4)
SET PSSTLS7=$PIECE(PSSTLS5,"^",5)
+4 IF 'PSSTLS7!(PSSTLS6="")
QUIT 1
+5 IF '$DATA(^PS(50.607,PSSTLS7,0))
QUIT 1
+6 IF PSSTLS6'?.N&(PSSTLS6'?.N1".".N)
QUIT 1
+7 QUIT 0
+8 ;
+9 ;
INRATE ;Infusion Rate error, default data already set in Inpatient
+1 ;N PSSDBEC1
+2 IF 'PSSDBEB3
QUIT
+3 IF $PIECE(PSSDBEB2,"^",5)=""!($PIECE(PSSDBEB2,"^",6)="")
DO EXCPS^PSSDSAPD(1)
+4 ;S PSSDBEC1=$P(PSSDBEB2,"^",11) S PSSDBEC1=$$UP^XLFSTR(PSSDBEC1) I $E(PSSDBEC1,1,4)'="CONT" Q
+5 SET $PIECE(PSSDBCAR(PSSDBEB1),"^",21)=1
+6 DO EXCPS^PSSDSAPD(3)
DO INFERRS^PSSDSAPK
+7 IF $DATA(PSSDBCAZ(PSSDBEB1,"FRQ_ERROR"))
DO EXCPS^PSSDSAPD(2)
+8 ;Maintenance Dose
IF $PIECE(PSSDBCAR(PSSDBEB1),"^",5)
SET $PIECE(PSSDBCAR(PSSDBEB1),"^",6)=1
SET $PIECE(PSSDBCAR(PSSDBEB1),"^",10)=1
QUIT
+9 ;Single Dose, code should never be invoked, because we don't send Continuous infusions
+10 SET $PIECE(PSSDBCAR(PSSDBEB1),"^")="S"
+11 SET $PIECE(PSSDBCAR(PSSDBEB1),"^",7)=1
+12 QUIT
+13 ;
+14 ;
INFRQ ;Frequency error
+1 IF 'PSSDBEB3
QUIT
+2 IF $PIECE(PSSDBEB2,"^",11)=""
QUIT
+3 ;I '$P(PSSDBCAR(PSSDBEB1),"^",5) Q
+4 DO EXCPS^PSSDSAPD(2)
+5 SET $PIECE(PSSDBCAR(PSSDBEB1),"^")="S"
+6 IF $PIECE(PSSDBCAR(PSSDBEB1),"^",5)
SET $PIECE(PSSDBCAR(PSSDBEB1),"^",8)=1
SET $PIECE(PSSDBCAR(PSSDBEB1),"^",10)=1
+7 ;Inpatient may already be setting next 3, because this applies to Outpatient and IV
+8 SET $PIECE(^TMP($JOB,PSSDBASE,"IN","DOSE",PSSDBEB1),"^",8)=1
SET $PIECE(^TMP($JOB,PSSDBASE,"IN","DOSE",PSSDBEB1),"^",9)=1
+9 ;S $P(^TMP($J,PSSDBASE,"IN","DOSE",PSSDBEB1),"^",9)=1
+10 SET $PIECE(^TMP($JOB,PSSDBASE,"IN","DOSE",PSSDBEB1),"^",10)=$PIECE(^TMP($JOB,PSSDBASE,"IN","DOSE",PSSDBEB1),"^",7)
+11 ; -- in 2.1 set Dummy Data flag
+12 SET $PIECE(PSSDBCAR(PSSDBEB1),"^",33)=1
+13 QUIT
+14 ;
+15 ;
DUNIT() ;Find unit
+1 ;Piece 3 of PSSDBCAR must be a File 50 IEN
+2 NEW PSSDBEG1,PSSDBEG2,PSSDBEG3,PSSDBEG4,PSSDBEG5,PSSDBEG6,PSSDBEG7,X,Y
+3 SET PSSDBEG4=""
+4 SET PSSDBEG1=$PIECE(PSSDBCAR(PSSDBEB1),"^",3)
+5 IF PSSDBEG1
Begin DoDot:1
+6 SET PSSDBEG2=$PIECE($GET(^PSDRUG(PSSDBEG1,"ND")),"^")
SET PSSDBEG3=$PIECE($GET(^PSDRUG(PSSDBEG1,"ND")),"^",3)
+7 IF 'PSSDBEG2!('PSSDBEG3)
QUIT
+8 SET PSSDBEG5=$$DFSU^PSNAPIS(PSSDBEG2,PSSDBEG3)
+9 SET PSSDBEG6=$PIECE(PSSDBEG5,"^",6)
+10 IF PSSDBEG6'=""
SET PSSDBEG7=$$UNIT^PSSDSAPI(PSSDBEG6)
IF PSSDBEG7'=""
SET PSSDBEG4=PSSDBEG7
End DoDot:1
IF PSSDBEG4'=""
QUIT PSSDBEG4
+11 IF PSSDBEG1
FOR PSSDBEG2=0:0
SET PSSDBEG2=$ORDER(^PSDRUG(PSSDBEG1,"DOS2",PSSDBEG2))
if 'PSSDBEG2!(PSSDBEG4'="")
QUIT
Begin DoDot:1
+12 SET PSSDBEG3=$PIECE($GET(^PSDRUG(PSSDBEG1,"DOS2",PSSDBEG2,0)),"^",5)
+13 IF PSSDBEG3
IF $PIECE($GET(^PS(51.24,PSSDBEG3,0)),"^",2)'=""
SET PSSDBEG4=$PIECE(^PS(51.24,PSSDBEG3,0),"^",2)
End DoDot:1
+14 IF PSSDBEG4'=""
QUIT PSSDBEG4
+15 IF PSSDBEG1
SET PSSDBEG2=$PIECE($GET(^PSDRUG(PSSDBEG1,2)),"^")
IF PSSDBEG2
Begin DoDot:1
+16 SET PSSDBEG3=$PIECE($GET(^PS(50.7,PSSDBEG2,0)),"^",2)
IF PSSDBEG3
Begin DoDot:2
+17 FOR PSSDBEG5=0:0
SET PSSDBEG5=$ORDER(^PS(50.606,PSSDBEG3,"NOUN",PSSDBEG5))
if 'PSSDBEG5!(PSSDBEG4'="")
QUIT
Begin DoDot:3
+18 SET PSSDBEG6=$PIECE($GET(^PS(50.606,PSSDBEG3,"NOUN",PSSDBEG5,0)),"^")
+19 IF PSSDBEG6'=""
SET PSSDBEG7=$$UNIT^PSSDSAPI(PSSDBEG6)
IF PSSDBEG7'=""
SET PSSDBEG4=PSSDBEG7
End DoDot:3
End DoDot:2
End DoDot:1
+20 IF PSSDBEG4'=""
QUIT PSSDBEG4
+21 QUIT "EACH"
