PSSDSAPI ;BIR/RTR-Dose Check APIs routine ;06/09/08
;;1.0;PHARMACY DATA MANAGEMENT;**117,160,173,178,206,224**;9/30/97;Build 3
;
EXMT(PSSVLIEN) ;Test if Drug should have Dose Call performed on it
;PSSVLIEN=File 50 internal entry number
;1=exempt from Dose Check, 0=not exempt from Dose check
N PSSVLND,PSSVLND1,PSSVLND3,PSSVLNDF,PSSVLDOV,PSSVLZR,PSSVLDF
S PSSVLZR=$G(^PSDRUG(PSSVLIEN,0))
I $P(PSSVLZR,"^",3)["S"!($E($P(PSSVLZR,"^",2),1,2)="XA") Q 1
S PSSVLND=$G(^PSDRUG(PSSVLIEN,"ND"))
S PSSVLND1=$P(PSSVLND,"^"),PSSVLND3=$P(PSSVLND,"^",3)
S PSSVLDOV="" K PSSVLDF
I $T(OVRIDE^PSNAPIS)]"",PSSVLND1,PSSVLND3 S PSSVLDOV=$$OVRIDE^PSNAPIS(PSSVLND1,PSSVLND3)
I PSSVLND1,PSSVLND3 S PSSVLNDF=$$DFSU^PSNAPIS(PSSVLND1,PSSVLND3) S PSSVLDF=$P(PSSVLNDF,"^")
I $G(PSSVLDF)'>0,$P($G(^PSDRUG(PSSVLIEN,2)),"^") S PSSVLDF=$P($G(^PS(50.7,+$P($G(^PSDRUG(PSSVLIEN,2)),"^"),0)),"^",2)
I PSSVLDOV=""!('$G(PSSVLDF))!($P($G(^PS(50.606,+$G(PSSVLDF),1)),"^")="") Q 0
I $P($G(^PS(50.606,+$G(PSSVLDF),1)),"^"),'PSSVLDOV Q 1
I '$P($G(^PS(50.606,+$G(PSSVLDF),1)),"^"),PSSVLDOV Q 1
Q 0
;
;
SUP(PSSSPLIN) ;Screen for Drug Interaction and Duplicate Therapy
;PSSSPLIN = File 50 internal entry number
;1=exempt, 0=not exempt
N PSSSPLZR
S PSSSPLZR=$G(^PSDRUG(PSSSPLIN,0))
I $P(PSSSPLZR,"^",3)["S"!($E($P(PSSSPLZR,"^",2),1,2)="XA") Q 1
Q 0
;
;
MRT(PSSRS1) ;Return Standard Medication Route and First DataBank Route
N PSSRS2,PSSRS3,PSSRS4,PSSRTNAM,PSSRTIEN,PSSRTARR,PSSPKGU,PSSRS4SM I '$G(PSSRS1) S PSSRS2="" G MRTX
S (PSSRTNAM,PSSRTIEN,PSSRS2,PSSRS4,PSSRS4SM)="",PSSRTNAM=$$GET1^DIQ(51.2,PSSRS1,.01) I $G(PSSRTNAM)="" S PSSRS2="" G MRTX
F S PSSRTIEN=$O(^PS(51.2,"B",PSSRTNAM,PSSRTIEN)) Q:PSSRTIEN="" D ;check for duplicate route names; if mapped, defined and has a valid effective date set array
.S PSSRS3="",PSSRS3=$P($G(^PS(51.2,PSSRTIEN,1)),"^")
.Q:'$G(PSSRS3)
.Q:'$D(^PS(51.23,+PSSRS3,0))
.Q:$$SCREEN^XTID(51.23,.01,+PSSRS3_",")
.S PSSPKGU="",PSSPKGU=$$GET1^DIQ(51.2,PSSRTIEN,3,"I") S:PSSPKGU="" PSSPKGU=0 S PSSRTARR(PSSPKGU,PSSRTIEN)=+PSSRS3
;If duplicate route names, select 1st "ALL Package" route for PACKAGE USE field in file 51.2. If no "ALL Package" route, select 1st "NDF Only" route. Otherwise, return nothing to indicate "invalid or undefined" route.
;If no duplicate route names, use the route passed in regardless of Packge Use value but only if mapped to route has valid effective date.
I $D(PSSRTARR) D
.I $D(PSSRTARR(1)) S PSSRS4=$O(PSSRTARR(1,PSSRS4)),PSSRS4SM=PSSRTARR(1,PSSRS4) Q
.S:$D(PSSRTARR(0)) PSSRS4=$O(PSSRTARR(0,PSSRS4)),PSSRS4SM=PSSRTARR(0,PSSRS4)
I PSSRS4="" G MRTX
S PSSRS2=$G(^PS(51.23,+PSSRS4SM,0))
MRTX ;
Q $P(PSSRS2,"^")_"^"_$P(PSSRS2,"^",2)
;
;
UNIT(PSSVUTUN) ;Find First DataBank Unit, can't do DIC Lookup because of exact match check
;Returns Null or First DataBank Unit for text passed in
N PSSVUTX,PSSVUTZ,PSSVUTAA,PSSVUTFL
S PSSVUTFL=0 I $G(PSSVUTUN)="" S PSSVUTZ="" G UNITX
S PSSVUTAA=$$UP^XLFSTR(PSSVUTUN)
UNITP ;
K PSSVUTZ S PSSVUTX=$O(^PS(51.24,"B",PSSVUTAA,0)) I PSSVUTX,'$$SCREEN^XTID(51.24,.01,PSSVUTX_",") S PSSVUTZ=$P($G(^PS(51.24,PSSVUTX,0)),"^",2) I PSSVUTZ'="" G UNITX
K PSSVUTZ S PSSVUTX=$O(^PS(51.24,"C",PSSVUTAA,0)) I PSSVUTX,'$$SCREEN^XTID(51.24,.01,PSSVUTX_",") S PSSVUTZ=$P($G(^PS(51.24,PSSVUTX,0)),"^",2) I PSSVUTZ'="" G UNITX
K PSSVUTZ S PSSVUTX=$O(^PS(51.24,"D",PSSVUTAA,0)) I PSSVUTX,'$$SCREEN^XTID(51.24,.01,PSSVUTX_",") S PSSVUTZ=$P($G(^PS(51.24,PSSVUTX,0)),"^",2) I PSSVUTZ'="" G UNITX
I 'PSSVUTFL,$G(PSSVUTUN)["/" S PSSVUTFL=1,PSSVUTAA=$P(PSSVUTUN,"/"),PSSVUTAA=$$UP^XLFSTR(PSSVUTAA) G:PSSVUTAA'="" UNITP
UNITX ;
Q $G(PSSVUTZ)
;
;
FRQ(PSSFWSCC,PSSFWFR,PSSFWPK,PSSFWDRL,PSSDRG) ;Return Daily Frequency for Daily Dose Check
;
;Input variables:
;PSSFWSC = Free Text Schedule
;PSSFWFR = Frequency in Minutes
;PSSFWPK = Package "O" for Outpatient, "I" for Inpatient
;PSSFWDRL = Duration
;PSSDRG = IEN from file 50 (added for MOCHA 2.1-PSS*1*178)
;Output: 2 pieces (More information see Forum DBIA 5425)
;piece 1 - Adjusted Daily Frequency, (May need adjusted if Duration is passed in)
;piece 2 - Daily Frequency solely based on Schedule
;
N PSSFWPR1,PSSFWPR2,PSSFWPR3,PSSFWPR4,PSSFWPR5,PSSFWPR6,PSSFWPR7,PSSOSN,PSSOMEDN,PSSX,PSSDECNO,PSSMLTFG
I $G(PSSFWSCC)="" Q "^"
S PSSX=$$OLDSCH^PSSSCHMS(PSSFWSCC),PSSFWSCC=$P(PSSX,U),PSSOSN=$P(PSSX,U,2)
S PSSFWPR1=0
S PSSFWPR2=$$FRQZ
I '$G(PSSMLTFG),($G(PSSFWFR)="D"),(PSSFWPR2="") Q ""
I PSSFWPR1 Q PSSFWPR2_"^"_$G(PSSFWPR7)
S PSSFWPR3=$L(PSSFWSCC) I PSSFWPR3<5 Q PSSFWPR2_"^"_$G(PSSFWPR7)
S PSSFWPR4=$E(PSSFWSCC,(PSSFWPR3-3),PSSFWPR3) S PSSFWPR4=$$UP^XLFSTR(PSSFWPR4)
I '$D(^PS(51.1,"APPSJ",PSSFWSCC)) Q $$MULTSCH^PSSSCHMS(PSSFWSCC,$G(PSSFWFR),$G(PSSFWPK),$G(PSSFWDRL))
S PSSFWPR5=PSSFWSCC
S PSSFWSCC=$E(PSSFWSCC,1,(PSSFWPR3-4)) K PSSFWPR7
S PSSFWPR6=$$FRQZ
S PSSFWSCC=PSSFWPR5
Q PSSFWPR6_"^"_$G(PSSFWPR7)
;
;
FRQZ() ;
N PSSFWRST,PSSFWFLG,PSSFWSC,PSSX
S PSSFWSC=$$UP^XLFSTR(PSSFWSCC)
K PSSFWRST
I $G(PSSFWPK)'="O",$G(PSSFWPK)'="I" Q ""
I $G(PSSFWFR)="D" D DAY Q $G(PSSFWRST)
D STN I PSSFWFLG Q PSSFWRST
; Need to check for DCF & old name from 51.
I ($G(PSSFWSCC)]""),($G(PSSFWPK)="O"),$S($D(^PS(51,"B",PSSFWSCC)):1,$D(^PS(51,"D",PSSFWSCC)):1,1:0) S PSSFWFLG=0
I PSSFWFLG Q PSSFWRST
I $G(PSSFWPK)="O" S PSSX=$$OLD51^PSSSCHMS(PSSFWSCC),PSSFWSCC=$P(PSSX,U),PSSOMEDN=$P(PSSX,U,2) D STNO I PSSFWFLG Q PSSFWRST
Q ""
;
;
DAY ;Day of week schedule
N PSSFWFND,PSSFWRGH,PSSFWLTH,PSSFWTMP,PSSFWLP,PSSFWLP1,PSSFWCNT,PSSFWQZ,PSSFWDIV,PSSFWNUM,PSSFWKZ1,PSSFWKZ2,PSSFWKZ3,PSSFWKZ4,PSSFWKZ5,PSSDCF,PSSX,PSSDIVFG
K PSSFWRST
I (PSSFWSC[" "),(PSSFWSC'[" PRN"),('$D(^PS(51.1,"APPSJ",PSSFWSC))&'$D(^PS(51,"B",PSSFWSC))) S PSSMLTFG=1 Q
I '$F(PSSFWSC,"@") S PSSFWSC=$$ADDAT^PSSSCHMS(PSSFWSC)
S PSSFWLTH=$L(PSSFWSC)
S PSSFWFND=$F(PSSFWSC,"@")
S PSSFWRGH=$E(PSSFWSC,PSSFWFND,PSSFWLTH)
S PSSFWTMP=$S($E(PSSFWRGH,$L(PSSFWRGH))'="-":PSSFWRGH_"-",1:PSSFWRGH)
I PSSFWTMP?.(2N1"-")!(PSSFWTMP?.(4N1"-")) D Q:$G(PSSDCF)]"" S PSSFWRST=PSSFWCNT,PSSFWPR1=1 Q
.S PSSDCF=$$DOWAT^PSSSCHMS(PSSFWSC,$G(PSSDRG))
.I PSSDCF]"" S PSSFWRST=$P(PSSDCF,U),PSSFWPR1=1 Q
.S PSSFWCNT=0 F PSSFWLP=1:1:$L(PSSFWTMP) I $E(PSSFWTMP,PSSFWLP)="-" S PSSFWCNT=PSSFWCNT+1
I PSSFWRGH'="" S PSSX=$$OLDSCH^PSSSCHMS(PSSFWRGH),PSSFWRGH=$P(PSSX,U),PSSOSN=$P(PSSX,U,2) D Q:($G(PSSFWRST)]"")
. I +$G(PSSOSN) S PSSFWLP1=PSSOSN D DAY1 Q:($G(PSSFWRST)]"")
. I '+$G(PSSOSN) F PSSFWLP1=0:0 S PSSFWLP1=$O(^PS(51.1,"APPSJ",PSSFWRGH,PSSFWLP1)) Q:'PSSFWLP1!($G(PSSFWRST)]"") D DAY1
I $G(PSSFWRST)]"" S PSSFWPR1=1 Q
I PSSFWRGH'="" F PSSFWLP1=0:0 S PSSFWLP1=$O(^PS(51.1,"APPSJ",PSSFWRGH,PSSFWLP1)) Q:'PSSFWLP1!($G(PSSFWRST)]"")!$G(PSSDIVFG) D
.K PSSFWQZ,PSSFWDIV
.S PSSDCF=$$DCFSCH^PSSSCHMS(PSSFWLP1,$G(PSSDRG),$G(PSSFWDRL))
.I PSSDCF]"" S PSSFWRST=$P(PSSDCF,U),PSSFWPR1=1 Q
.S PSSFWQZ=$P($G(^PS(51.1,PSSFWLP1,0)),"^",3)
.Q:'$G(PSSFWQZ)
.S PSSFWDIV=1440/PSSFWQZ
.I PSSFWDIV'>1 S PSSX=$$CONVSCH^PSSSCHMS(PSSFWQZ) S:$P(PSSX,U)="" PSSDIVFG=1 S PSSFWRST=$P(PSSX,U),PSSFWFLG=+$P(PSSX,U,2) Q
.I PSSFWDIV?.N S PSSFWRST=PSSFWDIV,PSSFWPR1=1
I +$G(PSSDIVFG) Q
I $G(PSSFWRST)]"" Q
I PSSFWPK="O" D DAYOUT Q:$G(PSSFWRST)
I PSSFWRGH?1"Q"1N.N1"H" S PSSFWRST=PSSFWRGH,PSSFWPR1=1 Q
I $G(PSSFWSC)'["@" S PSSFWRST=1 Q
I $E(PSSFWSC,$L(PSSFWSC))="@" S PSSFWRST=1 Q
Q
;
DAY1 ;Process schedule for the second piece of DOW@SCHEDULE
I '+$G(PSSOSN),($P($G(^PS(51.1,PSSFWLP1,0)),"^",5)'="D") Q
S PSSDCF=$$DCFSCH^PSSSCHMS(PSSFWLP1,$G(PSSDRG),$G(PSSFWDRL))
I PSSDCF]"" S PSSFWRST=$P(PSSDCF,U),PSSFWPR1=1 Q
S PSSFWKZ1=$P($G(^PS(51.1,PSSFWLP1,0)),"^",2)
S PSSFWKZ5=0 I PSSFWKZ1'="" D
.S PSSFWKZ2=$S($E(PSSFWKZ1,$L(PSSFWKZ1))'="-":PSSFWKZ1_"-",1:PSSFWKZ1)
.I PSSFWKZ2?.(2N1"-")!(PSSFWKZ2?.(4N1"-")) D
..S PSSFWKZ3=0 F PSSFWKZ4=1:1:$L(PSSFWKZ2) I $E(PSSFWKZ2,PSSFWKZ4)="-" S PSSFWKZ5=PSSFWKZ5+1
I $G(PSSFWKZ5) S PSSFWRST=PSSFWKZ5
Q
;
DAYOUT ;Day of week for Outpatient orders
N PSSFWKZ6,PSSFWKZ7,PSSFWKZ8,PSSX
I PSSFWRGH'="" S PSSX=$$OLD51^PSSSCHMS(PSSFWRGH),PSSFWRGH=$P(PSSX,U),PSSOMEDN=$P(PSSX,U,2) D Q:($G(PSSFWRST)]"")
. I +$G(PSSOMEDN) S PSSFWKZ6=PSSOMEDN D DAYOUT1 Q:($G(PSSFWRST)]"")
. I '+$G(PSSOMEDN) F PSSFWKZ6=0:0 S PSSFWKZ6=$O(^PS(51,"B",PSSFWRGH,PSSFWKZ6)) Q:'PSSFWKZ6!($G(PSSFWRST)) D DAYOUT1
Q
;
DAYOUT1 ;Cont. DOW for Outpatient orders
K PSSFWKZ7,PSSFWKZ8
;
S PSSDCF=$$DCF51^PSSSCHMS(PSSFWKZ6,$G(PSSDRG),$G(PSSFWDRL))
I PSSDCF]"" S PSSFWRST=$P(PSSDCF,U),PSSFWPR1=1 Q
;
S PSSFWKZ7=$P($G(^PS(51,PSSFWKZ6,0)),"^",8)
Q:'$G(PSSFWKZ7)
S PSSFWKZ8=1440/PSSFWKZ7 I PSSFWKZ8'>1 S PSSFWRST=1 Q
I PSSFWKZ8?.N S PSSFWRST=PSSFWKZ8,PSSFWPR1=1
Q
;
NUMB ;Frequency passed in as a number
;*** Remove for MOCHA 2.1 - IP will be doing it in UND24HRS^PSJOCDS
S PSSFWFLG=0 K PSSFWRST
N PSSFWDIS,PSSFWGRT,PSSFWMNT,PSSFWEEK,PSSFWXWK,PSSFWXMN
S PSSFWDIS=1440/PSSFWFR I PSSFWDIS?.N S PSSFWFLG=1,PSSFWRST=PSSFWDIS,PSSFWPR1=1 Q
I PSSFWDIS'<1 Q
S PSSFWGRT=PSSFWFR/1440
I PSSFWGRT?.N D Q
.S PSSFWMNT=PSSFWGRT/30 I PSSFWMNT?.N S PSSFWFLG=1,PSSFWRST="Q"_PSSFWMNT_"L",PSSFWPR1=1 Q
.S PSSFWEEK=PSSFWGRT/7 I PSSFWEEK?.N S PSSFWFLG=1,PSSFWRST="Q"_PSSFWEEK_"W",PSSFWPR1=1 Q
.S PSSFWFLG=1,PSSFWRST="Q"_PSSFWGRT_"D",PSSFWPR1=1 Q
I PSSFWFR'>10080 S PSSFWXWK=10080/PSSFWFR I PSSFWXWK?.N S PSSFWFLG=1,PSSFWRST="X"_PSSFWXWK_"W",PSSFWPR1=1 Q
S PSSFWXMN=43200/PSSFWFR I PSSFWXMN?.N S PSSFWFLG=1,PSSFWRST="X"_PSSFWXMN_"L",PSSFWPR1=1 Q
Q
;
STN ;Standard Logic
S PSSFWFLG=0 K PSSFWRST I $G(PSSFWSC)="" Q
N PSSFWLP2,PSSFWAA,PSSFWAAD,PSSFWAAM,PSSFWAMN,PSSFWAWK,PSSFWAXL,PSSFWAXW,PSSDCF,PSSDCFLG,PSSDIVFG
I $G(PSSOSN)]"" S PSSFWLP2=PSSOSN D STN1
;PSS*1*224
I $G(PSSOSN)="" S PSSFWSC=$$PRNSCHD^PSSDSUTL(PSSFWSC) F PSSFWLP2=0:0 S PSSFWLP2=$O(^PS(51.1,"APPSJ",PSSFWSC,PSSFWLP2)) Q:'PSSFWLP2!(PSSFWFLG)!$G(PSSDCFLG)!$G(PSSDIVFG) D STN1
K PSSDIVFG
Q:$G(PSSDCFLG)
I PSSFWFLG D DURLS I PSSFWFLG S PSSFWPR1=1 Q
Q
;
STN1 ;Standard Logic continue
K PSSFWAA,PSSFWAAD
S PSSDCF=$$DCFSCH^PSSSCHMS(PSSFWLP2,$G(PSSDRG),$G(PSSFWDRL))
;PSS*1*206
I PSSDCF="",(PSSFWSC[" PRN") D
. NEW PSSX
. S PSSX=PSSFWLP2
. I ($P(PSSFWSC," PRN",1)'=""),($P(PSSFWSC," PRN",1)'?." ") S PSSFWLP2=$O(^PS(51.1,"APPSJ",$P(PSSFWSC," PRN",1),0))
. S:+PSSFWLP2 PSSDCF=$$DCFSCH^PSSSCHMS(PSSFWLP2,$G(PSSDRG),$G(PSSFWDRL))
. S PSSFWLP2=PSSX
I PSSDCF]"" S (PSSFWPR1,PSSFWFLG,PSSDCFLG)=1,PSSFWRST=$P(PSSDCF,U),PSSFWPR7=$P(PSSDCF,U,2) Q
S PSSFWAA=$P($G(^PS(51.1,PSSFWLP2,0)),"^",3)
Q:'$G(PSSFWAA)
S PSSFWAAD=1440/PSSFWAA
I PSSFWAAD?.N S PSSFWRST=PSSFWAAD,PSSFWFLG=1 Q
I (PSSFWAA<1440),((PSSFWAA/60)?.N) S PSSFWRST="Q"_(PSSFWAA/60)_"H",PSSFWFLG=1 Q
I PSSFWAAD>1 Q
S PSSFWAAM=PSSFWAA/1440
I PSSFWAAM'?.N D Q
. S PSSFWFLG=1,PSSFWRST="",PSSDIVFG=1
. I (PSSFWAA/60)?.N S PSSFWRST="Q"_(PSSFWAA/60)_"H"
I PSSFWAAM?.N D Q
.S PSSFWAMN=PSSFWAAM/30 I PSSFWAMN?.N S PSSFWFLG=1,PSSFWRST="Q"_PSSFWAMN_"L" Q
.S PSSFWAWK=PSSFWAAM/7 I PSSFWAWK?.N S PSSFWFLG=1,PSSFWRST="Q"_PSSFWAWK_"W" Q
.S PSSFWFLG=1,PSSFWRST="Q"_PSSFWAAM_"D" Q
I PSSFWAA'>10080 S PSSFWAXW=10080/PSSFWAA I PSSFWAXW?.N S PSSFWFLG=1,PSSFWRST="X"_PSSFWAXW_"W" Q
S PSSFWAXL=43200/PSSFWAA I PSSFWAXL?.N S PSSFWFLG=1,PSSFWRST="X"_PSSFWAXL_"L" Q
Q
;
STNO ;Standard Logic part 2, using File 51, For Outpatient Orders only
S PSSFWFLG=0 K PSSFWRST I $G(PSSFWSC)="" Q
N PSSFWLP3,PSSFWBA,PSSFWBAD,PSSFWBAM,PSSFWBMN,PSSFWBWK,PSSFWBXL,PSSFWBXW,PSSDCFLG,PSSDIVFG
I $G(PSSOMEDN)]"" S PSSFWLP3=PSSOMEDN D STNO1
;PSS*1*224
I $G(PSSOMEDN)="" S PSSFWSC=$$PRNMI^PSSDSUTL(PSSFWSC) F PSSFWLP3=0:0 S PSSFWLP3=$O(^PS(51,"B",PSSFWSC,PSSFWLP3)) Q:'PSSFWLP3!(PSSFWFLG)!$G(PSSDIVFG) D STNO1
K PSSDIVFG
Q:$G(PSSDCFLG)
Q:$G(PSSDECNO)
I PSSFWFLG D DURLS I PSSFWFLG S PSSFWPR1=1 Q
I PSSFWSC?1"Q"1N.N1"H" S PSSFWRST=PSSFWSC,PSSFWFLG=1 D DURLS I PSSFWFLG S PSSFWPR1=1
Q
;
STNO1 ;Standard Logic part 2, using File 51, For Outpatient Orders only
K PSSFWBA,PSSFWBAD
S PSSDCF=$$DCF51^PSSSCHMS(PSSFWLP3,$G(PSSDRG),$G(PSSFWDRL))
I PSSDCF]"" S (PSSFWPR1,PSSFWFLG,PSSDCFLG)=1,PSSFWRST=$P(PSSDCF,U),PSSFWPR7=$P(PSSDCF,U,2) Q
S PSSFWBA=$P($G(^PS(51,PSSFWLP3,0)),"^",8)
Q:'$G(PSSFWBA)
S PSSFWBAD=1440/PSSFWBA
I PSSFWBAD?.N S PSSFWRST=PSSFWBAD,PSSFWFLG=1 Q
I (PSSFWBA<1440),((PSSFWBA/60)?.N) S PSSFWRST="Q"_(PSSFWBA/60)_"H",PSSFWFLG=1 Q
;PSSDECNO=1 when the admin time is not a whole #(dosing error message should display)
I PSSFWBAD>1 S PSSFWFLG=0,PSSDECNO=1 Q
S PSSFWBAM=PSSFWBA/1440
I PSSFWBAM'?.N S PSSFWFLG=1,PSSFWRST="",PSSDIVFG=1 Q
I PSSFWBAM?.N D Q
.S PSSFWBMN=PSSFWBAM/30 I PSSFWBMN?.N S PSSFWFLG=1,PSSFWRST="Q"_PSSFWBMN_"L" Q
.S PSSFWBWK=PSSFWBAM/7 I PSSFWBWK?.N S PSSFWFLG=1,PSSFWRST="Q"_PSSFWBWK_"W" Q
.S PSSFWFLG=1,PSSFWRST="Q"_PSSFWBAM_"D" Q
I PSSFWBA'>10080 S PSSFWBXW=10080/PSSFWBA I PSSFWBXW?.N S PSSFWFLG=1,PSSFWRST="X"_PSSFWBXW_"W" Q
S PSSFWBXL=43200/PSSFWBA I PSSFWBXL?.N S PSSFWFLG=1,PSSFWRST="X"_PSSFWBXL_"L" Q
Q
;
DS() ; Return 1 if Dose Checks are enabled, return 0 if Dose Checks are not enabled, 2.0 message to OR & 2.1 message to IP & OP
Q $S($P($G(^PS(59.7,1,81)),"^"):1,+$G(PSSDSWHE)=1:$$DS1(),1:$$DS2())
;;
DS1() ; called from $$DS to break line length
Q "0^Maximum Single Dose Order Check is not available; please complete a manual check for appropriate Dosing."
;;
DS2() ; called from $$DS to break line length
Q "0^Dosing Checks are not available; please complete a manual check for appropriate Dosing."
;;
IV(PSSADFOI) ;Return Additive Frequency default to CPRS, Forum DBIA 5425
;PSSADFOI = File 50.7 Internal Entry Number
N PSSADFRS,PSSADFIN,PSSADFLP,PSSADFXX,PSSADFHD,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
.S PSSADFIN=$P($G(^PS(52.6,PSSADFLP,"I")),"^")
.I PSSADFIN,PSSADFIN'>DT Q
.S PSSADFNN=PSSADFLP_","
.S PSSADFHD=$$GET1^DIQ(52.6,PSSADFNN,18,"I",,"PSSADFER") I PSSADFHD="" S PSSADFXX=1 Q
.I 'PSSADFCT S PSSADFRS=PSSADFHD S PSSADFCT=1 Q
.I PSSADFHD'=PSSADFRS S PSSADFXX=1
I PSSADFXX S PSSADFRS=""
Q PSSADFRS
;
;
BSA(PSSBSADF) ;
I '$G(PSSBSADF) Q "0^0"
N DFN,VADM,VAPTYP,VAHOW,VAROOT,VAERR,VA,X1,X2,X,%Y,PSSBSAW1,PSSBSAW2,PSSBSAH1,PSSBSAH2,GMRVSTR,PSSBSAB2,PSSBSAH3
S DFN=PSSBSADF
S (PSSBSAW2,PSSBSAH2,PSSBSAB2,PSSBSAH3)=0
S GMRVSTR="WT" K X D EN6^GMRVUTL
S PSSBSAW1=$P(X,"^",8) I PSSBSAW1 S PSSBSAW2=PSSBSAW1/2.2
S DFN=PSSBSADF
S GMRVSTR="HT" K X D EN6^GMRVUTL
S PSSBSAH1=$P(X,"^",8) I PSSBSAH1 S PSSBSAH2=.0254*PSSBSAH1,PSSBSAH3=$J(PSSBSAH1*2.54,0,2)
;Using DuBios formula for BSA calculation, and sending in 2 decimal places
I $G(PSSBSAW2),$G(PSSBSAH2) S PSSBSAB2=.20247*(PSSBSAH2**.725)*(PSSBSAW2**.425)
Q PSSBSAH3_"^"_PSSBSAW2_"^"_PSSBSAB2
;
;
UNITD(PSSVUTUN) ;Find First DataBank Unit, can't do DIC Lookup because of exact match check
;Returns Null or First DataBank Unit for text passed in
N PSSVUTX,PSSVUTZ,PSSVUTAA,PSSVUTFL
S PSSVUTFL=0 I $G(PSSVUTUN)="" S PSSVUTZ="" G UNITDX
S PSSVUTAA=$$UP^XLFSTR(PSSVUTUN)
UNITDP ;
K PSSVUTZ S PSSVUTX=$O(^PS(51.24,"B",PSSVUTAA,0)) I PSSVUTX,'$$SCREEN^XTID(51.24,.01,PSSVUTX_",") S PSSVUTZ=$P($G(^PS(51.24,PSSVUTX,0)),"^",2) I PSSVUTZ'="",$P($G(^PS(51.24,PSSVUTX,0)),"^",3)=0 G UNITDX
K PSSVUTZ S PSSVUTX=$O(^PS(51.24,"C",PSSVUTAA,0)) I PSSVUTX,'$$SCREEN^XTID(51.24,.01,PSSVUTX_",") S PSSVUTZ=$P($G(^PS(51.24,PSSVUTX,0)),"^",2) I PSSVUTZ'="",$P($G(^PS(51.24,PSSVUTX,0)),"^",3)=0 G UNITDX
K PSSVUTZ S PSSVUTX=$O(^PS(51.24,"D",PSSVUTAA,0)) I PSSVUTX,'$$SCREEN^XTID(51.24,.01,PSSVUTX_",") S PSSVUTZ=$P($G(^PS(51.24,PSSVUTX,0)),"^",2) I PSSVUTZ'="",$P($G(^PS(51.24,PSSVUTX,0)),"^",3)=0 G UNITDX
K PSSVUTZ I 'PSSVUTFL,$G(PSSVUTUN)["/" S PSSVUTFL=1,PSSVUTAA=$P(PSSVUTUN,"/"),PSSVUTAA=$$UP^XLFSTR(PSSVUTAA) G:PSSVUTAA'="" UNITDP
UNITDX ;
Q $G(PSSVUTZ)
;
;
DURLS ;If Duration is less that 24 hours, make Frequency adjustments if applicable
;Only check Frequencies of a whole number or in the format of Q#H
N PSSDK1,PSSDK2,PSSDK3,PSSDK4,PSSDK5,PSSDK6,PSSDSCNT
S (PSSDK4,PSSFWPR7)=PSSFWRST
I $G(PSSFWDRL)="" Q
S PSSDK1=$$DRT^PSSDSAPD(PSSFWDRL) I PSSDK1'<1440!(PSSDK1'>0) Q
S PSSDSCNT=$$CHKIPDUR^PSSSCHMS()
I +PSSDSCNT S PSSFWRST=$P(PSSDSCNT,U,2) Q
S PSSDK2=1440/PSSDK1
I PSSDK4?.N D Q
.S PSSDK5=PSSDK4/PSSDK2
.I PSSDK5<1 K PSSFWRST S PSSFWFLG=0 Q
.;PSS*1*178 - rounding up makes more sense
.S PSSDK6=$S((PSSDK5?.N):PSSDK5,1:$J((PSSDK5+.5),0,0))
.S PSSFWRST=PSSDK6
I PSSDK4?1"Q"1N.N1"H" D Q
.S PSSDK3=$$FRCON^PSSDSAPK(PSSDK4)
.S PSSDK5=PSSDK3/PSSDK2
.I PSSDK5<1 K PSSFWRST S PSSFWFLG=0 Q
.S PSSDK6=$J(PSSDK5,0,0)
.S PSSFWRST=PSSDK6
Q
;
;
DLTM(PSSNVTOI) ;Check if all drugs for a Non-VA Med order are exempt, if so, kill Input exceptions and Quit
N PSSNVT1,PSSNVTFL,PSSNVTIN
S PSSNVTFL=1
F PSSNVT1=0:0 S PSSNVT1=$O(^PSDRUG("ASP",PSSNVTOI,PSSNVT1)) Q:'PSSNVT1!('PSSNVTFL) D
.I $P($G(^PSDRUG(PSSNVT1,2)),"^",3)'["X" Q
.S PSSNVTIN=$P($G(^PSDRUG(PSSNVT1,"I")),"^") I PSSNVTIN,PSSNVTIN<DT Q
.S PSSNVTFL=$$EXMT^PSSDSAPI(PSSNVT1)
Q PSSNVTFL
;
;
EMSY() ;Return 1 if there are matched supplies, no active drugs, regardless of Package use
N PSSKST1,PSSKST2,PSSKST3,PSSKST4,PSSKST5,PSSKST6,PSSKST9
S (PSSKST9,PSSKST6)=0
F PSSKST1=0:0 S PSSKST1=$O(^PSDRUG("ASP",PSSNBOI,PSSKST1)) Q:'PSSKST1!(PSSKST9) D
.S PSSKST4=0,PSSKST2=$P($G(^PSDRUG(PSSKST1,"I")),"^") I PSSKST2,PSSKST2'>DT S PSSKST4=1
.S PSSKST5=$$SUP(PSSKST1)
.I 'PSSKST5,'PSSKST4 S PSSKST9=1 Q
.I 'PSSKST4,PSSKST5 S PSSKST6=1
I 'PSSKST9,PSSKST6 S $P(PSSNBRS,";",5)=0 Q 0
Q 1
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSSDSAPI 17720 printed Dec 13, 2024@02:31:04 Page 2
PSSDSAPI ;BIR/RTR-Dose Check APIs routine ;06/09/08
+1 ;;1.0;PHARMACY DATA MANAGEMENT;**117,160,173,178,206,224**;9/30/97;Build 3
+2 ;
EXMT(PSSVLIEN) ;Test if Drug should have Dose Call performed on it
+1 ;PSSVLIEN=File 50 internal entry number
+2 ;1=exempt from Dose Check, 0=not exempt from Dose check
+3 NEW PSSVLND,PSSVLND1,PSSVLND3,PSSVLNDF,PSSVLDOV,PSSVLZR,PSSVLDF
+4 SET PSSVLZR=$GET(^PSDRUG(PSSVLIEN,0))
+5 IF $PIECE(PSSVLZR,"^",3)["S"!($EXTRACT($PIECE(PSSVLZR,"^",2),1,2)="XA")
QUIT 1
+6 SET PSSVLND=$GET(^PSDRUG(PSSVLIEN,"ND"))
+7 SET PSSVLND1=$PIECE(PSSVLND,"^")
SET PSSVLND3=$PIECE(PSSVLND,"^",3)
+8 SET PSSVLDOV=""
KILL PSSVLDF
+9 IF $TEXT(OVRIDE^PSNAPIS)]""
IF PSSVLND1
IF PSSVLND3
SET PSSVLDOV=$$OVRIDE^PSNAPIS(PSSVLND1,PSSVLND3)
+10 IF PSSVLND1
IF PSSVLND3
SET PSSVLNDF=$$DFSU^PSNAPIS(PSSVLND1,PSSVLND3)
SET PSSVLDF=$PIECE(PSSVLNDF,"^")
+11 IF $GET(PSSVLDF)'>0
IF $PIECE($GET(^PSDRUG(PSSVLIEN,2)),"^")
SET PSSVLDF=$PIECE($GET(^PS(50.7,+$PIECE($GET(^PSDRUG(PSSVLIEN,2)),"^"),0)),"^",2)
+12 IF PSSVLDOV=""!('$GET(PSSVLDF))!($PIECE($GET(^PS(50.606,+$GET(PSSVLDF),1)),"^")="")
QUIT 0
+13 IF $PIECE($GET(^PS(50.606,+$GET(PSSVLDF),1)),"^")
IF 'PSSVLDOV
QUIT 1
+14 IF '$PIECE($GET(^PS(50.606,+$GET(PSSVLDF),1)),"^")
IF PSSVLDOV
QUIT 1
+15 QUIT 0
+16 ;
+17 ;
SUP(PSSSPLIN) ;Screen for Drug Interaction and Duplicate Therapy
+1 ;PSSSPLIN = File 50 internal entry number
+2 ;1=exempt, 0=not exempt
+3 NEW PSSSPLZR
+4 SET PSSSPLZR=$GET(^PSDRUG(PSSSPLIN,0))
+5 IF $PIECE(PSSSPLZR,"^",3)["S"!($EXTRACT($PIECE(PSSSPLZR,"^",2),1,2)="XA")
QUIT 1
+6 QUIT 0
+7 ;
+8 ;
MRT(PSSRS1) ;Return Standard Medication Route and First DataBank Route
+1 NEW PSSRS2,PSSRS3,PSSRS4,PSSRTNAM,PSSRTIEN,PSSRTARR,PSSPKGU,PSSRS4SM
IF '$GET(PSSRS1)
SET PSSRS2=""
GOTO MRTX
+2 SET (PSSRTNAM,PSSRTIEN,PSSRS2,PSSRS4,PSSRS4SM)=""
SET PSSRTNAM=$$GET1^DIQ(51.2,PSSRS1,.01)
IF $GET(PSSRTNAM)=""
SET PSSRS2=""
GOTO MRTX
+3 ;check for duplicate route names; if mapped, defined and has a valid effective date set array
FOR
SET PSSRTIEN=$ORDER(^PS(51.2,"B",PSSRTNAM,PSSRTIEN))
if PSSRTIEN=""
QUIT
Begin DoDot:1
+4 SET PSSRS3=""
SET PSSRS3=$PIECE($GET(^PS(51.2,PSSRTIEN,1)),"^")
+5 if '$GET(PSSRS3)
QUIT
+6 if '$DATA(^PS(51.23,+PSSRS3,0))
QUIT
+7 if $$SCREEN^XTID(51.23,.01,+PSSRS3_",")
QUIT
+8 SET PSSPKGU=""
SET PSSPKGU=$$GET1^DIQ(51.2,PSSRTIEN,3,"I")
if PSSPKGU=""
SET PSSPKGU=0
SET PSSRTARR(PSSPKGU,PSSRTIEN)=+PSSRS3
End DoDot:1
+9 ;If duplicate route names, select 1st "ALL Package" route for PACKAGE USE field in file 51.2. If no "ALL Package" route, select 1st "NDF Only" route. Otherwise, return nothing to indicate "invalid or undefined" route.
+10 ;If no duplicate route names, use the route passed in regardless of Packge Use value but only if mapped to route has valid effective date.
+11 IF $DATA(PSSRTARR)
Begin DoDot:1
+12 IF $DATA(PSSRTARR(1))
SET PSSRS4=$ORDER(PSSRTARR(1,PSSRS4))
SET PSSRS4SM=PSSRTARR(1,PSSRS4)
QUIT
+13 if $DATA(PSSRTARR(0))
SET PSSRS4=$ORDER(PSSRTARR(0,PSSRS4))
SET PSSRS4SM=PSSRTARR(0,PSSRS4)
End DoDot:1
+14 IF PSSRS4=""
GOTO MRTX
+15 SET PSSRS2=$GET(^PS(51.23,+PSSRS4SM,0))
MRTX ;
+1 QUIT $PIECE(PSSRS2,"^")_"^"_$PIECE(PSSRS2,"^",2)
+2 ;
+3 ;
UNIT(PSSVUTUN) ;Find First DataBank Unit, can't do DIC Lookup because of exact match check
+1 ;Returns Null or First DataBank Unit for text passed in
+2 NEW PSSVUTX,PSSVUTZ,PSSVUTAA,PSSVUTFL
+3 SET PSSVUTFL=0
IF $GET(PSSVUTUN)=""
SET PSSVUTZ=""
GOTO UNITX
+4 SET PSSVUTAA=$$UP^XLFSTR(PSSVUTUN)
UNITP ;
+1 KILL PSSVUTZ
SET PSSVUTX=$ORDER(^PS(51.24,"B",PSSVUTAA,0))
IF PSSVUTX
IF '$$SCREEN^XTID(51.24,.01,PSSVUTX_",")
SET PSSVUTZ=$PIECE($GET(^PS(51.24,PSSVUTX,0)),"^",2)
IF PSSVUTZ'=""
GOTO UNITX
+2 KILL PSSVUTZ
SET PSSVUTX=$ORDER(^PS(51.24,"C",PSSVUTAA,0))
IF PSSVUTX
IF '$$SCREEN^XTID(51.24,.01,PSSVUTX_",")
SET PSSVUTZ=$PIECE($GET(^PS(51.24,PSSVUTX,0)),"^",2)
IF PSSVUTZ'=""
GOTO UNITX
+3 KILL PSSVUTZ
SET PSSVUTX=$ORDER(^PS(51.24,"D",PSSVUTAA,0))
IF PSSVUTX
IF '$$SCREEN^XTID(51.24,.01,PSSVUTX_",")
SET PSSVUTZ=$PIECE($GET(^PS(51.24,PSSVUTX,0)),"^",2)
IF PSSVUTZ'=""
GOTO UNITX
+4 IF 'PSSVUTFL
IF $GET(PSSVUTUN)["/"
SET PSSVUTFL=1
SET PSSVUTAA=$PIECE(PSSVUTUN,"/")
SET PSSVUTAA=$$UP^XLFSTR(PSSVUTAA)
if PSSVUTAA'=""
GOTO UNITP
UNITX ;
+1 QUIT $GET(PSSVUTZ)
+2 ;
+3 ;
FRQ(PSSFWSCC,PSSFWFR,PSSFWPK,PSSFWDRL,PSSDRG) ;Return Daily Frequency for Daily Dose Check
+1 ;
+2 ;Input variables:
+3 ;PSSFWSC = Free Text Schedule
+4 ;PSSFWFR = Frequency in Minutes
+5 ;PSSFWPK = Package "O" for Outpatient, "I" for Inpatient
+6 ;PSSFWDRL = Duration
+7 ;PSSDRG = IEN from file 50 (added for MOCHA 2.1-PSS*1*178)
+8 ;Output: 2 pieces (More information see Forum DBIA 5425)
+9 ;piece 1 - Adjusted Daily Frequency, (May need adjusted if Duration is passed in)
+10 ;piece 2 - Daily Frequency solely based on Schedule
+11 ;
+12 NEW PSSFWPR1,PSSFWPR2,PSSFWPR3,PSSFWPR4,PSSFWPR5,PSSFWPR6,PSSFWPR7,PSSOSN,PSSOMEDN,PSSX,PSSDECNO,PSSMLTFG
+13 IF $GET(PSSFWSCC)=""
QUIT "^"
+14 SET PSSX=$$OLDSCH^PSSSCHMS(PSSFWSCC)
SET PSSFWSCC=$PIECE(PSSX,U)
SET PSSOSN=$PIECE(PSSX,U,2)
+15 SET PSSFWPR1=0
+16 SET PSSFWPR2=$$FRQZ
+17 IF '$GET(PSSMLTFG)
IF ($GET(PSSFWFR)="D")
IF (PSSFWPR2="")
QUIT ""
+18 IF PSSFWPR1
QUIT PSSFWPR2_"^"_$GET(PSSFWPR7)
+19 SET PSSFWPR3=$LENGTH(PSSFWSCC)
IF PSSFWPR3<5
QUIT PSSFWPR2_"^"_$GET(PSSFWPR7)
+20 SET PSSFWPR4=$EXTRACT(PSSFWSCC,(PSSFWPR3-3),PSSFWPR3)
SET PSSFWPR4=$$UP^XLFSTR(PSSFWPR4)
+21 IF '$DATA(^PS(51.1,"APPSJ",PSSFWSCC))
QUIT $$MULTSCH^PSSSCHMS(PSSFWSCC,$GET(PSSFWFR),$GET(PSSFWPK),$GET(PSSFWDRL))
+22 SET PSSFWPR5=PSSFWSCC
+23 SET PSSFWSCC=$EXTRACT(PSSFWSCC,1,(PSSFWPR3-4))
KILL PSSFWPR7
+24 SET PSSFWPR6=$$FRQZ
+25 SET PSSFWSCC=PSSFWPR5
+26 QUIT PSSFWPR6_"^"_$GET(PSSFWPR7)
+27 ;
+28 ;
FRQZ() ;
+1 NEW PSSFWRST,PSSFWFLG,PSSFWSC,PSSX
+2 SET PSSFWSC=$$UP^XLFSTR(PSSFWSCC)
+3 KILL PSSFWRST
+4 IF $GET(PSSFWPK)'="O"
IF $GET(PSSFWPK)'="I"
QUIT ""
+5 IF $GET(PSSFWFR)="D"
DO DAY
QUIT $GET(PSSFWRST)
+6 DO STN
IF PSSFWFLG
QUIT PSSFWRST
+7 ; Need to check for DCF & old name from 51.
+8 IF ($GET(PSSFWSCC)]"")
IF ($GET(PSSFWPK)="O")
IF $SELECT($DATA(^PS(51,"B",PSSFWSCC)):1,$DATA(^PS(51,"D",PSSFWSCC)):1,1:0)
SET PSSFWFLG=0
+9 IF PSSFWFLG
QUIT PSSFWRST
+10 IF $GET(PSSFWPK)="O"
SET PSSX=$$OLD51^PSSSCHMS(PSSFWSCC)
SET PSSFWSCC=$PIECE(PSSX,U)
SET PSSOMEDN=$PIECE(PSSX,U,2)
DO STNO
IF PSSFWFLG
QUIT PSSFWRST
+11 QUIT ""
+12 ;
+13 ;
DAY ;Day of week schedule
+1 NEW PSSFWFND,PSSFWRGH,PSSFWLTH,PSSFWTMP,PSSFWLP,PSSFWLP1,PSSFWCNT,PSSFWQZ,PSSFWDIV,PSSFWNUM,PSSFWKZ1,PSSFWKZ2,PSSFWKZ3,PSSFWKZ4,PSSFWKZ5,PSSDCF,PSSX,PSSDIVFG
+2 KILL PSSFWRST
+3 IF (PSSFWSC[" ")
IF (PSSFWSC'[" PRN")
IF ('$DATA(^PS(51.1,"APPSJ",PSSFWSC))&'$DATA(^PS(51,"B",PSSFWSC)))
SET PSSMLTFG=1
QUIT
+4 IF '$FIND(PSSFWSC,"@")
SET PSSFWSC=$$ADDAT^PSSSCHMS(PSSFWSC)
+5 SET PSSFWLTH=$LENGTH(PSSFWSC)
+6 SET PSSFWFND=$FIND(PSSFWSC,"@")
+7 SET PSSFWRGH=$EXTRACT(PSSFWSC,PSSFWFND,PSSFWLTH)
+8 SET PSSFWTMP=$SELECT($EXTRACT(PSSFWRGH,$LENGTH(PSSFWRGH))'="-":PSSFWRGH_"-",1:PSSFWRGH)
+9 IF PSSFWTMP?.(2N1"-")!(PSSFWTMP?.(4N1"-"))
Begin DoDot:1
+10 SET PSSDCF=$$DOWAT^PSSSCHMS(PSSFWSC,$GET(PSSDRG))
+11 IF PSSDCF]""
SET PSSFWRST=$PIECE(PSSDCF,U)
SET PSSFWPR1=1
QUIT
+12 SET PSSFWCNT=0
FOR PSSFWLP=1:1:$LENGTH(PSSFWTMP)
IF $EXTRACT(PSSFWTMP,PSSFWLP)="-"
SET PSSFWCNT=PSSFWCNT+1
End DoDot:1
if $GET(PSSDCF)]""
QUIT
SET PSSFWRST=PSSFWCNT
SET PSSFWPR1=1
QUIT
+13 IF PSSFWRGH'=""
SET PSSX=$$OLDSCH^PSSSCHMS(PSSFWRGH)
SET PSSFWRGH=$PIECE(PSSX,U)
SET PSSOSN=$PIECE(PSSX,U,2)
Begin DoDot:1
+14 IF +$GET(PSSOSN)
SET PSSFWLP1=PSSOSN
DO DAY1
if ($GET(PSSFWRST)]"")
QUIT
+15 IF '+$GET(PSSOSN)
FOR PSSFWLP1=0:0
SET PSSFWLP1=$ORDER(^PS(51.1,"APPSJ",PSSFWRGH,PSSFWLP1))
if 'PSSFWLP1!($GET(PSSFWRST)]"")
QUIT
DO DAY1
End DoDot:1
if ($GET(PSSFWRST)]"")
QUIT
+16 IF $GET(PSSFWRST)]""
SET PSSFWPR1=1
QUIT
+17 IF PSSFWRGH'=""
FOR PSSFWLP1=0:0
SET PSSFWLP1=$ORDER(^PS(51.1,"APPSJ",PSSFWRGH,PSSFWLP1))
if 'PSSFWLP1!($GET(PSSFWRST)]"")!$GET(PSSDIVFG)
QUIT
Begin DoDot:1
+18 KILL PSSFWQZ,PSSFWDIV
+19 SET PSSDCF=$$DCFSCH^PSSSCHMS(PSSFWLP1,$GET(PSSDRG),$GET(PSSFWDRL))
+20 IF PSSDCF]""
SET PSSFWRST=$PIECE(PSSDCF,U)
SET PSSFWPR1=1
QUIT
+21 SET PSSFWQZ=$PIECE($GET(^PS(51.1,PSSFWLP1,0)),"^",3)
+22 if '$GET(PSSFWQZ)
QUIT
+23 SET PSSFWDIV=1440/PSSFWQZ
+24 IF PSSFWDIV'>1
SET PSSX=$$CONVSCH^PSSSCHMS(PSSFWQZ)
if $PIECE(PSSX,U)=""
SET PSSDIVFG=1
SET PSSFWRST=$PIECE(PSSX,U)
SET PSSFWFLG=+$PIECE(PSSX,U,2)
QUIT
+25 IF PSSFWDIV?.N
SET PSSFWRST=PSSFWDIV
SET PSSFWPR1=1
End DoDot:1
+26 IF +$GET(PSSDIVFG)
QUIT
+27 IF $GET(PSSFWRST)]""
QUIT
+28 IF PSSFWPK="O"
DO DAYOUT
if $GET(PSSFWRST)
QUIT
+29 IF PSSFWRGH?1"Q"1N.N1"H"
SET PSSFWRST=PSSFWRGH
SET PSSFWPR1=1
QUIT
+30 IF $GET(PSSFWSC)'["@"
SET PSSFWRST=1
QUIT
+31 IF $EXTRACT(PSSFWSC,$LENGTH(PSSFWSC))="@"
SET PSSFWRST=1
QUIT
+32 QUIT
+33 ;
DAY1 ;Process schedule for the second piece of DOW@SCHEDULE
+1 IF '+$GET(PSSOSN)
IF ($PIECE($GET(^PS(51.1,PSSFWLP1,0)),"^",5)'="D")
QUIT
+2 SET PSSDCF=$$DCFSCH^PSSSCHMS(PSSFWLP1,$GET(PSSDRG),$GET(PSSFWDRL))
+3 IF PSSDCF]""
SET PSSFWRST=$PIECE(PSSDCF,U)
SET PSSFWPR1=1
QUIT
+4 SET PSSFWKZ1=$PIECE($GET(^PS(51.1,PSSFWLP1,0)),"^",2)
+5 SET PSSFWKZ5=0
IF PSSFWKZ1'=""
Begin DoDot:1
+6 SET PSSFWKZ2=$SELECT($EXTRACT(PSSFWKZ1,$LENGTH(PSSFWKZ1))'="-":PSSFWKZ1_"-",1:PSSFWKZ1)
+7 IF PSSFWKZ2?.(2N1"-")!(PSSFWKZ2?.(4N1"-"))
Begin DoDot:2
+8 SET PSSFWKZ3=0
FOR PSSFWKZ4=1:1:$LENGTH(PSSFWKZ2)
IF $EXTRACT(PSSFWKZ2,PSSFWKZ4)="-"
SET PSSFWKZ5=PSSFWKZ5+1
End DoDot:2
End DoDot:1
+9 IF $GET(PSSFWKZ5)
SET PSSFWRST=PSSFWKZ5
+10 QUIT
+11 ;
DAYOUT ;Day of week for Outpatient orders
+1 NEW PSSFWKZ6,PSSFWKZ7,PSSFWKZ8,PSSX
+2 IF PSSFWRGH'=""
SET PSSX=$$OLD51^PSSSCHMS(PSSFWRGH)
SET PSSFWRGH=$PIECE(PSSX,U)
SET PSSOMEDN=$PIECE(PSSX,U,2)
Begin DoDot:1
+3 IF +$GET(PSSOMEDN)
SET PSSFWKZ6=PSSOMEDN
DO DAYOUT1
if ($GET(PSSFWRST)]"")
QUIT
+4 IF '+$GET(PSSOMEDN)
FOR PSSFWKZ6=0:0
SET PSSFWKZ6=$ORDER(^PS(51,"B",PSSFWRGH,PSSFWKZ6))
if 'PSSFWKZ6!($GET(PSSFWRST))
QUIT
DO DAYOUT1
End DoDot:1
if ($GET(PSSFWRST)]"")
QUIT
+5 QUIT
+6 ;
DAYOUT1 ;Cont. DOW for Outpatient orders
+1 KILL PSSFWKZ7,PSSFWKZ8
+2 ;
+3 SET PSSDCF=$$DCF51^PSSSCHMS(PSSFWKZ6,$GET(PSSDRG),$GET(PSSFWDRL))
+4 IF PSSDCF]""
SET PSSFWRST=$PIECE(PSSDCF,U)
SET PSSFWPR1=1
QUIT
+5 ;
+6 SET PSSFWKZ7=$PIECE($GET(^PS(51,PSSFWKZ6,0)),"^",8)
+7 if '$GET(PSSFWKZ7)
QUIT
+8 SET PSSFWKZ8=1440/PSSFWKZ7
IF PSSFWKZ8'>1
SET PSSFWRST=1
QUIT
+9 IF PSSFWKZ8?.N
SET PSSFWRST=PSSFWKZ8
SET PSSFWPR1=1
+10 QUIT
+11 ;
NUMB ;Frequency passed in as a number
+1 ;*** Remove for MOCHA 2.1 - IP will be doing it in UND24HRS^PSJOCDS
+2 SET PSSFWFLG=0
KILL PSSFWRST
+3 NEW PSSFWDIS,PSSFWGRT,PSSFWMNT,PSSFWEEK,PSSFWXWK,PSSFWXMN
+4 SET PSSFWDIS=1440/PSSFWFR
IF PSSFWDIS?.N
SET PSSFWFLG=1
SET PSSFWRST=PSSFWDIS
SET PSSFWPR1=1
QUIT
+5 IF PSSFWDIS'<1
QUIT
+6 SET PSSFWGRT=PSSFWFR/1440
+7 IF PSSFWGRT?.N
Begin DoDot:1
+8 SET PSSFWMNT=PSSFWGRT/30
IF PSSFWMNT?.N
SET PSSFWFLG=1
SET PSSFWRST="Q"_PSSFWMNT_"L"
SET PSSFWPR1=1
QUIT
+9 SET PSSFWEEK=PSSFWGRT/7
IF PSSFWEEK?.N
SET PSSFWFLG=1
SET PSSFWRST="Q"_PSSFWEEK_"W"
SET PSSFWPR1=1
QUIT
+10 SET PSSFWFLG=1
SET PSSFWRST="Q"_PSSFWGRT_"D"
SET PSSFWPR1=1
QUIT
End DoDot:1
QUIT
+11 IF PSSFWFR'>10080
SET PSSFWXWK=10080/PSSFWFR
IF PSSFWXWK?.N
SET PSSFWFLG=1
SET PSSFWRST="X"_PSSFWXWK_"W"
SET PSSFWPR1=1
QUIT
+12 SET PSSFWXMN=43200/PSSFWFR
IF PSSFWXMN?.N
SET PSSFWFLG=1
SET PSSFWRST="X"_PSSFWXMN_"L"
SET PSSFWPR1=1
QUIT
+13 QUIT
+14 ;
STN ;Standard Logic
+1 SET PSSFWFLG=0
KILL PSSFWRST
IF $GET(PSSFWSC)=""
QUIT
+2 NEW PSSFWLP2,PSSFWAA,PSSFWAAD,PSSFWAAM,PSSFWAMN,PSSFWAWK,PSSFWAXL,PSSFWAXW,PSSDCF,PSSDCFLG,PSSDIVFG
+3 IF $GET(PSSOSN)]""
SET PSSFWLP2=PSSOSN
DO STN1
+4 ;PSS*1*224
+5 IF $GET(PSSOSN)=""
SET PSSFWSC=$$PRNSCHD^PSSDSUTL(PSSFWSC)
FOR PSSFWLP2=0:0
SET PSSFWLP2=$ORDER(^PS(51.1,"APPSJ",PSSFWSC,PSSFWLP2))
if 'PSSFWLP2!(PSSFWFLG)!$GET(PSSDCFLG)!$GET(PSSDIVFG)
QUIT
DO STN1
+6 KILL PSSDIVFG
+7 if $GET(PSSDCFLG)
QUIT
+8 IF PSSFWFLG
DO DURLS
IF PSSFWFLG
SET PSSFWPR1=1
QUIT
+9 QUIT
+10 ;
STN1 ;Standard Logic continue
+1 KILL PSSFWAA,PSSFWAAD
+2 SET PSSDCF=$$DCFSCH^PSSSCHMS(PSSFWLP2,$GET(PSSDRG),$GET(PSSFWDRL))
+3 ;PSS*1*206
+4 IF PSSDCF=""
IF (PSSFWSC[" PRN")
Begin DoDot:1
+5 NEW PSSX
+6 SET PSSX=PSSFWLP2
+7 IF ($PIECE(PSSFWSC," PRN",1)'="")
IF ($PIECE(PSSFWSC," PRN",1)'?." ")
SET PSSFWLP2=$ORDER(^PS(51.1,"APPSJ",$PIECE(PSSFWSC," PRN",1),0))
+8 if +PSSFWLP2
SET PSSDCF=$$DCFSCH^PSSSCHMS(PSSFWLP2,$GET(PSSDRG),$GET(PSSFWDRL))
+9 SET PSSFWLP2=PSSX
End DoDot:1
+10 IF PSSDCF]""
SET (PSSFWPR1,PSSFWFLG,PSSDCFLG)=1
SET PSSFWRST=$PIECE(PSSDCF,U)
SET PSSFWPR7=$PIECE(PSSDCF,U,2)
QUIT
+11 SET PSSFWAA=$PIECE($GET(^PS(51.1,PSSFWLP2,0)),"^",3)
+12 if '$GET(PSSFWAA)
QUIT
+13 SET PSSFWAAD=1440/PSSFWAA
+14 IF PSSFWAAD?.N
SET PSSFWRST=PSSFWAAD
SET PSSFWFLG=1
QUIT
+15 IF (PSSFWAA<1440)
IF ((PSSFWAA/60)?.N)
SET PSSFWRST="Q"_(PSSFWAA/60)_"H"
SET PSSFWFLG=1
QUIT
+16 IF PSSFWAAD>1
QUIT
+17 SET PSSFWAAM=PSSFWAA/1440
+18 IF PSSFWAAM'?.N
Begin DoDot:1
+19 SET PSSFWFLG=1
SET PSSFWRST=""
SET PSSDIVFG=1
+20 IF (PSSFWAA/60)?.N
SET PSSFWRST="Q"_(PSSFWAA/60)_"H"
End DoDot:1
QUIT
+21 IF PSSFWAAM?.N
Begin DoDot:1
+22 SET PSSFWAMN=PSSFWAAM/30
IF PSSFWAMN?.N
SET PSSFWFLG=1
SET PSSFWRST="Q"_PSSFWAMN_"L"
QUIT
+23 SET PSSFWAWK=PSSFWAAM/7
IF PSSFWAWK?.N
SET PSSFWFLG=1
SET PSSFWRST="Q"_PSSFWAWK_"W"
QUIT
+24 SET PSSFWFLG=1
SET PSSFWRST="Q"_PSSFWAAM_"D"
QUIT
End DoDot:1
QUIT
+25 IF PSSFWAA'>10080
SET PSSFWAXW=10080/PSSFWAA
IF PSSFWAXW?.N
SET PSSFWFLG=1
SET PSSFWRST="X"_PSSFWAXW_"W"
QUIT
+26 SET PSSFWAXL=43200/PSSFWAA
IF PSSFWAXL?.N
SET PSSFWFLG=1
SET PSSFWRST="X"_PSSFWAXL_"L"
QUIT
+27 QUIT
+28 ;
STNO ;Standard Logic part 2, using File 51, For Outpatient Orders only
+1 SET PSSFWFLG=0
KILL PSSFWRST
IF $GET(PSSFWSC)=""
QUIT
+2 NEW PSSFWLP3,PSSFWBA,PSSFWBAD,PSSFWBAM,PSSFWBMN,PSSFWBWK,PSSFWBXL,PSSFWBXW,PSSDCFLG,PSSDIVFG
+3 IF $GET(PSSOMEDN)]""
SET PSSFWLP3=PSSOMEDN
DO STNO1
+4 ;PSS*1*224
+5 IF $GET(PSSOMEDN)=""
SET PSSFWSC=$$PRNMI^PSSDSUTL(PSSFWSC)
FOR PSSFWLP3=0:0
SET PSSFWLP3=$ORDER(^PS(51,"B",PSSFWSC,PSSFWLP3))
if 'PSSFWLP3!(PSSFWFLG)!$GET(PSSDIVFG)
QUIT
DO STNO1
+6 KILL PSSDIVFG
+7 if $GET(PSSDCFLG)
QUIT
+8 if $GET(PSSDECNO)
QUIT
+9 IF PSSFWFLG
DO DURLS
IF PSSFWFLG
SET PSSFWPR1=1
QUIT
+10 IF PSSFWSC?1"Q"1N.N1"H"
SET PSSFWRST=PSSFWSC
SET PSSFWFLG=1
DO DURLS
IF PSSFWFLG
SET PSSFWPR1=1
+11 QUIT
+12 ;
STNO1 ;Standard Logic part 2, using File 51, For Outpatient Orders only
+1 KILL PSSFWBA,PSSFWBAD
+2 SET PSSDCF=$$DCF51^PSSSCHMS(PSSFWLP3,$GET(PSSDRG),$GET(PSSFWDRL))
+3 IF PSSDCF]""
SET (PSSFWPR1,PSSFWFLG,PSSDCFLG)=1
SET PSSFWRST=$PIECE(PSSDCF,U)
SET PSSFWPR7=$PIECE(PSSDCF,U,2)
QUIT
+4 SET PSSFWBA=$PIECE($GET(^PS(51,PSSFWLP3,0)),"^",8)
+5 if '$GET(PSSFWBA)
QUIT
+6 SET PSSFWBAD=1440/PSSFWBA
+7 IF PSSFWBAD?.N
SET PSSFWRST=PSSFWBAD
SET PSSFWFLG=1
QUIT
+8 IF (PSSFWBA<1440)
IF ((PSSFWBA/60)?.N)
SET PSSFWRST="Q"_(PSSFWBA/60)_"H"
SET PSSFWFLG=1
QUIT
+9 ;PSSDECNO=1 when the admin time is not a whole #(dosing error message should display)
+10 IF PSSFWBAD>1
SET PSSFWFLG=0
SET PSSDECNO=1
QUIT
+11 SET PSSFWBAM=PSSFWBA/1440
+12 IF PSSFWBAM'?.N
SET PSSFWFLG=1
SET PSSFWRST=""
SET PSSDIVFG=1
QUIT
+13 IF PSSFWBAM?.N
Begin DoDot:1
+14 SET PSSFWBMN=PSSFWBAM/30
IF PSSFWBMN?.N
SET PSSFWFLG=1
SET PSSFWRST="Q"_PSSFWBMN_"L"
QUIT
+15 SET PSSFWBWK=PSSFWBAM/7
IF PSSFWBWK?.N
SET PSSFWFLG=1
SET PSSFWRST="Q"_PSSFWBWK_"W"
QUIT
+16 SET PSSFWFLG=1
SET PSSFWRST="Q"_PSSFWBAM_"D"
QUIT
End DoDot:1
QUIT
+17 IF PSSFWBA'>10080
SET PSSFWBXW=10080/PSSFWBA
IF PSSFWBXW?.N
SET PSSFWFLG=1
SET PSSFWRST="X"_PSSFWBXW_"W"
QUIT
+18 SET PSSFWBXL=43200/PSSFWBA
IF PSSFWBXL?.N
SET PSSFWFLG=1
SET PSSFWRST="X"_PSSFWBXL_"L"
QUIT
+19 QUIT
+20 ;
DS() ; Return 1 if Dose Checks are enabled, return 0 if Dose Checks are not enabled, 2.0 message to OR & 2.1 message to IP & OP
+1 QUIT $SELECT($PIECE($GET(^PS(59.7,1,81)),"^"):1,+$GET(PSSDSWHE)=1:$$DS1(),1:$$DS2())
+2 ;;
DS1() ; called from $$DS to break line length
+1 QUIT "0^Maximum Single Dose Order Check is not available; please complete a manual check for appropriate Dosing."
+2 ;;
DS2() ; called from $$DS to break line length
+1 QUIT "0^Dosing Checks are not available; please complete a manual check for appropriate Dosing."
+2 ;;
IV(PSSADFOI) ;Return Additive Frequency default to CPRS, Forum DBIA 5425
+1 ;PSSADFOI = File 50.7 Internal Entry Number
+2 NEW PSSADFRS,PSSADFIN,PSSADFLP,PSSADFXX,PSSADFHD,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 SET PSSADFIN=$PIECE($GET(^PS(52.6,PSSADFLP,"I")),"^")
+7 IF PSSADFIN
IF PSSADFIN'>DT
QUIT
+8 SET PSSADFNN=PSSADFLP_","
+9 SET PSSADFHD=$$GET1^DIQ(52.6,PSSADFNN,18,"I",,"PSSADFER")
IF PSSADFHD=""
SET PSSADFXX=1
QUIT
+10 IF 'PSSADFCT
SET PSSADFRS=PSSADFHD
SET PSSADFCT=1
QUIT
+11 IF PSSADFHD'=PSSADFRS
SET PSSADFXX=1
End DoDot:1
+12 IF PSSADFXX
SET PSSADFRS=""
+13 QUIT PSSADFRS
+14 ;
+15 ;
BSA(PSSBSADF) ;
+1 IF '$GET(PSSBSADF)
QUIT "0^0"
+2 NEW DFN,VADM,VAPTYP,VAHOW,VAROOT,VAERR,VA,X1,X2,X,%Y,PSSBSAW1,PSSBSAW2,PSSBSAH1,PSSBSAH2,GMRVSTR,PSSBSAB2,PSSBSAH3
+3 SET DFN=PSSBSADF
+4 SET (PSSBSAW2,PSSBSAH2,PSSBSAB2,PSSBSAH3)=0
+5 SET GMRVSTR="WT"
KILL X
DO EN6^GMRVUTL
+6 SET PSSBSAW1=$PIECE(X,"^",8)
IF PSSBSAW1
SET PSSBSAW2=PSSBSAW1/2.2
+7 SET DFN=PSSBSADF
+8 SET GMRVSTR="HT"
KILL X
DO EN6^GMRVUTL
+9 SET PSSBSAH1=$PIECE(X,"^",8)
IF PSSBSAH1
SET PSSBSAH2=.0254*PSSBSAH1
SET PSSBSAH3=$JUSTIFY(PSSBSAH1*2.54,0,2)
+10 ;Using DuBios formula for BSA calculation, and sending in 2 decimal places
+11 IF $GET(PSSBSAW2)
IF $GET(PSSBSAH2)
SET PSSBSAB2=.20247*(PSSBSAH2**.725)*(PSSBSAW2**.425)
+12 QUIT PSSBSAH3_"^"_PSSBSAW2_"^"_PSSBSAB2
+13 ;
+14 ;
UNITD(PSSVUTUN) ;Find First DataBank Unit, can't do DIC Lookup because of exact match check
+1 ;Returns Null or First DataBank Unit for text passed in
+2 NEW PSSVUTX,PSSVUTZ,PSSVUTAA,PSSVUTFL
+3 SET PSSVUTFL=0
IF $GET(PSSVUTUN)=""
SET PSSVUTZ=""
GOTO UNITDX
+4 SET PSSVUTAA=$$UP^XLFSTR(PSSVUTUN)
UNITDP ;
+1 KILL PSSVUTZ
SET PSSVUTX=$ORDER(^PS(51.24,"B",PSSVUTAA,0))
IF PSSVUTX
IF '$$SCREEN^XTID(51.24,.01,PSSVUTX_",")
SET PSSVUTZ=$PIECE($GET(^PS(51.24,PSSVUTX,0)),"^",2)
IF PSSVUTZ'=""
IF $PIECE($GET(^PS(51.24,PSSVUTX,0)),"^",3)=0
GOTO UNITDX
+2 KILL PSSVUTZ
SET PSSVUTX=$ORDER(^PS(51.24,"C",PSSVUTAA,0))
IF PSSVUTX
IF '$$SCREEN^XTID(51.24,.01,PSSVUTX_",")
SET PSSVUTZ=$PIECE($GET(^PS(51.24,PSSVUTX,0)),"^",2)
IF PSSVUTZ'=""
IF $PIECE($GET(^PS(51.24,PSSVUTX,0)),"^",3)=0
GOTO UNITDX
+3 KILL PSSVUTZ
SET PSSVUTX=$ORDER(^PS(51.24,"D",PSSVUTAA,0))
IF PSSVUTX
IF '$$SCREEN^XTID(51.24,.01,PSSVUTX_",")
SET PSSVUTZ=$PIECE($GET(^PS(51.24,PSSVUTX,0)),"^",2)
IF PSSVUTZ'=""
IF $PIECE($GET(^PS(51.24,PSSVUTX,0)),"^",3)=0
GOTO UNITDX
+4 KILL PSSVUTZ
IF 'PSSVUTFL
IF $GET(PSSVUTUN)["/"
SET PSSVUTFL=1
SET PSSVUTAA=$PIECE(PSSVUTUN,"/")
SET PSSVUTAA=$$UP^XLFSTR(PSSVUTAA)
if PSSVUTAA'=""
GOTO UNITDP
UNITDX ;
+1 QUIT $GET(PSSVUTZ)
+2 ;
+3 ;
DURLS ;If Duration is less that 24 hours, make Frequency adjustments if applicable
+1 ;Only check Frequencies of a whole number or in the format of Q#H
+2 NEW PSSDK1,PSSDK2,PSSDK3,PSSDK4,PSSDK5,PSSDK6,PSSDSCNT
+3 SET (PSSDK4,PSSFWPR7)=PSSFWRST
+4 IF $GET(PSSFWDRL)=""
QUIT
+5 SET PSSDK1=$$DRT^PSSDSAPD(PSSFWDRL)
IF PSSDK1'<1440!(PSSDK1'>0)
QUIT
+6 SET PSSDSCNT=$$CHKIPDUR^PSSSCHMS()
+7 IF +PSSDSCNT
SET PSSFWRST=$PIECE(PSSDSCNT,U,2)
QUIT
+8 SET PSSDK2=1440/PSSDK1
+9 IF PSSDK4?.N
Begin DoDot:1
+10 SET PSSDK5=PSSDK4/PSSDK2
+11 IF PSSDK5<1
KILL PSSFWRST
SET PSSFWFLG=0
QUIT
+12 ;PSS*1*178 - rounding up makes more sense
+13 SET PSSDK6=$SELECT((PSSDK5?.N):PSSDK5,1:$JUSTIFY((PSSDK5+.5),0,0))
+14 SET PSSFWRST=PSSDK6
End DoDot:1
QUIT
+15 IF PSSDK4?1"Q"1N.N1"H"
Begin DoDot:1
+16 SET PSSDK3=$$FRCON^PSSDSAPK(PSSDK4)
+17 SET PSSDK5=PSSDK3/PSSDK2
+18 IF PSSDK5<1
KILL PSSFWRST
SET PSSFWFLG=0
QUIT
+19 SET PSSDK6=$JUSTIFY(PSSDK5,0,0)
+20 SET PSSFWRST=PSSDK6
End DoDot:1
QUIT
+21 QUIT
+22 ;
+23 ;
DLTM(PSSNVTOI) ;Check if all drugs for a Non-VA Med order are exempt, if so, kill Input exceptions and Quit
+1 NEW PSSNVT1,PSSNVTFL,PSSNVTIN
+2 SET PSSNVTFL=1
+3 FOR PSSNVT1=0:0
SET PSSNVT1=$ORDER(^PSDRUG("ASP",PSSNVTOI,PSSNVT1))
if 'PSSNVT1!('PSSNVTFL)
QUIT
Begin DoDot:1
+4 IF $PIECE($GET(^PSDRUG(PSSNVT1,2)),"^",3)'["X"
QUIT
+5 SET PSSNVTIN=$PIECE($GET(^PSDRUG(PSSNVT1,"I")),"^")
IF PSSNVTIN
IF PSSNVTIN<DT
QUIT
+6 SET PSSNVTFL=$$EXMT^PSSDSAPI(PSSNVT1)
End DoDot:1
+7 QUIT PSSNVTFL
+8 ;
+9 ;
EMSY() ;Return 1 if there are matched supplies, no active drugs, regardless of Package use
+1 NEW PSSKST1,PSSKST2,PSSKST3,PSSKST4,PSSKST5,PSSKST6,PSSKST9
+2 SET (PSSKST9,PSSKST6)=0
+3 FOR PSSKST1=0:0
SET PSSKST1=$ORDER(^PSDRUG("ASP",PSSNBOI,PSSKST1))
if 'PSSKST1!(PSSKST9)
QUIT
Begin DoDot:1
+4 SET PSSKST4=0
SET PSSKST2=$PIECE($GET(^PSDRUG(PSSKST1,"I")),"^")
IF PSSKST2
IF PSSKST2'>DT
SET PSSKST4=1
+5 SET PSSKST5=$$SUP(PSSKST1)
+6 IF 'PSSKST5
IF 'PSSKST4
SET PSSKST9=1
QUIT
+7 IF 'PSSKST4
IF PSSKST5
SET PSSKST6=1
End DoDot:1
+8 IF 'PSSKST9
IF PSSKST6
SET $PIECE(PSSNBRS,";",5)=0
QUIT 0
+9 QUIT 1
