Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: PSSORPH

PSSORPH.m

Go to the documentation of this file.
  1. PSSORPH ;BIR/RSB/RTR-Dosage choices by Dispense Drug ; 8/31/12 1:57pm
  1. ;;1.0;PHARMACY DATA MANAGEMENT;**34,38,49,69,150**;9/30/97;Build 2
  1. ;Reference to ^PS(50.607 supported by DBIA 2221
  1. ;Reference to ^YSCL(603.01 supported by DBIA 2697
  1. ;Reference to ^PSNAPIS supported by DBIA 2531
  1. ;
  1. DOSE(PSSX,PD,TYPE,PSSDFN,PSSUPD) ;
  1. K PSSX
  1. ; PSSX - Target variable for returned data
  1. ; PD - Pharmacy Dispense Drug
  1. ; TYPE - Type of Drug (O:Outpt, U:Unit Dose, I:IV, X:Non-VA Med)
  1. ; PSSDFN - Patient IEN
  1. ; PSSUPD - Units per Dose
  1. 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,POPD,PSSUNITZ,PSSLDV,PSSLDN,PSSUNITX
  1. N PSSDOSE,PSSUNTS,PSSUDOS,PSSMD,PSSMD1,PSSMDN,PSSBC,PSSOLDN
  1. S POPD=+$P($G(^PSDRUG(PD,2)),"^")
  1. S PSSOIU=$S(TYPE="I":1,TYPE="U":1,1:0)
  1. I $G(PSSUPD) G ^PSSORPH1
  1. S DLOOP=PD D
  1. .Q:'$O(^PSDRUG(DLOOP,"DOS1",0))
  1. .S PSSTRN=$P($G(^PSDRUG(DLOOP,"DOS")),"^"),PSSUNITZ=$P($G(^("DOS")),"^",2) Q:PSSTRN=""
  1. .S PSSUNITX=$S($P($G(^PS(50.607,+$G(PSSUNITZ),0)),"^")'=""&($P($G(^(0)),"^")'["/"):$P($G(^(0)),"^"),1:"")
  1. .Q:$G(^PSDRUG(DLOOP,"I"))]""&($G(^("I"))'>DT) ; omit inactive drugs
  1. .;Q:$P($G(^PSDRUG(DLOOP,2)),"^",3)'[TYPE
  1. .S PSSDSE=+$P($G(^PS(50.7,POPD,0)),"^",2),PSSVERB=$P($G(^PS(50.606,PSSDSE,"MISC")),"^"),PSSPREP=$P($G(^("MISC")),"^",3)
  1. .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)),"^")
  1. .; Set each possible dose node
  1. .F DLOOP1=0:0 S DLOOP1=$O(^PSDRUG(DLOOP,"DOS1",DLOOP1)) Q:'DLOOP1 D
  1. ..Q:'$D(^PSDRUG(DLOOP,"DOS1",DLOOP1,0))
  1. ..I PSSOIU,$P($G(^PSDRUG(DLOOP,"DOS1",DLOOP1,0)),"^",3)'["I" Q
  1. ..I 'PSSOIU,$P($G(^PSDRUG(DLOOP,"DOS1",DLOOP1,0)),"^",3)'["O" Q
  1. ..S (PSSDOSE,PSSUNTS,PSSUDOS,PSSBC)=""
  1. ..S PSSDOSE=$P($G(^PSDRUG(DLOOP,"DOS1",DLOOP1,0)),"^",2)
  1. ..S PSSUNTS=$P($G(^PS(50.607,+$P($G(^PSDRUG(DLOOP,"DOS")),"^",2),0)),"^")
  1. ..S PSSUDOS=$P($G(^PSDRUG(DLOOP,"DOS1",DLOOP1,0)),"^"),PSSBC=$P($G(^(0)),"^",4)
  1. ..I PSSDOSE]""&(PSSUDOS]"") D
  1. ...S DCNT1=$S('$D(DCNT1):1,1:DCNT1+1)
  1. ...S LOW(PSSDOSE,PSSUDOS,DCNT1)=""
  1. ...S FORM(PSSDOSE,$S($P($G(^PSDRUG(DLOOP,0)),"^",9)=1:1,1:0),DCNT1)=PSSUDOS
  1. ...D PARN
  1. ...S PSSX(DCNT1)=PSSDOSE_"^"_$S("OX"[$G(TYPE):$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)
  1. ...S PSSX(DCNT1)=PSSX(DCNT1)_$S("OX"'[$G(TYPE):"^^^"_$G(PSSBC),1:"")
  1. ...K PSSNP,PSSBC
  1. I '$O(PSSX(0)) G DOSE2
  1. ; delete non-formulary doses if formulary doses exist
  1. S PSSLOW="" F S PSSLOW=$O(FORM(PSSLOW)) Q:PSSLOW="" D
  1. .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)
  1. ;Find lowest units per dose
  1. S PSSLOW="" F S PSSLOW=$O(LOW(PSSLOW)) Q:PSSLOW="" D
  1. .S PSOLC=0 S PSSLOW1="" F S PSSLOW1=$O(LOW(PSSLOW,PSSLOW1)) Q:PSSLOW1="" D
  1. ..S PSOLC=PSOLC+1 S:PSOLC=1 PSSLOW4=$O(LOW(PSSLOW,PSSLOW1,0))
  1. ..S PSSLOW2="" F S PSSLOW2=$O(LOW(PSSLOW,PSSLOW1,PSSLOW2)) Q:PSSLOW2="" D
  1. ...I PSOLC>1 S PSSX(PSSLOW4,(PSOLC-1))=PSSX(PSSLOW2) K PSSX(PSSLOW2)
  1. 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
  1. .S PL2="" F S PL2=$O(PSSX(PL,PL2)) Q:PL2="" S PSSHOLD($P(PSSX(PL,PL2),"^"),PL,PL2)=PSSX(PL,PL2)
  1. 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),"^",4))) D:$O(PSSHOLD(PSSZ,PSSC,0)) MULTI S PSSA=PSSA+1
  1. .S (PSIEN,DLOOP)=+$P(PSSX(PSSA),"^",4) K PSSMAX D:$G(TYPE)["O" MAX
  1. .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)
  1. .D REQS S PSSX("DD",PSIEN)=PSSX("DD",PSIEN)_"^"_$G(PSSREQS)_"^"_$G(PSNNN)_"^"_$G(PSSVERB)_"^"_1
  1. K PSSHOLD
  1. D LEADP^PSSUTLA1
  1. Q
  1. DOSE2 ;Local Dose
  1. N PSOCT,PSONDS,PSOND,PSOND1,PSONDX,PSONDU,PSODOS,PSLOC,PSLOCV,PSODUPD
  1. S PSOCT=1
  1. S DLOOP=PD D
  1. .I $P($G(^PSDRUG(DLOOP,"I")),"^"),+$P($G(^("I")),"^")<DT Q
  1. .;Q:$P($G(^PSDRUG(DLOOP,2)),"^",3)'[TYPE
  1. .Q:'$O(^PSDRUG(DLOOP,"DOS2",0))
  1. .S PSONDS=$P($G(^PSDRUG(DLOOP,"DOS")),"^"),PSONDU=$P($G(^("DOS")),"^",2),PSOND=$P($G(^("ND")),"^",3),PSOND1=$P($G(^("ND")),"^")
  1. .I PSOND,PSOND1 I PSONDS=""!('PSONDU) S PSONDX=$$DFSU^PSNAPIS(PSOND1,PSOND)
  1. .I PSONDS="",PSOND,PSOND1 S PSONDS=$P($G(PSONDX),"^",4)
  1. .I 'PSONDU,PSOND,PSOND1 S PSONDU=$P($G(PSONDX),"^",5)
  1. .S PSODOS=+$P($G(^PS(50.7,POPD,0)),"^",2)
  1. .;LOOK IN DOS2 NODE FOR LOCAL DOSES
  1. .F PSLOC=0:0 S PSLOC=$O(^PSDRUG(DLOOP,"DOS2",PSLOC)) Q:'PSLOC D
  1. ..S PSLOCV=$P($G(^PSDRUG(DLOOP,"DOS2",PSLOC,0)),"^") Q:PSLOCV=""
  1. ..S PSSBC=$P($G(^PSDRUG(DLOOP,"DOS2",PSLOC,0)),"^",3)
  1. ..S PSSOLDN=$P($G(^PSDRUG(DLOOP,"DOS2",PSLOC,0)),"^",4)
  1. ..I PSSOIU,$P($G(^PSDRUG(DLOOP,"DOS2",PSLOC,0)),"^",2)'["I" Q
  1. ..I 'PSSOIU,$P($G(^PSDRUG(DLOOP,"DOS2",PSLOC,0)),"^",2)'["O" Q
  1. ..D SET2
  1. ;IF NO LOCAL DOSES, RETURN ANY DRUGS YOU CAN
  1. K PSSBC,PSSOLDN
  1. I '$O(PSSX(0)) K PSLOCV S PSOCT=1 D
  1. .S DLOOP=PD D
  1. ..I $P($G(^PSDRUG(DLOOP,"I")),"^"),+$P($G(^("I")),"^")<DT Q
  1. ..;Q:$P($G(^PSDRUG(DLOOP,2)),"^",3)'[TYPE
  1. ..S PSONDS=$P($G(^PSDRUG(DLOOP,"DOS")),"^"),PSONDU=$P($G(^("DOS")),"^",2),PSOND=$P($G(^("ND")),"^",3),PSOND1=$P($G(^("ND")),"^")
  1. ..K PSONDX I PSOND,PSOND1 I PSONDS=""!('PSONDU) S PSONDX=$$DFSU^PSNAPIS(PSOND1,PSOND)
  1. ..I PSONDS="",PSOND,PSOND1 S PSONDS=$P($G(PSONDX),"^",4)
  1. ..I 'PSONDU,PSOND,PSOND1 S PSONDU=$P($G(PSONDX),"^",5)
  1. ..S PSODOS=+$P($G(^PS(50.7,POPD,0)),"^",2)
  1. ..D SET2
  1. D LEADP^PSSUTLA1
  1. Q
  1. SET2 ;
  1. D ZSET
  1. I $G(PSLOCV)'="",$G(PSLOCV)["&" D AMP^PSSORPH1
  1. S PSSX(PSOCT)="^"_$S($G(PSONDU)=0:"",1:$G(PSONDU))_"^"_$G(PSLOCV)_"^"_DLOOP_"^"_$G(PSONDS)_"^"_$G(PSSLDN)_"^"_$P($G(^PS(50.606,+$G(PSODOS),0)),"^")_"^"_$P($G(^("MISC")),"^")_"^"_$P($G(^("MISC")),"^",3)
  1. S PSSX(PSOCT)=PSSX(PSOCT)_"^"_$P($G(^PS(50.606,+$G(PSODOS),"MISC")),"^",4)_$S("OX"'[$G(TYPE):"^^"_$G(PSSBC),1:"")
  1. S $P(PSSX(PSOCT),"^",13)=$G(PSSOLDN)
  1. I '$D(PSSX("DD",DLOOP)) D
  1. .D REQS
  1. .K PSSMAX I $G(TYPE)["O" D MAX
  1. .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:"")_"^"_$G(PSSMAX)_"^"_$G(PSSREQS)
  1. .S PSSX("DD",DLOOP)=PSSX("DD",DLOOP)_"^"_$G(PSSLDN)_"^"_$G(PSSLDV)_"^"_0
  1. S PSOCT=PSOCT+1
  1. Q
  1. ZSET ;
  1. K PSSLDN,PSSLNV
  1. S PSSLDV=$P($G(^PS(50.606,+$G(PSODOS),"MISC")),"^")
  1. ;K PSSLDN F PSSLDNN=0:0 S PSSLDNN=$O(^PS(50.606,+$G(PSODOS),"NOUN",PSSLDNN)) Q:'PSSLDNN!($D(PSSLDN)) S:$P($G(^(PSSLDNN,0)),"^")'="" PSSLDN=$P($G(^(0)),"^")
  1. K PSSLDNN
  1. Q
  1. MAX ;
  1. K PSSMAX S PSSDEA=$P($G(^PSDRUG(DLOOP,0)),"^",3)
  1. I PSSDEA["1"!(PSSDEA["2") S PSSMAX=0 Q
  1. I PSSDEA["A",PSSDEA'["B" S PSSMAX=0 Q
  1. I $P($G(^PSDRUG(DLOOP,"CLOZ1")),"^")="PSOCLO1",$G(PSSDFN) D Q
  1. .S PSSCLO=$O(^YSCL(603.01,"C",PSSDFN,0)) I PSSCLO,$P($G(^YSCL(603.01,+PSSCLO,0)),"^",3)="B" S PSSMAX=1 Q
  1. .S PSSMAX=0
  1. I PSSDEA["3"!(PSSDEA["4")!(PSSDEA["5") S PSSMAX=5 Q
  1. S PSSMAX=11
  1. Q
  1. SLS ;Convert dosage with /
  1. Q:'$D(PSSX(PSSA))
  1. ;*150 Correct Slash dosages
  1. K PSSDZUNT
  1. N PSSF,PSSF1,PSSF2,PSSG,PSSFA,PSSFA1,PSSFB,PSSFB1,PSSDZI,PSSDZSL,PSSDZND,PSSDZSL1,PSSDZSL2,PSSDZSL3,PSSDZSL4,PSSDZSL5,PSSDZ50,PSSGIEN
  1. S PSSF=$P($G(PSSX(PSSA)),"^"),PSSG=$P($G(PSSX(PSSA)),"^",2)
  1. I $G(^PS(50.607,PSSG,0))]"" S PSSGIEN=PSSG,PSSG=$P($G(^PS(50.607,PSSG,0)),"^")
  1. I PSSG'["/" S $P(PSSX(PSSA),"^",11)=$P($G(PSSX(PSSA)),"^")_$G(PSSUNTS) Q
  1. S PSSDZSL=0,PSSDZI=+$P($G(PSSX(PSSA)),"^",4),PSSDZ50=$P($G(^PSDRUG(PSSDZI,"DOS")),"^")
  1. 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
  1. S PSSFA=$P(PSSG,"/"),PSSFB=$P(PSSG,"/",2),PSSFA1=+$G(PSSFA),PSSFB1=+$G(PSSFB)
  1. I '$G(PSSDZND) S $P(PSSX(PSSA),"^",11)=$P(PSSX(PSSA),"^") G SLSQ
  1. 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))
  1. S PSSF2=$S('$G(PSSFA1):PSSF,1:($G(PSSFA1)*PSSF))_$S($G(PSSFA1):$P(PSSFA,PSSFA1,2),1:PSSFA)_"/"_$G(PSSDZSL5)
  1. ;S PSSDZUNT=$P(PSSG,"/")_"/"_$G(PSSDZSL4)_$S('$G(PSSFB1):$G(PSSFB),1:$P(PSSFB,PSSFB1,2)) S $P(PSSX(PSSA),"^",2)=PSSDZUNT
  1. S PSSDZUNT=$P(PSSG,"/")_"/"_$G(PSSDZSL4)_$S('$G(PSSFB1):$G(PSSFB),1:$P(PSSFB,PSSFB1,2)) S $P(PSSX(PSSA),"^",2)=PSSDZUNT
  1. S $P(PSSX(PSSA),"^",11)=PSSF2
  1. S:$G(PSSGIEN) $P(PSSX(PSSA),"^",2)=PSSGIEN
  1. SLSQ K PSSDZUNT
  1. Q
  1. REQS ;Schedule requirement flag
  1. N PSSRF,PSSRFX,PSSRFZ
  1. S PSSREQS=1
  1. ;No longer needed
  1. Q
  1. MULTI ;
  1. S PL3="" F S PL3=$O(PSSHOLD(PSSZ,PSSC,PL3)) Q:PL3="" S PSSX(PSSA,PL3)=PSSHOLD(PSSZ,PSSC,PL3) D:'$D(PSSX("DD",+$P(PSSX(PSSA,PL3),"^",4)))
  1. .S (PSIEN,DLOOP)=+$P(PSSX(PSSA,PL3),"^",4) K PSSMAX D:$G(TYPE)["O" MAX
  1. .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)
  1. .D REQS S PSSX("DD",PSIEN)=PSSX("DD",PSIEN)_"^"_$G(PSSREQS)_"^"_$G(PSNNN)_"^"_$G(PSSVERB)_"^"_1
  1. Q
  1. PARN ;
  1. N PSSNPL K PSSNP
  1. Q:$G(PSNNN)=""
  1. Q:$L(PSNNN)'>3
  1. S PSSNPL=$E(PSNNN,($L(PSNNN)-2),$L(PSNNN))
  1. I $G(PSSNPL)="(S)"!($G(PSSNPL)="(s)") D
  1. .I $G(PSSUDOS)'>1 S PSSNP=$E(PSNNN,1,($L(PSNNN)-3))
  1. .I $G(PSSUDOS)>1 S PSSNP=$E(PSNNN,1,($L(PSNNN)-3))_$E(PSSNPL,2)
  1. Q
  1. LEAD ;Add leading zeros
  1. F PSSMD=0:0 S PSSMD=$O(PSSX(PSSMD)) Q:'PSSMD D
  1. .F PSSMDN=1,5,11 I $E($P(PSSX(PSSMD),"^",PSSMDN),1)="." S $P(PSSX(PSSMD),"^",PSSMDN)="0"_$P(PSSX(PSSMD),"^",PSSMDN)
  1. .I $O(PSSX(PSSMD,0)) D
  1. ..F PSSMD1=0:0 S PSSMD1=$O(PSSX(PSSMD,PSSMD1)) Q:'PSSMD1 D
  1. ...F PSSMDN=1,5,11 I $E($P(PSSX(PSSMD,PSSMD1),"^",PSSMDN),1)="." S $P(PSSX(PSSMD,PSSMD1),"^",PSSMDN)="0"_$P(PSSX(PSSMD,PSSMD1),"^",PSSMDN)
  1. S PSSMD="" F S PSSMD=$O(PSSX("DD",PSSMD)) Q:PSSMD="" D
  1. .I $E($P(PSSX("DD",PSSMD),"^",5),1)="." S $P(PSSX("DD",PSSMD),"^",5)="0"_$P(PSSX("DD",PSSMD),"^",5)
  1. Q