- 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 Jan 18, 2025@03:31:46 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