PSSSCHMS ;BIR/MV - Frequency utilities routine ; Sep 13, 2010@16:00
;;1.0;PHARMACY DATA MANAGEMENT;**178,206,231,254**;9/30/97;Build 109
;;Reference to INP^VADPT supported by DBIA #10061
;
OLDSCH(PSSFWSCC) ;Get IEN for .01 of the schedule file from the Old Schedule name
;Input:
; PSSFWSC - Schedule name from the order
;Output:
; Schedule Name(.01)^51.1 IEN(if old schedule found)
;
NEW PSSOLDNM,PSSSCH,PSSIEN,PSSOSN
I $G(PSSFWSCC)="" Q ""
; Skip looking for the old schedule name if there is an exact matched for the original schedule
I $O(^PS(51.1,"APPSJ",PSSFWSCC,0)) Q PSSFWSCC
S PSSOLDNM=PSSFWSCC
S PSSIEN=+$O(^PS(51.1,"D",PSSOLDNM,0))
; If there is an exact matched to the old schedule name then use it. Otherwise retain the original schedule
I 'PSSIEN Q PSSFWSCC
S PSSSCH=$G(^PS(51.1,PSSIEN,0))
I $P(PSSSCH,U)]"",($P(PSSSCH,U,4)="PSJ") S PSSFWSCC=$P(PSSSCH,U),PSSOSN=+PSSIEN
Q PSSFWSCC_U_$G(PSSOSN)
;
OLD51(PSSFWSCC) ;Get IEN for .01 of the Med Instruction file from the Old Med Instruction name
;Input:
; PSSFWSC - Schedule name from the order
;Output:
; Med instruction name(.01)^51 IEN(If old med Instruction found)
;
NEW PSSOLDNM,PSSSCH,PSSIEN,PSSOMEDN
I $G(PSSFWSCC)="" Q ""
I $O(^PS(51,"B",PSSFWSCC,0)) Q PSSFWSCC
S PSSOLDNM=PSSFWSCC
S PSSIEN=+$O(^PS(51,"D",PSSOLDNM,0))
I 'PSSIEN Q PSSFWSCC
S PSSSCH=$P($G(^PS(51,PSSIEN,0)),U)
S:PSSSCH]"" PSSFWSCC=PSSSCH,PSSOMEDN=+PSSIEN
Q PSSFWSCC_U_$G(PSSOMEDN)
;
DCFSCH(PSSIEN,PSSDDIEN,PSSFWDRL) ;Dosing Check Frequency process for 51.1
;Input:
; PSSIEN - IEN from 51.1
; PSSDDIEN - IEN from file 50
; PSSFWDRL - The order duration
;Output:
; PSSDCF - P1(adjust if order duration is passed in)^P2(#51.1 - 0;11)
;
Q:'+$G(PSSIEN) ""
NEW PSSDCF,PSSDCFLG,PSSDCF1,PSSFRQF,PSSNODD
S PSSDCFLG=0
S PSSDCF=$$DCFCNV^PSSJSV($P($G(^PS(51.1,+PSSIEN,0)),U,11))
Q:PSSDCF="" ""
; If no dispense drug is defined in 51.1 then return DCF if available
I '$O(^PS(51.1,+PSSIEN,4,0)) S PSSDCFLG=1
I $G(PSSDBIFL) D Q:+PSSNODD ""
.S PSSNODD=$$NOTALLDD(+$G(PSSDBFDB("OI")),PSSIEN)
.S:'+PSSNODD PSSDDIEN=$P(PSSNODD,U,2)
; If the dispense drug is defined, then verify if PSSDDIEN existed
I 'PSSDCFLG,+$G(PSSDDIEN),$D(^PS(51.1,+PSSIEN,4,"B",+PSSDDIEN)) S PSSDCFLG=1
I 'PSSDCFLG Q ""
I $G(PSSFWDRL)]"" S PSSFRQF=$P($G(^PS(51.1,PSSIEN,0)),"^",3),PSSDCF1=$$DCFSCHD(PSSIEN,PSSFWDRL,PSSDCF,PSSFRQF) Q $S($G(PSSDCF1)]"":PSSDCF1,1:"")_U_PSSDCF
Q $S($G(PSSDCF1)]"":PSSDCF1,1:PSSDCF)_U_PSSDCF
;
DCFSCHD(PSSIEN,PSSFWDRL,PSSDCF,PSSFRQF) ;Adjusting the frequency based on the order duration
;PSSDRL - The order duration (in minute)
;PSSFRQF - Frequency value from 51 or 51.1
;Return the adjusted frequency
;Note - the frequency is rounded up when needed. (ex: Q4H for 6 hours (order duration), the frequency = 2;
; the reason is that the pt received dose 1 in the first hour and 2nd dose 4 hours later.
NEW PSSDRL,PSSFRQ,PSSDCFN,PSSDCFD,PSSDCF1
Q:$G(PSSDCF)="" ""
Q:$G(PSSFWDRL)="" ""
S PSSDRL=$$DRT^PSSDSAPD(PSSFWDRL)
I PSSDRL'<1440 Q ""
S PSSDCF1=""
; Adjust frequency for Q#H
I PSSDCF?1"Q"1N.N1"H" D Q PSSDCF1
. S PSSDCFN=+$E(PSSDCF,2,$L(PSSDCF))*60
. S PSSDCFD=PSSDRL/PSSDCFN
. I PSSDCFD<1 S PSSDCF1="" Q
. S PSSDCF1=$S((PSSDCFD?.N):PSSDCFD,1:$J((PSSDCFD+.5),0,0))
; Adjust frequency for #XD (# per day)
I +$G(PSSFRQF),(PSSDCF?1N.N1"XD") D Q PSSDCF1
. I '+$G(PSSIEN) S PSSDCF1="" Q
. S PSSFRQ=PSSDRL/PSSFRQF
. S PSSFRQ=$S((PSSFRQ?.N):PSSFRQ,1:$J((PSSFRQ+.5),0,0))
. S (PSSDCFN,PSSDCF1)=+PSSDCF
. I PSSDCFN>PSSFRQ S PSSDCF1=PSSFRQ
Q $G(PSSDCF1)
;
DCF51(PSSIEN,PSSDDIEN,PSSFWDRL) ;Dosing Check Frequency process for Med Instruction file
;Input:
; PSSIEN - IEN from 51
; PSSDDIEN - IEN from file 50
; PSSFWDRL - Order duration
;Output:
; PSSDCF - P1(adjust if order duration is passed in)^P2(#51 - 0;9)
;
Q:'+$G(PSSIEN) ""
NEW PSSDCF,PSSDCFLG,PSSDCF1,PSSFRQF
S PSSDCFLG=0
S PSSDCF=$$DCFCNV^PSSJSV($P($G(^PS(51,+PSSIEN,0)),U,9))
Q:PSSDCF="" ""
; check if the dispense drug is specified in 51
I '$O(^PS(51,+PSSIEN,5,0)) S PSSDCFLG=1
I 'PSSDCFLG,+$G(PSSDDIEN),$D(^PS(51,+PSSIEN,5,"B",+PSSDDIEN)) S PSSDCFLG=1
I 'PSSDCFLG Q ""
I $G(PSSFWDRL)]"" S PSSFRQF=$P($G(^PS(51,PSSIEN,0)),U,8),PSSDCF1=$$DCFSCHD(PSSIEN,PSSFWDRL,PSSDCF,PSSFRQF)
Q $S($G(PSSDCF1)]"":PSSDCF1,1:PSSDCF)_U_PSSDCF
;
MULTSCH(PSSMSCH,PSSFWFR,PSSFWPK,PSSFWDRL) ;Return Frequency for PSSMSCHD with multi schedules
;Piece out each word (schedule) in PSSMSCH
;PSSMSCH - Multi-schedules
;PSSFWSCC - Single schedule (pieced out)
;PSSFRQ - Return 2 pieces - p1 = adjusted frequency (duration); p2 = the frequency
;It is necessary to set PSSDBAR("TYPE")="SINGLE DOSE" when the schedule is determined for "Once" or "ONCALL".
;PSSDBAR array came from DOSE^PSSDSAPD
NEW PSSFRQ,PSSFWSCC,PSSDOW,PSSDOWAT,PSSONCE,PSSODRL,PSSOSCH,PSSOUT1,PSSOUTD,PSSOUTX,PSSP1,PSSX
S PSSFRQ="^",PSSONCE=0,PSSDOW=0,PSSODRL=$G(PSSFWDRL),PSSOSCH=""
I $G(PSSMSCH)="" Q "^"
F PSSX=1:1:$L(PSSMSCH," ") S PSSFWSCC=$P(PSSMSCH," ",PSSX) D Q:PSSONCE
. I $G(PSSFWSCC)="" S PSSFRQ="^"
. S PSSFWSCC=$$ADDAT(PSSFWSCC)
. I $$ONETIME(PSSFWSCC) S PSSONCE=1 Q
. I PSSFWSCC["@" S PSSFWFR="D",PSSDOW=1
. ; $$FRQZ^PSSDSAPI needs PSSFWFR="D" for DOW schedule
. S PSSOUT1=$$FRQZ^PSSDSAPI()
. ;I PSSFWSCC["@" S PSSDOWAT=PSSOUT1
. I PSSFWSCC["@" S:$G(PSSOUT1)]"" PSSOUTD(PSSOUT1,PSSFWSCC)=""
. I PSSOUT1]"" S PSSOUTX(PSSOUT1,PSSFWSCC)="" S:PSSOSCH="" PSSOSCH=PSSFWSCC
;
I $G(PSSONCE) S PSSDBAR("TYPE")="SINGLE DOSE" Q "1^1"
I $D(PSSOUTD) D Q $S($G(PSSP1)]"":PSSP1_"^"_PSSP1,1:"^")
. S PSSP1=$O(PSSOUTD("")) I $O(PSSOUTD(PSSP1))]"" S PSSP1="" Q
; Check if the schedules have the same frequency.
S PSSP1=$O(PSSOUTX("")) I $O(PSSOUTX(PSSP1))]"" Q "^"
I $G(PSSFWDRL)="" Q PSSP1_U_PSSP1
; Get the frequency for piece 2 without the duration factor in
I $G(PSSP1)]"",($G(PSSFWDRL)]""),($G(PSSOSCH)]"") S PSSFWDRL="",PSSFWSCC=PSSOSCH,PSSFRQ=PSSP1_U_$$FRQZ^PSSDSAPI(),PSSFWDRL=PSSODRL
Q PSSFRQ
ONETIME(PSSSCHD) ;check for one-time, now, oncall schedules
;Return 1 if schedule is one-time, now
; 0 if not
NEW PSSX,PSSASIEN,PSSOUT
I $G(PSSSCHD)="" Q 0
S PSSOUT=0
F PSSASIEN=0:0 S PSSASIEN=$O(^PS(51.1,"APPSJ",PSSSCHD,PSSASIEN)) Q:'PSSASIEN D Q:PSSOUT
. S PSSX=$P($G(^PS(51.1,PSSASIEN,0)),U,5)
. S:PSSX="O"!(PSSX="OC") PSSOUT=1
Q PSSOUT
;
DOWAT(PSSFWSCC,PSSDDIEN) ;
;Process day of week with admin times (ex SU-MO@12)
NEW PSSIEN,PSSSCH1,PSSSCH2
Q:$G(PSSFWSCC)="" ""
S PSSSCH1=$P(PSSFWSCC,"@"),PSSSCH2=$P(PSSFWSCC,"@",2)
S PSSIEN=$$DOWIEN(PSSFWSCC,PSSSCH1,PSSSCH2)
I 'PSSIEN S PSSIEN=$$DOWIEN(PSSSCH1_"@"_PSSSCH2,PSSSCH1,PSSSCH2)
I 'PSSIEN S PSSIEN=$$DOWIEN(PSSSCH1_"@"_$$AT(PSSSCH2,2),PSSSCH1,PSSSCH2)
I 'PSSIEN S PSSIEN=$$DOWIEN(PSSSCH1_"@"_$$AT(PSSSCH2,4),PSSSCH1,PSSSCH2)
I 'PSSIEN S PSSIEN=$$DOWIEN(PSSSCH1,PSSSCH1,PSSSCH2)
I 'PSSIEN Q ""
;Get DCF(the order duration is ignored when it's DOW schedule)
Q $$DCFSCH(PSSIEN,$G(PSSDDIEN))
;
DOWIEN(PSSSCH,PSSSCH1,PSSSCH2) ;
;Return 51.1 IEN (if more than one matched, return the DOW, else the first matched)
NEW PSSIEN,PSSX,PSSFLG
Q:$G(PSSSCH)="" ""
S PSSIEN=0,PSSFLG=0
F PSSX=0:0 S PSSX=$O(^PS(51.1,"APPSJ",PSSSCH,PSSX)) Q:'PSSX D Q:PSSFLG
. I '$$SCHAT(PSSX,$G(PSSSCH1),$G(PSSSCH2)) Q
. ; store the first IEN found
. I 'PSSIEN S PSSIEN=PSSX
. I $P($G(^PS(51.1,PSSX,0)),U,5)="D" S PSSIEN=PSSX,PSSFLG=1 Q
Q PSSIEN
;
AT(PSSAT,PSSDIG) ;return admin time(s) in 2 or 4 digits format
;PSSDIG - set admin time to 2 digits or 4 digits format (ex: 09 or 0900)
NEW PSSY,PSSX
Q:$G(PSSAT)="" ""
I '+$G(PSSDIG) S PSSDIG=4
S PSSX=""
F PSSY=1:1:$L(PSSAT,"-") S PSSX=PSSX_$S(PSSX="":"",1:"-")_$E($P(PSSAT,"-",PSSY)_"0000",1,PSSDIG)
Q PSSX
;
SCHAT(PSSIEN,PSSSCH1,PSSSCH2) ;return PSSIEN from 51.1 for DOW
NEW PSSFL1,PSSFL2,PSSAT,PSSIEN0
Q:'+$G(PSSIEN) 0
S PSSIEN0=$G(^PS(51.1,PSSIEN,0))
S PSSAT=$P(PSSIEN0,U,2),(PSSFL1,PSSFL2)=0
; Return IEN if there is no admin time define and schedule matched .01
I (PSSAT=""),($G(PSSSCH1)_"@"_$G(PSSSCH2))=$P(PSSIEN0,U) Q PSSIEN
I (PSSAT=""),($G(PSSSCH1)_"@"_$$AT($G(PSSSCH2),2))=$P(PSSIEN0,U) Q PSSIEN
I (PSSAT=""),($G(PSSSCH1)_"@"_$$AT($G(PSSSCH2),4))=$P(PSSIEN0,U) Q PSSIEN
; If admin is not defined in 51.1 but was entered with order
I (PSSAT=""),(PSSSCH2]"") S PSSFL1=1
; There maybe multiple entries with the same DOW. Tried to find the one with the same admin time
; Check for schedule and admin times from 51.1(in 2 & 4 digit format) matched to the admin time entered for the order
I (PSSAT]""),($G(PSSSCH1)_"@"_$$AT(PSSAT,2))'=($G(PSSSCH1)_"@"_$$AT($G(PSSSCH2),2)) S PSSFL1=1
I (PSSAT]""),($G(PSSSCH1)_"@"_$$AT(PSSAT,4))'=($G(PSSSCH1)_"@"_$$AT($G(PSSSCH2),4)) S PSSFL1=1
; Only return PSSIEN if the schedule and admin time from 51.1 matched order's Admin time
I PSSFL1 S PSSIEN=0
Q PSSIEN
ADDAT(PSSFWSCC) ;concatenate admin times from 51.1 to the schedule name for DOW
;PSSFWSCC - Schedule name
NEW PSSASIEN,PSSX,PSSXFG
I $G(PSSFWSCC)="" Q ""
S PSSXFG=0
F PSSASIEN=0:0 S PSSASIEN=$O(^PS(51.1,"APPSJ",PSSFWSCC,PSSASIEN)) Q:'PSSASIEN D Q:PSSXFG
. I PSSFWSCC["@" S PSSXFG=1 Q
. S PSSX=$G(^PS(51.1,PSSASIEN,0))
. I $P(PSSX,U,5)'="D" S PSSXFG=1 Q
. I $P(PSSX,U,2)]"" S PSSFWSCC=PSSFWSCC_"@"_$P(PSSX,U,2) S PSSXFG=1
Q PSSFWSCC
CONVSCH(PSSFRQ) ;Convert numeric frequency to a schedule
;PSSFRQ - Frequency in minutes
;Return null or Schedule_0/1
I '+$G(PSSFRQ) Q ""
NEW PSSFWBAM,PSSFWBMN,PSSFWBNM,PSSFWRST,PSSFWBWK,PSSFWBXW,PSSFWBXL,PSSFWFLG
S PSSFWFLG=0
S PSSFWBAM=PSSFRQ/1440
I PSSFWBAM'?.N Q ""
I PSSFWBAM?.N D Q PSSFWRST_U_PSSFWFLG
.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 PSSFRQ'>10080 S PSSFWBXW=10080/PSSFRQ I PSSFWBXW?.N S PSSFWFLG=1,PSSFWRST=PSSFWBXW_"XW" Q PSSFWRST_U_PSSFWFLG
S PSSFWBXL=43200/PSSFRQ I PSSFWBXL?.N S PSSFWFLG=1,PSSFWRST=PSSFWBXL_"XL" Q PSSFWRST_U_PSSFWFLG
Q ""
NOTALLDD(PSSGTOI,PSSIEN) ;When only OI is sent from CPRS, all DDs must be defined in 51.1 in order for the DCF value to be used.
;PSSNOTDD=1 if not all dispense drugs are defined in in 51.1 and the last good DD
;PSSGOI - Orderable Item
;PSSIEN - 51.1 ien
NEW PSSDD,PSSDDIEN,PSSDDACT,PSSNODD
Q:'+$G(PSSGTOI) 0
Q:'+$G(PSSIEN) 0
I '$O(^PS(51.1,+PSSIEN,4,0)) Q 0 ;PSS*1*231 Correct issue with orphan 0 node
S PSSNODD=0
F PSSDDIEN=0:0 S PSSDDIEN=$O(^PSDRUG("ASP",PSSGTOI,PSSDDIEN)) Q:'PSSDDIEN!PSSNODD D
.I $$EXMT^PSSDSAPI(PSSDDIEN) Q
.S PSSDDACT=$P($G(^PSDRUG(PSSDDIEN,"I")),"^") I PSSDDACT,PSSDDACT<DT Q
.S PSSDD=PSSDDIEN
.I '$D(^PS(51.1,+PSSIEN,4,"B",+PSSDDIEN)) S PSSNODD=1
Q PSSNODD_U_$G(PSSDD)
CHKIPDUR() ;Check if CPRR IP has a duration <24hrs
;*************************************************************************
;*** MOCHA 2.1b - only perform daily dose if it is not a complex order ***
;*************************************************************************
;This is for CPRS IP order
;Check: only one sequence(not complex); EFD (expected first dose); Duration <24h;
;Return: 0 or 1^# of dose(s) for admin times within the duration.
NEW PSSDUR,PSSADMIN,PSSDSCNT,PSSX
I '$D(PSSDBFDB)!'$D(PSSDBDS) Q 0
I $O(PSSDBFDB(1)) Q 0
I $G(PSSDBFDB("PACKAGE"))'="I" Q 0
I $G(PSSDBDS(1,"EFD"))="" Q 0
S PSSX=$G(PSSDBDS(1,"DRATE"))
S PSSDUR=$S((PSSX["H"):(+PSSX*60),(PSSX["M"):+PSSX,1:0)
I 'PSSDUR Q 0
I PSSDUR'<1440 Q 0
S PSSADMIN=$$ADMIN($G(PSSDBDFN),$G(PSSDBDS(1,"SCHEDULE")))
I PSSADMIN="" Q 0
S PSSDSCNT=$$DOSECNT^PSSSCHMS(PSSDBDS(1,"EFD"),PSSADMIN,PSSDUR)
Q 1_U_PSSDSCNT
ADMIN(DFN,PSSSCHD) ;Determine if admin times for the ward should be used
NEW VAIN,PSSWARD,PSSIEN,PSSADM,PSSWDADM
I $G(PSSSCHD)="" Q ""
;I '+$G(DFN) Q ""
D:+$G(DFN) INP^VADPT
S PSSWARD=+$G(VAIN(4))
S (PSSADM,PSSWDADM)=""
F PSSIEN=0:0 S PSSIEN=$O(^PS(51.1,"APPSJ",PSSSCHD,PSSIEN)) Q:(PSSIEN="")!(PSSWDADM]"") D
. S:PSSADM="" PSSADM=$P($G(^PS(51.1,PSSIEN,0)),U,2)
. S PSSWDADM=$P($G(^PS(51.1,PSSIEN,1,+PSSWARD,0)),U,2)
I PSSWDADM]"" Q PSSWDADM
Q PSSADM
DOSECNT(PSSEFD,PSSAT,PSSDUR) ;count # of dose for duration <24h
;PSSEFD - Expected First Dose (dt.time)^Admin times from CPRS
;PSSDUR - duration in minutes
;Calculate # of doses for CPRS IP order with a duration
;Return p1^p2 (p1=0 unable to figure, 1 use p2 for count; p2=# doses need for this duration)
NEW PSSEDT,PSSCNT,PSSSTRTM,PSSSTPTM,PSSDTFLG,PSSADMIN,PSSX
Q:$G(PSSEFD)="" 0
Q:$G(PSSAT)="" 0
Q:'+$G(PSSDUR) 0
S PSSEDT=$$FMADD^XLFDT(PSSEFD,,,+PSSDUR)
S PSSCNT=0
S PSSSTRTM=$E($P(PSSEFD,".",2)_"0000",1,4)
S PSSSTPTM=$E($P(PSSEDT,".",2)_"0000",1,4)
S PSSDTFLG=0
I $P(PSSEFD,".")=$P(PSSEDT,".") S PSSDTFLG=1
F PSSX=1:1 S PSSADMIN=$P(PSSAT,"-",PSSX) Q:PSSADMIN="" D
. S PSSADMIN=$E($P(PSSAT,"-",PSSX)_"0000",1,4)
. I PSSDTFLG D Q
.. I (PSSSTRTM'>PSSADMIN),(PSSADMIN<PSSSTPTM) S PSSCNT=PSSCNT+1
. I (PSSSTRTM'>PSSADMIN) S PSSCNT=PSSCNT+1
. I (PSSSTPTM>PSSADMIN) S PSSCNT=PSSCNT+1
Q PSSCNT
SCHD ;^PSSDSAPD is too big - move it here.
N PSSDBSCD,PSSDBSCP,PSSDBSCF,PSSDBSCG,PSSDBSCH,PSSDCF
S PSSDBAR("FREQ")=""
;I $D(PSSDBFDB(PSSDBLP,"FREQ")) S PSSDBAR("FREQ")=PSSDBFDB(PSSDBLP,"FREQ") Q
I PSSDBAR("TYPE")="SINGLE DOSE" S PSSDBAR("FREQ")="" Q
;I $G(PSSDBDS(PSSDBLP,"DRATE"))'="",$$DRT(PSSDBDS(PSSDBLP,"DRATE"))<1440 S PSSDBSDR=1
S PSSDBSCD=$G(PSSDBDS(PSSDBLP,"SCHEDULE"))
I PSSDBSCD="",'$D(PSSDBFDB(PSSDBLP,"FREQ")) S PSSDBCAZ(PSSDBFDB(PSSDBLP,"RX_NUM"),"FRQ_ERROR")="" Q
S (PSSDBSCF,PSSDBSCH)="" S PSSDBSCP=$P(PSSDBFDB(PSSDBLP,"RX_NUM"),";")
I $G(PSSDBSCD)'="" F PSSDBSCG=0:0 S PSSDBSCG=$O(^PS(51.1,"APPSJ",PSSDBSCD,PSSDBSCG)) Q:'PSSDBSCG!(PSSDBSCH) D
.I $P($G(^PS(51.1,PSSDBSCG,0)),"^",5)="D" S PSSDBSCF="D"
.I $P($G(^PS(51.1,PSSDBSCG,0)),"^",5)="O"!($P($G(^PS(51.1,PSSDBSCG,0)),"^",5)="OC") S PSSDBSCH=1
I PSSDBSCH,'$D(PSSDBFDB(PSSDBLP,"FREQ")) S PSSDBAR("FREQ")=1 Q
I $G(PSSDBSCD)["@" S PSSDBSCF="D"
I $G(PSSDBSCD)'="" D
. S PSSDBSCP=$S(PSSDBSCP="I":"I",1:"O")
. S PSSDBAR("FREQZZ")=$$FRQ^PSSDSAPI(PSSDBSCD,PSSDBSCF,PSSDBSCP,$G(PSSDBDS(PSSDBLP,"DRATE")),$G(PSSDBFDB(PSSDBLP,"DRUG_IEN")))
. S PSSDCF=$P(PSSDBAR("FREQZZ"),U,2)
. I PSSDCF?1N.N1"XD" S PSSDBAR("FREQZZ")=PSSDCF_U_PSSDCF,PSSDBFDB(PSSDBLP,"FREQ")=PSSDCF
. S PSSDBAR("FREQ")=$P(PSSDBAR("FREQZZ"),"^")
I $D(PSSDBFDB(PSSDBLP,"FREQ")) S PSSDBAR("FREQ")=PSSDBFDB(PSSDBLP,"FREQ") Q
S:PSSDBAR("FREQ")="" PSSDBCAZ(PSSDBFDB(PSSDBLP,"RX_NUM"),"FRQ_ERROR")=""
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSSSCHMS 14706 printed Sep 23, 2025@20:10:08 Page 2
PSSSCHMS ;BIR/MV - Frequency utilities routine ; Sep 13, 2010@16:00
+1 ;;1.0;PHARMACY DATA MANAGEMENT;**178,206,231,254**;9/30/97;Build 109
+2 ;;Reference to INP^VADPT supported by DBIA #10061
+3 ;
OLDSCH(PSSFWSCC) ;Get IEN for .01 of the schedule file from the Old Schedule name
+1 ;Input:
+2 ; PSSFWSC - Schedule name from the order
+3 ;Output:
+4 ; Schedule Name(.01)^51.1 IEN(if old schedule found)
+5 ;
+6 NEW PSSOLDNM,PSSSCH,PSSIEN,PSSOSN
+7 IF $GET(PSSFWSCC)=""
QUIT ""
+8 ; Skip looking for the old schedule name if there is an exact matched for the original schedule
+9 IF $ORDER(^PS(51.1,"APPSJ",PSSFWSCC,0))
QUIT PSSFWSCC
+10 SET PSSOLDNM=PSSFWSCC
+11 SET PSSIEN=+$ORDER(^PS(51.1,"D",PSSOLDNM,0))
+12 ; If there is an exact matched to the old schedule name then use it. Otherwise retain the original schedule
+13 IF 'PSSIEN
QUIT PSSFWSCC
+14 SET PSSSCH=$GET(^PS(51.1,PSSIEN,0))
+15 IF $PIECE(PSSSCH,U)]""
IF ($PIECE(PSSSCH,U,4)="PSJ")
SET PSSFWSCC=$PIECE(PSSSCH,U)
SET PSSOSN=+PSSIEN
+16 QUIT PSSFWSCC_U_$GET(PSSOSN)
+17 ;
OLD51(PSSFWSCC) ;Get IEN for .01 of the Med Instruction file from the Old Med Instruction name
+1 ;Input:
+2 ; PSSFWSC - Schedule name from the order
+3 ;Output:
+4 ; Med instruction name(.01)^51 IEN(If old med Instruction found)
+5 ;
+6 NEW PSSOLDNM,PSSSCH,PSSIEN,PSSOMEDN
+7 IF $GET(PSSFWSCC)=""
QUIT ""
+8 IF $ORDER(^PS(51,"B",PSSFWSCC,0))
QUIT PSSFWSCC
+9 SET PSSOLDNM=PSSFWSCC
+10 SET PSSIEN=+$ORDER(^PS(51,"D",PSSOLDNM,0))
+11 IF 'PSSIEN
QUIT PSSFWSCC
+12 SET PSSSCH=$PIECE($GET(^PS(51,PSSIEN,0)),U)
+13 if PSSSCH]""
SET PSSFWSCC=PSSSCH
SET PSSOMEDN=+PSSIEN
+14 QUIT PSSFWSCC_U_$GET(PSSOMEDN)
+15 ;
DCFSCH(PSSIEN,PSSDDIEN,PSSFWDRL) ;Dosing Check Frequency process for 51.1
+1 ;Input:
+2 ; PSSIEN - IEN from 51.1
+3 ; PSSDDIEN - IEN from file 50
+4 ; PSSFWDRL - The order duration
+5 ;Output:
+6 ; PSSDCF - P1(adjust if order duration is passed in)^P2(#51.1 - 0;11)
+7 ;
+8 if '+$GET(PSSIEN)
QUIT ""
+9 NEW PSSDCF,PSSDCFLG,PSSDCF1,PSSFRQF,PSSNODD
+10 SET PSSDCFLG=0
+11 SET PSSDCF=$$DCFCNV^PSSJSV($PIECE($GET(^PS(51.1,+PSSIEN,0)),U,11))
+12 if PSSDCF=""
QUIT ""
+13 ; If no dispense drug is defined in 51.1 then return DCF if available
+14 IF '$ORDER(^PS(51.1,+PSSIEN,4,0))
SET PSSDCFLG=1
+15 IF $GET(PSSDBIFL)
Begin DoDot:1
+16 SET PSSNODD=$$NOTALLDD(+$GET(PSSDBFDB("OI")),PSSIEN)
+17 if '+PSSNODD
SET PSSDDIEN=$PIECE(PSSNODD,U,2)
End DoDot:1
if +PSSNODD
QUIT ""
+18 ; If the dispense drug is defined, then verify if PSSDDIEN existed
+19 IF 'PSSDCFLG
IF +$GET(PSSDDIEN)
IF $DATA(^PS(51.1,+PSSIEN,4,"B",+PSSDDIEN))
SET PSSDCFLG=1
+20 IF 'PSSDCFLG
QUIT ""
+21 IF $GET(PSSFWDRL)]""
SET PSSFRQF=$PIECE($GET(^PS(51.1,PSSIEN,0)),"^",3)
SET PSSDCF1=$$DCFSCHD(PSSIEN,PSSFWDRL,PSSDCF,PSSFRQF)
QUIT $SELECT($GET(PSSDCF1)]"":PSSDCF1,1:"")_U_PSSDCF
+22 QUIT $SELECT($GET(PSSDCF1)]"":PSSDCF1,1:PSSDCF)_U_PSSDCF
+23 ;
DCFSCHD(PSSIEN,PSSFWDRL,PSSDCF,PSSFRQF) ;Adjusting the frequency based on the order duration
+1 ;PSSDRL - The order duration (in minute)
+2 ;PSSFRQF - Frequency value from 51 or 51.1
+3 ;Return the adjusted frequency
+4 ;Note - the frequency is rounded up when needed. (ex: Q4H for 6 hours (order duration), the frequency = 2;
+5 ; the reason is that the pt received dose 1 in the first hour and 2nd dose 4 hours later.
+6 NEW PSSDRL,PSSFRQ,PSSDCFN,PSSDCFD,PSSDCF1
+7 if $GET(PSSDCF)=""
QUIT ""
+8 if $GET(PSSFWDRL)=""
QUIT ""
+9 SET PSSDRL=$$DRT^PSSDSAPD(PSSFWDRL)
+10 IF PSSDRL'<1440
QUIT ""
+11 SET PSSDCF1=""
+12 ; Adjust frequency for Q#H
+13 IF PSSDCF?1"Q"1N.N1"H"
Begin DoDot:1
+14 SET PSSDCFN=+$EXTRACT(PSSDCF,2,$LENGTH(PSSDCF))*60
+15 SET PSSDCFD=PSSDRL/PSSDCFN
+16 IF PSSDCFD<1
SET PSSDCF1=""
QUIT
+17 SET PSSDCF1=$SELECT((PSSDCFD?.N):PSSDCFD,1:$JUSTIFY((PSSDCFD+.5),0,0))
End DoDot:1
QUIT PSSDCF1
+18 ; Adjust frequency for #XD (# per day)
+19 IF +$GET(PSSFRQF)
IF (PSSDCF?1N.N1"XD")
Begin DoDot:1
+20 IF '+$GET(PSSIEN)
SET PSSDCF1=""
QUIT
+21 SET PSSFRQ=PSSDRL/PSSFRQF
+22 SET PSSFRQ=$SELECT((PSSFRQ?.N):PSSFRQ,1:$JUSTIFY((PSSFRQ+.5),0,0))
+23 SET (PSSDCFN,PSSDCF1)=+PSSDCF
+24 IF PSSDCFN>PSSFRQ
SET PSSDCF1=PSSFRQ
End DoDot:1
QUIT PSSDCF1
+25 QUIT $GET(PSSDCF1)
+26 ;
DCF51(PSSIEN,PSSDDIEN,PSSFWDRL) ;Dosing Check Frequency process for Med Instruction file
+1 ;Input:
+2 ; PSSIEN - IEN from 51
+3 ; PSSDDIEN - IEN from file 50
+4 ; PSSFWDRL - Order duration
+5 ;Output:
+6 ; PSSDCF - P1(adjust if order duration is passed in)^P2(#51 - 0;9)
+7 ;
+8 if '+$GET(PSSIEN)
QUIT ""
+9 NEW PSSDCF,PSSDCFLG,PSSDCF1,PSSFRQF
+10 SET PSSDCFLG=0
+11 SET PSSDCF=$$DCFCNV^PSSJSV($PIECE($GET(^PS(51,+PSSIEN,0)),U,9))
+12 if PSSDCF=""
QUIT ""
+13 ; check if the dispense drug is specified in 51
+14 IF '$ORDER(^PS(51,+PSSIEN,5,0))
SET PSSDCFLG=1
+15 IF 'PSSDCFLG
IF +$GET(PSSDDIEN)
IF $DATA(^PS(51,+PSSIEN,5,"B",+PSSDDIEN))
SET PSSDCFLG=1
+16 IF 'PSSDCFLG
QUIT ""
+17 IF $GET(PSSFWDRL)]""
SET PSSFRQF=$PIECE($GET(^PS(51,PSSIEN,0)),U,8)
SET PSSDCF1=$$DCFSCHD(PSSIEN,PSSFWDRL,PSSDCF,PSSFRQF)
+18 QUIT $SELECT($GET(PSSDCF1)]"":PSSDCF1,1:PSSDCF)_U_PSSDCF
+19 ;
MULTSCH(PSSMSCH,PSSFWFR,PSSFWPK,PSSFWDRL) ;Return Frequency for PSSMSCHD with multi schedules
+1 ;Piece out each word (schedule) in PSSMSCH
+2 ;PSSMSCH - Multi-schedules
+3 ;PSSFWSCC - Single schedule (pieced out)
+4 ;PSSFRQ - Return 2 pieces - p1 = adjusted frequency (duration); p2 = the frequency
+5 ;It is necessary to set PSSDBAR("TYPE")="SINGLE DOSE" when the schedule is determined for "Once" or "ONCALL".
+6 ;PSSDBAR array came from DOSE^PSSDSAPD
+7 NEW PSSFRQ,PSSFWSCC,PSSDOW,PSSDOWAT,PSSONCE,PSSODRL,PSSOSCH,PSSOUT1,PSSOUTD,PSSOUTX,PSSP1,PSSX
+8 SET PSSFRQ="^"
SET PSSONCE=0
SET PSSDOW=0
SET PSSODRL=$GET(PSSFWDRL)
SET PSSOSCH=""
+9 IF $GET(PSSMSCH)=""
QUIT "^"
+10 FOR PSSX=1:1:$LENGTH(PSSMSCH," ")
SET PSSFWSCC=$PIECE(PSSMSCH," ",PSSX)
Begin DoDot:1
+11 IF $GET(PSSFWSCC)=""
SET PSSFRQ="^"
+12 SET PSSFWSCC=$$ADDAT(PSSFWSCC)
+13 IF $$ONETIME(PSSFWSCC)
SET PSSONCE=1
QUIT
+14 IF PSSFWSCC["@"
SET PSSFWFR="D"
SET PSSDOW=1
+15 ; $$FRQZ^PSSDSAPI needs PSSFWFR="D" for DOW schedule
+16 SET PSSOUT1=$$FRQZ^PSSDSAPI()
+17 ;I PSSFWSCC["@" S PSSDOWAT=PSSOUT1
+18 IF PSSFWSCC["@"
if $GET(PSSOUT1)]""
SET PSSOUTD(PSSOUT1,PSSFWSCC)=""
+19 IF PSSOUT1]""
SET PSSOUTX(PSSOUT1,PSSFWSCC)=""
if PSSOSCH=""
SET PSSOSCH=PSSFWSCC
End DoDot:1
if PSSONCE
QUIT
+20 ;
+21 IF $GET(PSSONCE)
SET PSSDBAR("TYPE")="SINGLE DOSE"
QUIT "1^1"
+22 IF $DATA(PSSOUTD)
Begin DoDot:1
+23 SET PSSP1=$ORDER(PSSOUTD(""))
IF $ORDER(PSSOUTD(PSSP1))]""
SET PSSP1=""
QUIT
End DoDot:1
QUIT $SELECT($GET(PSSP1)]"":PSSP1_"^"_PSSP1,1:"^")
+24 ; Check if the schedules have the same frequency.
+25 SET PSSP1=$ORDER(PSSOUTX(""))
IF $ORDER(PSSOUTX(PSSP1))]""
QUIT "^"
+26 IF $GET(PSSFWDRL)=""
QUIT PSSP1_U_PSSP1
+27 ; Get the frequency for piece 2 without the duration factor in
+28 IF $GET(PSSP1)]""
IF ($GET(PSSFWDRL)]"")
IF ($GET(PSSOSCH)]"")
SET PSSFWDRL=""
SET PSSFWSCC=PSSOSCH
SET PSSFRQ=PSSP1_U_$$FRQZ^PSSDSAPI()
SET PSSFWDRL=PSSODRL
+29 QUIT PSSFRQ
ONETIME(PSSSCHD) ;check for one-time, now, oncall schedules
+1 ;Return 1 if schedule is one-time, now
+2 ; 0 if not
+3 NEW PSSX,PSSASIEN,PSSOUT
+4 IF $GET(PSSSCHD)=""
QUIT 0
+5 SET PSSOUT=0
+6 FOR PSSASIEN=0:0
SET PSSASIEN=$ORDER(^PS(51.1,"APPSJ",PSSSCHD,PSSASIEN))
if 'PSSASIEN
QUIT
Begin DoDot:1
+7 SET PSSX=$PIECE($GET(^PS(51.1,PSSASIEN,0)),U,5)
+8 if PSSX="O"!(PSSX="OC")
SET PSSOUT=1
End DoDot:1
if PSSOUT
QUIT
+9 QUIT PSSOUT
+10 ;
DOWAT(PSSFWSCC,PSSDDIEN) ;
+1 ;Process day of week with admin times (ex SU-MO@12)
+2 NEW PSSIEN,PSSSCH1,PSSSCH2
+3 if $GET(PSSFWSCC)=""
QUIT ""
+4 SET PSSSCH1=$PIECE(PSSFWSCC,"@")
SET PSSSCH2=$PIECE(PSSFWSCC,"@",2)
+5 SET PSSIEN=$$DOWIEN(PSSFWSCC,PSSSCH1,PSSSCH2)
+6 IF 'PSSIEN
SET PSSIEN=$$DOWIEN(PSSSCH1_"@"_PSSSCH2,PSSSCH1,PSSSCH2)
+7 IF 'PSSIEN
SET PSSIEN=$$DOWIEN(PSSSCH1_"@"_$$AT(PSSSCH2,2),PSSSCH1,PSSSCH2)
+8 IF 'PSSIEN
SET PSSIEN=$$DOWIEN(PSSSCH1_"@"_$$AT(PSSSCH2,4),PSSSCH1,PSSSCH2)
+9 IF 'PSSIEN
SET PSSIEN=$$DOWIEN(PSSSCH1,PSSSCH1,PSSSCH2)
+10 IF 'PSSIEN
QUIT ""
+11 ;Get DCF(the order duration is ignored when it's DOW schedule)
+12 QUIT $$DCFSCH(PSSIEN,$GET(PSSDDIEN))
+13 ;
DOWIEN(PSSSCH,PSSSCH1,PSSSCH2) ;
+1 ;Return 51.1 IEN (if more than one matched, return the DOW, else the first matched)
+2 NEW PSSIEN,PSSX,PSSFLG
+3 if $GET(PSSSCH)=""
QUIT ""
+4 SET PSSIEN=0
SET PSSFLG=0
+5 FOR PSSX=0:0
SET PSSX=$ORDER(^PS(51.1,"APPSJ",PSSSCH,PSSX))
if 'PSSX
QUIT
Begin DoDot:1
+6 IF '$$SCHAT(PSSX,$GET(PSSSCH1),$GET(PSSSCH2))
QUIT
+7 ; store the first IEN found
+8 IF 'PSSIEN
SET PSSIEN=PSSX
+9 IF $PIECE($GET(^PS(51.1,PSSX,0)),U,5)="D"
SET PSSIEN=PSSX
SET PSSFLG=1
QUIT
End DoDot:1
if PSSFLG
QUIT
+10 QUIT PSSIEN
+11 ;
AT(PSSAT,PSSDIG) ;return admin time(s) in 2 or 4 digits format
+1 ;PSSDIG - set admin time to 2 digits or 4 digits format (ex: 09 or 0900)
+2 NEW PSSY,PSSX
+3 if $GET(PSSAT)=""
QUIT ""
+4 IF '+$GET(PSSDIG)
SET PSSDIG=4
+5 SET PSSX=""
+6 FOR PSSY=1:1:$LENGTH(PSSAT,"-")
SET PSSX=PSSX_$SELECT(PSSX="":"",1:"-")_$EXTRACT($PIECE(PSSAT,"-",PSSY)_"0000",1,PSSDIG)
+7 QUIT PSSX
+8 ;
SCHAT(PSSIEN,PSSSCH1,PSSSCH2) ;return PSSIEN from 51.1 for DOW
+1 NEW PSSFL1,PSSFL2,PSSAT,PSSIEN0
+2 if '+$GET(PSSIEN)
QUIT 0
+3 SET PSSIEN0=$GET(^PS(51.1,PSSIEN,0))
+4 SET PSSAT=$PIECE(PSSIEN0,U,2)
SET (PSSFL1,PSSFL2)=0
+5 ; Return IEN if there is no admin time define and schedule matched .01
+6 IF (PSSAT="")
IF ($GET(PSSSCH1)_"@"_$GET(PSSSCH2))=$PIECE(PSSIEN0,U)
QUIT PSSIEN
+7 IF (PSSAT="")
IF ($GET(PSSSCH1)_"@"_$$AT($GET(PSSSCH2),2))=$PIECE(PSSIEN0,U)
QUIT PSSIEN
+8 IF (PSSAT="")
IF ($GET(PSSSCH1)_"@"_$$AT($GET(PSSSCH2),4))=$PIECE(PSSIEN0,U)
QUIT PSSIEN
+9 ; If admin is not defined in 51.1 but was entered with order
+10 IF (PSSAT="")
IF (PSSSCH2]"")
SET PSSFL1=1
+11 ; There maybe multiple entries with the same DOW. Tried to find the one with the same admin time
+12 ; Check for schedule and admin times from 51.1(in 2 & 4 digit format) matched to the admin time entered for the order
+13 IF (PSSAT]"")
IF ($GET(PSSSCH1)_"@"_$$AT(PSSAT,2))'=($GET(PSSSCH1)_"@"_$$AT($GET(PSSSCH2),2))
SET PSSFL1=1
+14 IF (PSSAT]"")
IF ($GET(PSSSCH1)_"@"_$$AT(PSSAT,4))'=($GET(PSSSCH1)_"@"_$$AT($GET(PSSSCH2),4))
SET PSSFL1=1
+15 ; Only return PSSIEN if the schedule and admin time from 51.1 matched order's Admin time
+16 IF PSSFL1
SET PSSIEN=0
+17 QUIT PSSIEN
ADDAT(PSSFWSCC) ;concatenate admin times from 51.1 to the schedule name for DOW
+1 ;PSSFWSCC - Schedule name
+2 NEW PSSASIEN,PSSX,PSSXFG
+3 IF $GET(PSSFWSCC)=""
QUIT ""
+4 SET PSSXFG=0
+5 FOR PSSASIEN=0:0
SET PSSASIEN=$ORDER(^PS(51.1,"APPSJ",PSSFWSCC,PSSASIEN))
if 'PSSASIEN
QUIT
Begin DoDot:1
+6 IF PSSFWSCC["@"
SET PSSXFG=1
QUIT
+7 SET PSSX=$GET(^PS(51.1,PSSASIEN,0))
+8 IF $PIECE(PSSX,U,5)'="D"
SET PSSXFG=1
QUIT
+9 IF $PIECE(PSSX,U,2)]""
SET PSSFWSCC=PSSFWSCC_"@"_$PIECE(PSSX,U,2)
SET PSSXFG=1
End DoDot:1
if PSSXFG
QUIT
+10 QUIT PSSFWSCC
CONVSCH(PSSFRQ) ;Convert numeric frequency to a schedule
+1 ;PSSFRQ - Frequency in minutes
+2 ;Return null or Schedule_0/1
+3 IF '+$GET(PSSFRQ)
QUIT ""
+4 NEW PSSFWBAM,PSSFWBMN,PSSFWBNM,PSSFWRST,PSSFWBWK,PSSFWBXW,PSSFWBXL,PSSFWFLG
+5 SET PSSFWFLG=0
+6 SET PSSFWBAM=PSSFRQ/1440
+7 IF PSSFWBAM'?.N
QUIT ""
+8 IF PSSFWBAM?.N
Begin DoDot:1
+9 SET PSSFWBMN=PSSFWBAM/30
IF PSSFWBMN?.N
SET PSSFWFLG=1
SET PSSFWRST="Q"_PSSFWBMN_"L"
QUIT
+10 SET PSSFWBWK=PSSFWBAM/7
IF PSSFWBWK?.N
SET PSSFWFLG=1
SET PSSFWRST="Q"_PSSFWBWK_"W"
QUIT
+11 SET PSSFWFLG=1
SET PSSFWRST="Q"_PSSFWBAM_"D"
QUIT
End DoDot:1
QUIT PSSFWRST_U_PSSFWFLG
+12 IF PSSFRQ'>10080
SET PSSFWBXW=10080/PSSFRQ
IF PSSFWBXW?.N
SET PSSFWFLG=1
SET PSSFWRST=PSSFWBXW_"XW"
QUIT PSSFWRST_U_PSSFWFLG
+13 SET PSSFWBXL=43200/PSSFRQ
IF PSSFWBXL?.N
SET PSSFWFLG=1
SET PSSFWRST=PSSFWBXL_"XL"
QUIT PSSFWRST_U_PSSFWFLG
+14 QUIT ""
NOTALLDD(PSSGTOI,PSSIEN) ;When only OI is sent from CPRS, all DDs must be defined in 51.1 in order for the DCF value to be used.
+1 ;PSSNOTDD=1 if not all dispense drugs are defined in in 51.1 and the last good DD
+2 ;PSSGOI - Orderable Item
+3 ;PSSIEN - 51.1 ien
+4 NEW PSSDD,PSSDDIEN,PSSDDACT,PSSNODD
+5 if '+$GET(PSSGTOI)
QUIT 0
+6 if '+$GET(PSSIEN)
QUIT 0
+7 ;PSS*1*231 Correct issue with orphan 0 node
IF '$ORDER(^PS(51.1,+PSSIEN,4,0))
QUIT 0
+8 SET PSSNODD=0
+9 FOR PSSDDIEN=0:0
SET PSSDDIEN=$ORDER(^PSDRUG("ASP",PSSGTOI,PSSDDIEN))
if 'PSSDDIEN!PSSNODD
QUIT
Begin DoDot:1
+10 IF $$EXMT^PSSDSAPI(PSSDDIEN)
QUIT
+11 SET PSSDDACT=$PIECE($GET(^PSDRUG(PSSDDIEN,"I")),"^")
IF PSSDDACT
IF PSSDDACT<DT
QUIT
+12 SET PSSDD=PSSDDIEN
+13 IF '$DATA(^PS(51.1,+PSSIEN,4,"B",+PSSDDIEN))
SET PSSNODD=1
End DoDot:1
+14 QUIT PSSNODD_U_$GET(PSSDD)
CHKIPDUR() ;Check if CPRR IP has a duration <24hrs
+1 ;*************************************************************************
+2 ;*** MOCHA 2.1b - only perform daily dose if it is not a complex order ***
+3 ;*************************************************************************
+4 ;This is for CPRS IP order
+5 ;Check: only one sequence(not complex); EFD (expected first dose); Duration <24h;
+6 ;Return: 0 or 1^# of dose(s) for admin times within the duration.
+7 NEW PSSDUR,PSSADMIN,PSSDSCNT,PSSX
+8 IF '$DATA(PSSDBFDB)!'$DATA(PSSDBDS)
QUIT 0
+9 IF $ORDER(PSSDBFDB(1))
QUIT 0
+10 IF $GET(PSSDBFDB("PACKAGE"))'="I"
QUIT 0
+11 IF $GET(PSSDBDS(1,"EFD"))=""
QUIT 0
+12 SET PSSX=$GET(PSSDBDS(1,"DRATE"))
+13 SET PSSDUR=$SELECT((PSSX["H"):(+PSSX*60),(PSSX["M"):+PSSX,1:0)
+14 IF 'PSSDUR
QUIT 0
+15 IF PSSDUR'<1440
QUIT 0
+16 SET PSSADMIN=$$ADMIN($GET(PSSDBDFN),$GET(PSSDBDS(1,"SCHEDULE")))
+17 IF PSSADMIN=""
QUIT 0
+18 SET PSSDSCNT=$$DOSECNT^PSSSCHMS(PSSDBDS(1,"EFD"),PSSADMIN,PSSDUR)
+19 QUIT 1_U_PSSDSCNT
ADMIN(DFN,PSSSCHD) ;Determine if admin times for the ward should be used
+1 NEW VAIN,PSSWARD,PSSIEN,PSSADM,PSSWDADM
+2 IF $GET(PSSSCHD)=""
QUIT ""
+3 ;I '+$G(DFN) Q ""
+4 if +$GET(DFN)
DO INP^VADPT
+5 SET PSSWARD=+$GET(VAIN(4))
+6 SET (PSSADM,PSSWDADM)=""
+7 FOR PSSIEN=0:0
SET PSSIEN=$ORDER(^PS(51.1,"APPSJ",PSSSCHD,PSSIEN))
if (PSSIEN="")!(PSSWDADM]"")
QUIT
Begin DoDot:1
+8 if PSSADM=""
SET PSSADM=$PIECE($GET(^PS(51.1,PSSIEN,0)),U,2)
+9 SET PSSWDADM=$PIECE($GET(^PS(51.1,PSSIEN,1,+PSSWARD,0)),U,2)
End DoDot:1
+10 IF PSSWDADM]""
QUIT PSSWDADM
+11 QUIT PSSADM
DOSECNT(PSSEFD,PSSAT,PSSDUR) ;count # of dose for duration <24h
+1 ;PSSEFD - Expected First Dose (dt.time)^Admin times from CPRS
+2 ;PSSDUR - duration in minutes
+3 ;Calculate # of doses for CPRS IP order with a duration
+4 ;Return p1^p2 (p1=0 unable to figure, 1 use p2 for count; p2=# doses need for this duration)
+5 NEW PSSEDT,PSSCNT,PSSSTRTM,PSSSTPTM,PSSDTFLG,PSSADMIN,PSSX
+6 if $GET(PSSEFD)=""
QUIT 0
+7 if $GET(PSSAT)=""
QUIT 0
+8 if '+$GET(PSSDUR)
QUIT 0
+9 SET PSSEDT=$$FMADD^XLFDT(PSSEFD,,,+PSSDUR)
+10 SET PSSCNT=0
+11 SET PSSSTRTM=$EXTRACT($PIECE(PSSEFD,".",2)_"0000",1,4)
+12 SET PSSSTPTM=$EXTRACT($PIECE(PSSEDT,".",2)_"0000",1,4)
+13 SET PSSDTFLG=0
+14 IF $PIECE(PSSEFD,".")=$PIECE(PSSEDT,".")
SET PSSDTFLG=1
+15 FOR PSSX=1:1
SET PSSADMIN=$PIECE(PSSAT,"-",PSSX)
if PSSADMIN=""
QUIT
Begin DoDot:1
+16 SET PSSADMIN=$EXTRACT($PIECE(PSSAT,"-",PSSX)_"0000",1,4)
+17 IF PSSDTFLG
Begin DoDot:2
+18 IF (PSSSTRTM'>PSSADMIN)
IF (PSSADMIN<PSSSTPTM)
SET PSSCNT=PSSCNT+1
End DoDot:2
QUIT
+19 IF (PSSSTRTM'>PSSADMIN)
SET PSSCNT=PSSCNT+1
+20 IF (PSSSTPTM>PSSADMIN)
SET PSSCNT=PSSCNT+1
End DoDot:1
+21 QUIT PSSCNT
SCHD ;^PSSDSAPD is too big - move it here.
+1 NEW PSSDBSCD,PSSDBSCP,PSSDBSCF,PSSDBSCG,PSSDBSCH,PSSDCF
+2 SET PSSDBAR("FREQ")=""
+3 ;I $D(PSSDBFDB(PSSDBLP,"FREQ")) S PSSDBAR("FREQ")=PSSDBFDB(PSSDBLP,"FREQ") Q
+4 IF PSSDBAR("TYPE")="SINGLE DOSE"
SET PSSDBAR("FREQ")=""
QUIT
+5 ;I $G(PSSDBDS(PSSDBLP,"DRATE"))'="",$$DRT(PSSDBDS(PSSDBLP,"DRATE"))<1440 S PSSDBSDR=1
+6 SET PSSDBSCD=$GET(PSSDBDS(PSSDBLP,"SCHEDULE"))
+7 IF PSSDBSCD=""
IF '$DATA(PSSDBFDB(PSSDBLP,"FREQ"))
SET PSSDBCAZ(PSSDBFDB(PSSDBLP,"RX_NUM"),"FRQ_ERROR")=""
QUIT
+8 SET (PSSDBSCF,PSSDBSCH)=""
SET PSSDBSCP=$PIECE(PSSDBFDB(PSSDBLP,"RX_NUM"),";")
+9 IF $GET(PSSDBSCD)'=""
FOR PSSDBSCG=0:0
SET PSSDBSCG=$ORDER(^PS(51.1,"APPSJ",PSSDBSCD,PSSDBSCG))
if 'PSSDBSCG!(PSSDBSCH)
QUIT
Begin DoDot:1
+10 IF $PIECE($GET(^PS(51.1,PSSDBSCG,0)),"^",5)="D"
SET PSSDBSCF="D"
+11 IF $PIECE($GET(^PS(51.1,PSSDBSCG,0)),"^",5)="O"!($PIECE($GET(^PS(51.1,PSSDBSCG,0)),"^",5)="OC")
SET PSSDBSCH=1
End DoDot:1
+12 IF PSSDBSCH
IF '$DATA(PSSDBFDB(PSSDBLP,"FREQ"))
SET PSSDBAR("FREQ")=1
QUIT
+13 IF $GET(PSSDBSCD)["@"
SET PSSDBSCF="D"
+14 IF $GET(PSSDBSCD)'=""
Begin DoDot:1
+15 SET PSSDBSCP=$SELECT(PSSDBSCP="I":"I",1:"O")
+16 SET PSSDBAR("FREQZZ")=$$FRQ^PSSDSAPI(PSSDBSCD,PSSDBSCF,PSSDBSCP,$GET(PSSDBDS(PSSDBLP,"DRATE")),$GET(PSSDBFDB(PSSDBLP,"DRUG_IEN")))
+17 SET PSSDCF=$PIECE(PSSDBAR("FREQZZ"),U,2)
+18 IF PSSDCF?1N.N1"XD"
SET PSSDBAR("FREQZZ")=PSSDCF_U_PSSDCF
SET PSSDBFDB(PSSDBLP,"FREQ")=PSSDCF
+19 SET PSSDBAR("FREQ")=$PIECE(PSSDBAR("FREQZZ"),"^")
End DoDot:1
+20 IF $DATA(PSSDBFDB(PSSDBLP,"FREQ"))
SET PSSDBAR("FREQ")=PSSDBFDB(PSSDBLP,"FREQ")
QUIT
+21 if PSSDBAR("FREQ")=""
SET PSSDBCAZ(PSSDBFDB(PSSDBLP,"RX_NUM"),"FRQ_ERROR")=""
+22 QUIT
