Routine: PSSORUTZ

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)

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)

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

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

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

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

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)

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)

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

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

PSSORUTZ.m