PSSDOSRP ;BIR/RTR-Dosage review report ;03/24/00
;;1.0;PHARMACY DATA MANAGEMENT;**34,38,49,129**;9/30/97;Build 67
;Reference to ^PS(50.607 supported by DBIA 2221
EN ;
N ZTRTN,ZTDESC,ZTSAVE,DUOUT,DTOUT,POP,ZTSK
K PSSHOW,PSSBEG,PSSEND,PSSSRT
K DIR S DIR(0)="S^A:ALL;S:SELECT A RANGE",DIR("B")="S",DIR("A")="Print Report for (A)ll or (S)elect a Range" D D ^DIR K DIR I Y["^"!($D(DTOUT))!($D(DUOUT)) W !!,"Nothing queued to print.",! G ENDX
.S DIR("?")=" ",DIR("?",1)="Enter 'A' to run report for all dispense drugs. Enter 'S' to select a range",DIR("?",2)="(alphabetically) of dispense drugs to print."
.S DIR("?",3)="This report displays Possible Dosage and Local Possible Dosage information for",DIR("?",4)="the dispense drugs in the range selected."
S PSSHOW=Y I PSSHOW="A" S PSSBEG="A",PSSEND="Z" S PSSSRT="A" G DEV
;W !!,"To see drugs beginning with the letter 'A', enter 'A', or whichever letter you",!,"wish to see. To see drugs in a range, for example drugs starting with the",!,"letters 'G', 'H', 'I' and 'J', enter in the format 'G-J'.",!
ASK ;
K DIR,PSSBEG,PSSEND,PSSNUMBX
S PSSNUMB=""
F S PSSNUMB=$O(^PSDRUG("B",PSSNUMB)) Q:'PSSNUMB!($G(PSSNUMBX)) S PSSNUMBX=1
I $G(PSSNUMBX) K DIR S DIR(0)="Y",DIR("A")="Print report for drugs with leading numerics",DIR("B")="N" D D ^DIR K DIR I Y["^"!($D(DUOUT))!($D(DTOUT)) W !!,"Nothing queued to print.",! G ENDX
.W !!!,"There are drugs in the Drug file with leading numerics.",!
.S DIR("?")=" ",DIR("?",1)="There are some entries in the drug file with leading numerics.",DIR("?",2)="Enter Yes to print the report for those drugs.",DIR("?",3)=" "
I $G(PSSNUMBX),$G(Y)=1 S PSSSRT="N" G DEV
K PSSNUMB,PSSNUMBX
ASKA K PSSBEG,PSSEND
W !!,"To see drugs beginning with the letter 'A', enter 'A', or whichever letter you",!,"wish to see. To see drugs in a range, for example drugs starting with the",!,"letters 'G', 'H', 'I' and 'J', enter in the format 'G-J'.",!
S DIR("?",1)=" ",DIR("?",2)="Enter either 1 letter, 'A', 'B', etc., to see drugs beginning with that letter,",DIR("?",3)="or to see a range of drugs enter in the format 'A-C', 'G-M', 'S-Z', etc.",DIR("?",4)=" ",DIR("?")=" "
S DIR("A")="Select a Range",DIR(0)="F^1:3" D ^DIR I Y["^"!($D(DTOUT))!($D(DUOUT)) W !!,"Nothing queued to print.",! G ENDX
S X=Y I X'?1U&(X'?1U1"-"1U)&(X'?1L)&(X'?1L1"-"1L) W !!,"Invalid response, enter a letter, 'A', 'B', etc., or a range, 'C-F', 'M-R', etc.",! G ASKA
I X["-" S PSSBEG=$P(X,"-"),PSSEND=$P(X,"-",2) I $A(PSSEND)<$A(PSSBEG) W !!,"Invalid response.",! G ASKA
I X'["-" S PSSBEG=X,PSSEND=X
S PSSSRT="X"
DEV I PSSSRT="X" W !!,"Report will be for drugs starting with the letter "_$G(PSSBEG)_",",!,"and ending with drugs starting with the letter "_$G(PSSEND)_".",!
I PSSSRT="N" W !!,"This report will be for drugs with leading numerics.",!
I PSSSRT="A" W !!,"This report will be for all drugs.",!
K DIR S DIR(0)="Y",DIR("A")="Is this correct",DIR("B")="Y" D ^DIR K DIR I Y'=1 W ! G EN
W $C(7),!!?3,"This report is designed for 132 column format!",!
K IOP,%ZIS,POP S %ZIS="QM" D ^%ZIS I $G(POP) W !!,"Nothing queued to print.",! G ENDX
I $D(IO("Q")) S ZTRTN="START^PSSDOSRP",ZTDESC="Dosage Review Report",ZTSAVE("PSSHOW")="",ZTSAVE("PSSBEG")="",ZTSAVE("PSSEND")="",ZTSAVE("PSSSRT")="" D ^%ZTLOAD K %ZIS W !,"Report queued to print.",! G ENDX
START ;
U IO
I '$G(DT) S DT=$$DT^XLFDT
S X1=DT,X2=-365 D C^%DTC S PSSYEAR=$G(X) K X,X1,X2
S PSSOUT=0,PSSDV=$S($E(IOST,1,2)'="C-":"P",1:"C"),PSSCT=1
K PSSLINE S $P(PSSLINE,"-",130)=""
D HD
G:PSSSRT="N" PASS
S PSSX=$A(PSSBEG)-1
S PSSNAME=$C(PSSX)_"zzzz"
PASS ;
I $G(PSSSRT)="N" S (PSSNAME,PSSEND)=""
I $G(PSSSRT)="A" S (PSSNAME,PSSEND)=""
F S PSSNAME=$O(^PSDRUG("B",PSSNAME)) Q:$S(PSSSRT="N"&('PSSNAME):1,PSSSRT="X"&(PSSNAME](PSSEND_"zzzz")):1,1:0)!(PSSNAME=""&(PSSSRT="X"))!(PSSSRT="A"&(PSSNAME=""))!($G(PSSOUT)) D
.F PSSIEN=0:0 S PSSIEN=$O(^PSDRUG("B",PSSNAME,PSSIEN)) Q:'PSSIEN!($G(PSSOUT)) D
..Q:'$D(^PSDRUG(PSSIEN,0))
..I ($Y+5)>IOSL D HD Q:$G(PSSOUT)
..K PSSINA,PSSNF,PSSINAD,PSSUNIT,PSSAPU S PSSNF=$S($P($G(^PSDRUG(PSSIEN,0)),"^",9):1,1:0),PSSINA=$P($G(^PSDRUG(PSSIEN,"I")),"^"),PSSNODE=$G(^("DOS"))
..I $G(PSSINA),$G(PSSYEAR),$G(PSSINA)<$G(PSSYEAR) Q
..S PSSMSG=$P($G(^PSDRUG(PSSIEN,0)),"^",10)
..S PSSAPU=$P($G(^PSDRUG(PSSIEN,2)),"^",3)
..I $G(PSSINA) S PSSINAD=$E(PSSINA,4,5)_"/"_$E(PSSINA,6,7)_"/"_$E(PSSINA,2,3)
..I $P(PSSNODE,"^",2) S PSSUNIT=$P($G(^PS(50.607,+$P(PSSNODE,"^",2),0)),"^")
..S PSSSTR=$P(PSSNODE,"^")
..W !!!,"("_$G(PSSIEN)_")",?19,$G(PSSNAME)_$S($G(PSSNF):" *N/F*",1:"") W ?72,"Inactive Date: "_$G(PSSINAD)
..I ($Y+5)>IOSL D HD Q:$G(PSSOUT)
..I $G(PSSMSG)'="" W !?12,$G(PSSMSG)
..I '$O(^PSDRUG(PSSIEN,"DOS1",0)),'$O(^PSDRUG(PSSIEN,"DOS2",0)) D NEWX Q
..I ($Y+5)>IOSL D HD Q:$G(PSSOUT)
..W !?12,"Strength: "_$S($E($G(PSSSTR),1)=".":"0",1:"")_$G(PSSSTR) W ?43,"Units: " I $G(PSSUNIT)'="",$G(PSSUNIT)'["/" W $G(PSSUNIT)
..I $G(PSSUNIT)'="",$G(PSSUNIT)'["/",$L(PSSUNIT)>15 W !
..W ?66,"Application Package: "_$G(PSSAPU)
..I ($Y+5)>IOSL D HD Q:$G(PSSOUT)
..S PSSA=0 K PSSC,PSSD,PSSE W !?4,"Possible Dosages: " I $G(PSSSTR)'="",$G(PSSUNIT)'="" D
...F PSSB=0:0 S PSSB=$O(^PSDRUG(PSSIEN,"DOS1",PSSB)) Q:'PSSB!($G(PSSOUT)) S PSSC=$P($G(^(PSSB,0)),"^"),PSSD=$P($G(^(0)),"^",2),PSSE=$P($G(^(0)),"^",3) I $G(PSSC),$G(PSSD) S PSSA=1 D
....I ($Y+5)>IOSL D HD Q:$G(PSSOUT)
....W !?3,"Dispense Units Per Dose: "_$S($E($G(PSSC),1)=".":"0",1:"")_$G(PSSC),?44,"Dose: " D
.....I $G(PSSUNIT)'["/" W $S($E($G(PSSD),1)=".":"0",1:"")_$G(PSSD)_$G(PSSUNIT) W ?78,"Package: "_$G(PSSE) D OUT Q
.....D SETD D ZERO W $G(PSSCALC),?78,"Package: "_$G(PSSE) D OUT
..Q:$G(PSSOUT)
..I 'PSSA W "(None)"
..S PSSA=0 W !?4,"Local Possible Dosages: " F PSSB=0:0 S PSSB=$O(^PSDRUG(PSSIEN,"DOS2",PSSB)) Q:'PSSB!($G(PSSOUT)) D
...I $P($G(^PSDRUG(PSSIEN,"DOS2",PSSB,0)),"^")'="" S PSSA=1 D
....I ($Y+5)>IOSL D HD Q:$G(PSSOUT)
....W !?6,$P($G(^PSDRUG(PSSIEN,"DOS2",PSSB,0)),"^") D NEW
..Q:$G(PSSOUT)
..I 'PSSA W "(None)"
..D NEWX
END ;
I '$G(PSSOUT),$G(PSSDV)="C" W !!,"End of Report." K DIR S DIR(0)="E",DIR("A")="Press Return to continue" D ^DIR K DIR
I $G(PSSDV)="C" W !
E W @IOF
ENDX K PSSNODE,PSSNUMB,PSSNUMBX,PSSSRT,PSSCALC,PSSSTR,PSSUNIT,PSSIEN,PSSINAD,PSSINA,PSSNF,PSSNAME,PSSDV,PSSX,PSSOUT,PSSHOW,PSSBEG,PSSLINE,PSSEND,PSSA,PSSB,PSSC,PSSD,PSSE,PSSAPU,PSSMSG,PSSYEAR,PSSDFOI,PSSDFOIN,PSSDF,PSSDZZ,PSSDZ,X,Y,PSSCT
D ^%ZISC S:$D(ZTQUEUED) ZTREQ="@"
Q
HD ;
I $G(PSSDV)="C",$G(PSSCT)'=1 W ! K DIR S DIR(0)="E",DIR("A")="Press Return to continue, '^' to exit" D ^DIR K DIR I 'Y S PSSOUT=1 Q
W @IOF W !,$S(PSSSRT="N":"Dosage report for drugs with leading numerics",PSSSRT="A":"Dosage report for all drugs",1:"Dosage report for drugs from "_PSSBEG_" through "_PSSEND)
W ?94,"Outpatient Expansion",?119,"PAGE: "_$G(PSSCT),!,PSSLINE S PSSCT=PSSCT+1
Q
SETD ;
N PSSVA,PSSVA1,PSSVB,PSSVB1,PSSDASH,PSSNDFS,PSSDASH2,PSSDASH3,PSSDASH4,PSSDASH5 K PSSCALC
S PSSDASH=0 S PSSNDFS=$$PSJST^PSNAPIS(+$P($G(^PSDRUG(PSSIEN,"ND")),"^"),+$P($G(^PSDRUG(PSSIEN,"ND")),"^",3)) S PSSNDFS=+$P($G(PSSNDFS),"^",2) I $G(PSSNDFS),$G(PSSSTR),+$G(PSSSTR)'=+$G(PSSNDFS) S PSSDASH=1
S PSSVA=$P(PSSUNIT,"/"),PSSVB=$P(PSSUNIT,"/",2),PSSVA1=+$G(PSSVA),PSSVB1=+$G(PSSVB)
I $G(PSSDASH) S PSSDASH2=PSSSTR/PSSNDFS,PSSDASH3=PSSDASH2*PSSC S PSSDASH4=PSSDASH3*$S($G(PSSVB1):PSSVB1,1:1) S PSSDASH5=$S('$G(PSSVB1):PSSDASH4_$G(PSSVB),1:PSSDASH4_$P(PSSVB,PSSVB1,2))
S PSSCALC=$S('$G(PSSVA1):PSSD,1:($G(PSSVA1)*PSSD))_$S($G(PSSVA1):$P(PSSVA,PSSVA1,2),1:PSSVA)_"/"_$S($G(PSSDASH):$G(PSSDASH5),'$G(PSSVB1):+$G(PSSC)_$G(PSSVB),1:(+$G(PSSC)*+PSSVB1)_$P(PSSVB,PSSVB1,2))
Q
OUT ;
K PSSDFOI,PSSDFOIN,PSSDF,PSSDZZ
Q:$G(PSSE)'["O"
S PSSDFOI=$P($G(^PSDRUG(PSSIEN,2)),"^") Q:'PSSDFOI
S PSSDF=$P($G(^PS(50.7,+PSSDFOI,0)),"^",2)
S PSSDFOIN=$P($G(^PS(50.606,+$G(PSSDF),0)),"^")
Q:'PSSDF
K PSSDZ F PSSDZZ=0:0 S PSSDZZ=$O(^PS(50.606,PSSDF,"NOUN",PSSDZZ)) Q:'PSSDZZ!($G(PSSDZ)'="") I $P($G(^(PSSDZZ,0)),"^")'="" S PSSDZ=$P($G(^(0)),"^")
I $G(PSSDZ)="" S PSSDZ=$G(PSSDFOIN)
I $G(PSSC) D PARN
W ?94,$S($E($G(PSSC),1)=".":"0",1:"")_$G(PSSC)_" "_$S($G(PSSDZN)'="":$G(PSSDZN),1:$G(PSSDZ))
K PSSDFOI,PSSDF,PSSDZ,PSSDZZ,PSSDZN,PSSDZNX,PSSDFOIN
Q
PARN ;
K PSSDZN,PSSDZNX
Q:$G(PSSDZ)=""
Q:$L(PSSDZ)'>3
S PSSDZNX=$E(PSSDZ,($L(PSSDZ)-2),$L(PSSDZ))
I $G(PSSDZNX)="(S)"!($G(PSSDZNX)="(s)") D
.I $G(PSSC)'>1 S PSSDZN=$E(PSSDZ,1,($L(PSSDZ)-3))
.I $G(PSSC)>1 S PSSDZN=$E(PSSDZ,1,($L(PSSDZ)-3))_$E(PSSDZNX,2)
Q
ZERO ;Leading zeros
I $E($G(PSSCALC),1)="." S PSSCALC="0"_$G(PSSCALC)
N PSSLEZ,PSSLEZ1,PSSLEZD
I $G(PSSCALC)["/." S PSSLEZD=$G(PSSCALC) D
.S PSSLEZ=$P(PSSLEZD,"/."),PSSLEZ1=$P(PSSLEZD,"/.",2)
.S PSSCALC=$G(PSSLEZ)_"/0."_$G(PSSLEZ1)
Q
;
NEW ;new fields added with patch PSS*1*129
I ($Y+5)>IOSL D HD Q:$G(PSSOUT)
N PSSYWD,PSSYWN,PSSYWNN
S PSSYWD=$P($G(^PSDRUG(PSSIEN,"DOS2",PSSB,0)),"^",5),PSSYWN=$P($G(^PSDRUG(PSSIEN,"DOS2",PSSB,0)),"^",6)
S PSSYWNN=$S($E($G(PSSYWN),1)=".":"0"_$G(PSSYWN),1:$G(PSSYWN))
W !?6,"Numeric Dose: "_$G(PSSYWNN),?46,"Dose Unit: "_$S($G(PSSYWD):$P($G(^PS(51.24,+PSSYWD,0)),"^"),1:""),?92,"Package: ",$P($G(^PSDRUG(PSSIEN,"DOS2",PSSB,0)),"^",2)
I ($Y+5)>IOSL D HD Q:$G(PSSOUT)
Q
NEWX ;new fields added with patch PSS*1*129
I ($Y+5)>IOSL D HD Q:$G(PSSOUT)
N PSSYWND1,PSSYWND3,PSSYWNDN,PSSYWNDS,PSSYWFS,PSSYWFSS
S PSSYWFS=$P($G(^PSDRUG(PSSIEN,"DOS")),"^")
S PSSYWFSS=$S($E($G(PSSYWFS),1)=".":"0"_$G(PSSYWFS),1:$G(PSSYWFS))
I PSSYWFSS="" Q
S PSSYWND1=$P($G(^PSDRUG(PSSIEN,"ND")),"^"),PSSYWND3=$P($G(^PSDRUG(PSSIEN,"ND")),"^",3)
I 'PSSYWND1!('PSSYWND3) Q
S PSSYWNDN=$$PROD0^PSNAPIS(PSSYWND1,PSSYWND3)
S PSSYWNDS=$S($E($P(PSSYWNDN,"^",3),1)=".":"0"_$P(PSSYWNDN,"^",3),1:$P(PSSYWNDN,"^",3))
I PSSYWNDS="" Q
I PSSYWFSS=PSSYWNDS Q
W !,?3,"Note: Strength of "_PSSYWFSS_" does not match NDF strength of "_PSSYWNDS_"."
I ($Y+5)>IOSL D HD Q:$G(PSSOUT)
W !?3,"VA PRODUCT MATCH: "_$P(PSSYWNDN,"^")
I ($Y+5)>IOSL D HD Q:$G(PSSOUT)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSSDOSRP 10044 printed Sep 23, 2025@20:06:39 Page 2
PSSDOSRP ;BIR/RTR-Dosage review report ;03/24/00
+1 ;;1.0;PHARMACY DATA MANAGEMENT;**34,38,49,129**;9/30/97;Build 67
+2 ;Reference to ^PS(50.607 supported by DBIA 2221
EN ;
+1 NEW ZTRTN,ZTDESC,ZTSAVE,DUOUT,DTOUT,POP,ZTSK
+2 KILL PSSHOW,PSSBEG,PSSEND,PSSSRT
+3 KILL DIR
SET DIR(0)="S^A:ALL;S:SELECT A RANGE"
SET DIR("B")="S"
SET DIR("A")="Print Report for (A)ll or (S)elect a Range"
Begin DoDot:1
+4 SET DIR("?")=" "
SET DIR("?",1)="Enter 'A' to run report for all dispense drugs. Enter 'S' to select a range"
SET DIR("?",2)="(alphabetically) of dispense drugs to print."
+5 SET DIR("?",3)="This report displays Possible Dosage and Local Possible Dosage information for"
SET DIR("?",4)="the dispense drugs in the range selected."
End DoDot:1
DO ^DIR
KILL DIR
IF Y["^"!($DATA(DTOUT))!($DATA(DUOUT))
WRITE !!,"Nothing queued to print.",!
GOTO ENDX
+6 SET PSSHOW=Y
IF PSSHOW="A"
SET PSSBEG="A"
SET PSSEND="Z"
SET PSSSRT="A"
GOTO DEV
+7 ;W !!,"To see drugs beginning with the letter 'A', enter 'A', or whichever letter you",!,"wish to see. To see drugs in a range, for example drugs starting with the",!,"letters 'G', 'H', 'I' and 'J', enter in the format 'G-J'.",!
ASK ;
+1 KILL DIR,PSSBEG,PSSEND,PSSNUMBX
+2 SET PSSNUMB=""
+3 FOR
SET PSSNUMB=$ORDER(^PSDRUG("B",PSSNUMB))
if 'PSSNUMB!($GET(PSSNUMBX))
QUIT
SET PSSNUMBX=1
+4 IF $GET(PSSNUMBX)
KILL DIR
SET DIR(0)="Y"
SET DIR("A")="Print report for drugs with leading numerics"
SET DIR("B")="N"
Begin DoDot:1
+5 WRITE !!!,"There are drugs in the Drug file with leading numerics.",!
+6 SET DIR("?")=" "
SET DIR("?",1)="There are some entries in the drug file with leading numerics."
SET DIR("?",2)="Enter Yes to print the report for those drugs."
SET DIR("?",3)=" "
End DoDot:1
DO ^DIR
KILL DIR
IF Y["^"!($DATA(DUOUT))!($DATA(DTOUT))
WRITE !!,"Nothing queued to print.",!
GOTO ENDX
+7 IF $GET(PSSNUMBX)
IF $GET(Y)=1
SET PSSSRT="N"
GOTO DEV
+8 KILL PSSNUMB,PSSNUMBX
ASKA KILL PSSBEG,PSSEND
+1 WRITE !!,"To see drugs beginning with the letter 'A', enter 'A', or whichever letter you",!,"wish to see. To see drugs in a range, for example drugs starting with the",!,"letters 'G', 'H', 'I' and 'J', enter in the format 'G-J'.",!
+2 SET DIR("?",1)=" "
SET DIR("?",2)="Enter either 1 letter, 'A', 'B', etc., to see drugs beginning with that letter,"
SET DIR("?",3)="or to see a range of drugs enter in the format 'A-C', 'G-M', 'S-Z', etc."
SET DIR("?",4)=" "
SET DIR("?")=" "
+3 SET DIR("A")="Select a Range"
SET DIR(0)="F^1:3"
DO ^DIR
IF Y["^"!($DATA(DTOUT))!($DATA(DUOUT))
WRITE !!,"Nothing queued to print.",!
GOTO ENDX
+4 SET X=Y
IF X'?1U&(X'?1U1"-"1U)&(X'?1L)&(X'?1L1"-"1L)
WRITE !!,"Invalid response, enter a letter, 'A', 'B', etc., or a range, 'C-F', 'M-R', etc.",!
GOTO ASKA
+5 IF X["-"
SET PSSBEG=$PIECE(X,"-")
SET PSSEND=$PIECE(X,"-",2)
IF $ASCII(PSSEND)<$ASCII(PSSBEG)
WRITE !!,"Invalid response.",!
GOTO ASKA
+6 IF X'["-"
SET PSSBEG=X
SET PSSEND=X
+7 SET PSSSRT="X"
DEV IF PSSSRT="X"
WRITE !!,"Report will be for drugs starting with the letter "_$GET(PSSBEG)_",",!,"and ending with drugs starting with the letter "_$GET(PSSEND)_".",!
+1 IF PSSSRT="N"
WRITE !!,"This report will be for drugs with leading numerics.",!
+2 IF PSSSRT="A"
WRITE !!,"This report will be for all drugs.",!
+3 KILL DIR
SET DIR(0)="Y"
SET DIR("A")="Is this correct"
SET DIR("B")="Y"
DO ^DIR
KILL DIR
IF Y'=1
WRITE !
GOTO EN
+4 WRITE $CHAR(7),!!?3,"This report is designed for 132 column format!",!
+5 KILL IOP,%ZIS,POP
SET %ZIS="QM"
DO ^%ZIS
IF $GET(POP)
WRITE !!,"Nothing queued to print.",!
GOTO ENDX
+6 IF $DATA(IO("Q"))
SET ZTRTN="START^PSSDOSRP"
SET ZTDESC="Dosage Review Report"
SET ZTSAVE("PSSHOW")=""
SET ZTSAVE("PSSBEG")=""
SET ZTSAVE("PSSEND")=""
SET ZTSAVE("PSSSRT")=""
DO ^%ZTLOAD
KILL %ZIS
WRITE !,"Report queued to print.",!
GOTO ENDX
START ;
+1 USE IO
+2 IF '$GET(DT)
SET DT=$$DT^XLFDT
+3 SET X1=DT
SET X2=-365
DO C^%DTC
SET PSSYEAR=$GET(X)
KILL X,X1,X2
+4 SET PSSOUT=0
SET PSSDV=$SELECT($EXTRACT(IOST,1,2)'="C-":"P",1:"C")
SET PSSCT=1
+5 KILL PSSLINE
SET $PIECE(PSSLINE,"-",130)=""
+6 DO HD
+7 if PSSSRT="N"
GOTO PASS
+8 SET PSSX=$ASCII(PSSBEG)-1
+9 SET PSSNAME=$CHAR(PSSX)_"zzzz"
PASS ;
+1 IF $GET(PSSSRT)="N"
SET (PSSNAME,PSSEND)=""
+2 IF $GET(PSSSRT)="A"
SET (PSSNAME,PSSEND)=""
+3 FOR
SET PSSNAME=$ORDER(^PSDRUG("B",PSSNAME))
if $SELECT(PSSSRT="N"&('PSSNAME)
QUIT
Begin DoDot:1
+4 FOR PSSIEN=0:0
SET PSSIEN=$ORDER(^PSDRUG("B",PSSNAME,PSSIEN))
if 'PSSIEN!($GET(PSSOUT))
QUIT
Begin DoDot:2
+5 if '$DATA(^PSDRUG(PSSIEN,0))
QUIT
+6 IF ($Y+5)>IOSL
DO HD
if $GET(PSSOUT)
QUIT
+7 KILL PSSINA,PSSNF,PSSINAD,PSSUNIT,PSSAPU
SET PSSNF=$SELECT($PIECE($GET(^PSDRUG(PSSIEN,0)),"^",9):1,1:0)
SET PSSINA=$PIECE($GET(^PSDRUG(PSSIEN,"I")),"^")
SET PSSNODE=$GET(^("DOS"))
+8 IF $GET(PSSINA)
IF $GET(PSSYEAR)
IF $GET(PSSINA)<$GET(PSSYEAR)
QUIT
+9 SET PSSMSG=$PIECE($GET(^PSDRUG(PSSIEN,0)),"^",10)
+10 SET PSSAPU=$PIECE($GET(^PSDRUG(PSSIEN,2)),"^",3)
+11 IF $GET(PSSINA)
SET PSSINAD=$EXTRACT(PSSINA,4,5)_"/"_$EXTRACT(PSSINA,6,7)_"/"_$EXTRACT(PSSINA,2,3)
+12 IF $PIECE(PSSNODE,"^",2)
SET PSSUNIT=$PIECE($GET(^PS(50.607,+$PIECE(PSSNODE,"^",2),0)),"^")
+13 SET PSSSTR=$PIECE(PSSNODE,"^")
+14 WRITE !!!,"("_$GET(PSSIEN)_")",?19,$GET(PSSNAME)_$SELECT($GET(PSSNF):" *N/F*",1:"")
WRITE ?72,"Inactive Date: "_$GET(PSSINAD)
+15 IF ($Y+5)>IOSL
DO HD
if $GET(PSSOUT)
QUIT
+16 IF $GET(PSSMSG)'=""
WRITE !?12,$GET(PSSMSG)
+17 IF '$ORDER(^PSDRUG(PSSIEN,"DOS1",0))
IF '$ORDER(^PSDRUG(PSSIEN,"DOS2",0))
DO NEWX
QUIT
+18 IF ($Y+5)>IOSL
DO HD
if $GET(PSSOUT)
QUIT
+19 WRITE !?12,"Strength: "_$SELECT($EXTRACT($GET(PSSSTR),1)=".":"0",1:"")_$GET(PSSSTR)
WRITE ?43,"Units: "
IF $GET(PSSUNIT)'=""
IF $GET(PSSUNIT)'["/"
WRITE $GET(PSSUNIT)
+20 IF $GET(PSSUNIT)'=""
IF $GET(PSSUNIT)'["/"
IF $LENGTH(PSSUNIT)>15
WRITE !
+21 WRITE ?66,"Application Package: "_$GET(PSSAPU)
+22 IF ($Y+5)>IOSL
DO HD
if $GET(PSSOUT)
QUIT
+23 SET PSSA=0
KILL PSSC,PSSD,PSSE
WRITE !?4,"Possible Dosages: "
IF $GET(PSSSTR)'=""
IF $GET(PSSUNIT)'=""
Begin DoDot:3
+24 FOR PSSB=0:0
SET PSSB=$ORDER(^PSDRUG(PSSIEN,"DOS1",PSSB))
if 'PSSB!($GET(PSSOUT))
QUIT
SET PSSC=$PIECE($GET(^(PSSB,0)),"^")
SET PSSD=$PIECE($GET(^(0)),"^",2)
SET PSSE=$PIECE($GET(^(0)),"^",3)
IF $GET(PSSC)
IF $GET(PSSD)
SET PSSA=1
Begin DoDot:4
+25 IF ($Y+5)>IOSL
DO HD
if $GET(PSSOUT)
QUIT
+26 WRITE !?3,"Dispense Units Per Dose: "_$SELECT($EXTRACT($GET(PSSC),1)=".":"0",1:"")_$GET(PSSC),?44,"Dose: "
Begin DoDot:5
+27 IF $GET(PSSUNIT)'["/"
WRITE $SELECT($EXTRACT($GET(PSSD),1)=".":"0",1:"")_$GET(PSSD)_$GET(PSSUNIT)
WRITE ?78,"Package: "_$GET(PSSE)
DO OUT
QUIT
+28 DO SETD
DO ZERO
WRITE $GET(PSSCALC),?78,"Package: "_$GET(PSSE)
DO OUT
End DoDot:5
End DoDot:4
End DoDot:3
+29 if $GET(PSSOUT)
QUIT
+30 IF 'PSSA
WRITE "(None)"
+31 SET PSSA=0
WRITE !?4,"Local Possible Dosages: "
FOR PSSB=0:0
SET PSSB=$ORDER(^PSDRUG(PSSIEN,"DOS2",PSSB))
if 'PSSB!($GET(PSSOUT))
QUIT
Begin DoDot:3
+32 IF $PIECE($GET(^PSDRUG(PSSIEN,"DOS2",PSSB,0)),"^")'=""
SET PSSA=1
Begin DoDot:4
+33 IF ($Y+5)>IOSL
DO HD
if $GET(PSSOUT)
QUIT
+34 WRITE !?6,$PIECE($GET(^PSDRUG(PSSIEN,"DOS2",PSSB,0)),"^")
DO NEW
End DoDot:4
End DoDot:3
+35 if $GET(PSSOUT)
QUIT
+36 IF 'PSSA
WRITE "(None)"
+37 DO NEWX
End DoDot:2
End DoDot:1
END ;
+1 IF '$GET(PSSOUT)
IF $GET(PSSDV)="C"
WRITE !!,"End of Report."
KILL DIR
SET DIR(0)="E"
SET DIR("A")="Press Return to continue"
DO ^DIR
KILL DIR
+2 IF $GET(PSSDV)="C"
WRITE !
+3 IF '$TEST
WRITE @IOF
ENDX KILL PSSNODE,PSSNUMB,PSSNUMBX,PSSSRT,PSSCALC,PSSSTR,PSSUNIT,PSSIEN,PSSINAD,PSSINA,PSSNF,PSSNAME,PSSDV,PSSX,PSSOUT,PSSHOW,PSSBEG,PSSLINE,PSSEND,PSSA,PSSB,PSSC,PSSD,PSSE,PSSAPU,PSSMSG,PSSYEAR,PSSDFOI,PSSDFOIN,PSSDF,PSSDZZ,PSSDZ,X,Y,PSSCT
+1 DO ^%ZISC
if $DATA(ZTQUEUED)
SET ZTREQ="@"
+2 QUIT
HD ;
+1 IF $GET(PSSDV)="C"
IF $GET(PSSCT)'=1
WRITE !
KILL DIR
SET DIR(0)="E"
SET DIR("A")="Press Return to continue, '^' to exit"
DO ^DIR
KILL DIR
IF 'Y
SET PSSOUT=1
QUIT
+2 WRITE @IOF
WRITE !,$SELECT(PSSSRT="N":"Dosage report for drugs with leading numerics",PSSSRT="A":"Dosage report for all drugs",1:"Dosage report for drugs from "_PSSBEG_" through "_PSSEND)
+3 WRITE ?94,"Outpatient Expansion",?119,"PAGE: "_$GET(PSSCT),!,PSSLINE
SET PSSCT=PSSCT+1
+4 QUIT
SETD ;
+1 NEW PSSVA,PSSVA1,PSSVB,PSSVB1,PSSDASH,PSSNDFS,PSSDASH2,PSSDASH3,PSSDASH4,PSSDASH5
KILL PSSCALC
+2 SET PSSDASH=0
SET PSSNDFS=$$PSJST^PSNAPIS(+$PIECE($GET(^PSDRUG(PSSIEN,"ND")),"^"),+$PIECE($GET(^PSDRUG(PSSIEN,"ND")),"^",3))
SET PSSNDFS=+$PIECE($GET(PSSNDFS),"^",2)
IF $GET(PSSNDFS)
IF $GET(PSSSTR)
IF +$GET(PSSSTR)'=+$GET(PSSNDFS)
SET PSSDASH=1
+3 SET PSSVA=$PIECE(PSSUNIT,"/")
SET PSSVB=$PIECE(PSSUNIT,"/",2)
SET PSSVA1=+$GET(PSSVA)
SET PSSVB1=+$GET(PSSVB)
+4 IF $GET(PSSDASH)
SET PSSDASH2=PSSSTR/PSSNDFS
SET PSSDASH3=PSSDASH2*PSSC
SET PSSDASH4=PSSDASH3*$SELECT($GET(PSSVB1):PSSVB1,1:1)
SET PSSDASH5=$SELECT('$GET(PSSVB1):PSSDASH4_$GET(PSSVB),1:PSSDASH4_$PIECE(PSSVB,PSSVB1,2))
+5 SET PSSCALC=$SELECT('$GET(PSSVA1):PSSD,1:($GET(PSSVA1)*PSSD))_$SELECT($GET(PSSVA1):$PIECE(PSSVA,PSSVA1,2),1:PSSVA)_"/"_$SELECT($GET(PSSDASH):$GET(PSSDASH5),'$GET(PSSVB1):+$GET(PSSC)_$GET(PSSVB),1:(+$GET(PSSC)*+PSSVB1)_$PIECE(PSSVB,PSSVB1,2))
+6 QUIT
OUT ;
+1 KILL PSSDFOI,PSSDFOIN,PSSDF,PSSDZZ
+2 if $GET(PSSE)'["O"
QUIT
+3 SET PSSDFOI=$PIECE($GET(^PSDRUG(PSSIEN,2)),"^")
if 'PSSDFOI
QUIT
+4 SET PSSDF=$PIECE($GET(^PS(50.7,+PSSDFOI,0)),"^",2)
+5 SET PSSDFOIN=$PIECE($GET(^PS(50.606,+$GET(PSSDF),0)),"^")
+6 if 'PSSDF
QUIT
+7 KILL PSSDZ
FOR PSSDZZ=0:0
SET PSSDZZ=$ORDER(^PS(50.606,PSSDF,"NOUN",PSSDZZ))
if 'PSSDZZ!($GET(PSSDZ)'="")
QUIT
IF $PIECE($GET(^(PSSDZZ,0)),"^")'=""
SET PSSDZ=$PIECE($GET(^(0)),"^")
+8 IF $GET(PSSDZ)=""
SET PSSDZ=$GET(PSSDFOIN)
+9 IF $GET(PSSC)
DO PARN
+10 WRITE ?94,$SELECT($EXTRACT($GET(PSSC),1)=".":"0",1:"")_$GET(PSSC)_" "_$SELECT($GET(PSSDZN)'="":$GET(PSSDZN),1:$GET(PSSDZ))
+11 KILL PSSDFOI,PSSDF,PSSDZ,PSSDZZ,PSSDZN,PSSDZNX,PSSDFOIN
+12 QUIT
PARN ;
+1 KILL PSSDZN,PSSDZNX
+2 if $GET(PSSDZ)=""
QUIT
+3 if $LENGTH(PSSDZ)'>3
QUIT
+4 SET PSSDZNX=$EXTRACT(PSSDZ,($LENGTH(PSSDZ)-2),$LENGTH(PSSDZ))
+5 IF $GET(PSSDZNX)="(S)"!($GET(PSSDZNX)="(s)")
Begin DoDot:1
+6 IF $GET(PSSC)'>1
SET PSSDZN=$EXTRACT(PSSDZ,1,($LENGTH(PSSDZ)-3))
+7 IF $GET(PSSC)>1
SET PSSDZN=$EXTRACT(PSSDZ,1,($LENGTH(PSSDZ)-3))_$EXTRACT(PSSDZNX,2)
End DoDot:1
+8 QUIT
ZERO ;Leading zeros
+1 IF $EXTRACT($GET(PSSCALC),1)="."
SET PSSCALC="0"_$GET(PSSCALC)
+2 NEW PSSLEZ,PSSLEZ1,PSSLEZD
+3 IF $GET(PSSCALC)["/."
SET PSSLEZD=$GET(PSSCALC)
Begin DoDot:1
+4 SET PSSLEZ=$PIECE(PSSLEZD,"/.")
SET PSSLEZ1=$PIECE(PSSLEZD,"/.",2)
+5 SET PSSCALC=$GET(PSSLEZ)_"/0."_$GET(PSSLEZ1)
End DoDot:1
+6 QUIT
+7 ;
NEW ;new fields added with patch PSS*1*129
+1 IF ($Y+5)>IOSL
DO HD
if $GET(PSSOUT)
QUIT
+2 NEW PSSYWD,PSSYWN,PSSYWNN
+3 SET PSSYWD=$PIECE($GET(^PSDRUG(PSSIEN,"DOS2",PSSB,0)),"^",5)
SET PSSYWN=$PIECE($GET(^PSDRUG(PSSIEN,"DOS2",PSSB,0)),"^",6)
+4 SET PSSYWNN=$SELECT($EXTRACT($GET(PSSYWN),1)=".":"0"_$GET(PSSYWN),1:$GET(PSSYWN))
+5 WRITE !?6,"Numeric Dose: "_$GET(PSSYWNN),?46,"Dose Unit: "_$SELECT($GET(PSSYWD):$PIECE($GET(^PS(51.24,+PSSYWD,0)),"^"),1:""),?92,"Package: ",$PIECE($GET(^PSDRUG(PSSIEN,"DOS2",PSSB,0)),"^",2)
+6 IF ($Y+5)>IOSL
DO HD
if $GET(PSSOUT)
QUIT
+7 QUIT
NEWX ;new fields added with patch PSS*1*129
+1 IF ($Y+5)>IOSL
DO HD
if $GET(PSSOUT)
QUIT
+2 NEW PSSYWND1,PSSYWND3,PSSYWNDN,PSSYWNDS,PSSYWFS,PSSYWFSS
+3 SET PSSYWFS=$PIECE($GET(^PSDRUG(PSSIEN,"DOS")),"^")
+4 SET PSSYWFSS=$SELECT($EXTRACT($GET(PSSYWFS),1)=".":"0"_$GET(PSSYWFS),1:$GET(PSSYWFS))
+5 IF PSSYWFSS=""
QUIT
+6 SET PSSYWND1=$PIECE($GET(^PSDRUG(PSSIEN,"ND")),"^")
SET PSSYWND3=$PIECE($GET(^PSDRUG(PSSIEN,"ND")),"^",3)
+7 IF 'PSSYWND1!('PSSYWND3)
QUIT
+8 SET PSSYWNDN=$$PROD0^PSNAPIS(PSSYWND1,PSSYWND3)
+9 SET PSSYWNDS=$SELECT($EXTRACT($PIECE(PSSYWNDN,"^",3),1)=".":"0"_$PIECE(PSSYWNDN,"^",3),1:$PIECE(PSSYWNDN,"^",3))
+10 IF PSSYWNDS=""
QUIT
+11 IF PSSYWFSS=PSSYWNDS
QUIT
+12 WRITE !,?3,"Note: Strength of "_PSSYWFSS_" does not match NDF strength of "_PSSYWNDS_"."
+13 IF ($Y+5)>IOSL
DO HD
if $GET(PSSOUT)
QUIT
+14 WRITE !?3,"VA PRODUCT MATCH: "_$PIECE(PSSYWNDN,"^")
+15 IF ($Y+5)>IOSL
DO HD
if $GET(PSSOUT)
QUIT
+16 QUIT
