PSSDSAPD ;BIR/RTR-Main Dose Check API ;09/16/08
;;1.0;PHARMACY DATA MANAGEMENT;**117,160,173,201,178,206**;9/30/97;Build 10
;
;Dose Check API
;
;Input
;PSSDBASE = Name of subscript
;PSSDBDFN = Patient Internal Entry Number
;PSSDBDS = Data to use to build actual Input data, for pieces not sent in PSSDBFDB array
;PSSDBFDB = Array where if the node exists, just set that data (even if null) directly into the corresponding API piece
DOSE(PSSDBASX,PSSDBDFN,PSSDBDS,PSSDBFDB) ;
I $G(PSSDBASX(1))="" Q
N PSSDBASE,PSSDBASF,PSSDBASG,PSSDBASA,PSSDBASB S PSSDBASE=PSSDBASX(1),PSSDBASF=$G(PSSDBASX(2)),PSSDBASG=$G(PSSDBASX(3)) K ^TMP($J,PSSDBASE) K ^TMP($J,"PSSDOSGL") K ^TMP($J,"PSSCNX")
S PSSDBASA=0 I $G(PSSDBASF)'="" K ^TMP($J,PSSDBASF) S PSSDBASA=1
S PSSDBASB=0 I $G(PSSDBASG)'="" K ^TMP($J,PSSDBASG) S PSSDBASB=1
S ^TMP($J,PSSDBASE,"IN","PING")="" D IN^PSSHRQ2(PSSDBASE)
I $P($G(^TMP($J,PSSDBASE,"OUT",0)),"^")=-1 D DOWN^PSSDSAPK Q
K ^TMP($J,PSSDBASE)
N PSSDBLP,PSSDBND1,PSSDBND3,PSSDBAR,PSSDBFST,PSSDBFLG,PSSDBCOT,PSSDBCAR,PSSDBFRC,PSSDBFRB,PSSDBIFL,PSSDBIFG,PSSDBCAX,PSSDBCAZ,PSSDBFTX,PSSDBADJ,PSSDBCDP,PSSDSDPL,PSSDSWHE,PSSENHK,PSSENHKZ,PSSDSIVF,PSSENO,PSSDBSNO,PSSDLEM
I +$G(PSSDBDFN)'>0 Q
S (PSSDBFLG,PSSDBSNO)=0 S PSSDSWHE=$S($E($G(PSSDBASE),1,2)="OR":1,1:0) ;2.1 PSSDBSNO added - remains at 0 if all schedules are excluded from all Dosing checks, set in Comp Tag
F PSSDBLP=0:0 S PSSDBLP=$O(PSSDBFDB(PSSDBLP)) Q:'PSSDBLP D
.K PSSDBAR,PSSDBND1,PSSDBND3 S (PSSDBIFL,PSSDBIFG,PSSDSIVF,PSSENO)=0
.I $G(PSSDBFDB(PSSDBLP,"RX_NUM"))="" Q
.I $G(PSSDBFDB(PSSDBLP,"DRUG_NM"))="" Q
.S PSSDBFDB("OI")=$S($G(PSSDBFDB(PSSDBLP,"OI")):$G(PSSDBFDB(PSSDBLP,"OI")),1:$G(PSSDBFDB("OI"))) I $G(PSSDBFDB(PSSDBLP,"DRUG_IEN"))'>0,$G(PSSDBFDB("OI"))'>0 Q
.I $G(PSSDBFDB(PSSDBLP,"DRUG_IEN"))>0,$$EXMT^PSSDSAPI($G(PSSDBFDB(PSSDBLP,"DRUG_IEN"))) Q
.S PSSDLEM=$$QORDLEM^PSSDSAPL() Q:PSSDLEM=1
.D INERR^PSSDSAPM Q:PSSENO I $G(PSSDBFDB(PSSDBLP,"DRUG_IEN"))'>0 D FDRUG^PSSDSAPM I PSSDBIFG D ONT^PSSDSAPA
.I PSSDBIFL,'PSSDBIFG D NXDRUG^PSSDSAPM Q
.D NDINFO
.I $G(PSSDBND1),$G(PSSDBND3) D
..S PSSDBAR("GCN")=$P($$PROD0^PSNAPIS(PSSDBND1,PSSDBND3),"^",7)
..S PSSDBAR("VUID")=$$GETVUID^XTID(50.68,,+PSSDBND3_",")
.S PSSDBAR("NAME")=$G(PSSDBFDB(PSSDBLP,"DRUG_NM"))
.D AMT I $G(PSSDBAR("AMN"))'="",$L(PSSDBAR("AMN"))>1,$E(PSSDBAR("AMN"),1)="0" S PSSDBAR("AMN")=$E(PSSDBAR("AMN"),2,$L(PSSDBAR("AMN")))
.D DTYPE
.S PSSDBAR("DSE")=$S($D(PSSDBFDB(PSSDBLP,"DOSE_RATE")):$G(PSSDBFDB(PSSDBLP,"DOSE_RATE")),1:"DAY")
.D RTE
.D SCHD^PSSSCHMS
.D DURR
.D DURRAT
.S PSSDBAR("SPFC")="" S:$G(PSSDBFDB(PSSDBLP,"ENH")) PSSENHK(PSSDBFDB(PSSDBLP,"RX_NUM"))=1
.S PSSDBFST=$G(PSSDBAR("GCN"))_"^"_$S($P($G(PSSDBAR("VUID")),"^")'=0:$G(PSSDBAR("VUID")),1:"")_"^"_$S('PSSDBIFL:PSSDBFDB(PSSDBLP,"DRUG_IEN"),PSSDBIFL&(PSSDBIFG):PSSDBIFG,1:"")_"^"_PSSDBAR("NAME")
.S PSSDBFLG=1
.S ^TMP($J,PSSDBASE,"IN","PROSPECTIVE",PSSDBFDB(PSSDBLP,"RX_NUM"))=PSSDBFST
.S ^TMP($J,PSSDBASE,"IN","DOSE",PSSDBFDB(PSSDBLP,"RX_NUM"))=PSSDBFST_"^"_$G(PSSDBAR("AMN"))_"^"_$G(PSSDBAR("UNIT"))_"^"_PSSDBAR("DSE")_"^"_PSSDBAR("FREQ")_"^"_PSSDBAR("DUR")_"^"_PSSDBAR("DRR")_"^"_PSSDBAR("RT")_"^"_PSSDBAR("TYPE")
.S ^TMP($J,PSSDBASE,"IN","DOSE",PSSDBFDB(PSSDBLP,"RX_NUM"))=^TMP($J,PSSDBASE,"IN","DOSE",PSSDBFDB(PSSDBLP,"RX_NUM"))_"^"_PSSDBAR("SPFC")_"^"_$$DFM^PSSDSEXC
.S PSSDBFRC(PSSDBFDB(PSSDBLP,"RX_NUM"),"CONJ")=$G(PSSDBDS(PSSDBLP,"CONJ")) S PSSDBFRC(PSSDBFDB(PSSDBLP,"RX_NUM"),"SCHEDULE")=$G(PSSDBDS(PSSDBLP,"SCHEDULE"))
.I $G(PSSDBDS(PSSDBLP,"DRATE"))'="" I PSSDBDS(PSSDBLP,"DRATE")?.N!(PSSDBDS(PSSDBLP,"DRATE")?.N1".".N) S PSSDBDS(PSSDBLP,"DRATE")=PSSDBDS(PSSDBLP,"DRATE")_"D"
.S PSSDBFRB(PSSDBFDB(PSSDBLP,"RX_NUM"),"DRATE")=$G(PSSDBDS(PSSDBLP,"DRATE")) D ADJU^PSSDSEXC
.D INFUE^PSSDSAPM
.D FRQE^PSSDSAPM
.S ^TMP($J,"PSSCNX","IN","DOSE",PSSDBLP,PSSDBFDB(PSSDBLP,"RX_NUM"))=^TMP($J,PSSDBASE,"IN","DOSE",PSSDBFDB(PSSDBLP,"RX_NUM"))
D COMP ;Set up complex Doses
S ^TMP($J,PSSDBASE,"IN","IEN")=PSSDBDFN
S ^TMP($J,PSSDBASE,"IN","DOSE")=""
D PAT^PSSDSAPM K ^TMP($J,"PSSCNX")
N PSSDBDGO ; Only go to interface if you have at least one Dose Sequence that needs to go
S PSSDBDGO=0 I $D(^TMP($J,PSSDBASE,"IN","EXCEPTIONS")) S (PSSDBDGO,PSSDBSNO)=1
D ERR ;Set up PSSDBCAX error array and default data
I PSSDBDGO,PSSDBSNO D:$D(PSSDBFTX) FTX^PSSDSAPK D IN^PSSHRQ2(PSSDBASE) D:$D(PSSDBFTX) FTXRS^PSSDSAPK ;2.1 PSSDBSNO check added
I PSSDBASA!(PSSDBASB) D FMT^PSSDSEXC I $P($G(^TMP($J,PSSDBASE,"OUT",0)),"^")'=-1 D ADDCT^PSSDSAPM,REM^PSSDSAPA
Q
AMT ;Set Dose Amount and Dose Unit
D DPL^PSSDSAPK
I $D(PSSDBCAZ(PSSDBFDB(PSSDBLP,"RX_NUM"),"NO_DRUG")) D MLTS^PSSDSAPM Q
N PSSDBUNT,PSSDBFAL,PSSDBXP,PSSDBNOD,PSSDBNT,PSSDSXTD,PSSDBUNA,PSSDBLPD,PSSDSLCL,PSSDSLC1,PSSDSLCT
S (PSSDBFAL,PSSDBLPD,PSSDSLCT)=0
I 'PSSDBIFL,$D(PSSDBFDB(PSSDBLP,"DOSE_AMT")),$D(PSSDBFDB(PSSDBLP,"DOSE_UNIT")) S PSSDBAR("AMN")=PSSDBFDB(PSSDBLP,"DOSE_AMT"),PSSDBAR("UNIT")=PSSDBFDB(PSSDBLP,"DOSE_UNIT") D LDZ Q
I 'PSSDBIFL,$G(PSSDBDS(PSSDBLP,"DRG_AMT")),$G(PSSDBDS(PSSDBLP,"DRG_UNIT"))'="" D
.;For Drug Units like MG/ML, take first piece of"/"
.S PSSDBUNT=$S(PSSDBDS(PSSDBLP,"DRG_UNIT")["/":$P(PSSDBDS(PSSDBLP,"DRG_UNIT"),"/"),1:PSSDBDS(PSSDBLP,"DRG_UNIT"))
.S PSSDBUNT=$$UP^XLFSTR(PSSDBUNT)
.S PSSDBUNA=$$UNIT^PSSDSAPI(PSSDBUNT)
.I PSSDBUNA'="" S PSSDBAR("AMN")=PSSDBDS(PSSDBLP,"DRG_AMT"),PSSDBAR("UNIT")=PSSDBUNA,PSSDBFAL=1 D LDZ
I PSSDBFAL Q
;"DOSE" Node should only come from CPRS, for selected Local Possible Dosage
S PSSDSLCL=$S($G(PSSDBDS(PSSDBLP,"DOSE"))'="":$P(PSSDBDS(PSSDBLP,"DOSE"),"&",5),1:$G(PSSDBDS(PSSDBLP,"DO")))
I PSSDSLCL["(" D PTH^PSSDSUTL
I PSSDBIFL D MLT^PSSDSAPM Q
AMTRT ;Retry for Local Dosages with parenthesis
I PSSDSLCL'="" D
.F PSSDBXP=0:0 S PSSDBXP=$O(^PSDRUG(PSSDBFDB(PSSDBLP,"DRUG_IEN"),"DOS2",PSSDBXP)) Q:'PSSDBXP!(PSSDBFAL) D
..S PSSDBNOD=$G(^PSDRUG(PSSDBFDB(PSSDBLP,"DRUG_IEN"),"DOS2",PSSDBXP,0))
..;ignore package of the Local Possible Dose
..I $$MTCH^PSSDSAPK S PSSDBLPD=1 I $P(PSSDBNOD,"^",5),$P(PSSDBNOD,"^",6)'="" D
...;XTID Screening out Inactive Dose Units
...S PSSDSXTD=+$P(PSSDBNOD,"^",5) I PSSDSXTD,$$SCREEN^XTID(51.24,.01,PSSDSXTD_",") Q
...S PSSDBNT=$P($G(^PS(51.24,+$P(PSSDBNOD,"^",5),0)),"^",2)
...I PSSDBNT'="" S PSSDBAR("AMN")=$P(PSSDBNOD,"^",6),PSSDBAR("UNIT")=PSSDBNT,PSSDBFAL=1
.;Only do auto-population logic if Local Possible Dosage was not found at all in File 50
.I PSSDBFAL Q
.I PSSDBLPD D DPOP^PSSDSAPK I PSSDBFAL Q
.D ITEM^PSSDSAPK D:'PSSDBFAL NUM^PSSDSAPL D:'PSSDBFAL RANGE^PSSDSUTL
I 'PSSDBFAL,PSSDSLCT S PSSDSLCL=PSSDSLC1(PSSDSLCT),PSSDSLCT=PSSDSLCT-1,PSSDBLPD=0 G AMTRT
Q
LDZ ;
I $E(PSSDBAR("AMN"))=0,$L(PSSDBAR("AMN"))>1 S PSSDBAR("AMN")=$E(PSSDBAR("AMN"),2,$L(PSSDBAR("AMN")))
Q
RTE ;Get First DataBank Med Route
N PSSDBMRT
K PSSDBMRT
I $D(PSSDBFDB(PSSDBLP,"ROUTE")) S PSSDBAR("RT")=PSSDBFDB(PSSDBLP,"ROUTE") Q
I $G(PSSDBDS(PSSDBLP,"MR_IEN")) S PSSDBMRT=$$MRT^PSSDSAPI(PSSDBDS(PSSDBLP,"MR_IEN")) I $P(PSSDBMRT,"^",2)'="" S PSSDBAR("RT")=$P(PSSDBMRT,"^",2) Q
S PSSDBAR("RT")=""
Q
DTYPE ;Find Dose Type
N PSSDBST1,PSSDBST2,PSSDBST3,PSSDBST4,PSSDBSTX
I $D(PSSDBFDB(PSSDBLP,"DOSE_TYPE")) S PSSDBAR("TYPE")=PSSDBFDB(PSSDBLP,"DOSE_TYPE") Q
S PSSDBST1=$G(PSSDBDS(PSSDBLP,"SCHEDULE"))
I PSSDBST1="" S PSSDBAR("TYPE")="MAINTENANCE" Q
S PSSDBST3=0
;PSS*1*206
I PSSDBST1[" PRN",'$D(^PS(51.1,"APPSJ",PSSDBST1)) S PSSDBSTX=$P(PSSDBST1," PRN",1) S:PSSDBSTX]"" PSSDBST1=PSSDBSTX
F PSSDBST2=0:0 S PSSDBST2=$O(^PS(51.1,"APPSJ",PSSDBST1,PSSDBST2)) Q:'PSSDBST2!(PSSDBST3) D
.S PSSDBST4=$P($G(^PS(51.1,PSSDBST2,0)),"^",5)
.I PSSDBST4="O"!(PSSDBST4="OC") S PSSDBAR("TYPE")="SINGLE DOSE",PSSDBST3=1
I 'PSSDBST3 S PSSDBAR("TYPE")="MAINTENANCE"
Q
DURR ;Set Duration
I $D(PSSDBFDB(PSSDBLP,"DURATION")) S PSSDBAR("DUR")=PSSDBFDB(PSSDBLP,"DURATION") Q
S PSSDBAR("DUR")=$S($G(PSSDBAR("TYPE"))="SINGLE DOSE":"",1:1)
Q
DURRAT ;Set Duration Rate
I $D(PSSDBFDB(PSSDBLP,"DURATION_RT")) S PSSDBAR("DRR")=PSSDBFDB(PSSDBLP,"DURATION_RT") Q
S PSSDBAR("DRR")=$S($G(PSSDBAR("TYPE"))="SINGLE DOSE":"",1:"DAY")
Q
COMP ;Handle complex order, set PSSDBCAR array, see routine PSSDSEXC for PSSBDCAR piece details
;if you have to add new create input entry, just add a piece 5 = 1 to the Pharmacy Order Number
N PSSDBKLP,PSSDBKUN,PSSDBKMR,PSSDBKND,PSSDBKRF,PSSDBKNW,PSSDBKFL,PSSDBKTM,PSSDBKFQ,PSSDBKGG,PSSCNX1,PSSDBCDA,PSSDCLX
S PSSDBKTM="PSSTTMP"
K ^TMP($J,PSSDBKTM)
S PSSDBKFL=0
F PSSCNX1=0:0 S PSSCNX1=$O(^TMP($J,"PSSCNX","IN","DOSE",PSSCNX1)) Q:'PSSCNX1 S PSSDBKLP=$O(^TMP($J,"PSSCNX","IN","DOSE",PSSCNX1,"")) I PSSDBKLP'="" D
.S PSSDBKND=$G(^TMP($J,PSSDBASE,"IN","DOSE",PSSDBKLP)) S PSSDBKFQ=$S($D(PSSDBCAZ(PSSDBKLP,"FRQ_ERROR")):0,1:1) S PSSDBKGG=$S($P(PSSDBKND,"^",12)="SINGLE DOSE":1,1:0)
.S PSSDBCDA($S($P(PSSDBKND,"^",3)="":"NULL",1:$P(PSSDBKND,"^",3)),$S($P(PSSDBKND,"^",11)="":"NULL",1:$P(PSSDBKND,"^",11)))=PSSDBKLP I $G(PSSDCLX)="" S PSSDCLX=PSSDBKLP ;2.1 removed PSSDSWHE check
.S PSSDBCAR(PSSDBKLP)="B"_"^"_$P(PSSDBKND,"^",4)_"^"_$P(PSSDBKND,"^",3)_"^"_PSSDBKFQ_"^"_$S($P(PSSDBKND,"^",12)="SINGLE DOSE":0,1:1) S:$G(PSSDBFRC(PSSDBKLP,"CONJ"))="A" $P(PSSDBCAR(PSSDBKLP),"^",7)=1
.S $P(PSSDBCAR(PSSDBKLP),"^",9)=$P(PSSDBKND,"^",11) D MLTNO^PSSDSAPM,SXCL^PSSDSAPA S:$G(PSSDBFRC(PSSDBKLP,"CONJ"))'=""!($G(PSSDBFRC(PSSDCLX,"CONJ"))'="") $P(PSSDBCAR(PSSDBKLP),"^",16)=1 S PSSDCLX=PSSDBKLP ; 2.1 removed PSSDSWHE check
.S:'$P(PSSDBCAR(PSSDBKLP),"^",14) PSSDBSNO=1 I $G(PSSDBFRC(PSSDBKLP,"CONJ"))'="A"!($O(^TMP($J,"PSSCNX","IN","DOSE",PSSCNX1))="") S PSSDBKNW($P(PSSDBKLP,";",4),PSSDBKLP)="" D CRT K PSSDBKNW,PSSDBCDA S PSSDBKFL=0 Q
.S PSSDBKFL=PSSDBKFL+1
.S PSSDBKNW($P(PSSDBKLP,";",4),PSSDBKLP)=""
.S $P(PSSDBCAR(PSSDBKLP),"^")="S",$P(PSSDBCAR(PSSDBKLP),"^",12)=1
I $D(^TMP($J,PSSDBKTM)) M ^TMP($J,PSSDBASE)=^TMP($J,PSSDBKTM)
K ^TMP($J,PSSDBKTM)
Q
DRT(PSSDBJV) ;Return number of minutes based on duration, API also called from Inpatient Medications
;If only a numeric is passed in, the API will assume Days
I $G(PSSDBJV)="" Q -1
I PSSDBJV?.N1".".N1"D"!(PSSDBJV?.N1"D") Q (1440*+PSSDBJV)
I PSSDBJV?.N1".".N!(PSSDBJV?.N) Q (1440*+PSSDBJV)
I PSSDBJV?.N1".".N1"H"!(PSSDBJV?.N1"H") Q (60*+PSSDBJV)
I PSSDBJV?.N1".".N1"M"!(PSSDBJV?.N1"M") Q (+PSSDBJV)
I PSSDBJV?.N1".".N1"W"!(PSSDBJV?.N1"W") Q (10080*+PSSDBJV)
I PSSDBJV?.N1".".N1"L"!(PSSDBJV?.N1"L") Q (43200*+PSSDBJV)
Q -1
CRT ;Possibly create new Input Dose Node just for Daily Dose purposes
I 'PSSDBKFL!($G(PSSDBFRC(PSSDBKLP,"CONJ"))="A") S $P(PSSDBCAR(PSSDBKLP),"^")=$S($G(PSSDBFRC(PSSDBKLP,"CONJ"))="A":"S",$G(PSSDBKGG):"S",$G(PSSDBFRB(PSSDBKLP,"DRATE"))="":"B",1:"B") D S12 Q
N PSSDBR1,PSSDBR2,PSSDBR3,PSSDBR4,PSSDBR5,PSSDBR6,PSSDBR7,PSSDBRCT,PSSDBRNO,PSSDBRLS,PSSDBR9,PSSDBR91,PSSDBEQ2,PSSDBEQ3,PSSDBEQ4,PSSDBR8,PSSDBXAX,PSSDBRLP,PSSDBRLA
S (PSSDBRNO,PSSDBRCT,PSSDBR5)=0
;Then or Except Conjunction, or last Dosing Sequence in the series, with previous dosages to add up for Daily Dose
;PSSDBKNW array holds all previous dosing sequences and current one
S PSSDBRLP="" F S PSSDBRLP=$O(PSSDBKNW(PSSDBRLP)) Q:PSSDBRLP="" S PSSDBR1=$O(PSSDBKNW(PSSDBRLP,"")) I PSSDBR1'="" D
.S PSSDBR2=$G(^TMP($J,PSSDBASE,"IN","DOSE",PSSDBR1))
.I $O(PSSDBKNW(PSSDBRLP))="" S $P(PSSDBCAR(PSSDBKLP),"^")="S",$P(PSSDBCAR(PSSDBKLP),"^",12)=1
.I $P(PSSDBR2,"^",12)'="MAINTENANCE" D NX(4)
.S PSSDBRCT=PSSDBRCT+1
.I $G(PSSDBFRC(PSSDBR1,"SCHEDULE"))["@" D NX(10)
.I '$D(PSSDBEQ2(10)),$G(PSSDBFRC(PSSDBR1,"SCHEDULE"))'="" F PSSDBEQ4=0:0 S PSSDBEQ4=$O(^PS(51.1,"APPSJ",$G(PSSDBFRC(PSSDBR1,"SCHEDULE")),PSSDBEQ4)) Q:'PSSDBEQ4!($D(PSSDBEQ2(10))) D
..I $P($G(^PS(51.1,PSSDBEQ4,0)),"^",5)="D" D NX(10)
.I PSSDBRCT=1 D Q
..I '$P(PSSDBR2,"^",5) D NX(11)
..S PSSDBR91=$G(PSSDBFRB(PSSDBR1,"DRATE"))
..S PSSDBR3=$P(PSSDBR2,"^",6),PSSDBR4=$P(PSSDBR2,"^",11) I PSSDBR3=""!(PSSDBR4="") S PSSDBRNO=1 D:PSSDBR3="" NX(5) D:PSSDBR4="" NX(6)
..S PSSDBR5=$P(PSSDBR2,"^",8)
..I $D(PSSDBCAZ(PSSDBR1,"FRQ_ERROR")) D NX(7)
..I 'PSSDBRNO S PSSDBR8=$$FRCON^PSSDSAPK(PSSDBR5) S:PSSDBR8'<1 PSSDBR6=$P(PSSDBR2,"^",5)*PSSDBR8 I PSSDBR8<1 D NX(7)
..I $G(PSSDBFRB(PSSDBR1,"DRATE"))'="" S PSSDBR7=$$DRT(PSSDBFRB(PSSDBR1,"DRATE")) I PSSDBR7<1440 D NX(9)
..I '$O(PSSDBKNW(PSSDBRLP)) S PSSDBRLS=PSSDBR1 ; Get Last entry
.I '$P(PSSDBR2,"^",5) D NX(11)
.I PSSDBR3'=$P(PSSDBR2,"^",6) D NX(5)
.I PSSDBR4'=$P(PSSDBR2,"^",11) D NX(6)
.I $G(PSSDBFRB(PSSDBR1,"DRATE"))'=PSSDBR91 D NX(8)
.S PSSDBR5=$P(PSSDBR2,"^",8) I $D(PSSDBCAZ(PSSDBR1,"FRQ_ERROR")) D NX(7)
.I 'PSSDBRNO S PSSDBR8=$$FRCON^PSSDSAPK(PSSDBR5) S:PSSDBR8'<1 PSSDBR6=PSSDBR6+($P(PSSDBR2,"^",5)*PSSDBR8) I PSSDBR8<1 D NX(7)
.I $G(PSSDBFRB(PSSDBR1,"DRATE"))'="" S PSSDBR7=$$DRT(PSSDBFRB(PSSDBR1,"DRATE")) I PSSDBR7<1440 D NX(9)
.I '$O(PSSDBKNW(PSSDBRLP)) S PSSDBRLS=PSSDBR1 ; Get Last entry
I PSSDBRNO D S $P(PSSDBCAR(PSSDBRLS),"^",8)=1,$P(PSSDBCAR(PSSDBRLS),"^",7)="" D MLTNP^PSSDSAPM Q ;2.1 Removed RESET^PSSDSAPA call - works witn GEN+2^PSSDSEXC add back for 2.2
.S PSSDBRLA="" F S PSSDBRLA=$O(PSSDBKNW(PSSDBRLA)) Q:PSSDBRLA="" S PSSDBR9=$O(PSSDBKNW(PSSDBRLA,"")) I PSSDBR9'="" S $P(PSSDBCAR(PSSDBR9),"^")="S",$P(PSSDBCAR(PSSDBR9),"^",12)=1
.;Set error message only for last entry where Daily Dose should have been done
.D ERST^PSSDSAPM
S ^TMP($J,PSSDBKTM,"IN","DOSE",PSSDBRLS_";1")=^TMP($J,PSSDBASE,"IN","DOSE",PSSDBRLS)
S ^TMP($J,PSSDBKTM,"IN","PROSPECTIVE",PSSDBRLS_";1")=$P(^TMP($J,PSSDBASE,"IN","DOSE",PSSDBRLS),"^",1,4)
S $P(^TMP($J,PSSDBKTM,"IN","DOSE",PSSDBRLS_";1"),"^",8)=1
S $P(^TMP($J,PSSDBKTM,"IN","DOSE",PSSDBRLS_";1"),"^",5)=PSSDBR6
S PSSDBCAR(PSSDBRLS_";1")="D"_"^"_$P(PSSDBKND,"^",4)_"^"_$P(PSSDBKND,"^",3)_"^"_PSSDBKFQ S $P(PSSDBCAR(PSSDBRLS),"^",11)=1
Q
NDINFO ;Set National Drug File information
I 'PSSDBIFL,$G(PSSDBFDB(PSSDBLP,"DRUG_IEN")) S PSSDBND1=$P($G(^PSDRUG(PSSDBFDB(PSSDBLP,"DRUG_IEN"),"ND")),"^"),PSSDBND3=$P($G(^PSDRUG(PSSDBFDB(PSSDBLP,"DRUG_IEN"),"ND")),"^",3) Q
I $G(PSSDBIFG) S PSSDBND1=$P($G(^PSDRUG(PSSDBIFG,"ND")),"^"),PSSDBND3=$P($G(^PSDRUG(PSSDBIFG,"ND")),"^",3)
Q
ERR ;Loop through PSSDBCAR, set PSSDBCAX error array
N PSSDBEB1,PSSDBEB2,PSSDBEB3
S PSSDBEB3=$S($G(^TMP($J,PSSDBASE,"IN","DOSE","AGE")):1,1:0)
;Skip AGE, WT and BSA and newly created Dosages for complex additions
;Rx_NUM MUST contain a ";", or you will not set PSSDBDGO
S PSSDBEB1="" F S PSSDBEB1=$O(^TMP($J,PSSDBASE,"IN","DOSE",PSSDBEB1)) Q:PSSDBEB1="" S:'PSSDBEB3&(PSSDBEB1[";") $P(PSSDBCAR(PSSDBEB1),"^",13)=1 D:'$P(PSSDBEB1,";",5)&(PSSDBEB1[";")
.S PSSDBEB2=$G(^TMP($J,PSSDBASE,"IN","DOSE",PSSDBEB1))
.I $D(PSSDBCAZ(PSSDBEB1,"INF_ERROR")) D INRATE^PSSDSAPA S PSSDBDGO=1 S $P(PSSDBCAR(PSSDBEB1),"^",13)=1 Q
.I $P(PSSDBEB2,"^",5)=""!($P(PSSDBEB2,"^",6)="") D BDOSE^PSSDSAPK S $P(PSSDBCAR(PSSDBEB1),"^",13)=1 Q
.;I $D(PSSDBCAZ(PSSDBEB1,"FRQ_ERROR")) D INFRQ^PSSDSAPA S PSSDBDGO=1 Q ;; 2.1 change, ensure null freq are sent in line below
.I $$FCY^PSSDSUTA() D INFRQ^PSSDSAPA S PSSDBDGO=1 Q
.I '$P(PSSDBCAR(PSSDBEB1),"^",5) D SING^PSSDSAPK S PSSDBDGO=1 Q
.S PSSDBDGO=1
Q
EXCPS(PSSDBEQ1) ;Set errors
I $P(PSSDBCAR(PSSDBEB1),"^",16),PSSDBEQ1=2 Q ;Complex order - remove in 2.2
I $P(PSSDBCAR(PSSDBEB1),"^",15),PSSDBEQ1=2 Q ;2.1 Don't set Frequency error if Schedule excluded from Daily Dose check
I PSSDBEQ1=2,$D(PSSDBCAZ(PSSDBEB1,"FRQD_ERROR")) S PSSDBCAX(PSSDBEB1,15)="" Q
S PSSDBCAX(PSSDBEB1,PSSDBEQ1)=""
Q
S12 ;
S:$P(PSSDBCAR(PSSDBKLP),"^")="S" $P(PSSDBCAR(PSSDBKLP),"^",12)=1
Q
NX(PSSNX) ;
S PSSDBRNO=1
S PSSDBEQ2(PSSNX)=""
S PSSDBXAX(PSSNX,PSSDBR1)=""
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSSDSAPD 15661 printed Dec 13, 2024@02:31:04 Page 2
PSSDSAPD ;BIR/RTR-Main Dose Check API ;09/16/08
+1 ;;1.0;PHARMACY DATA MANAGEMENT;**117,160,173,201,178,206**;9/30/97;Build 10
+2 ;
+3 ;Dose Check API
+4 ;
+5 ;Input
+6 ;PSSDBASE = Name of subscript
+7 ;PSSDBDFN = Patient Internal Entry Number
+8 ;PSSDBDS = Data to use to build actual Input data, for pieces not sent in PSSDBFDB array
+9 ;PSSDBFDB = Array where if the node exists, just set that data (even if null) directly into the corresponding API piece
DOSE(PSSDBASX,PSSDBDFN,PSSDBDS,PSSDBFDB) ;
+1 IF $GET(PSSDBASX(1))=""
QUIT
+2 NEW PSSDBASE,PSSDBASF,PSSDBASG,PSSDBASA,PSSDBASB
SET PSSDBASE=PSSDBASX(1)
SET PSSDBASF=$GET(PSSDBASX(2))
SET PSSDBASG=$GET(PSSDBASX(3))
KILL ^TMP($JOB,PSSDBASE)
KILL ^TMP($JOB,"PSSDOSGL")
KILL ^TMP($JOB,"PSSCNX")
+3 SET PSSDBASA=0
IF $GET(PSSDBASF)'=""
KILL ^TMP($JOB,PSSDBASF)
SET PSSDBASA=1
+4 SET PSSDBASB=0
IF $GET(PSSDBASG)'=""
KILL ^TMP($JOB,PSSDBASG)
SET PSSDBASB=1
+5 SET ^TMP($JOB,PSSDBASE,"IN","PING")=""
DO IN^PSSHRQ2(PSSDBASE)
+6 IF $PIECE($GET(^TMP($JOB,PSSDBASE,"OUT",0)),"^")=-1
DO DOWN^PSSDSAPK
QUIT
+7 KILL ^TMP($JOB,PSSDBASE)
+8 NEW PSSDBLP,PSSDBND1,PSSDBND3,PSSDBAR,PSSDBFST,PSSDBFLG,PSSDBCOT,PSSDBCAR,PSSDBFRC,PSSDBFRB,PSSDBIFL,PSSDBIFG,PSSDBCAX,PSSDBCAZ,PSSDBFTX,PSSDBADJ,PSSDBCDP,PSSDSDPL,PSSDSWHE,PSSENHK,PSSENHKZ,PSSDSIVF,PSSENO,PSSDBSNO,PSSDLEM
+9 IF +$GET(PSSDBDFN)'>0
QUIT
+10 ;2.1 PSSDBSNO added - remains at 0 if all schedules are excluded from all Dosing checks, set in Comp Tag
SET (PSSDBFLG,PSSDBSNO)=0
SET PSSDSWHE=$SELECT($EXTRACT($GET(PSSDBASE),1,2)="OR":1,1:0)
+11 FOR PSSDBLP=0:0
SET PSSDBLP=$ORDER(PSSDBFDB(PSSDBLP))
if 'PSSDBLP
QUIT
Begin DoDot:1
+12 KILL PSSDBAR,PSSDBND1,PSSDBND3
SET (PSSDBIFL,PSSDBIFG,PSSDSIVF,PSSENO)=0
+13 IF $GET(PSSDBFDB(PSSDBLP,"RX_NUM"))=""
QUIT
+14 IF $GET(PSSDBFDB(PSSDBLP,"DRUG_NM"))=""
QUIT
+15 SET PSSDBFDB("OI")=$SELECT($GET(PSSDBFDB(PSSDBLP,"OI")):$GET(PSSDBFDB(PSSDBLP,"OI")),1:$GET(PSSDBFDB("OI")))
IF $GET(PSSDBFDB(PSSDBLP,"DRUG_IEN"))'>0
IF $GET(PSSDBFDB("OI"))'>0
QUIT
+16 IF $GET(PSSDBFDB(PSSDBLP,"DRUG_IEN"))>0
IF $$EXMT^PSSDSAPI($GET(PSSDBFDB(PSSDBLP,"DRUG_IEN")))
QUIT
+17 SET PSSDLEM=$$QORDLEM^PSSDSAPL()
if PSSDLEM=1
QUIT
+18 DO INERR^PSSDSAPM
if PSSENO
QUIT
IF $GET(PSSDBFDB(PSSDBLP,"DRUG_IEN"))'>0
DO FDRUG^PSSDSAPM
IF PSSDBIFG
DO ONT^PSSDSAPA
+19 IF PSSDBIFL
IF 'PSSDBIFG
DO NXDRUG^PSSDSAPM
QUIT
+20 DO NDINFO
+21 IF $GET(PSSDBND1)
IF $GET(PSSDBND3)
Begin DoDot:2
+22 SET PSSDBAR("GCN")=$PIECE($$PROD0^PSNAPIS(PSSDBND1,PSSDBND3),"^",7)
+23 SET PSSDBAR("VUID")=$$GETVUID^XTID(50.68,,+PSSDBND3_",")
End DoDot:2
+24 SET PSSDBAR("NAME")=$GET(PSSDBFDB(PSSDBLP,"DRUG_NM"))
+25 DO AMT
IF $GET(PSSDBAR("AMN"))'=""
IF $LENGTH(PSSDBAR("AMN"))>1
IF $EXTRACT(PSSDBAR("AMN"),1)="0"
SET PSSDBAR("AMN")=$EXTRACT(PSSDBAR("AMN"),2,$LENGTH(PSSDBAR("AMN")))
+26 DO DTYPE
+27 SET PSSDBAR("DSE")=$SELECT($DATA(PSSDBFDB(PSSDBLP,"DOSE_RATE")):$GET(PSSDBFDB(PSSDBLP,"DOSE_RATE")),1:"DAY")
+28 DO RTE
+29 DO SCHD^PSSSCHMS
+30 DO DURR
+31 DO DURRAT
+32 SET PSSDBAR("SPFC")=""
if $GET(PSSDBFDB(PSSDBLP,"ENH"))
SET PSSENHK(PSSDBFDB(PSSDBLP,"RX_NUM"))=1
+33 SET PSSDBFST=$GET(PSSDBAR("GCN"))_"^"_$SELECT($PIECE($GET(PSSDBAR("VUID")),"^")'=0:$GET(PSSDBAR("VUID")),1:"")_"^"_$SELECT('PSSDBIFL:PSSDBFDB(PSSDBLP,"DRUG_IEN"),PSSDBIFL&(PSSDBIFG):PSSDBIFG,1:"")_"^"_PSSDBAR("NAME")
+34 SET PSSDBFLG=1
+35 SET ^TMP($JOB,PSSDBASE,"IN","PROSPECTIVE",PSSDBFDB(PSSDBLP,"RX_NUM"))=PSSDBFST
+36 SET ^TMP($JOB,PSSDBASE,"IN","DOSE",PSSDBFDB(PSSDBLP,"RX_NUM"))=PSSDBFST_"^"_$GET(PSSDBAR("AMN"))_"^"_$GET(PSSDBAR("UNIT"))_"^"_PSSDBAR("DSE")_"^"_PSSDBAR("FREQ")_"^"_PSSDBAR("DUR")_"^"_PSSDBAR("DRR")_"^"_PSSDBAR("RT")_"^"_PSSDBAR("TYPE"
)
+37 SET ^TMP($JOB,PSSDBASE,"IN","DOSE",PSSDBFDB(PSSDBLP,"RX_NUM"))=^TMP($JOB,PSSDBASE,"IN","DOSE",PSSDBFDB(PSSDBLP,"RX_NUM"))_"^"_PSSDBAR("SPFC")_"^"_$$DFM^PSSDSEXC
+38 SET PSSDBFRC(PSSDBFDB(PSSDBLP,"RX_NUM"),"CONJ")=$GET(PSSDBDS(PSSDBLP,"CONJ"))
SET PSSDBFRC(PSSDBFDB(PSSDBLP,"RX_NUM"),"SCHEDULE")=$GET(PSSDBDS(PSSDBLP,"SCHEDULE"))
+39 IF $GET(PSSDBDS(PSSDBLP,"DRATE"))'=""
IF PSSDBDS(PSSDBLP,"DRATE")?.N!(PSSDBDS(PSSDBLP,"DRATE")?.N1".".N)
SET PSSDBDS(PSSDBLP,"DRATE")=PSSDBDS(PSSDBLP,"DRATE")_"D"
+40 SET PSSDBFRB(PSSDBFDB(PSSDBLP,"RX_NUM"),"DRATE")=$GET(PSSDBDS(PSSDBLP,"DRATE"))
DO ADJU^PSSDSEXC
+41 DO INFUE^PSSDSAPM
+42 DO FRQE^PSSDSAPM
+43 SET ^TMP($JOB,"PSSCNX","IN","DOSE",PSSDBLP,PSSDBFDB(PSSDBLP,"RX_NUM"))=^TMP($JOB,PSSDBASE,"IN","DOSE",PSSDBFDB(PSSDBLP,"RX_NUM"))
End DoDot:1
+44 ;Set up complex Doses
DO COMP
+45 SET ^TMP($JOB,PSSDBASE,"IN","IEN")=PSSDBDFN
+46 SET ^TMP($JOB,PSSDBASE,"IN","DOSE")=""
+47 DO PAT^PSSDSAPM
KILL ^TMP($JOB,"PSSCNX")
+48 ; Only go to interface if you have at least one Dose Sequence that needs to go
NEW PSSDBDGO
+49 SET PSSDBDGO=0
IF $DATA(^TMP($JOB,PSSDBASE,"IN","EXCEPTIONS"))
SET (PSSDBDGO,PSSDBSNO)=1
+50 ;Set up PSSDBCAX error array and default data
DO ERR
+51 ;2.1 PSSDBSNO check added
IF PSSDBDGO
IF PSSDBSNO
if $DATA(PSSDBFTX)
DO FTX^PSSDSAPK
DO IN^PSSHRQ2(PSSDBASE)
if $DATA(PSSDBFTX)
DO FTXRS^PSSDSAPK
+52 IF PSSDBASA!(PSSDBASB)
DO FMT^PSSDSEXC
IF $PIECE($GET(^TMP($JOB,PSSDBASE,"OUT",0)),"^")'=-1
DO ADDCT^PSSDSAPM
DO REM^PSSDSAPA
+53 QUIT
AMT ;Set Dose Amount and Dose Unit
+1 DO DPL^PSSDSAPK
+2 IF $DATA(PSSDBCAZ(PSSDBFDB(PSSDBLP,"RX_NUM"),"NO_DRUG"))
DO MLTS^PSSDSAPM
QUIT
+3 NEW PSSDBUNT,PSSDBFAL,PSSDBXP,PSSDBNOD,PSSDBNT,PSSDSXTD,PSSDBUNA,PSSDBLPD,PSSDSLCL,PSSDSLC1,PSSDSLCT
+4 SET (PSSDBFAL,PSSDBLPD,PSSDSLCT)=0
+5 IF 'PSSDBIFL
IF $DATA(PSSDBFDB(PSSDBLP,"DOSE_AMT"))
IF $DATA(PSSDBFDB(PSSDBLP,"DOSE_UNIT"))
SET PSSDBAR("AMN")=PSSDBFDB(PSSDBLP,"DOSE_AMT")
SET PSSDBAR("UNIT")=PSSDBFDB(PSSDBLP,"DOSE_UNIT")
DO LDZ
QUIT
+6 IF 'PSSDBIFL
IF $GET(PSSDBDS(PSSDBLP,"DRG_AMT"))
IF $GET(PSSDBDS(PSSDBLP,"DRG_UNIT"))'=""
Begin DoDot:1
+7 ;For Drug Units like MG/ML, take first piece of"/"
+8 SET PSSDBUNT=$SELECT(PSSDBDS(PSSDBLP,"DRG_UNIT")["/":$PIECE(PSSDBDS(PSSDBLP,"DRG_UNIT"),"/"),1:PSSDBDS(PSSDBLP,"DRG_UNIT"))
+9 SET PSSDBUNT=$$UP^XLFSTR(PSSDBUNT)
+10 SET PSSDBUNA=$$UNIT^PSSDSAPI(PSSDBUNT)
+11 IF PSSDBUNA'=""
SET PSSDBAR("AMN")=PSSDBDS(PSSDBLP,"DRG_AMT")
SET PSSDBAR("UNIT")=PSSDBUNA
SET PSSDBFAL=1
DO LDZ
End DoDot:1
+12 IF PSSDBFAL
QUIT
+13 ;"DOSE" Node should only come from CPRS, for selected Local Possible Dosage
+14 SET PSSDSLCL=$SELECT($GET(PSSDBDS(PSSDBLP,"DOSE"))'="":$PIECE(PSSDBDS(PSSDBLP,"DOSE"),"&",5),1:$GET(PSSDBDS(PSSDBLP,"DO")))
+15 IF PSSDSLCL["("
DO PTH^PSSDSUTL
+16 IF PSSDBIFL
DO MLT^PSSDSAPM
QUIT
AMTRT ;Retry for Local Dosages with parenthesis
+1 IF PSSDSLCL'=""
Begin DoDot:1
+2 FOR PSSDBXP=0:0
SET PSSDBXP=$ORDER(^PSDRUG(PSSDBFDB(PSSDBLP,"DRUG_IEN"),"DOS2",PSSDBXP))
if 'PSSDBXP!(PSSDBFAL)
QUIT
Begin DoDot:2
+3 SET PSSDBNOD=$GET(^PSDRUG(PSSDBFDB(PSSDBLP,"DRUG_IEN"),"DOS2",PSSDBXP,0))
+4 ;ignore package of the Local Possible Dose
+5 IF $$MTCH^PSSDSAPK
SET PSSDBLPD=1
IF $PIECE(PSSDBNOD,"^",5)
IF $PIECE(PSSDBNOD,"^",6)'=""
Begin DoDot:3
+6 ;XTID Screening out Inactive Dose Units
+7 SET PSSDSXTD=+$PIECE(PSSDBNOD,"^",5)
IF PSSDSXTD
IF $$SCREEN^XTID(51.24,.01,PSSDSXTD_",")
QUIT
+8 SET PSSDBNT=$PIECE($GET(^PS(51.24,+$PIECE(PSSDBNOD,"^",5),0)),"^",2)
+9 IF PSSDBNT'=""
SET PSSDBAR("AMN")=$PIECE(PSSDBNOD,"^",6)
SET PSSDBAR("UNIT")=PSSDBNT
SET PSSDBFAL=1
End DoDot:3
End DoDot:2
+10 ;Only do auto-population logic if Local Possible Dosage was not found at all in File 50
+11 IF PSSDBFAL
QUIT
+12 IF PSSDBLPD
DO DPOP^PSSDSAPK
IF PSSDBFAL
QUIT
+13 DO ITEM^PSSDSAPK
if 'PSSDBFAL
DO NUM^PSSDSAPL
if 'PSSDBFAL
DO RANGE^PSSDSUTL
End DoDot:1
+14 IF 'PSSDBFAL
IF PSSDSLCT
SET PSSDSLCL=PSSDSLC1(PSSDSLCT)
SET PSSDSLCT=PSSDSLCT-1
SET PSSDBLPD=0
GOTO AMTRT
+15 QUIT
LDZ ;
+1 IF $EXTRACT(PSSDBAR("AMN"))=0
IF $LENGTH(PSSDBAR("AMN"))>1
SET PSSDBAR("AMN")=$EXTRACT(PSSDBAR("AMN"),2,$LENGTH(PSSDBAR("AMN")))
+2 QUIT
RTE ;Get First DataBank Med Route
+1 NEW PSSDBMRT
+2 KILL PSSDBMRT
+3 IF $DATA(PSSDBFDB(PSSDBLP,"ROUTE"))
SET PSSDBAR("RT")=PSSDBFDB(PSSDBLP,"ROUTE")
QUIT
+4 IF $GET(PSSDBDS(PSSDBLP,"MR_IEN"))
SET PSSDBMRT=$$MRT^PSSDSAPI(PSSDBDS(PSSDBLP,"MR_IEN"))
IF $PIECE(PSSDBMRT,"^",2)'=""
SET PSSDBAR("RT")=$PIECE(PSSDBMRT,"^",2)
QUIT
+5 SET PSSDBAR("RT")=""
+6 QUIT
DTYPE ;Find Dose Type
+1 NEW PSSDBST1,PSSDBST2,PSSDBST3,PSSDBST4,PSSDBSTX
+2 IF $DATA(PSSDBFDB(PSSDBLP,"DOSE_TYPE"))
SET PSSDBAR("TYPE")=PSSDBFDB(PSSDBLP,"DOSE_TYPE")
QUIT
+3 SET PSSDBST1=$GET(PSSDBDS(PSSDBLP,"SCHEDULE"))
+4 IF PSSDBST1=""
SET PSSDBAR("TYPE")="MAINTENANCE"
QUIT
+5 SET PSSDBST3=0
+6 ;PSS*1*206
+7 IF PSSDBST1[" PRN"
IF '$DATA(^PS(51.1,"APPSJ",PSSDBST1))
SET PSSDBSTX=$PIECE(PSSDBST1," PRN",1)
if PSSDBSTX]""
SET PSSDBST1=PSSDBSTX
+8 FOR PSSDBST2=0:0
SET PSSDBST2=$ORDER(^PS(51.1,"APPSJ",PSSDBST1,PSSDBST2))
if 'PSSDBST2!(PSSDBST3)
QUIT
Begin DoDot:1
+9 SET PSSDBST4=$PIECE($GET(^PS(51.1,PSSDBST2,0)),"^",5)
+10 IF PSSDBST4="O"!(PSSDBST4="OC")
SET PSSDBAR("TYPE")="SINGLE DOSE"
SET PSSDBST3=1
End DoDot:1
+11 IF 'PSSDBST3
SET PSSDBAR("TYPE")="MAINTENANCE"
+12 QUIT
DURR ;Set Duration
+1 IF $DATA(PSSDBFDB(PSSDBLP,"DURATION"))
SET PSSDBAR("DUR")=PSSDBFDB(PSSDBLP,"DURATION")
QUIT
+2 SET PSSDBAR("DUR")=$SELECT($GET(PSSDBAR("TYPE"))="SINGLE DOSE":"",1:1)
+3 QUIT
DURRAT ;Set Duration Rate
+1 IF $DATA(PSSDBFDB(PSSDBLP,"DURATION_RT"))
SET PSSDBAR("DRR")=PSSDBFDB(PSSDBLP,"DURATION_RT")
QUIT
+2 SET PSSDBAR("DRR")=$SELECT($GET(PSSDBAR("TYPE"))="SINGLE DOSE":"",1:"DAY")
+3 QUIT
COMP ;Handle complex order, set PSSDBCAR array, see routine PSSDSEXC for PSSBDCAR piece details
+1 ;if you have to add new create input entry, just add a piece 5 = 1 to the Pharmacy Order Number
+2 NEW PSSDBKLP,PSSDBKUN,PSSDBKMR,PSSDBKND,PSSDBKRF,PSSDBKNW,PSSDBKFL,PSSDBKTM,PSSDBKFQ,PSSDBKGG,PSSCNX1,PSSDBCDA,PSSDCLX
+3 SET PSSDBKTM="PSSTTMP"
+4 KILL ^TMP($JOB,PSSDBKTM)
+5 SET PSSDBKFL=0
+6 FOR PSSCNX1=0:0
SET PSSCNX1=$ORDER(^TMP($JOB,"PSSCNX","IN","DOSE",PSSCNX1))
if 'PSSCNX1
QUIT
SET PSSDBKLP=$ORDER(^TMP($JOB,"PSSCNX","IN","DOSE",PSSCNX1,""))
IF PSSDBKLP'=""
Begin DoDot:1
+7 SET PSSDBKND=$GET(^TMP($JOB,PSSDBASE,"IN","DOSE",PSSDBKLP))
SET PSSDBKFQ=$SELECT($DATA(PSSDBCAZ(PSSDBKLP,"FRQ_ERROR")):0,1:1)
SET PSSDBKGG=$SELECT($PIECE(PSSDBKND,"^",12)="SINGLE DOSE":1,1:0)
+8 ;2.1 removed PSSDSWHE check
SET PSSDBCDA($SELECT($PIECE(PSSDBKND,"^",3)="":"NULL",1:$PIECE(PSSDBKND,"^",3)),$SELECT($PIECE(PSSDBKND,"^",11)="":"NULL",1:$PIECE(PSSDBKND,"^",11)))=PSSDBKLP
IF $GET(PSSDCLX)=""
SET PSSDCLX=PSSDBKLP
+9 SET PSSDBCAR(PSSDBKLP)="B"_"^"_$PIECE(PSSDBKND,"^",4)_"^"_$PIECE(PSSDBKND,"^",3)_"^"_PSSDBKFQ_"^"_$SELECT($PIECE(PSSDBKND,"^",12)="SINGLE DOSE":0,1:1)
if $GET(PSSDBFRC(PSSDBKLP,"CONJ"))="A"
SET $PIECE(PSSDBCAR(PSSDBKLP),"^",7)=1
+10 ; 2.1 removed PSSDSWHE check
SET $PIECE(PSSDBCAR(PSSDBKLP),"^",9)=$PIECE(PSSDBKND,"^",11)
DO MLTNO^PSSDSAPM
DO SXCL^PSSDSAPA
if $GET(PSSDBFRC(PSSDBKLP,"CONJ"))'=""!($GET(PSSDBFRC(PSSDCLX,"CONJ"))'="")
SET $PIECE(PSSDBCAR(PSSDBKLP),"^",16)=1
SET PSSDCLX=PSSDBKLP
+11 if '$PIECE(PSSDBCAR(PSSDBKLP),"^",14)
SET PSSDBSNO=1
IF $GET(PSSDBFRC(PSSDBKLP,"CONJ"))'="A"!($ORDER(^TMP($JOB,"PSSCNX","IN","DOSE",PSSCNX1))="")
SET PSSDBKNW($PIECE(PSSDBKLP,";",4),PSSDBKLP)=""
DO CRT
KILL PSSDBKNW,PSSDBCDA
SET PSSDBKFL=0
QUIT
+12 SET PSSDBKFL=PSSDBKFL+1
+13 SET PSSDBKNW($PIECE(PSSDBKLP,";",4),PSSDBKLP)=""
+14 SET $PIECE(PSSDBCAR(PSSDBKLP),"^")="S"
SET $PIECE(PSSDBCAR(PSSDBKLP),"^",12)=1
End DoDot:1
+15 IF $DATA(^TMP($JOB,PSSDBKTM))
MERGE ^TMP($JOB,PSSDBASE)=^TMP($JOB,PSSDBKTM)
+16 KILL ^TMP($JOB,PSSDBKTM)
+17 QUIT
DRT(PSSDBJV) ;Return number of minutes based on duration, API also called from Inpatient Medications
+1 ;If only a numeric is passed in, the API will assume Days
+2 IF $GET(PSSDBJV)=""
QUIT -1
+3 IF PSSDBJV?.N1".".N1"D"!(PSSDBJV?.N1"D")
QUIT (1440*+PSSDBJV)
+4 IF PSSDBJV?.N1".".N!(PSSDBJV?.N)
QUIT (1440*+PSSDBJV)
+5 IF PSSDBJV?.N1".".N1"H"!(PSSDBJV?.N1"H")
QUIT (60*+PSSDBJV)
+6 IF PSSDBJV?.N1".".N1"M"!(PSSDBJV?.N1"M")
QUIT (+PSSDBJV)
+7 IF PSSDBJV?.N1".".N1"W"!(PSSDBJV?.N1"W")
QUIT (10080*+PSSDBJV)
+8 IF PSSDBJV?.N1".".N1"L"!(PSSDBJV?.N1"L")
QUIT (43200*+PSSDBJV)
+9 QUIT -1
CRT ;Possibly create new Input Dose Node just for Daily Dose purposes
+1 IF 'PSSDBKFL!($GET(PSSDBFRC(PSSDBKLP,"CONJ"))="A")
SET $PIECE(PSSDBCAR(PSSDBKLP),"^")=$SELECT($GET(PSSDBFRC(PSSDBKLP,"CONJ"))="A":"S",$GET(PSSDBKGG):"S",$GET(PSSDBFRB(PSSDBKLP,"DRATE"))="":"B",1:"B")
DO S12
QUIT
+2 NEW PSSDBR1,PSSDBR2,PSSDBR3,PSSDBR4,PSSDBR5,PSSDBR6,PSSDBR7,PSSDBRCT,PSSDBRNO,PSSDBRLS,PSSDBR9,PSSDBR91,PSSDBEQ2,PSSDBEQ3,PSSDBEQ4,PSSDBR8,PSSDBXAX,PSSDBRLP,PSSDBRLA
+3 SET (PSSDBRNO,PSSDBRCT,PSSDBR5)=0
+4 ;Then or Except Conjunction, or last Dosing Sequence in the series, with previous dosages to add up for Daily Dose
+5 ;PSSDBKNW array holds all previous dosing sequences and current one
+6 SET PSSDBRLP=""
FOR
SET PSSDBRLP=$ORDER(PSSDBKNW(PSSDBRLP))
if PSSDBRLP=""
QUIT
SET PSSDBR1=$ORDER(PSSDBKNW(PSSDBRLP,""))
IF PSSDBR1'=""
Begin DoDot:1
+7 SET PSSDBR2=$GET(^TMP($JOB,PSSDBASE,"IN","DOSE",PSSDBR1))
+8 IF $ORDER(PSSDBKNW(PSSDBRLP))=""
SET $PIECE(PSSDBCAR(PSSDBKLP),"^")="S"
SET $PIECE(PSSDBCAR(PSSDBKLP),"^",12)=1
+9 IF $PIECE(PSSDBR2,"^",12)'="MAINTENANCE"
DO NX(4)
+10 SET PSSDBRCT=PSSDBRCT+1
+11 IF $GET(PSSDBFRC(PSSDBR1,"SCHEDULE"))["@"
DO NX(10)
+12 IF '$DATA(PSSDBEQ2(10))
IF $GET(PSSDBFRC(PSSDBR1,"SCHEDULE"))'=""
FOR PSSDBEQ4=0:0
SET PSSDBEQ4=$ORDER(^PS(51.1,"APPSJ",$GET(PSSDBFRC(PSSDBR1,"SCHEDULE")),PSSDBEQ4))
if 'PSSDBEQ4!($DATA(PSSDBEQ2(10)))
QUIT
Begin DoDot:2
+13 IF $PIECE($GET(^PS(51.1,PSSDBEQ4,0)),"^",5)="D"
DO NX(10)
End DoDot:2
+14 IF PSSDBRCT=1
Begin DoDot:2
+15 IF '$PIECE(PSSDBR2,"^",5)
DO NX(11)
+16 SET PSSDBR91=$GET(PSSDBFRB(PSSDBR1,"DRATE"))
+17 SET PSSDBR3=$PIECE(PSSDBR2,"^",6)
SET PSSDBR4=$PIECE(PSSDBR2,"^",11)
IF PSSDBR3=""!(PSSDBR4="")
SET PSSDBRNO=1
if PSSDBR3=""
DO NX(5)
if PSSDBR4=""
DO NX(6)
+18 SET PSSDBR5=$PIECE(PSSDBR2,"^",8)
+19 IF $DATA(PSSDBCAZ(PSSDBR1,"FRQ_ERROR"))
DO NX(7)
+20 IF 'PSSDBRNO
SET PSSDBR8=$$FRCON^PSSDSAPK(PSSDBR5)
if PSSDBR8'<1
SET PSSDBR6=$PIECE(PSSDBR2,"^",5)*PSSDBR8
IF PSSDBR8<1
DO NX(7)
+21 IF $GET(PSSDBFRB(PSSDBR1,"DRATE"))'=""
SET PSSDBR7=$$DRT(PSSDBFRB(PSSDBR1,"DRATE"))
IF PSSDBR7<1440
DO NX(9)
+22 ; Get Last entry
IF '$ORDER(PSSDBKNW(PSSDBRLP))
SET PSSDBRLS=PSSDBR1
End DoDot:2
QUIT
+23 IF '$PIECE(PSSDBR2,"^",5)
DO NX(11)
+24 IF PSSDBR3'=$PIECE(PSSDBR2,"^",6)
DO NX(5)
+25 IF PSSDBR4'=$PIECE(PSSDBR2,"^",11)
DO NX(6)
+26 IF $GET(PSSDBFRB(PSSDBR1,"DRATE"))'=PSSDBR91
DO NX(8)
+27 SET PSSDBR5=$PIECE(PSSDBR2,"^",8)
IF $DATA(PSSDBCAZ(PSSDBR1,"FRQ_ERROR"))
DO NX(7)
+28 IF 'PSSDBRNO
SET PSSDBR8=$$FRCON^PSSDSAPK(PSSDBR5)
if PSSDBR8'<1
SET PSSDBR6=PSSDBR6+($PIECE(PSSDBR2,"^",5)*PSSDBR8)
IF PSSDBR8<1
DO NX(7)
+29 IF $GET(PSSDBFRB(PSSDBR1,"DRATE"))'=""
SET PSSDBR7=$$DRT(PSSDBFRB(PSSDBR1,"DRATE"))
IF PSSDBR7<1440
DO NX(9)
+30 ; Get Last entry
IF '$ORDER(PSSDBKNW(PSSDBRLP))
SET PSSDBRLS=PSSDBR1
End DoDot:1
+31 ;2.1 Removed RESET^PSSDSAPA call - works witn GEN+2^PSSDSEXC add back for 2.2
IF PSSDBRNO
Begin DoDot:1
+32 SET PSSDBRLA=""
FOR
SET PSSDBRLA=$ORDER(PSSDBKNW(PSSDBRLA))
if PSSDBRLA=""
QUIT
SET PSSDBR9=$ORDER(PSSDBKNW(PSSDBRLA,""))
IF PSSDBR9'=""
SET $PIECE(PSSDBCAR(PSSDBR9),"^")="S"
SET $PIECE(PSSDBCAR(PSSDBR9),"^",12)=1
+33 ;Set error message only for last entry where Daily Dose should have been done
+34 DO ERST^PSSDSAPM
End DoDot:1
SET $PIECE(PSSDBCAR(PSSDBRLS),"^",8)=1
SET $PIECE(PSSDBCAR(PSSDBRLS),"^",7)=""
DO MLTNP^PSSDSAPM
QUIT
+35 SET ^TMP($JOB,PSSDBKTM,"IN","DOSE",PSSDBRLS_";1")=^TMP($JOB,PSSDBASE,"IN","DOSE",PSSDBRLS)
+36 SET ^TMP($JOB,PSSDBKTM,"IN","PROSPECTIVE",PSSDBRLS_";1")=$PIECE(^TMP($JOB,PSSDBASE,"IN","DOSE",PSSDBRLS),"^",1,4)
+37 SET $PIECE(^TMP($JOB,PSSDBKTM,"IN","DOSE",PSSDBRLS_";1"),"^",8)=1
+38 SET $PIECE(^TMP($JOB,PSSDBKTM,"IN","DOSE",PSSDBRLS_";1"),"^",5)=PSSDBR6
+39 SET PSSDBCAR(PSSDBRLS_";1")="D"_"^"_$PIECE(PSSDBKND,"^",4)_"^"_$PIECE(PSSDBKND,"^",3)_"^"_PSSDBKFQ
SET $PIECE(PSSDBCAR(PSSDBRLS),"^",11)=1
+40 QUIT
NDINFO ;Set National Drug File information
+1 IF 'PSSDBIFL
IF $GET(PSSDBFDB(PSSDBLP,"DRUG_IEN"))
SET PSSDBND1=$PIECE($GET(^PSDRUG(PSSDBFDB(PSSDBLP,"DRUG_IEN"),"ND")),"^")
SET PSSDBND3=$PIECE($GET(^PSDRUG(PSSDBFDB(PSSDBLP,"DRUG_IEN"),"ND")),"^",3)
QUIT
+2 IF $GET(PSSDBIFG)
SET PSSDBND1=$PIECE($GET(^PSDRUG(PSSDBIFG,"ND")),"^")
SET PSSDBND3=$PIECE($GET(^PSDRUG(PSSDBIFG,"ND")),"^",3)
+3 QUIT
ERR ;Loop through PSSDBCAR, set PSSDBCAX error array
+1 NEW PSSDBEB1,PSSDBEB2,PSSDBEB3
+2 SET PSSDBEB3=$SELECT($GET(^TMP($JOB,PSSDBASE,"IN","DOSE","AGE")):1,1:0)
+3 ;Skip AGE, WT and BSA and newly created Dosages for complex additions
+4 ;Rx_NUM MUST contain a ";", or you will not set PSSDBDGO
+5 SET PSSDBEB1=""
FOR
SET PSSDBEB1=$ORDER(^TMP($JOB,PSSDBASE,"IN","DOSE",PSSDBEB1))
if PSSDBEB1=""
QUIT
if 'PSSDBEB3&(PSSDBEB1[";")
SET $PIECE(PSSDBCAR(PSSDBEB1),"^",13)=1
if '$PIECE(PSSDBEB1,";",5)&(PSSDBEB1[";")
Begin DoDot:1
+6 SET PSSDBEB2=$GET(^TMP($JOB,PSSDBASE,"IN","DOSE",PSSDBEB1))
+7 IF $DATA(PSSDBCAZ(PSSDBEB1,"INF_ERROR"))
DO INRATE^PSSDSAPA
SET PSSDBDGO=1
SET $PIECE(PSSDBCAR(PSSDBEB1),"^",13)=1
QUIT
+8 IF $PIECE(PSSDBEB2,"^",5)=""!($PIECE(PSSDBEB2,"^",6)="")
DO BDOSE^PSSDSAPK
SET $PIECE(PSSDBCAR(PSSDBEB1),"^",13)=1
QUIT
+9 ;I $D(PSSDBCAZ(PSSDBEB1,"FRQ_ERROR")) D INFRQ^PSSDSAPA S PSSDBDGO=1 Q ;; 2.1 change, ensure null freq are sent in line below
+10 IF $$FCY^PSSDSUTA()
DO INFRQ^PSSDSAPA
SET PSSDBDGO=1
QUIT
+11 IF '$PIECE(PSSDBCAR(PSSDBEB1),"^",5)
DO SING^PSSDSAPK
SET PSSDBDGO=1
QUIT
+12 SET PSSDBDGO=1
End DoDot:1
+13 QUIT
EXCPS(PSSDBEQ1) ;Set errors
+1 ;Complex order - remove in 2.2
IF $PIECE(PSSDBCAR(PSSDBEB1),"^",16)
IF PSSDBEQ1=2
QUIT
+2 ;2.1 Don't set Frequency error if Schedule excluded from Daily Dose check
IF $PIECE(PSSDBCAR(PSSDBEB1),"^",15)
IF PSSDBEQ1=2
QUIT
+3 IF PSSDBEQ1=2
IF $DATA(PSSDBCAZ(PSSDBEB1,"FRQD_ERROR"))
SET PSSDBCAX(PSSDBEB1,15)=""
QUIT
+4 SET PSSDBCAX(PSSDBEB1,PSSDBEQ1)=""
+5 QUIT
S12 ;
+1 if $PIECE(PSSDBCAR(PSSDBKLP),"^")="S"
SET $PIECE(PSSDBCAR(PSSDBKLP),"^",12)=1
+2 QUIT
NX(PSSNX) ;
+1 SET PSSDBRNO=1
+2 SET PSSDBEQ2(PSSNX)=""
+3 SET PSSDBXAX(PSSNX,PSSDBR1)=""
+4 QUIT
