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