- PSSORPH ;BIR/RSB/RTR-Dosage choices by Dispense Drug ; 8/31/12 1:57pm
- ;;1.0;PHARMACY DATA MANAGEMENT;**34,38,49,69,150**;9/30/97;Build 2
- ;Reference to ^PS(50.607 supported by DBIA 2221
- ;Reference to ^YSCL(603.01 supported by DBIA 2697
- ;Reference to ^PSNAPIS supported by DBIA 2531
- ;
- DOSE(PSSX,PD,TYPE,PSSDFN,PSSUPD) ;
- K PSSX
- ; PSSX - Target variable for returned data
- ; PD - Pharmacy Dispense Drug
- ; TYPE - Type of Drug (O:Outpt, U:Unit Dose, I:IV, X:Non-VA Med)
- ; PSSDFN - Patient IEN
- ; PSSUPD - Units per Dose
- 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
- N PSSDOSE,PSSUNTS,PSSUDOS,PSSMD,PSSMD1,PSSMDN,PSSBC,PSSOLDN
- S POPD=+$P($G(^PSDRUG(PD,2)),"^")
- S PSSOIU=$S(TYPE="I":1,TYPE="U":1,1:0)
- I $G(PSSUPD) G ^PSSORPH1
- S DLOOP=PD D
- .Q:'$O(^PSDRUG(DLOOP,"DOS1",0))
- .S PSSTRN=$P($G(^PSDRUG(DLOOP,"DOS")),"^"),PSSUNITZ=$P($G(^("DOS")),"^",2) Q:PSSTRN=""
- .S PSSUNITX=$S($P($G(^PS(50.607,+$G(PSSUNITZ),0)),"^")'=""&($P($G(^(0)),"^")'["/"):$P($G(^(0)),"^"),1:"")
- .Q:$G(^PSDRUG(DLOOP,"I"))]""&($G(^("I"))'>DT) ; omit inactive drugs
- .;Q:$P($G(^PSDRUG(DLOOP,2)),"^",3)'[TYPE
- .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)),"^")
- .; Set each possible dose node
- .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,PSSBC)=""
- ..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)),"^"),PSSBC=$P($G(^(0)),"^",4)
- ..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_"^"_$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)
- ...S PSSX(DCNT1)=PSSX(DCNT1)_$S("OX"'[$G(TYPE):"^^^"_$G(PSSBC),1:"")
- ...K PSSNP,PSSBC
- I '$O(PSSX(0)) G DOSE2
- ; delete non-formulary doses if formulary doses exist
- 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),"^",4))) D:$O(PSSHOLD(PSSZ,PSSC,0)) MULTI S PSSA=PSSA+1
- .S (PSIEN,DLOOP)=+$P(PSSX(PSSA),"^",4) 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")),"^")_"^"_$G(PSSUNITX)_"^"_$G(PSSMAX)
- .D REQS S PSSX("DD",PSIEN)=PSSX("DD",PSIEN)_"^"_$G(PSSREQS)_"^"_$G(PSNNN)_"^"_$G(PSSVERB)_"^"_1
- K PSSHOLD
- D LEADP^PSSUTLA1
- Q
- DOSE2 ;Local Dose
- N PSOCT,PSONDS,PSOND,PSOND1,PSONDX,PSONDU,PSODOS,PSLOC,PSLOCV,PSODUPD
- S PSOCT=1
- S DLOOP=PD D
- .I $P($G(^PSDRUG(DLOOP,"I")),"^"),+$P($G(^("I")),"^")<DT Q
- .;Q:$P($G(^PSDRUG(DLOOP,2)),"^",3)'[TYPE
- .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,POPD,0)),"^",2)
- .;LOOK IN DOS2 NODE 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=""
- ..S PSSBC=$P($G(^PSDRUG(DLOOP,"DOS2",PSLOC,0)),"^",3)
- ..S PSSOLDN=$P($G(^PSDRUG(DLOOP,"DOS2",PSLOC,0)),"^",4)
- ..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, RETURN ANY DRUGS YOU CAN
- K PSSBC,PSSOLDN
- I '$O(PSSX(0)) K PSLOCV S PSOCT=1 D
- .S DLOOP=PD D
- ..I $P($G(^PSDRUG(DLOOP,"I")),"^"),+$P($G(^("I")),"^")<DT Q
- ..;Q:$P($G(^PSDRUG(DLOOP,2)),"^",3)'[TYPE
- ..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,POPD,0)),"^",2)
- ..D SET2
- D LEADP^PSSUTLA1
- Q
- SET2 ;
- D ZSET
- I $G(PSLOCV)'="",$G(PSLOCV)["&" D AMP^PSSORPH1
- 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)
- S PSSX(PSOCT)=PSSX(PSOCT)_"^"_$P($G(^PS(50.606,+$G(PSODOS),"MISC")),"^",4)_$S("OX"'[$G(TYPE):"^^"_$G(PSSBC),1:"")
- S $P(PSSX(PSOCT),"^",13)=$G(PSSOLDN)
- 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:"")_"^"_$G(PSSMAX)_"^"_$G(PSSREQS)
- .S PSSX("DD",DLOOP)=PSSX("DD",DLOOP)_"^"_$G(PSSLDN)_"^"_$G(PSSLDV)_"^"_0
- S PSOCT=PSOCT+1
- Q
- ZSET ;
- K PSSLDN,PSSLNV
- S PSSLDV=$P($G(^PS(50.606,+$G(PSODOS),"MISC")),"^")
- ;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)),"^")
- K PSSLDNN
- 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 ;Convert dosage with /
- Q:'$D(PSSX(PSSA))
- ;*150 Correct Slash dosages
- K PSSDZUNT
- N PSSF,PSSF1,PSSF2,PSSG,PSSFA,PSSFA1,PSSFB,PSSFB1,PSSDZI,PSSDZSL,PSSDZND,PSSDZSL1,PSSDZSL2,PSSDZSL3,PSSDZSL4,PSSDZSL5,PSSDZ50,PSSGIEN
- S PSSF=$P($G(PSSX(PSSA)),"^"),PSSG=$P($G(PSSX(PSSA)),"^",2)
- I $G(^PS(50.607,PSSG,0))]"" S PSSGIEN=PSSG,PSSG=$P($G(^PS(50.607,PSSG,0)),"^")
- I PSSG'["/" S $P(PSSX(PSSA),"^",11)=$P($G(PSSX(PSSA)),"^")_$G(PSSUNTS) Q
- S PSSDZSL=0,PSSDZI=+$P($G(PSSX(PSSA)),"^",4),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),"^",11)=$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)
- ;S PSSDZUNT=$P(PSSG,"/")_"/"_$G(PSSDZSL4)_$S('$G(PSSFB1):$G(PSSFB),1:$P(PSSFB,PSSFB1,2)) S $P(PSSX(PSSA),"^",2)=PSSDZUNT
- 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),"^",11)=PSSF2
- S:$G(PSSGIEN) $P(PSSX(PSSA),"^",2)=PSSGIEN
- SLSQ K PSSDZUNT
- Q
- REQS ;Schedule requirement flag
- N PSSRF,PSSRFX,PSSRFZ
- S PSSREQS=1
- ;No longer needed
- Q
- MULTI ;
- 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)))
- .S (PSIEN,DLOOP)=+$P(PSSX(PSSA,PL3),"^",4) 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")),"^")_"^"_$G(PSSUNITX)_"^"_$G(PSSMAX)
- .D REQS S PSSX("DD",PSIEN)=PSSX("DD",PSIEN)_"^"_$G(PSSREQS)_"^"_$G(PSNNN)_"^"_$G(PSSVERB)_"^"_1
- 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 PSSMD=0:0 S PSSMD=$O(PSSX(PSSMD)) Q:'PSSMD D
- .F PSSMDN=1,5,11 I $E($P(PSSX(PSSMD),"^",PSSMDN),1)="." S $P(PSSX(PSSMD),"^",PSSMDN)="0"_$P(PSSX(PSSMD),"^",PSSMDN)
- .I $O(PSSX(PSSMD,0)) D
- ..F PSSMD1=0:0 S PSSMD1=$O(PSSX(PSSMD,PSSMD1)) Q:'PSSMD1 D
- ...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)
- S PSSMD="" F S PSSMD=$O(PSSX("DD",PSSMD)) Q:PSSMD="" D
- .I $E($P(PSSX("DD",PSSMD),"^",5),1)="." S $P(PSSX("DD",PSSMD),"^",5)="0"_$P(PSSX("DD",PSSMD),"^",5)
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSSORPH 10269 printed Jan 18, 2025@03:34:07 Page 2
- 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
- +2 ;Reference to ^PS(50.607 supported by DBIA 2221
- +3 ;Reference to ^YSCL(603.01 supported by DBIA 2697
- +4 ;Reference to ^PSNAPIS supported by DBIA 2531
- +5 ;
- DOSE(PSSX,PD,TYPE,PSSDFN,PSSUPD) ;
- +1 KILL PSSX
- +2 ; PSSX - Target variable for returned data
- +3 ; PD - Pharmacy Dispense Drug
- +4 ; TYPE - Type of Drug (O:Outpt, U:Unit Dose, I:IV, X:Non-VA Med)
- +5 ; PSSDFN - Patient IEN
- +6 ; PSSUPD - Units per Dose
- +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,POPD,PSSUNITZ,PSSLDV,PSSLDN,PSSUNITX
- +8 NEW PSSDOSE,PSSUNTS,PSSUDOS,PSSMD,PSSMD1,PSSMDN,PSSBC,PSSOLDN
- +9 SET POPD=+$PIECE($GET(^PSDRUG(PD,2)),"^")
- +10 SET PSSOIU=$SELECT(TYPE="I":1,TYPE="U":1,1:0)
- +11 IF $GET(PSSUPD)
- GOTO ^PSSORPH1
- +12 SET DLOOP=PD
- Begin DoDot:1
- +13 if '$ORDER(^PSDRUG(DLOOP,"DOS1",0))
- QUIT
- +14 SET PSSTRN=$PIECE($GET(^PSDRUG(DLOOP,"DOS")),"^")
- SET PSSUNITZ=$PIECE($GET(^("DOS")),"^",2)
- if PSSTRN=""
- QUIT
- +15 SET PSSUNITX=$SELECT($PIECE($GET(^PS(50.607,+$GET(PSSUNITZ),0)),"^")'=""&($PIECE($GET(^(0)),"^")'["/"):$PIECE($GET(^(0)),"^"),1:"")
- +16 ; omit inactive drugs
- if $GET(^PSDRUG(DLOOP,"I"))]""&($GET(^("I"))'>DT)
- QUIT
- +17 ;Q:$P($G(^PSDRUG(DLOOP,2)),"^",3)'[TYPE
- +18 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)
- +19 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)),"^")
- +20 ; Set each possible dose node
- +21 FOR DLOOP1=0:0
- SET DLOOP1=$ORDER(^PSDRUG(DLOOP,"DOS1",DLOOP1))
- if 'DLOOP1
- QUIT
- Begin DoDot:2
- +22 if '$DATA(^PSDRUG(DLOOP,"DOS1",DLOOP1,0))
- QUIT
- +23 IF PSSOIU
- IF $PIECE($GET(^PSDRUG(DLOOP,"DOS1",DLOOP1,0)),"^",3)'["I"
- QUIT
- +24 IF 'PSSOIU
- IF $PIECE($GET(^PSDRUG(DLOOP,"DOS1",DLOOP1,0)),"^",3)'["O"
- QUIT
- +25 SET (PSSDOSE,PSSUNTS,PSSUDOS,PSSBC)=""
- +26 SET PSSDOSE=$PIECE($GET(^PSDRUG(DLOOP,"DOS1",DLOOP1,0)),"^",2)
- +27 SET PSSUNTS=$PIECE($GET(^PS(50.607,+$PIECE($GET(^PSDRUG(DLOOP,"DOS")),"^",2),0)),"^")
- +28 SET PSSUDOS=$PIECE($GET(^PSDRUG(DLOOP,"DOS1",DLOOP1,0)),"^")
- SET PSSBC=$PIECE($GET(^(0)),"^",4)
- +29 IF PSSDOSE]""&(PSSUDOS]"")
- Begin DoDot:3
- +30 SET DCNT1=$SELECT('$DATA(DCNT1):1,1:DCNT1+1)
- +31 SET LOW(PSSDOSE,PSSUDOS,DCNT1)=""
- +32 SET FORM(PSSDOSE,$SELECT($PIECE($GET(^PSDRUG(DLOOP,0)),"^",9)=1:1,1:0),DCNT1)=PSSUDOS
- +33 DO PARN
- +34 SET PSSX(DCNT1)=PSSDOSE_"^"_$SELECT("OX"[$GET(TYPE):$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)
- +35 SET PSSX(DCNT1)=PSSX(DCNT1)_$SELECT("OX"'[$GET(TYPE):"^^^"_$GET(PSSBC),1:"")
- +36 KILL PSSNP,PSSBC
- End DoDot:3
- End DoDot:2
- End DoDot:1
- +37 IF '$ORDER(PSSX(0))
- GOTO DOSE2
- +38 ; delete non-formulary doses if formulary doses exist
- +39 SET PSSLOW=""
- FOR
- SET PSSLOW=$ORDER(FORM(PSSLOW))
- if PSSLOW=""
- QUIT
- Begin DoDot:1
- +40 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
- +41 ;Find lowest units per dose
- +42 SET PSSLOW=""
- FOR
- SET PSSLOW=$ORDER(LOW(PSSLOW))
- if PSSLOW=""
- QUIT
- Begin DoDot:1
- +43 SET PSOLC=0
- SET PSSLOW1=""
- FOR
- SET PSSLOW1=$ORDER(LOW(PSSLOW,PSSLOW1))
- if PSSLOW1=""
- QUIT
- Begin DoDot:2
- +44 SET PSOLC=PSOLC+1
- if PSOLC=1
- SET PSSLOW4=$ORDER(LOW(PSSLOW,PSSLOW1,0))
- +45 SET PSSLOW2=""
- FOR
- SET PSSLOW2=$ORDER(LOW(PSSLOW,PSSLOW1,PSSLOW2))
- if PSSLOW2=""
- QUIT
- Begin DoDot:3
- +46 IF PSOLC>1
- SET PSSX(PSSLOW4,(PSOLC-1))=PSSX(PSSLOW2)
- KILL PSSX(PSSLOW2)
- End DoDot:3
- End DoDot:2
- End DoDot:1
- +47 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
- +48 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
- +49 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),"^",4)))
- Begin DoDot:1
- +50 SET (PSIEN,DLOOP)=+$PIECE(PSSX(PSSA),"^",4)
- KILL PSSMAX
- if $GET(TYPE)["O"
- DO MAX
- +51 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)
- +52 DO REQS
- SET PSSX("DD",PSIEN)=PSSX("DD",PSIEN)_"^"_$GET(PSSREQS)_"^"_$GET(PSNNN)_"^"_$GET(PSSVERB)_"^"_1
- End DoDot:1
- if $ORDER(PSSHOLD(PSSZ,PSSC,0))
- DO MULTI
- SET PSSA=PSSA+1
- +53 KILL PSSHOLD
- +54 DO LEADP^PSSUTLA1
- +55 QUIT
- DOSE2 ;Local Dose
- +1 NEW PSOCT,PSONDS,PSOND,PSOND1,PSONDX,PSONDU,PSODOS,PSLOC,PSLOCV,PSODUPD
- +2 SET PSOCT=1
- +3 SET DLOOP=PD
- Begin DoDot:1
- +4 IF $PIECE($GET(^PSDRUG(DLOOP,"I")),"^")
- IF +$PIECE($GET(^("I")),"^")<DT
- QUIT
- +5 ;Q:$P($G(^PSDRUG(DLOOP,2)),"^",3)'[TYPE
- +6 if '$ORDER(^PSDRUG(DLOOP,"DOS2",0))
- QUIT
- +7 SET PSONDS=$PIECE($GET(^PSDRUG(DLOOP,"DOS")),"^")
- SET PSONDU=$PIECE($GET(^("DOS")),"^",2)
- SET PSOND=$PIECE($GET(^("ND")),"^",3)
- SET PSOND1=$PIECE($GET(^("ND")),"^")
- +8 IF PSOND
- IF PSOND1
- IF PSONDS=""!('PSONDU)
- SET PSONDX=$$DFSU^PSNAPIS(PSOND1,PSOND)
- +9 IF PSONDS=""
- IF PSOND
- IF PSOND1
- SET PSONDS=$PIECE($GET(PSONDX),"^",4)
- +10 IF 'PSONDU
- IF PSOND
- IF PSOND1
- SET PSONDU=$PIECE($GET(PSONDX),"^",5)
- +11 SET PSODOS=+$PIECE($GET(^PS(50.7,POPD,0)),"^",2)
- +12 ;LOOK IN DOS2 NODE FOR LOCAL DOSES
- +13 FOR PSLOC=0:0
- SET PSLOC=$ORDER(^PSDRUG(DLOOP,"DOS2",PSLOC))
- if 'PSLOC
- QUIT
- Begin DoDot:2
- +14 SET PSLOCV=$PIECE($GET(^PSDRUG(DLOOP,"DOS2",PSLOC,0)),"^")
- if PSLOCV=""
- QUIT
- +15 SET PSSBC=$PIECE($GET(^PSDRUG(DLOOP,"DOS2",PSLOC,0)),"^",3)
- +16 SET PSSOLDN=$PIECE($GET(^PSDRUG(DLOOP,"DOS2",PSLOC,0)),"^",4)
- +17 IF PSSOIU
- IF $PIECE($GET(^PSDRUG(DLOOP,"DOS2",PSLOC,0)),"^",2)'["I"
- QUIT
- +18 IF 'PSSOIU
- IF $PIECE($GET(^PSDRUG(DLOOP,"DOS2",PSLOC,0)),"^",2)'["O"
- QUIT
- +19 DO SET2
- End DoDot:2
- End DoDot:1
- +20 ;IF NO LOCAL DOSES, RETURN ANY DRUGS YOU CAN
- +21 KILL PSSBC,PSSOLDN
- +22 IF '$ORDER(PSSX(0))
- KILL PSLOCV
- SET PSOCT=1
- Begin DoDot:1
- +23 SET DLOOP=PD
- Begin DoDot:2
- +24 IF $PIECE($GET(^PSDRUG(DLOOP,"I")),"^")
- IF +$PIECE($GET(^("I")),"^")<DT
- QUIT
- +25 ;Q:$P($G(^PSDRUG(DLOOP,2)),"^",3)'[TYPE
- +26 SET PSONDS=$PIECE($GET(^PSDRUG(DLOOP,"DOS")),"^")
- SET PSONDU=$PIECE($GET(^("DOS")),"^",2)
- SET PSOND=$PIECE($GET(^("ND")),"^",3)
- SET PSOND1=$PIECE($GET(^("ND")),"^")
- +27 KILL PSONDX
- IF PSOND
- IF PSOND1
- IF PSONDS=""!('PSONDU)
- SET PSONDX=$$DFSU^PSNAPIS(PSOND1,PSOND)
- +28 IF PSONDS=""
- IF PSOND
- IF PSOND1
- SET PSONDS=$PIECE($GET(PSONDX),"^",4)
- +29 IF 'PSONDU
- IF PSOND
- IF PSOND1
- SET PSONDU=$PIECE($GET(PSONDX),"^",5)
- +30 SET PSODOS=+$PIECE($GET(^PS(50.7,POPD,0)),"^",2)
- +31 DO SET2
- End DoDot:2
- End DoDot:1
- +32 DO LEADP^PSSUTLA1
- +33 QUIT
- SET2 ;
- +1 DO ZSET
- +2 IF $GET(PSLOCV)'=""
- IF $GET(PSLOCV)["&"
- DO AMP^PSSORPH1
- +3 SET PSSX(PSOCT)="^"_$SELECT($GET(PSONDU)=0:"",1:$GET(PSONDU))_"^"_$GET(PSLOCV)_"^"_DLOOP_"^"_$GET(PSONDS)_"^"_$GET(PSSLDN)_"^"_$PIECE($GET(^PS(50.606,+$GET(PSODOS),0)),"^")_"^"_$PIECE($GET(^("MISC")),"^")_"^"_$PIECE($GET(^("MISC")),"^",3)
- +4 SET PSSX(PSOCT)=PSSX(PSOCT)_"^"_$PIECE($GET(^PS(50.606,+$GET(PSODOS),"MISC")),"^",4)_$SELECT("OX"'[$GET(TYPE):"^^"_$GET(PSSBC),1:"")
- +5 SET $PIECE(PSSX(PSOCT),"^",13)=$GET(PSSOLDN)
- +6 IF '$DATA(PSSX("DD",DLOOP))
- Begin DoDot:1
- +7 DO REQS
- +8 KILL PSSMAX
- IF $GET(TYPE)["O"
- DO MAX
- +9 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:"")_"^"_$GET(PSSMAX)_"^"_$GET(PSSREQS)
- +10 SET PSSX("DD",DLOOP)=PSSX("DD",DLOOP)_"^"_$GET(PSSLDN)_"^"_$GET(PSSLDV)_"^"_0
- End DoDot:1
- +11 SET PSOCT=PSOCT+1
- +12 QUIT
- ZSET ;
- +1 KILL PSSLDN,PSSLNV
- +2 SET PSSLDV=$PIECE($GET(^PS(50.606,+$GET(PSODOS),"MISC")),"^")
- +3 ;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)),"^")
- +4 KILL PSSLDNN
- +5 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 ;Convert dosage with /
- +1 if '$DATA(PSSX(PSSA))
- QUIT
- +2 ;*150 Correct Slash dosages
- +3 KILL PSSDZUNT
- +4 NEW PSSF,PSSF1,PSSF2,PSSG,PSSFA,PSSFA1,PSSFB,PSSFB1,PSSDZI,PSSDZSL,PSSDZND,PSSDZSL1,PSSDZSL2,PSSDZSL3,PSSDZSL4,PSSDZSL5,PSSDZ50,PSSGIEN
- +5 SET PSSF=$PIECE($GET(PSSX(PSSA)),"^")
- SET PSSG=$PIECE($GET(PSSX(PSSA)),"^",2)
- +6 IF $GET(^PS(50.607,PSSG,0))]""
- SET PSSGIEN=PSSG
- SET PSSG=$PIECE($GET(^PS(50.607,PSSG,0)),"^")
- +7 IF PSSG'["/"
- SET $PIECE(PSSX(PSSA),"^",11)=$PIECE($GET(PSSX(PSSA)),"^")_$GET(PSSUNTS)
- QUIT
- +8 SET PSSDZSL=0
- SET PSSDZI=+$PIECE($GET(PSSX(PSSA)),"^",4)
- SET PSSDZ50=$PIECE($GET(^PSDRUG(PSSDZI,"DOS")),"^")
- +9 ;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)
- +10 SET PSSFA=$PIECE(PSSG,"/")
- SET PSSFB=$PIECE(PSSG,"/",2)
- SET PSSFA1=+$GET(PSSFA)
- SET PSSFB1=+$GET(PSSFB)
- +11 IF '$GET(PSSDZND)
- SET $PIECE(PSSX(PSSA),"^",11)=$PIECE(PSSX(PSSA),"^")
- GOTO SLSQ
- +12 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))
- +13 SET PSSF2=$SELECT('$GET(PSSFA1):PSSF,1:($GET(PSSFA1)*PSSF))_$SELECT($GET(PSSFA1):$PIECE(PSSFA,PSSFA1,2),1:PSSFA)_"/"_$GET(PSSDZSL5)
- +14 ;S PSSDZUNT=$P(PSSG,"/")_"/"_$G(PSSDZSL4)_$S('$G(PSSFB1):$G(PSSFB),1:$P(PSSFB,PSSFB1,2)) S $P(PSSX(PSSA),"^",2)=PSSDZUNT
- +15 SET PSSDZUNT=$PIECE(PSSG,"/")_"/"_$GET(PSSDZSL4)_$SELECT('$GET(PSSFB1):$GET(PSSFB),1:$PIECE(PSSFB,PSSFB1,2))
- SET $PIECE(PSSX(PSSA),"^",2)=PSSDZUNT
- +16 SET $PIECE(PSSX(PSSA),"^",11)=PSSF2
- +17 if $GET(PSSGIEN)
- SET $PIECE(PSSX(PSSA),"^",2)=PSSGIEN
- SLSQ KILL PSSDZUNT
- +1 QUIT
- REQS ;Schedule requirement flag
- +1 NEW PSSRF,PSSRFX,PSSRFZ
- +2 SET PSSREQS=1
- +3 ;No longer needed
- +4 QUIT
- MULTI ;
- +1 SET PL3=""
- FOR
- SET PL3=$ORDER(PSSHOLD(PSSZ,PSSC,PL3))
- if PL3=""
- QUIT
- SET PSSX(PSSA,PL3)=PSSHOLD(PSSZ,PSSC,PL3)
- if '$DATA(PSSX("DD",+$PIECE(PSSX(PSSA,PL3),"^",4)))
- Begin DoDot:1
- +2 SET (PSIEN,DLOOP)=+$PIECE(PSSX(PSSA,PL3),"^",4)
- 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")),"^")_"^"_$GET(PSSUNITX)_"^"_$GET(PSSMAX)
- +4 DO REQS
- SET PSSX("DD",PSIEN)=PSSX("DD",PSIEN)_"^"_$GET(PSSREQS)_"^"_$GET(PSNNN)_"^"_$GET(PSSVERB)_"^"_1
- End DoDot:1
- +5 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 PSSMD=0:0
- SET PSSMD=$ORDER(PSSX(PSSMD))
- if 'PSSMD
- QUIT
- Begin DoDot:1
- +2 FOR PSSMDN=1,5,11
- IF $EXTRACT($PIECE(PSSX(PSSMD),"^",PSSMDN),1)="."
- SET $PIECE(PSSX(PSSMD),"^",PSSMDN)="0"_$PIECE(PSSX(PSSMD),"^",PSSMDN)
- +3 IF $ORDER(PSSX(PSSMD,0))
- Begin DoDot:2
- +4 FOR PSSMD1=0:0
- SET PSSMD1=$ORDER(PSSX(PSSMD,PSSMD1))
- if 'PSSMD1
- QUIT
- Begin DoDot:3
- +5 FOR PSSMDN=1,5,11
- IF $EXTRACT($PIECE(PSSX(PSSMD,PSSMD1),"^",PSSMDN),1)="."
- SET $PIECE(PSSX(PSSMD,PSSMD1),"^",PSSMDN)="0"_$PIECE(PSSX(PSSMD,PSSMD1),"^",PSSMDN)
- End DoDot:3
- End DoDot:2
- End DoDot:1
- +6 SET PSSMD=""
- FOR
- SET PSSMD=$ORDER(PSSX("DD",PSSMD))
- if PSSMD=""
- QUIT
- Begin DoDot:1
- +7 IF $EXTRACT($PIECE(PSSX("DD",PSSMD),"^",5),1)="."
- SET $PIECE(PSSX("DD",PSSMD),"^",5)="0"_$PIECE(PSSX("DD",PSSMD),"^",5)
- End DoDot:1
- +8 QUIT