PSSORUTZ ;BIR/RSB/RTR-Dosage choices for report ;03/24/00
;;1.0;PHARMACY DATA MANAGEMENT;**40,49**;9/30/97
;Reference to ^PS(50.607 supported by DBIA 2221
;Reference to ^YSCL(603.01 supported by DBIA 2697
;
DOSE(PSSX,PD,TYPE,PSSDFN) ;
K PSSX
; PSSX - Target array
; PD - Orderable Item
; TYPE - Drug type (O:Outpt, U:Unit Dose, I:IV)
; PSSDFN - Patient IEN
;
N DLOOP,DCNT1,DLOOP1,LOW,FORM,PSSOIU,PSSLOW,PSSLOW1,PSSLOW2,PSOLC,PL,PSSHOLD,PSSA,PSSZ,PSSC,PSIEN,PSSTRN,PSSDSE,PSSVERB,PSSPREP,PSSCLO,PSSDEA,PSSMAX,PSSDLP,PSNN,PSNNN,PSSREQS,PSSLOW4,PL2,PSSA1,PL3,PSSUNITX,PSSLD,PSSLD1
N PSSDOSE,PSSUNTS,PSSUDOS,PSSQT
S PSSOIU=$S(TYPE="I":1,TYPE="U":1,1:0)
F DLOOP=0:0 S DLOOP=$O(^PSDRUG("ASP",PD,DLOOP)) Q:'DLOOP D
.Q:'$O(^PSDRUG(DLOOP,"DOS1",0))
.S PSSTRN=$P($G(^PSDRUG(DLOOP,"DOS")),"^"),PSSUNITX=$P($G(^("DOS")),"^",2) Q:PSSTRN=""
.S PSSUNITX=$S($P($G(^PS(50.607,+$G(PSSUNITX),0)),"^")'=""&($P($G(^(0)),"^")'["/"):$P($G(^(0)),"^"),1:"")
.Q:$G(^PSDRUG(DLOOP,"I"))]""&($G(^("I"))'>DT)
.D APP Q:PSSQT
.S PSSDSE=+$P($G(^PS(50.7,PD,0)),"^",2),PSSVERB=$P($G(^PS(50.606,PSSDSE,"MISC")),"^"),PSSPREP=$P($G(^("MISC")),"^",3)
.K PSNNN F PSNN=0:0 S PSNN=$O(^PS(50.606,PSSDSE,"NOUN",PSNN)) Q:'PSNN!($D(PSNNN)) S:$P($G(^(PSNN,0)),"^")'="" PSNNN=$P($G(^(0)),"^")
.; Set possible dose nodes
.F DLOOP1=0:0 S DLOOP1=$O(^PSDRUG(DLOOP,"DOS1",DLOOP1)) Q:'DLOOP1 D
..Q:'$D(^PSDRUG(DLOOP,"DOS1",DLOOP1,0))
..I PSSOIU,$P($G(^PSDRUG(DLOOP,"DOS1",DLOOP1,0)),"^",3)'["I" Q
..I 'PSSOIU,$P($G(^PSDRUG(DLOOP,"DOS1",DLOOP1,0)),"^",3)'["O" Q
..S (PSSDOSE,PSSUNTS,PSSUDOS)=""
..S PSSDOSE=$P($G(^PSDRUG(DLOOP,"DOS1",DLOOP1,0)),"^",2)
..S PSSUNTS=$P($G(^PS(50.607,+$P($G(^PSDRUG(DLOOP,"DOS")),"^",2),0)),"^")
..S PSSUDOS=$P($G(^PSDRUG(DLOOP,"DOS1",DLOOP1,0)),"^")
..I PSSDOSE]""&(PSSUDOS]"") D
...S DCNT1=$S('$D(DCNT1):1,1:DCNT1+1)
...S LOW(PSSDOSE,PSSUDOS,DCNT1)=""
...S FORM(PSSDOSE,$S($P($G(^PSDRUG(DLOOP,0)),"^",9)=1:1,1:0),DCNT1)=PSSUDOS
...D PARN
...S PSSX(DCNT1)=PSSDOSE_"^"_PSSUNTS_"^"_PSSUDOS_"^"_$S($G(PSSNP)'="":$G(PSSNP),1:$G(PSNNN))_"^^"_DLOOP K PSSNP
I '$O(PSSX(0)) G DOSE2
; delete n/f duplicate doses
S PSSLOW="" F S PSSLOW=$O(FORM(PSSLOW)) Q:PSSLOW="" D
.I $O(FORM(PSSLOW,0,0)) S PSSLOW2="" F S PSSLOW2=$O(FORM(PSSLOW,1,PSSLOW2)) Q:PSSLOW2="" K PSSX(PSSLOW2),LOW(PSSLOW,+$G(FORM(PSSLOW,1,PSSLOW2)),PSSLOW2)
;Find lowest units per dose
S PSSLOW="" F S PSSLOW=$O(LOW(PSSLOW)) Q:PSSLOW="" D
.S PSOLC=0 S PSSLOW1="" F S PSSLOW1=$O(LOW(PSSLOW,PSSLOW1)) Q:PSSLOW1="" D
..S PSOLC=PSOLC+1 S:PSOLC=1 PSSLOW4=$O(LOW(PSSLOW,PSSLOW1,0))
..S PSSLOW2="" F S PSSLOW2=$O(LOW(PSSLOW,PSSLOW1,PSSLOW2)) Q:PSSLOW2="" D
...I PSOLC>1 S PSSX(PSSLOW4,(PSOLC-1))=PSSX(PSSLOW2) K PSSX(PSSLOW2)
K PSSHOLD S PL="" F S PL=$O(PSSX(PL)) Q:PL="" S PSSHOLD($P(PSSX(PL),"^"),PL)=PSSX(PL) I $O(PSSX(PL,0)) D
.S PL2="" F S PL2=$O(PSSX(PL,PL2)) Q:PL2="" S PSSHOLD($P(PSSX(PL,PL2),"^"),PL,PL2)=PSSX(PL,PL2)
K PSSX S PSSA=1,PSSZ="" F S PSSZ=$O(PSSHOLD(PSSZ)) Q:PSSZ="" F PSSC=0:0 S PSSC=$O(PSSHOLD(PSSZ,PSSC)) Q:'PSSC S PSSX(PSSA)=PSSHOLD(PSSZ,PSSC) D SLS D:'$D(PSSX("DD",+$P(PSSX(PSSA),"^",6))) D:$O(PSSHOLD(PSSZ,PSSC,0)) MULTI S PSSA=PSSA+1
.S (PSIEN,DLOOP)=+$P(PSSX(PSSA),"^",6) K PSSMAX D:$G(TYPE)["O" MAX
.S PSSX("DD",PSIEN)=$P($G(^PSDRUG(PSIEN,0)),"^")_"^"_$P($G(^(660)),"^",6)_"^"_$P($G(^(0)),"^",9)_"^"_$P($G(^(660)),"^",8)_"^"_$P($G(^("DOS")),"^")
.S PSSX("DD",PSIEN)=PSSX("DD",PSIEN)_"^"_$G(PSSUNITX)_"^"_$P($G(^PS(50.606,+$G(PSSDSE),0)),"^")_"^"_$G(PSSMAX)
.D REQS S PSSX("DD",PSIEN)=PSSX("DD",PSIEN)_"^"_$G(PSSREQS) D DEA^PSSUTLAZ(PSIEN)
.S PSSX("MISC")=$G(PSSVERB)_"^"_$G(PSSPREP)_"^"_$P($G(^PS(50.606,+$G(PSSDSE),"MISC")),"^",4)
K PSSHOLD,PSSDZUNT
D LEAD^PSSUTLA1 D:$G(TYPE)["O" EN3^PSSUTLAZ(PD,80)
Q
DOSE2 ;Local doses
N PSOCT,PSONDS,PSOND,PSOND1,PSONDX,PSONDU,PSODOS,PSLOC,PSLOCV,PSODUPD,PSOXDOSE
S PSOCT=1
S PSOXDOSE=+$P($G(^PS(50.7,PD,0)),"^",2) K PSNNN ;F PSNN=0:0 S PSNN=$O(^PS(50.606,PSOXDOSE,"NOUN",PSNN)) Q:'PSNN!($D(PSNNN)) S:$P($G(^(PSNN,0)),"^")'="" PSNNN=$P($G(^(0)),"^")
F DLOOP=0:0 S DLOOP=$O(^PSDRUG("ASP",PD,DLOOP)) Q:'DLOOP D
.I $P($G(^PSDRUG(DLOOP,"I")),"^"),+$P($G(^("I")),"^")<DT Q
.D APP Q:PSSQT
.Q:'$O(^PSDRUG(DLOOP,"DOS2",0))
.S PSONDS=$P($G(^PSDRUG(DLOOP,"DOS")),"^"),PSONDU=$P($G(^("DOS")),"^",2),PSOND=$P($G(^("ND")),"^",3),PSOND1=$P($G(^("ND")),"^")
.I PSOND,PSOND1 I PSONDS=""!('PSONDU) S PSONDX=$$DFSU^PSNAPIS(PSOND1,PSOND)
.I PSONDS="",PSOND,PSOND1 S PSONDS=$P($G(PSONDX),"^",4)
.I 'PSONDU,PSOND,PSOND1 S PSONDU=$P($G(PSONDX),"^",5)
.S PSODOS=+$P($G(^PS(50.7,PD,0)),"^",2)
.;LOOK FOR LOCAL DOSES
.F PSLOC=0:0 S PSLOC=$O(^PSDRUG(DLOOP,"DOS2",PSLOC)) Q:'PSLOC D
..S PSLOCV=$P($G(^PSDRUG(DLOOP,"DOS2",PSLOC,0)),"^") Q:PSLOCV=""
..I PSSOIU,$P($G(^PSDRUG(DLOOP,"DOS2",PSLOC,0)),"^",2)'["I" Q
..I 'PSSOIU,$P($G(^PSDRUG(DLOOP,"DOS2",PSLOC,0)),"^",2)'["O" Q
..D SET2
;IF NO LOCAL DOSES FOUND
I '$O(PSSX(0)) K PSLOCV S PSOCT=1 D
.F DLOOP=0:0 S DLOOP=$O(^PSDRUG("ASP",PD,DLOOP)) Q:'DLOOP D
..I $P($G(^PSDRUG(DLOOP,"I")),"^"),+$P($G(^("I")),"^")<DT Q
..D APP Q:PSSQT
..S PSONDS=$P($G(^PSDRUG(DLOOP,"DOS")),"^"),PSONDU=$P($G(^("DOS")),"^",2),PSOND=$P($G(^("ND")),"^",3),PSOND1=$P($G(^("ND")),"^")
..K PSONDX I PSOND,PSOND1 I PSONDS=""!('PSONDU) S PSONDX=$$DFSU^PSNAPIS(PSOND1,PSOND)
..I PSONDS="",PSOND,PSOND1 S PSONDS=$P($G(PSONDX),"^",4)
..I 'PSONDU,PSOND,PSOND1 S PSONDU=$P($G(PSONDX),"^",5)
..S PSODOS=+$P($G(^PS(50.7,PD,0)),"^",2)
..D SET2
D LEAD^PSSUTLA1 D:$G(TYPE)["O" EN3^PSSUTLAZ(PD,80)
Q
SET2 ;
I $G(PSLOCV)'="",$G(PSLOCV)["&" D AMP^PSSORPHZ
S PSSX(PSOCT)="^"_$S($G(PSONDU):$P($G(^PS(50.607,+$G(PSONDU),0)),"^"),1:"")_"^^"_$G(PSNNN)_"^"_$G(PSLOCV)_"^"_DLOOP
I '$D(PSSX("DD",DLOOP)) D
.D REQS
.K PSSMAX I $G(TYPE)["O" D MAX
.S PSSX("DD",DLOOP)=$P($G(^PSDRUG(DLOOP,0)),"^")_"^"_$P($G(^(660)),"^",6)_"^"_$P($G(^(0)),"^",9)_"^"_$P($G(^(660)),"^",8)_"^"_$G(PSONDS)_"^"_$S($G(PSONDU):$P($G(^PS(50.607,+$G(PSONDU),0)),"^"),1:"")
.S PSSX("DD",DLOOP)=PSSX("DD",DLOOP)_"^"_$P($G(^PS(50.606,+$G(PSODOS),0)),"^")_"^"_$G(PSSMAX)_"^"_$G(PSSREQS) D DEA^PSSUTLAZ(DLOOP)
.S PSSX("MISC")=$P($G(^PS(50.606,+$G(PSODOS),"MISC")),"^")_"^"_$P($G(^("MISC")),"^",3)_"^"_$P($G(^("MISC")),"^",4)
S PSOCT=PSOCT+1
Q
MAX ;
K PSSMAX S PSSDEA=$P($G(^PSDRUG(DLOOP,0)),"^",3)
I PSSDEA["1"!(PSSDEA["2") S PSSMAX=0 Q
I PSSDEA["A",PSSDEA'["B" S PSSMAX=0 Q
I $P($G(^PSDRUG(DLOOP,"CLOZ1")),"^")="PSOCLO1",$G(PSSDFN) D Q
.S PSSCLO=$O(^YSCL(603.01,"C",PSSDFN,0)) I PSSCLO,$P($G(^YSCL(603.01,+PSSCLO,0)),"^",3)="B" S PSSMAX=1 Q
.S PSSMAX=0
I PSSDEA["3"!(PSSDEA["4")!(PSSDEA["5") S PSSMAX=5 Q
S PSSMAX=11
Q
SLS ;Dosage with /
K PSSDZUNT
I $P($G(PSSX(PSSA)),"^",2)'["/" S $P(PSSX(PSSA),"^",5)=$P($G(PSSX(PSSA)),"^")_$P($G(PSSX(PSSA)),"^",2) Q
N PSSF,PSSF1,PSSF2,PSSG,PSSFA,PSSFA1,PSSFB,PSSFB1,PSSDZI,PSSDZSL,PSSDZND,PSSDZSL1,PSSDZSL2,PSSDZSL3,PSSDZSL4,PSSDZSL5,PSSDZ50
S PSSF=$P($G(PSSX(PSSA)),"^"),PSSG=$P($G(PSSX(PSSA)),"^",2)
S PSSDZSL=0,PSSDZI=+$P($G(PSSX(PSSA)),"^",6),PSSDZ50=$P($G(^PSDRUG(PSSDZI,"DOS")),"^")
S PSSDZND=$$PSJST^PSNAPIS(+$P($G(^PSDRUG(PSSDZI,"ND")),"^"),+$P($G(^PSDRUG(PSSDZI,"ND")),"^",3)) S PSSDZND=+$P($G(PSSDZND),"^",2) ;I $G(PSSDZND),$G(PSSDZ50),+$G(PSSDZND)'=+$G(PSSDZ50) S PSSDZSL=1
S PSSFA=$P(PSSG,"/"),PSSFB=$P(PSSG,"/",2),PSSFA1=+$G(PSSFA),PSSFB1=+$G(PSSFB)
I '$G(PSSDZND) S $P(PSSX(PSSA),"^",5)=$P(PSSX(PSSA),"^") G SLSQ
S PSSDZSL2=PSSDZ50/PSSDZND,PSSDZSL3=PSSDZSL2*+$P($G(PSSX(PSSA)),"^",3) S PSSDZSL4=PSSDZSL3*$S($G(PSSFB1):PSSFB1,1:1) S PSSDZSL5=$S('$G(PSSFB1):PSSDZSL4_$G(PSSFB),1:PSSDZSL4_$P(PSSFB,PSSFB1,2))
S PSSF2=$S('$G(PSSFA1):PSSF,1:($G(PSSFA1)*PSSF))_$S($G(PSSFA1):$P(PSSFA,PSSFA1,2),1:PSSFA)_"/"_$G(PSSDZSL5)
;HERE RESET UNIT TO "ON THE FLY" IF STRENGTH HAS BEEN EDITED
S PSSDZUNT=$P(PSSG,"/")_"/"_$G(PSSDZSL4)_$S('$G(PSSFB1):$G(PSSFB),1:$P(PSSFB,PSSFB1,2)) S $P(PSSX(PSSA),"^",2)=PSSDZUNT
S $P(PSSX(PSSA),"^",5)=PSSF2
SLSQ Q
REQS ;Schedule
S PSSREQS=1
Q
MULTI ;
S PL3="" F S PL3=$O(PSSHOLD(PSSZ,PSSC,PL3)) Q:PL3="" S PSSX(PSSA,PL3)=PSSHOLD(PSSZ,PSSC,PL3) D SLS^PSSUTLPZ D:'$D(PSSX("DD",+$P(PSSX(PSSA,PL3),"^",4)))
.S (PSIEN,DLOOP)=+$P(PSSX(PSSA,PL3),"^",6) K PSSMAX D:$G(TYPE)["O" MAX
.S PSSX("DD",PSIEN)=$P($G(^PSDRUG(PSIEN,0)),"^")_"^"_$P($G(^(660)),"^",6)_"^"_$P($G(^(0)),"^",9)_"^"_$P($G(^(660)),"^",8)_"^"_$P($G(^("DOS")),"^")
.S PSSX("DD",PSIEN)=PSSX("DD",PSIEN)_"^"_$G(PSSUNITX)_"^"_$P($G(^PS(50.606,+$G(PSSDSE),0)),"^")_"^"_$G(PSSMAX)
.D REQS S PSSX("DD",PSIEN)=PSSX("DD",PSIEN)_"^"_$G(PSSREQS) D DEA^PSSUTLAZ(PSIEN)
.S PSSX("MISC")=$G(PSSVERB)_"^"_$G(PSSPREP)_"^"_$P($G(^PS(50.606,+$G(PSSDSE),"MISC")),"^",4)
K PSSJZUNT
Q
PARN ;
N PSSNPL K PSSNP
Q:$G(PSNNN)=""
Q:$L(PSNNN)'>3
S PSSNPL=$E(PSNNN,($L(PSNNN)-2),$L(PSNNN))
I $G(PSSNPL)="(S)"!($G(PSSNPL)="(s)") D
.I $G(PSSUDOS)'>1 S PSSNP=$E(PSNNN,1,($L(PSNNN)-3))
.I $G(PSSUDOS)>1 S PSSNP=$E(PSNNN,1,($L(PSNNN)-3))_$E(PSSNPL,2)
Q
LEAD ;Add leading zeros
F PSSLD=0:0 S PSSLD=$O(PSSX(PSSLD)) Q:'PSSLD D
.I $E($P(PSSX(PSSLD),"^"),1)="." S $P(PSSX(PSSLD),"^")="0"_$P(PSSX(PSSLD),"^")
.I $E($P(PSSX(PSSLD),"^",5),1)="." S $P(PSSX(PSSLD),"^",5)="0"_$P(PSSX(PSSLD),"^",5)
.I $O(PSSX(PSSLD,0)) D
..F PSSLD1=0:0 S PSSLD1=$O(PSSX(PSSLD,PSSLD1)) Q:'PSSLD1 D
...I $E($P(PSSX(PSSLD,PSSLD1),"^"),1)="." S $P(PSSX(PSSLD,PSSLD1),"^")="0"_$P(PSSX(PSSLD,PSSLD1),"^")
...I $E($P(PSSX(PSSLD,PSSLD1),"^",5),1)="." S $P(PSSX(PSSLD,PSSLD1),"^",5)="0"_$P(PSSX(PSSLD,PSSLD1),"^",5)
S PSSLD="" F S PSSLD=$O(PSSX("DD",PSSLD)) Q:PSSLD="" D
.I $E($P(PSSX("DD",PSSLD),"^",5),1)="." S $P(PSSX("DD",PSSLD),"^",5)="0"_$P(PSSX("DD",PSSLD),"^",5)
Q
APP ;
S PSSQT=0
I $G(TYPE)="O" S:$P($G(^PSDRUG(DLOOP,2)),"^",3)'["O" PSSQT=1 Q
I $P($G(^PSDRUG(DLOOP,2)),"^",3)'["U",$P($G(^(2)),"^",3)'["I" S PSSQT=1
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSSORUTZ 9857 printed Oct 16, 2024@18:34:13 Page 2
PSSORUTZ ;BIR/RSB/RTR-Dosage choices for report ;03/24/00
+1 ;;1.0;PHARMACY DATA MANAGEMENT;**40,49**;9/30/97
+2 ;Reference to ^PS(50.607 supported by DBIA 2221
+3 ;Reference to ^YSCL(603.01 supported by DBIA 2697
+4 ;
DOSE(PSSX,PD,TYPE,PSSDFN) ;
+1 KILL PSSX
+2 ; PSSX - Target array
+3 ; PD - Orderable Item
+4 ; TYPE - Drug type (O:Outpt, U:Unit Dose, I:IV)
+5 ; PSSDFN - Patient IEN
+6 ;
+7 NEW DLOOP,DCNT1,DLOOP1,LOW,FORM,PSSOIU,PSSLOW,PSSLOW1,PSSLOW2,PSOLC,PL,PSSHOLD,PSSA,PSSZ,PSSC,PSIEN,PSSTRN,PSSDSE,PSSVERB,PSSPREP,PSSCLO,PSSDEA,PSSMAX,PSSDLP,PSNN,PSNNN,PSSREQS,PSSLOW4,PL2,PSSA1,PL3,PSSUNITX,PSSLD,PSSLD1
+8 NEW PSSDOSE,PSSUNTS,PSSUDOS,PSSQT
+9 SET PSSOIU=$SELECT(TYPE="I":1,TYPE="U":1,1:0)
+10 FOR DLOOP=0:0
SET DLOOP=$ORDER(^PSDRUG("ASP",PD,DLOOP))
if 'DLOOP
QUIT
Begin DoDot:1
+11 if '$ORDER(^PSDRUG(DLOOP,"DOS1",0))
QUIT
+12 SET PSSTRN=$PIECE($GET(^PSDRUG(DLOOP,"DOS")),"^")
SET PSSUNITX=$PIECE($GET(^("DOS")),"^",2)
if PSSTRN=""
QUIT
+13 SET PSSUNITX=$SELECT($PIECE($GET(^PS(50.607,+$GET(PSSUNITX),0)),"^")'=""&($PIECE($GET(^(0)),"^")'["/"):$PIECE($GET(^(0)),"^"),1:"")
+14 if $GET(^PSDRUG(DLOOP,"I"))]""&($GET(^("I"))'>DT)
QUIT
+15 DO APP
if PSSQT
QUIT
+16 SET PSSDSE=+$PIECE($GET(^PS(50.7,PD,0)),"^",2)
SET PSSVERB=$PIECE($GET(^PS(50.606,PSSDSE,"MISC")),"^")
SET PSSPREP=$PIECE($GET(^("MISC")),"^",3)
+17 KILL PSNNN
FOR PSNN=0:0
SET PSNN=$ORDER(^PS(50.606,PSSDSE,"NOUN",PSNN))
if 'PSNN!($DATA(PSNNN))
QUIT
if $PIECE($GET(^(PSNN,0)),"^")'=""
SET PSNNN=$PIECE($GET(^(0)),"^")
+18 ; Set possible dose nodes
+19 FOR DLOOP1=0:0
SET DLOOP1=$ORDER(^PSDRUG(DLOOP,"DOS1",DLOOP1))
if 'DLOOP1
QUIT
Begin DoDot:2
+20 if '$DATA(^PSDRUG(DLOOP,"DOS1",DLOOP1,0))
QUIT
+21 IF PSSOIU
IF $PIECE($GET(^PSDRUG(DLOOP,"DOS1",DLOOP1,0)),"^",3)'["I"
QUIT
+22 IF 'PSSOIU
IF $PIECE($GET(^PSDRUG(DLOOP,"DOS1",DLOOP1,0)),"^",3)'["O"
QUIT
+23 SET (PSSDOSE,PSSUNTS,PSSUDOS)=""
+24 SET PSSDOSE=$PIECE($GET(^PSDRUG(DLOOP,"DOS1",DLOOP1,0)),"^",2)
+25 SET PSSUNTS=$PIECE($GET(^PS(50.607,+$PIECE($GET(^PSDRUG(DLOOP,"DOS")),"^",2),0)),"^")
+26 SET PSSUDOS=$PIECE($GET(^PSDRUG(DLOOP,"DOS1",DLOOP1,0)),"^")
+27 IF PSSDOSE]""&(PSSUDOS]"")
Begin DoDot:3
+28 SET DCNT1=$SELECT('$DATA(DCNT1):1,1:DCNT1+1)
+29 SET LOW(PSSDOSE,PSSUDOS,DCNT1)=""
+30 SET FORM(PSSDOSE,$SELECT($PIECE($GET(^PSDRUG(DLOOP,0)),"^",9)=1:1,1:0),DCNT1)=PSSUDOS
+31 DO PARN
+32 SET PSSX(DCNT1)=PSSDOSE_"^"_PSSUNTS_"^"_PSSUDOS_"^"_$SELECT($GET(PSSNP)'="":$GET(PSSNP),1:$GET(PSNNN))_"^^"_DLOOP
KILL PSSNP
End DoDot:3
End DoDot:2
End DoDot:1
+33 IF '$ORDER(PSSX(0))
GOTO DOSE2
+34 ; delete n/f duplicate doses
+35 SET PSSLOW=""
FOR
SET PSSLOW=$ORDER(FORM(PSSLOW))
if PSSLOW=""
QUIT
Begin DoDot:1
+36 IF $ORDER(FORM(PSSLOW,0,0))
SET PSSLOW2=""
FOR
SET PSSLOW2=$ORDER(FORM(PSSLOW,1,PSSLOW2))
if PSSLOW2=""
QUIT
KILL PSSX(PSSLOW2),LOW(PSSLOW,+$GET(FORM(PSSLOW,1,PSSLOW2)),PSSLOW2)
End DoDot:1
+37 ;Find lowest units per dose
+38 SET PSSLOW=""
FOR
SET PSSLOW=$ORDER(LOW(PSSLOW))
if PSSLOW=""
QUIT
Begin DoDot:1
+39 SET PSOLC=0
SET PSSLOW1=""
FOR
SET PSSLOW1=$ORDER(LOW(PSSLOW,PSSLOW1))
if PSSLOW1=""
QUIT
Begin DoDot:2
+40 SET PSOLC=PSOLC+1
if PSOLC=1
SET PSSLOW4=$ORDER(LOW(PSSLOW,PSSLOW1,0))
+41 SET PSSLOW2=""
FOR
SET PSSLOW2=$ORDER(LOW(PSSLOW,PSSLOW1,PSSLOW2))
if PSSLOW2=""
QUIT
Begin DoDot:3
+42 IF PSOLC>1
SET PSSX(PSSLOW4,(PSOLC-1))=PSSX(PSSLOW2)
KILL PSSX(PSSLOW2)
End DoDot:3
End DoDot:2
End DoDot:1
+43 KILL PSSHOLD
SET PL=""
FOR
SET PL=$ORDER(PSSX(PL))
if PL=""
QUIT
SET PSSHOLD($PIECE(PSSX(PL),"^"),PL)=PSSX(PL)
IF $ORDER(PSSX(PL,0))
Begin DoDot:1
+44 SET PL2=""
FOR
SET PL2=$ORDER(PSSX(PL,PL2))
if PL2=""
QUIT
SET PSSHOLD($PIECE(PSSX(PL,PL2),"^"),PL,PL2)=PSSX(PL,PL2)
End DoDot:1
+45 KILL PSSX
SET PSSA=1
SET PSSZ=""
FOR
SET PSSZ=$ORDER(PSSHOLD(PSSZ))
if PSSZ=""
QUIT
FOR PSSC=0:0
SET PSSC=$ORDER(PSSHOLD(PSSZ,PSSC))
if 'PSSC
QUIT
SET PSSX(PSSA)=PSSHOLD(PSSZ,PSSC)
DO SLS
if '$DATA(PSSX("DD",+$PIECE(PSSX(PSSA),"^",6)))
Begin DoDot:1
+46 SET (PSIEN,DLOOP)=+$PIECE(PSSX(PSSA),"^",6)
KILL PSSMAX
if $GET(TYPE)["O"
DO MAX
+47 SET PSSX("DD",PSIEN)=$PIECE($GET(^PSDRUG(PSIEN,0)),"^")_"^"_$PIECE($GET(^(660)),"^",6)_"^"_$PIECE($GET(^(0)),"^",9)_"^"_$PIECE($GET(^(660)),"^",8)_"^"_$PIECE($GET(^("DOS")),"^")
+48 SET PSSX("DD",PSIEN)=PSSX("DD",PSIEN)_"^"_$GET(PSSUNITX)_"^"_$PIECE($GET(^PS(50.606,+$GET(PSSDSE),0)),"^")_"^"_$GET(PSSMAX)
+49 DO REQS
SET PSSX("DD",PSIEN)=PSSX("DD",PSIEN)_"^"_$GET(PSSREQS)
DO DEA^PSSUTLAZ(PSIEN)
+50 SET PSSX("MISC")=$GET(PSSVERB)_"^"_$GET(PSSPREP)_"^"_$PIECE($GET(^PS(50.606,+$GET(PSSDSE),"MISC")),"^",4)
End DoDot:1
if $ORDER(PSSHOLD(PSSZ,PSSC,0))
DO MULTI
SET PSSA=PSSA+1
+51 KILL PSSHOLD,PSSDZUNT
+52 DO LEAD^PSSUTLA1
if $GET(TYPE)["O"
DO EN3^PSSUTLAZ(PD,80)
+53 QUIT
DOSE2 ;Local doses
+1 NEW PSOCT,PSONDS,PSOND,PSOND1,PSONDX,PSONDU,PSODOS,PSLOC,PSLOCV,PSODUPD,PSOXDOSE
+2 SET PSOCT=1
+3 ;F PSNN=0:0 S PSNN=$O(^PS(50.606,PSOXDOSE,"NOUN",PSNN)) Q:'PSNN!($D(PSNNN)) S:$P($G(^(PSNN,0)),"^")'="" PSNNN=$P($G(^(0)),"^")
SET PSOXDOSE=+$PIECE($GET(^PS(50.7,PD,0)),"^",2)
KILL PSNNN
+4 FOR DLOOP=0:0
SET DLOOP=$ORDER(^PSDRUG("ASP",PD,DLOOP))
if 'DLOOP
QUIT
Begin DoDot:1
+5 IF $PIECE($GET(^PSDRUG(DLOOP,"I")),"^")
IF +$PIECE($GET(^("I")),"^")<DT
QUIT
+6 DO APP
if PSSQT
QUIT
+7 if '$ORDER(^PSDRUG(DLOOP,"DOS2",0))
QUIT
+8 SET PSONDS=$PIECE($GET(^PSDRUG(DLOOP,"DOS")),"^")
SET PSONDU=$PIECE($GET(^("DOS")),"^",2)
SET PSOND=$PIECE($GET(^("ND")),"^",3)
SET PSOND1=$PIECE($GET(^("ND")),"^")
+9 IF PSOND
IF PSOND1
IF PSONDS=""!('PSONDU)
SET PSONDX=$$DFSU^PSNAPIS(PSOND1,PSOND)
+10 IF PSONDS=""
IF PSOND
IF PSOND1
SET PSONDS=$PIECE($GET(PSONDX),"^",4)
+11 IF 'PSONDU
IF PSOND
IF PSOND1
SET PSONDU=$PIECE($GET(PSONDX),"^",5)
+12 SET PSODOS=+$PIECE($GET(^PS(50.7,PD,0)),"^",2)
+13 ;LOOK FOR LOCAL DOSES
+14 FOR PSLOC=0:0
SET PSLOC=$ORDER(^PSDRUG(DLOOP,"DOS2",PSLOC))
if 'PSLOC
QUIT
Begin DoDot:2
+15 SET PSLOCV=$PIECE($GET(^PSDRUG(DLOOP,"DOS2",PSLOC,0)),"^")
if PSLOCV=""
QUIT
+16 IF PSSOIU
IF $PIECE($GET(^PSDRUG(DLOOP,"DOS2",PSLOC,0)),"^",2)'["I"
QUIT
+17 IF 'PSSOIU
IF $PIECE($GET(^PSDRUG(DLOOP,"DOS2",PSLOC,0)),"^",2)'["O"
QUIT
+18 DO SET2
End DoDot:2
End DoDot:1
+19 ;IF NO LOCAL DOSES FOUND
+20 IF '$ORDER(PSSX(0))
KILL PSLOCV
SET PSOCT=1
Begin DoDot:1
+21 FOR DLOOP=0:0
SET DLOOP=$ORDER(^PSDRUG("ASP",PD,DLOOP))
if 'DLOOP
QUIT
Begin DoDot:2
+22 IF $PIECE($GET(^PSDRUG(DLOOP,"I")),"^")
IF +$PIECE($GET(^("I")),"^")<DT
QUIT
+23 DO APP
if PSSQT
QUIT
+24 SET PSONDS=$PIECE($GET(^PSDRUG(DLOOP,"DOS")),"^")
SET PSONDU=$PIECE($GET(^("DOS")),"^",2)
SET PSOND=$PIECE($GET(^("ND")),"^",3)
SET PSOND1=$PIECE($GET(^("ND")),"^")
+25 KILL PSONDX
IF PSOND
IF PSOND1
IF PSONDS=""!('PSONDU)
SET PSONDX=$$DFSU^PSNAPIS(PSOND1,PSOND)
+26 IF PSONDS=""
IF PSOND
IF PSOND1
SET PSONDS=$PIECE($GET(PSONDX),"^",4)
+27 IF 'PSONDU
IF PSOND
IF PSOND1
SET PSONDU=$PIECE($GET(PSONDX),"^",5)
+28 SET PSODOS=+$PIECE($GET(^PS(50.7,PD,0)),"^",2)
+29 DO SET2
End DoDot:2
End DoDot:1
+30 DO LEAD^PSSUTLA1
if $GET(TYPE)["O"
DO EN3^PSSUTLAZ(PD,80)
+31 QUIT
SET2 ;
+1 IF $GET(PSLOCV)'=""
IF $GET(PSLOCV)["&"
DO AMP^PSSORPHZ
+2 SET PSSX(PSOCT)="^"_$SELECT($GET(PSONDU):$PIECE($GET(^PS(50.607,+$GET(PSONDU),0)),"^"),1:"")_"^^"_$GET(PSNNN)_"^"_$GET(PSLOCV)_"^"_DLOOP
+3 IF '$DATA(PSSX("DD",DLOOP))
Begin DoDot:1
+4 DO REQS
+5 KILL PSSMAX
IF $GET(TYPE)["O"
DO MAX
+6 SET PSSX("DD",DLOOP)=$PIECE($GET(^PSDRUG(DLOOP,0)),"^")_"^"_$PIECE($GET(^(660)),"^",6)_"^"_$PIECE($GET(^(0)),"^",9)_"^"_$PIECE($GET(^(660)),"^",8)_"^"_$GET(PSONDS)_"^"_$SELECT($GET(PSONDU):$PIECE($GET(^PS(50.607,+$GET(PSONDU),0)),"^"),1
:"")
+7 SET PSSX("DD",DLOOP)=PSSX("DD",DLOOP)_"^"_$PIECE($GET(^PS(50.606,+$GET(PSODOS),0)),"^")_"^"_$GET(PSSMAX)_"^"_$GET(PSSREQS)
DO DEA^PSSUTLAZ(DLOOP)
+8 SET PSSX("MISC")=$PIECE($GET(^PS(50.606,+$GET(PSODOS),"MISC")),"^")_"^"_$PIECE($GET(^("MISC")),"^",3)_"^"_$PIECE($GET(^("MISC")),"^",4)
End DoDot:1
+9 SET PSOCT=PSOCT+1
+10 QUIT
MAX ;
+1 KILL PSSMAX
SET PSSDEA=$PIECE($GET(^PSDRUG(DLOOP,0)),"^",3)
+2 IF PSSDEA["1"!(PSSDEA["2")
SET PSSMAX=0
QUIT
+3 IF PSSDEA["A"
IF PSSDEA'["B"
SET PSSMAX=0
QUIT
+4 IF $PIECE($GET(^PSDRUG(DLOOP,"CLOZ1")),"^")="PSOCLO1"
IF $GET(PSSDFN)
Begin DoDot:1
+5 SET PSSCLO=$ORDER(^YSCL(603.01,"C",PSSDFN,0))
IF PSSCLO
IF $PIECE($GET(^YSCL(603.01,+PSSCLO,0)),"^",3)="B"
SET PSSMAX=1
QUIT
+6 SET PSSMAX=0
End DoDot:1
QUIT
+7 IF PSSDEA["3"!(PSSDEA["4")!(PSSDEA["5")
SET PSSMAX=5
QUIT
+8 SET PSSMAX=11
+9 QUIT
SLS ;Dosage with /
+1 KILL PSSDZUNT
+2 IF $PIECE($GET(PSSX(PSSA)),"^",2)'["/"
SET $PIECE(PSSX(PSSA),"^",5)=$PIECE($GET(PSSX(PSSA)),"^")_$PIECE($GET(PSSX(PSSA)),"^",2)
QUIT
+3 NEW PSSF,PSSF1,PSSF2,PSSG,PSSFA,PSSFA1,PSSFB,PSSFB1,PSSDZI,PSSDZSL,PSSDZND,PSSDZSL1,PSSDZSL2,PSSDZSL3,PSSDZSL4,PSSDZSL5,PSSDZ50
+4 SET PSSF=$PIECE($GET(PSSX(PSSA)),"^")
SET PSSG=$PIECE($GET(PSSX(PSSA)),"^",2)
+5 SET PSSDZSL=0
SET PSSDZI=+$PIECE($GET(PSSX(PSSA)),"^",6)
SET PSSDZ50=$PIECE($GET(^PSDRUG(PSSDZI,"DOS")),"^")
+6 ;I $G(PSSDZND),$G(PSSDZ50),+$G(PSSDZND)'=+$G(PSSDZ50) S PSSDZSL=1
SET PSSDZND=$$PSJST^PSNAPIS(+$PIECE($GET(^PSDRUG(PSSDZI,"ND")),"^"),+$PIECE($GET(^PSDRUG(PSSDZI,"ND")),"^",3))
SET PSSDZND=+$PIECE($GET(PSSDZND),"^",2)
+7 SET PSSFA=$PIECE(PSSG,"/")
SET PSSFB=$PIECE(PSSG,"/",2)
SET PSSFA1=+$GET(PSSFA)
SET PSSFB1=+$GET(PSSFB)
+8 IF '$GET(PSSDZND)
SET $PIECE(PSSX(PSSA),"^",5)=$PIECE(PSSX(PSSA),"^")
GOTO SLSQ
+9 SET PSSDZSL2=PSSDZ50/PSSDZND
SET PSSDZSL3=PSSDZSL2*+$PIECE($GET(PSSX(PSSA)),"^",3)
SET PSSDZSL4=PSSDZSL3*$SELECT($GET(PSSFB1):PSSFB1,1:1)
SET PSSDZSL5=$SELECT('$GET(PSSFB1):PSSDZSL4_$GET(PSSFB),1:PSSDZSL4_$PIECE(PSSFB,PSSFB1,2))
+10 SET PSSF2=$SELECT('$GET(PSSFA1):PSSF,1:($GET(PSSFA1)*PSSF))_$SELECT($GET(PSSFA1):$PIECE(PSSFA,PSSFA1,2),1:PSSFA)_"/"_$GET(PSSDZSL5)
+11 ;HERE RESET UNIT TO "ON THE FLY" IF STRENGTH HAS BEEN EDITED
+12 SET PSSDZUNT=$PIECE(PSSG,"/")_"/"_$GET(PSSDZSL4)_$SELECT('$GET(PSSFB1):$GET(PSSFB),1:$PIECE(PSSFB,PSSFB1,2))
SET $PIECE(PSSX(PSSA),"^",2)=PSSDZUNT
+13 SET $PIECE(PSSX(PSSA),"^",5)=PSSF2
SLSQ QUIT
REQS ;Schedule
+1 SET PSSREQS=1
+2 QUIT
MULTI ;
+1 SET PL3=""
FOR
SET PL3=$ORDER(PSSHOLD(PSSZ,PSSC,PL3))
if PL3=""
QUIT
SET PSSX(PSSA,PL3)=PSSHOLD(PSSZ,PSSC,PL3)
DO SLS^PSSUTLPZ
if '$DATA(PSSX("DD",+$PIECE(PSSX(PSSA,PL3),"^",4)))
Begin DoDot:1
+2 SET (PSIEN,DLOOP)=+$PIECE(PSSX(PSSA,PL3),"^",6)
KILL PSSMAX
if $GET(TYPE)["O"
DO MAX
+3 SET PSSX("DD",PSIEN)=$PIECE($GET(^PSDRUG(PSIEN,0)),"^")_"^"_$PIECE($GET(^(660)),"^",6)_"^"_$PIECE($GET(^(0)),"^",9)_"^"_$PIECE($GET(^(660)),"^",8)_"^"_$PIECE($GET(^("DOS")),"^")
+4 SET PSSX("DD",PSIEN)=PSSX("DD",PSIEN)_"^"_$GET(PSSUNITX)_"^"_$PIECE($GET(^PS(50.606,+$GET(PSSDSE),0)),"^")_"^"_$GET(PSSMAX)
+5 DO REQS
SET PSSX("DD",PSIEN)=PSSX("DD",PSIEN)_"^"_$GET(PSSREQS)
DO DEA^PSSUTLAZ(PSIEN)
+6 SET PSSX("MISC")=$GET(PSSVERB)_"^"_$GET(PSSPREP)_"^"_$PIECE($GET(^PS(50.606,+$GET(PSSDSE),"MISC")),"^",4)
End DoDot:1
+7 KILL PSSJZUNT
+8 QUIT
PARN ;
+1 NEW PSSNPL
KILL PSSNP
+2 if $GET(PSNNN)=""
QUIT
+3 if $LENGTH(PSNNN)'>3
QUIT
+4 SET PSSNPL=$EXTRACT(PSNNN,($LENGTH(PSNNN)-2),$LENGTH(PSNNN))
+5 IF $GET(PSSNPL)="(S)"!($GET(PSSNPL)="(s)")
Begin DoDot:1
+6 IF $GET(PSSUDOS)'>1
SET PSSNP=$EXTRACT(PSNNN,1,($LENGTH(PSNNN)-3))
+7 IF $GET(PSSUDOS)>1
SET PSSNP=$EXTRACT(PSNNN,1,($LENGTH(PSNNN)-3))_$EXTRACT(PSSNPL,2)
End DoDot:1
+8 QUIT
LEAD ;Add leading zeros
+1 FOR PSSLD=0:0
SET PSSLD=$ORDER(PSSX(PSSLD))
if 'PSSLD
QUIT
Begin DoDot:1
+2 IF $EXTRACT($PIECE(PSSX(PSSLD),"^"),1)="."
SET $PIECE(PSSX(PSSLD),"^")="0"_$PIECE(PSSX(PSSLD),"^")
+3 IF $EXTRACT($PIECE(PSSX(PSSLD),"^",5),1)="."
SET $PIECE(PSSX(PSSLD),"^",5)="0"_$PIECE(PSSX(PSSLD),"^",5)
+4 IF $ORDER(PSSX(PSSLD,0))
Begin DoDot:2
+5 FOR PSSLD1=0:0
SET PSSLD1=$ORDER(PSSX(PSSLD,PSSLD1))
if 'PSSLD1
QUIT
Begin DoDot:3
+6 IF $EXTRACT($PIECE(PSSX(PSSLD,PSSLD1),"^"),1)="."
SET $PIECE(PSSX(PSSLD,PSSLD1),"^")="0"_$PIECE(PSSX(PSSLD,PSSLD1),"^")
+7 IF $EXTRACT($PIECE(PSSX(PSSLD,PSSLD1),"^",5),1)="."
SET $PIECE(PSSX(PSSLD,PSSLD1),"^",5)="0"_$PIECE(PSSX(PSSLD,PSSLD1),"^",5)
End DoDot:3
End DoDot:2
End DoDot:1
+8 SET PSSLD=""
FOR
SET PSSLD=$ORDER(PSSX("DD",PSSLD))
if PSSLD=""
QUIT
Begin DoDot:1
+9 IF $EXTRACT($PIECE(PSSX("DD",PSSLD),"^",5),1)="."
SET $PIECE(PSSX("DD",PSSLD),"^",5)="0"_$PIECE(PSSX("DD",PSSLD),"^",5)
End DoDot:1
+10 QUIT
APP ;
+1 SET PSSQT=0
+2 IF $GET(TYPE)="O"
if $PIECE($GET(^PSDRUG(DLOOP,2)),"^",3)'["O"
SET PSSQT=1
QUIT
+3 IF $PIECE($GET(^PSDRUG(DLOOP,2)),"^",3)'["U"
IF $PIECE($GET(^(2)),"^",3)'["I"
SET PSSQT=1
+4 QUIT
