PSSORPHZ ;BIR/RTR-Dosage by Dispense Units for report ;03/24/00
;;1.0;PHARMACY DATA MANAGEMENT;**40**;9/30/97
;Reference to ^PS(50.607 supported by DBIA 2221
;
S DLOOP=$G(PD)
Q:'$G(DLOOP)
;SET PSSX(1)=-1^DDRUG IS INACTIVE OR NOT APP USE ANYMORE?
I $P($G(^PSDRUG(DLOOP,"I")),"^")&($P($G(^("I")),"^")'>DT) S PSSX(1)="-1^Drug is inactive" Q
;I $P($G(^PSDRUG(DLOOP,2)),"^",3)'[TYPE S PSSX(1)="-1^Drug not marked for application" Q
S PSSTRN=$P($G(^PSDRUG(DLOOP,"DOS")),"^"),PSSUNITZ=$P($G(^("DOS")),"^",2)
S PSSUNITX=$S($P($G(^PS(50.607,+$G(PSSUNITZ),0)),"^")'=""&($P($G(^(0)),"^")'["/"):$P($G(^(0)),"^"),1:"")
S PSSDSE=+$P($G(^PS(50.7,POPD,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)),"^")
S (PSSDOSE,PSSUNTS,PSSUDOS)=""
S PSSUNTS=$P($G(^PS(50.607,+$P($G(^PSDRUG(DLOOP,"DOS")),"^",2),0)),"^")
S PSSUDOS=$G(PSSUPD)
S PSSDOSE=PSSUDOS*+PSSTRN
I $G(PSSTRN)=""!('$G(PSSUNITZ)) D SET D LEAD^PSSORPH Q
I '$G(PSSDOSE)!('$G(PSSUDOS)) D SET D LEAD^PSSORPH Q
S DCNT1=1
D PARN^PSSORPH
S PSSX(DCNT1)=PSSDOSE_"^"_$S($G(TYPE)="O":$G(PSSUNITZ),1:$G(PSSUNTS))_"^"_PSSUDOS_"^"_DLOOP_"^"_$G(PSSTRN)_"^"_$S($G(PSSNP)'="":$G(PSSNP),1:$G(PSNNN))_"^"_$P($G(^PS(50.606,+$G(PSSDSE),0)),"^")_"^"_$G(PSSVERB)_"^"_$G(PSSPREP) K PSSNP
S PSSA=1 D SLS^PSSORPH
S (PSIEN,DLOOP)=+$P(PSSX(PSSA),"^",4) K PSSMAX D:$G(TYPE)["O" MAX^PSSORPH
S PSSX("DD",PSIEN)=$P($G(^PSDRUG(PSIEN,0)),"^")_"^"_$P($G(^(660)),"^",6)_"^"_$P($G(^(0)),"^",9)_"^"_$P($G(^(660)),"^",8)_"^"_$P($G(^("DOS")),"^")_"^"_$G(PSSUNITX)_"^"_$G(PSSMAX)
D REQS^PSSORPH S PSSX("DD",PSIEN)=PSSX("DD",PSIEN)_"^"_$G(PSSREQS)_"^"_$G(PSNNN)_"^"_$G(PSSVERB)
D LEAD^PSSORPH
Q
SET ;
D PARN^PSSORPH
S PSSX(1)="^"_$S($G(TYPE)="O":$G(PSSUNITZ),1:$G(PSSUNTS))_"^^"_DLOOP_"^"_$G(PSSTRN)_"^"_$S($G(PSSNP)'="":$G(PSSNP),1:$G(PSNNN))_"^"_$P($G(^PS(50.606,+$G(PSSDSE),0)),"^")_"^"_$G(PSSVERB)_"^"_$G(PSSPREP) K PSSNP
S (PSIEN,DLOOP)=+$P(PSSX(1),"^",4) K PSSMAX D:$G(TYPE)["O" MAX^PSSORPH
S PSSX("DD",PSIEN)=$P($G(^PSDRUG(PSIEN,0)),"^")_"^"_$P($G(^(660)),"^",6)_"^"_$P($G(^(0)),"^",9)_"^"_$P($G(^(660)),"^",8)_"^"_$P($G(^("DOS")),"^")_"^"_$G(PSSUNITX)_"^"_$G(PSSMAX)
D REQS^PSSORPH S PSSX("DD",PSIEN)=PSSX("DD",PSIEN)_"^"_$G(PSSREQS)_"^"_$G(PSNNN)_"^"_$G(PSSVERB)
Q
AMP ;Replace & with AND when returning local doses to CPRS
N PSSAB,PSSABT,PSSABA,PSSABL,PSSABZ,PSSABX,PSSABF1,PSSABF2
I PSLOCV="&" S PSLOCV=" AND " Q
I $E(PSLOCV,1)="&" D
.I $E(PSLOCV,2)=" " S PSLOCV=" AND"_$E(PSLOCV,2,999) Q
.S PSLOCV=" AND "_$E(PSLOCV,2,999)
S PSSABL=$L(PSLOCV)
I $E(PSLOCV,PSSABL)="&" D
.I $E(PSLOCV,(PSSABL-1))=" " S PSLOCV=$E(PSLOCV,1,(PSSABL-1))_"AND " Q
.S PSLOCV=$E(PSLOCV,1,(PSSABL-1))_" AND "
Q:$G(PSLOCV)'["&"
S PSSABT=0
F PSSAB=1:1:$L(PSLOCV) I $E(PSLOCV,PSSAB)="&" S PSSABT=PSSABT+1
F PSSAB=1:1:(PSSABT+1) S PSSABA(PSSAB)=$P(PSLOCV,"&") S PSLOCV=$P(PSLOCV,"&",2,999)
F PSSABZ=1:1:PSSABT D
.K PSSABF1,PSSABF2
.I $L($G(PSSABA(PSSABZ)))>0 S PSSABF1=$E(PSSABA(PSSABZ),$L(PSSABA(PSSABZ)))
.I $D(PSSABA(PSSABZ+1)) S PSSABF2=$E(PSSABA(PSSABZ+1),1)
.S PSSABA(PSSABZ)=PSSABA(PSSABZ)_$S($G(PSSABF1)=" ":"AND",1:" AND")_$S($G(PSSABF2)=" ":"",1:" ")
K PSLOCV F PSSABX=1:1:(PSSABT+1) S PSLOCV=$G(PSLOCV)_$G(PSSABA(PSSABX))
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSSORPHZ 3393 printed Dec 13, 2024@02:33:28 Page 2
PSSORPHZ ;BIR/RTR-Dosage by Dispense Units for report ;03/24/00
+1 ;;1.0;PHARMACY DATA MANAGEMENT;**40**;9/30/97
+2 ;Reference to ^PS(50.607 supported by DBIA 2221
+3 ;
+4 SET DLOOP=$GET(PD)
+5 if '$GET(DLOOP)
QUIT
+6 ;SET PSSX(1)=-1^DDRUG IS INACTIVE OR NOT APP USE ANYMORE?
+7 IF $PIECE($GET(^PSDRUG(DLOOP,"I")),"^")&($PIECE($GET(^("I")),"^")'>DT)
SET PSSX(1)="-1^Drug is inactive"
QUIT
+8 ;I $P($G(^PSDRUG(DLOOP,2)),"^",3)'[TYPE S PSSX(1)="-1^Drug not marked for application" Q
+9 SET PSSTRN=$PIECE($GET(^PSDRUG(DLOOP,"DOS")),"^")
SET PSSUNITZ=$PIECE($GET(^("DOS")),"^",2)
+10 SET PSSUNITX=$SELECT($PIECE($GET(^PS(50.607,+$GET(PSSUNITZ),0)),"^")'=""&($PIECE($GET(^(0)),"^")'["/"):$PIECE($GET(^(0)),"^"),1:"")
+11 SET PSSDSE=+$PIECE($GET(^PS(50.7,POPD,0)),"^",2)
SET PSSVERB=$PIECE($GET(^PS(50.606,PSSDSE,"MISC")),"^")
SET PSSPREP=$PIECE($GET(^("MISC")),"^",3)
+12 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)),"^")
+13 SET (PSSDOSE,PSSUNTS,PSSUDOS)=""
+14 SET PSSUNTS=$PIECE($GET(^PS(50.607,+$PIECE($GET(^PSDRUG(DLOOP,"DOS")),"^",2),0)),"^")
+15 SET PSSUDOS=$GET(PSSUPD)
+16 SET PSSDOSE=PSSUDOS*+PSSTRN
+17 IF $GET(PSSTRN)=""!('$GET(PSSUNITZ))
DO SET
DO LEAD^PSSORPH
QUIT
+18 IF '$GET(PSSDOSE)!('$GET(PSSUDOS))
DO SET
DO LEAD^PSSORPH
QUIT
+19 SET DCNT1=1
+20 DO PARN^PSSORPH
+21 SET PSSX(DCNT1)=PSSDOSE_"^"_$SELECT($GET(TYPE)="O":$GET(PSSUNITZ),1:$GET(PSSUNTS))_"^"_PSSUDOS_"^"_DLOOP_"^"_$GET(PSSTRN)_"^"_$SELECT($GET(PSSNP)'="":$GET(PSSNP),1:$GET(PSNNN))_"^"_...
... $PIECE($GET(^PS(50.606,+$GET(PSSDSE),0)),"^")_"^"_$GET(PSSVERB)_"^"_$GET(PSSPREP)
KILL PSSNP
+22 SET PSSA=1
DO SLS^PSSORPH
+23 SET (PSIEN,DLOOP)=+$PIECE(PSSX(PSSA),"^",4)
KILL PSSMAX
if $GET(TYPE)["O"
DO MAX^PSSORPH
+24 SET PSSX("DD",PSIEN)=$PIECE($GET(^PSDRUG(PSIEN,0)),"^")_"^"_$PIECE($GET(^(660)),"^",6)_"^"_$PIECE($GET(^(0)),"^",9)_"^"_$PIECE($GET(^(660)),"^",8)_"^"_$PIECE($GET(^("DOS")),"^")_"^"_$GET(PSSUNITX)_"^"_$GET(PSSMAX)
+25 DO REQS^PSSORPH
SET PSSX("DD",PSIEN)=PSSX("DD",PSIEN)_"^"_$GET(PSSREQS)_"^"_$GET(PSNNN)_"^"_$GET(PSSVERB)
+26 DO LEAD^PSSORPH
+27 QUIT
SET ;
+1 DO PARN^PSSORPH
+2 SET PSSX(1)="^"_$SELECT($GET(TYPE)="O":$GET(PSSUNITZ),1:$GET(PSSUNTS))_"^^"_DLOOP_"^"_$GET(PSSTRN)_"^"_$SELECT($GET(PSSNP)'="":$GET(PSSNP),1:$GET(PSNNN))_"^"_$PIECE($GET(^PS(50.606,+$GET(PSSDSE),0)),"^")_"^"_$GET(PSSVERB)_"^"_$GET(PSSPREP)
KILL PSSNP
+3 SET (PSIEN,DLOOP)=+$PIECE(PSSX(1),"^",4)
KILL PSSMAX
if $GET(TYPE)["O"
DO MAX^PSSORPH
+4 SET PSSX("DD",PSIEN)=$PIECE($GET(^PSDRUG(PSIEN,0)),"^")_"^"_$PIECE($GET(^(660)),"^",6)_"^"_$PIECE($GET(^(0)),"^",9)_"^"_$PIECE($GET(^(660)),"^",8)_"^"_$PIECE($GET(^("DOS")),"^")_"^"_$GET(PSSUNITX)_"^"_$GET(PSSMAX)
+5 DO REQS^PSSORPH
SET PSSX("DD",PSIEN)=PSSX("DD",PSIEN)_"^"_$GET(PSSREQS)_"^"_$GET(PSNNN)_"^"_$GET(PSSVERB)
+6 QUIT
AMP ;Replace & with AND when returning local doses to CPRS
+1 NEW PSSAB,PSSABT,PSSABA,PSSABL,PSSABZ,PSSABX,PSSABF1,PSSABF2
+2 IF PSLOCV="&"
SET PSLOCV=" AND "
QUIT
+3 IF $EXTRACT(PSLOCV,1)="&"
Begin DoDot:1
+4 IF $EXTRACT(PSLOCV,2)=" "
SET PSLOCV=" AND"_$EXTRACT(PSLOCV,2,999)
QUIT
+5 SET PSLOCV=" AND "_$EXTRACT(PSLOCV,2,999)
End DoDot:1
+6 SET PSSABL=$LENGTH(PSLOCV)
+7 IF $EXTRACT(PSLOCV,PSSABL)="&"
Begin DoDot:1
+8 IF $EXTRACT(PSLOCV,(PSSABL-1))=" "
SET PSLOCV=$EXTRACT(PSLOCV,1,(PSSABL-1))_"AND "
QUIT
+9 SET PSLOCV=$EXTRACT(PSLOCV,1,(PSSABL-1))_" AND "
End DoDot:1
+10 if $GET(PSLOCV)'["&"
QUIT
+11 SET PSSABT=0
+12 FOR PSSAB=1:1:$LENGTH(PSLOCV)
IF $EXTRACT(PSLOCV,PSSAB)="&"
SET PSSABT=PSSABT+1
+13 FOR PSSAB=1:1:(PSSABT+1)
SET PSSABA(PSSAB)=$PIECE(PSLOCV,"&")
SET PSLOCV=$PIECE(PSLOCV,"&",2,999)
+14 FOR PSSABZ=1:1:PSSABT
Begin DoDot:1
+15 KILL PSSABF1,PSSABF2
+16 IF $LENGTH($GET(PSSABA(PSSABZ)))>0
SET PSSABF1=$EXTRACT(PSSABA(PSSABZ),$LENGTH(PSSABA(PSSABZ)))
+17 IF $DATA(PSSABA(PSSABZ+1))
SET PSSABF2=$EXTRACT(PSSABA(PSSABZ+1),1)
+18 SET PSSABA(PSSABZ)=PSSABA(PSSABZ)_$SELECT($GET(PSSABF1)=" ":"AND",1:" AND")_$SELECT($GET(PSSABF2)=" ":"",1:" ")
End DoDot:1
+19 KILL PSLOCV
FOR PSSABX=1:1:(PSSABT+1)
SET PSLOCV=$GET(PSLOCV)_$GET(PSSABA(PSSABX))
+20 QUIT
