PSSSCHRP ;BIR/RTR-Schedule Report ; 10/15/15 4:26pm
;;1.0;PHARMACY DATA MANAGEMENT;**129,160,189,201**;9/30/97;Build 25
;External reference to ^PSNAPIS supported by DBIA #2531
;
EN ;Prompts for Administration File Schedule Report
W !!,"This report displays entries from the ADMINISTRATION SCHEDULE (#51.1) File."
W !,"It can be run for all Schedules, or only Schedules without a FREQUENCY"
W !,"(IN MINUTES). Only schedules with a PSJ Package Prefix will be displayed, since"
W !,"they are the only schedules the software will look at when deriving a FREQUENCY"
W !,"(IN MINUTES) for the daily dosage checks. If a FREQUENCY (IN MINUTES) cannot",!,"be determined for an order, the daily dosage check cannot occur for that order."
N DIR,PSSAFRP,PSSALONG,Y,X,DTOUT,DUOUT,DIRUT,DIROUT,IOP,%ZIS,POP,ZTRTN,ZTDESC,ZTSAVE,ZTSK
K DIR,Y S DIR(0)="SO^A:All Schedules;O:Only Schedules with a missing frequency",DIR("A")="Print All Schedules, or Only Schedules without a frequency",DIR("B")="A"
S DIR("?")=" ",DIR("?",1)=" ",DIR("?",2)="Enter 'A' to see all Administration Schedules, enter 'O' to see only",DIR("?",3)="those Administration Schedules without data in the FREQUENCY (IN MINUTES)"
S DIR("?",4)="(#2) Field. A FREQUENCY (IN MINUTES) must be derived from a Schedule",DIR("?",5)="for the daily dosage check to occur for an order."
W ! D ^DIR K DIR I $D(DUOUT)!($D(DTOUT)) D MESS K DIR,Y S DIR(0)="E",DIR("A")="Press Return to continue" D ^DIR K DIR Q
I Y'="A",Y'="O" D MESS K DIR,Y S DIR(0)="E",DIR("A")="Press Return to continue" D ^DIR K DIR Q
S PSSAFRP=Y
K DIR,Y S DIR(0)="SO^80:80 Column;132:132 Column",DIR("A")="Print report in 80 or 132 column format",DIR("B")="80"
S DIR("?")=" ",DIR("?",1)="Enter 80 to print the report in an 80 column format,",DIR("?",2)="Enter 132 to print the report in an 132 column format."
W ! D ^DIR K DIR I $D(DUOUT)!($D(DTOUT)) D MESS K DIR,Y S DIR(0)="E",DIR("A")="Press Return to continue" D ^DIR K DIR Q
I Y'="80",Y'="132" D MESS K DIR,Y S DIR(0)="E",DIR("A")="Press Return to continue" D ^DIR K DIR Q
S PSSALONG=Y W !
K IOP,%ZIS,POP S %ZIS="QM" D ^%ZIS I $G(POP)>0 D MESS K DIR,Y S DIR(0)="E",DIR("A")="Press Return to continue" D ^DIR K DIR,IOP,%ZIS,POP Q
I $D(IO("Q")) S ZTRTN="START^PSSSCHRP",ZTDESC="Administration Schedule Report",ZTSAVE("PSSAFRP")="",ZTSAVE("PSSALONG")="" D ^%ZTLOAD K %ZIS W !!,"Report queued to print.",! K DIR,Y S DIR(0)="E",DIR("A")="Press Return to continue" D ^DIR K DIR Q
;
;
START ;Print Administration Schedule File report
U IO
N PSSAFCT,PSSAFOUT,PSSAFDEV,PSSAFLIN,PSSAFQ,PSSAFQEN,PSSAFQS,PSSAFQL,PSSAFQQ,PSSAFQC,PSSAFAA,PSSAFAL,PSSWAS,PSSWASEN,PSSWASNM,PSSWASAD,PSSWASLL,PSSTPE
N PSSAFRA,PSSAFRAA,PSSAFROP,PSSAFQL,PSSAFROO,PSSAFRFL,PSSWASX,PSSAFZZZ,PSSAFABC,PSSAFNOF,PSSFD,PSSDFS
S (PSSAFOUT,PSSAFNOF)=0,PSSAFDEV=$S($E(IOST,1,2)'="C-":"P",1:"C"),PSSAFCT=1
K PSSAFLIN S:PSSALONG=132 $P(PSSAFLIN,"-",130)="" S:PSSALONG=80 $P(PSSAFLIN,"-",78)=""
D HD
S PSSAFQ="" F S PSSAFQ=$O(^PS(51.1,"B",PSSAFQ)) Q:PSSAFQ=""!(PSSAFOUT) D
.F PSSAFQEN=0:0 S PSSAFQEN=$O(^PS(51.1,"B",PSSAFQ,PSSAFQEN)) Q:'PSSAFQEN!(PSSAFOUT) D
..K PSSAFRA,PSSAFRAA,PSSAFROP,PSSAFQS,PSSAFROP,PSSAFROO,PSSAFQL,PSSWASX,PSSAFQC,PSSAFQQ
..S PSSAFRA=PSSAFQEN_","
..D GETS^DIQ(51.1,PSSAFRA,".01;1;2;4;8;8.1;9;10;11;11.1*;12;13*","E","PSSAFRAA")
..I $G(PSSAFRAA(51.1,PSSAFRA,4,"E"))'="PSJ" Q
..I PSSAFRP="O",$G(PSSAFRAA(51.1,PSSAFRA,2,"E")) Q
..S PSSAFNOF=1
..W !!,$G(PSSAFRAA(51.1,PSSAFRA,.01,"E"))
..I ($Y+5)>IOSL D HD Q:PSSAFOUT
..S PSSAFQS=$G(PSSAFRAA(51.1,PSSAFRA,1,"E"))
..W !?5,"STANDARD ADMINISTRATION TIMES: " D K PSSAFAA Q:PSSAFOUT
...Q:PSSAFQS=""
...S PSSAFQL=$L(PSSAFQS)
...I PSSALONG=132 D Q
....I PSSAFQL<96 D Q
.....W PSSAFQS
.....I ($Y+5)>IOSL D HD Q:PSSAFOUT
....K PSSAFAA D FORMAT(PSSAFQS,96)
....S PSSAFRFL=0 F PSSAFAL=0:0 S PSSAFAL=$O(PSSAFAA(PSSAFAL)) Q:'PSSAFAL!(PSSAFOUT) D
.....W:'PSSAFRFL ?36,$G(PSSAFAA(PSSAFAL)) W:PSSAFRFL !?36,$G(PSSAFAA(PSSAFAL)) S PSSAFRFL=1
.....I ($Y+5)>IOSL D HD Q:PSSAFOUT
...I PSSAFQL<44 D Q
....W PSSAFQS
....I ($Y+5)>IOSL D HD Q:PSSAFOUT
...K PSSAFAA D FORMAT(PSSAFQS,44)
...S PSSAFRFL=0 F PSSAFAL=0:0 S PSSAFAL=$O(PSSAFAA(PSSAFAL)) Q:'PSSAFAL!(PSSAFOUT) D
....W:'PSSAFRFL ?36,$G(PSSAFAA(PSSAFAL)) W:PSSAFRFL !?36,$G(PSSAFAA(PSSAFAL)) S PSSAFRFL=1
....I ($Y+5)>IOSL D HD Q:PSSAFOUT
..I ($Y+5)>IOSL D HD Q:PSSAFOUT
..W !?14,"OUTPATIENT EXPANSION: " D
...S PSSAFROP=$G(PSSAFRAA(51.1,PSSAFRA,8,"E"))
...I PSSALONG=132 D Q
....I $L(PSSAFROP)<96 W PSSAFROP,! Q
....N X,DIWL,DIWR,DIWF S X=PSSAFROP,DIWL=37,DIWR=131,DIWF="W" K ^UTILITY($J,"W") D ^DIWP D ^DIWW K ^UTILITY($J,"W")
...I $L(PSSAFROP)<44 W PSSAFROP,! Q
...N X,DIWL,DIWR,DIWF S X=PSSAFROP,DIWL=37,DIWR=79,DIWF="W" K ^UTILITY($J,"W") D ^DIWP D ^DIWW K ^UTILITY($J,"W")
..I ($Y+5)>IOSL D HD Q:PSSAFOUT W !
..W ?10,"OTHER LANGUAGE EXPANSION: " D
...S PSSAFROO=$G(PSSAFRAA(51.1,PSSAFRA,8.1,"E"))
...I PSSALONG=132 D Q
....I $L(PSSAFROO)<96 W PSSAFROO,! Q
....N X,DIWL,DIWR,DIWF S X=PSSAFROO,DIWL=37,DIWR=131,DIWF="W" K ^UTILITY($J,"W") D ^DIWP D ^DIWW K ^UTILITY($J,"W")
...I $L(PSSAFROO)<44 W PSSAFROO,! Q
...N X,DIWL,DIWR,DIWF S X=PSSAFROO,DIWL=37,DIWR=79,DIWF="W" K ^UTILITY($J,"W") D ^DIWP D ^DIWW K ^UTILITY($J,"W")
..;Set PSSAFZZZ=0 if last write had a line feed, PSSAFZZZ=1 if last write did not have a line feed, to use for OLD SCHEDULE NAME(S)
..S PSSAFZZZ=0 I ($Y+5)>IOSL D HD S PSSAFZZZ=0 Q:PSSAFOUT
..S PSSAFRFL=0 F PSSWAS=0:0 S PSSWAS=$O(^PS(51.1,PSSAFQEN,1,PSSWAS)) Q:'PSSWAS!(PSSAFOUT) D
...S PSSWASEN=$P($G(^PS(51.1,PSSAFQEN,1,PSSWAS,0)),"^") Q:'PSSWASEN
...S PSSWASX=PSSWAS_","_PSSAFQEN_"," S PSSWASNM=$$GET1^DIQ(51.11,PSSWASX,".01") Q:PSSWASNM=""
...;PSSARFRL=0 if last Write ended in Line Feed, =1 if Last Write did not end in line feed, for writing Wards
...W:'PSSAFRFL ?30,"WARD: "_PSSWASNM W:PSSAFRFL !?30,"WARD: "_PSSWASNM S (PSSAFZZZ,PSSAFRFL)=1
...I ($Y+5)>IOSL D HD S (PSSAFZZZ,PSSAFRFL)=0 Q:PSSAFOUT
...W !?9,"WARD ADMINISTRATION TIMES: " S (PSSAFZZZ,PSSAFRFL)=1
...S PSSWASAD=$P($G(^PS(51.1,PSSAFQEN,1,PSSWAS,0)),"^",2)
...Q:PSSWASAD=""
...S (PSSWASLL,PSSAFQL)=$L(PSSWASAD)
...I PSSALONG=132 D Q
....I PSSWASLL<96 D Q
.....W PSSWASAD S (PSSAFZZZ,PSSAFRFL)=1
.....I ($Y+5)>IOSL D HD S (PSSAFZZZ,PSSAFRFL)=0 Q:PSSAFOUT
....K PSSAFAA D FORMAT(PSSWASAD,96)
....S PSSAFABC=0 F PSSAFAL=0:0 S PSSAFAL=$O(PSSAFAA(PSSAFAL)) Q:'PSSAFAL!(PSSAFOUT) D
.....W:'PSSAFABC ?36,$G(PSSAFAA(PSSAFAL)) W:PSSAFABC !?36,$G(PSSAFAA(PSSAFAL)) S PSSAFABC=1 S (PSSAFZZZ,PSSAFRFL)=1
.....I ($Y+5)>IOSL D HD S (PSSAFZZZ,PSSAFRFL)=0 Q:PSSAFOUT
...I PSSWASLL<37 D Q
....W PSSWASAD S (PSSAFZZZ,PSSAFRFL)=1
....I ($Y+5)>IOSL D HD S (PSSAFZZZ,PSSAFRFL)=0 Q:PSSAFOUT
...K PSSAFAA D FORMAT(PSSWASAD,44)
...S PSSAFABC=0 F PSSAFAL=0:0 S PSSAFAL=$O(PSSAFAA(PSSAFAL)) Q:'PSSAFAL!(PSSAFOUT) D
....W:'PSSAFABC ?36,$G(PSSAFAA(PSSAFAL)) W:PSSAFABC !?36,$G(PSSAFAA(PSSAFAL)) S PSSAFABC=1 S (PSSAFZZZ,PSSAFRFL)=1
....I ($Y+5)>IOSL D HD S (PSSAFZZZ,PSSAFRFL)=0 Q:PSSAFOUT
..Q:PSSAFOUT
..K PSSAFAA
..I ($Y+5)>IOSL D HD S (PSSAFZZZ,PSSAFRFL)=0 Q:PSSAFOUT
..W:'PSSAFZZZ ?14,"OLD SCHEDULE NAME(S): " W:PSSAFZZZ !?14,"OLD SCHEDULE NAME(S): "
..S:$D(PSSAFRAA(51.113)) PSSFD=1,PSSDFS=0 IF $D(PSSFD),$D(PSSDFS) FOR SET PSSFD=$O(PSSAFRAA(51.113,PSSFD)) Q:PSSFD']""!(PSSAFOUT) D
...W:'PSSDFS ?36,$G(PSSAFRAA(51.113,PSSFD,.01,"E")) W:PSSDFS !,?36,$G(PSSAFRAA(51.113,PSSFD,.01,"E")) S PSSDFS=1
...I ($Y+5)>IOSL D HD Q:PSSAFOUT
..Q:PSSAFOUT
..K PSSTPE S PSSTPE=$$GET1^DIQ(51.1,PSSAFQEN_",",5)
..W:'PSSAFZZZ !?21,"SCHEDULE TYPE: "_$G(PSSTPE) W:PSSAFZZZ !?21,"SCHEDULE TYPE: "_$G(PSSTPE)
..I ($Y+5)>IOSL D HD Q:PSSAFOUT
..W !?12,"FREQUENCY (IN MINUTES): "_$G(PSSAFRAA(51.1,PSSAFRA,2,"E"))
..I ($Y+5)>IOSL D HD Q:PSSAFOUT
..W !?6,"EXCLUDE FROM ALL DOSE CHECKS: "_$G(PSSAFRAA(51.1,PSSAFRA,9,"E"))
..I ($Y+5)>IOSL D HD Q:PSSAFOUT
..W !?5,"EXCLUDE FROM DAILY DOSE CHECK: "_$G(PSSAFRAA(51.1,PSSAFRA,10,"E"))
..I ($Y+5)>IOSL D HD Q:PSSAFOUT
..W !?12,"DOSING CHECK FREQUENCY: "_$G(PSSAFRAA(51.1,PSSAFRA,11,"E"))
..I ($Y+5)>IOSL D HD Q:PSSAFOUT
..W !?7,"DRUG(S) FOR DOSING CHK FREQ: "
..S:$D(PSSAFRAA(51.111)) PSSFD=1,PSSDFS=0 IF $D(PSSFD),$D(PSSDFS) FOR SET PSSFD=$O(PSSAFRAA(51.111,PSSFD)) Q:PSSFD']""!(PSSAFOUT) D
...W:'PSSDFS ?36,$G(PSSAFRAA(51.111,PSSFD,.01,"E")) W:PSSDFS !,?36,$G(PSSAFRAA(51.111,PSSFD,.01,"E")) S PSSDFS=1
...I ($Y+5)>IOSL D HD Q:PSSAFOUT
..W !?26,"INACTIVE: "_$G(PSSAFRAA(51.1,PSSAFRA,12,"E"))
..I ($Y+5)>IOSL D HD Q:PSSAFOUT
;
END ;
I '$G(PSSAFOUT),PSSAFRP="O",'$G(PSSAFNOF) W !!,"No schedules found without frequencies.",!
I $G(PSSAFDEV)="P" W !!,"End of Report.",!
I '$G(PSSAFOUT),$G(PSSAFDEV)="C" W !!,"End of Report." K DIR S DIR(0)="E",DIR("A")="Press Return to continue" D ^DIR K DIR
I $G(PSSAFDEV)="C" W !
E W @IOF
K PSSAFRP,PSSALONG
D ^%ZISC S:$D(ZTQUEUED) ZTREQ="@"
Q
;
;
HD ;Report Header
I $G(PSSAFDEV)="C",$G(PSSAFCT)'=1 W ! K DIR,Y S DIR(0)="E",DIR("A")="Press Return to continue, '^' to exit" D ^DIR K DIR I 'Y S PSSAFOUT=1 Q
W @IOF
I PSSAFRP="A" W !,"ADMINISTRATION SCHEDULE FILE REPORT (All)"
I PSSAFRP="O" W !,"ADMINISTRATION SCHEDULE WITHOUT FREQUENCY REPORT"
W ?$S(PSSALONG=80:68,1:120),"PAGE: "_PSSAFCT,!,PSSAFLIN,! S PSSAFCT=PSSAFCT+1
Q
;
;
MESS ;
W !!,"Nothing queued to print.",!
Q
;
;
FORMAT(PSSAFQC,PSSAFQQ) ;Format print arrays, breaking on the "-" character
;PSSAFQC = Administration Times text
;PSSAFQQ = Character at which to break
N PSSAFAC,PSSAFAB,PSSAFAZ,PSSAFAD,PSSAFAF,PSSAFAX
S PSSAFAC=1,PSSAFAZ=0 K PSSAFAB
F PSSAFAD=1:1:PSSAFQL I $E(PSSAFQC,PSSAFAD)="-" S PSSAFAB(PSSAFAC)=$P(PSSAFQC,"-",PSSAFAC)_"-" S PSSAFAC=PSSAFAC+1,PSSAFAZ=PSSAFAD+1
I PSSAFAZ<PSSAFAD S:PSSAFAZ=0 PSSAFAZ=1 S PSSAFAB(PSSAFAC)=$E(PSSAFQC,PSSAFAZ,PSSAFQL) S PSSAFAC=PSSAFAC+1
S PSSAFAF=1
F PSSAFAX=1:1:PSSAFAC D
.Q:'$D(PSSAFAB(PSSAFAX))
.I '$D(PSSAFAA(PSSAFAF)) S PSSAFAA(PSSAFAF)=PSSAFAB(PSSAFAX) Q
.I $L(PSSAFAA(PSSAFAF))+$L(PSSAFAB(PSSAFAX))<PSSAFQQ S PSSAFAA(PSSAFAF)=PSSAFAA(PSSAFAF)_PSSAFAB(PSSAFAX) Q
.S PSSAFAF=PSSAFAF+1 S PSSAFAA(PSSAFAF)=PSSAFAB(PSSAFAX)
Q
;
;
TRAIL ;Trailing spaces Report
W !!,"This report displays active, multi-ingredient entries from the DRUG (#50) File"
W !,"with Local Possible Dosages defined, with trailing spaces in the name. Entries"
W !,"not matched to National Drug File are also included if there are trailing"
W !,"spaces. Trailing spaces can potentially cause the Dose check to fail, and"
W !,"also possibly cause the conjunction and drug name to become part of the Dosage.",!
N DIR,Y,X,DTOUT,DUOUT,DIRUT,DIROUT,IOP,%ZIS,POP,ZTRTN,ZTDESC,ZTSAVE,ZTSK
K IOP,%ZIS,POP S %ZIS="QM" D ^%ZIS I $G(POP)>0 D MESS K DIR,Y S DIR(0)="E",DIR("A")="Press Return to continue" D ^DIR K DIR,IOP,%ZIS,POP Q
I $D(IO("Q")) S ZTRTN="STRAIL^PSSSCHRP",ZTDESC="Trailing Spaces Report" D ^%ZTLOAD K %ZIS W !!,"Report queued to print.",! K DIR,Y S DIR(0)="E",DIR("A")="Press Return to continue" D ^DIR K DIR Q
;
;
STRAIL ;Print Trailing spaces report
U IO
N PSSTRSOT,PSSTRSLG,PSSTRSFL,PSSTRSDV,PSSTRSPG,PSSTRSAA,PSSTRSBB,PSSTRSNM,PSSTRSIN,PSSTRSST,PSSTRSUN,PSSTRSN1,PSSTRSN3,PSSTRSN9
S (PSSTRSOT,PSSTRSFL)=0,PSSTRSDV=$S($E(IOST,1,2)'="C-":"P",1:"C"),PSSTRSPG=1
K PSSTRSLG S $P(PSSTRSLG,"-",78)=""
D STHD
S PSSTRSAA="" F S PSSTRSAA=$O(^PSDRUG("B",PSSTRSAA)) Q:PSSTRSAA=""!(PSSTRSOT) D
.F PSSTRSBB=0:0 S PSSTRSBB=$O(^PSDRUG("B",PSSTRSAA,PSSTRSBB)) Q:'PSSTRSBB!(PSSTRSOT) D:$O(^PSDRUG(PSSTRSBB,"DOS2",0))
..S PSSTRSNM=$P($G(^PSDRUG(PSSTRSBB,0)),"^"),PSSTRSIN=$P($G(^PSDRUG(PSSTRSBB,"I")),"^")
..I $E(PSSTRSNM,$L(PSSTRSNM))'=" " Q
..I PSSTRSIN,PSSTRSIN<DT Q
..S PSSTRSN1=$P($G(^PSDRUG(PSSTRSBB,"ND")),"^"),PSSTRSN3=$P($G(^PSDRUG(PSSTRSBB,"ND")),"^",3)
..I 'PSSTRSN1!('PSSTRSN3) W !,PSSTRSNM_" ("_PSSTRSBB_")" S PSSTRSFL=1 D:($Y+5)>IOSL STHD Q
..S PSSTRSST=$P($G(^PSDRUG(PSSTRSBB,"DOS")),"^"),PSSTRSUN=$P($G(^PSDRUG(PSSTRSBB,"DOS")),"^",2)
..I PSSTRSST'="" Q
..K PSSTRSN9 I PSSTRSST=""!('PSSTRSUN) S PSSTRSN9=$$DFSU^PSNAPIS(PSSTRSN1,PSSTRSN3)
..S PSSTRSST=$P($G(PSSTRSN9),"^",4) I $$STST() Q
..W !,PSSTRSNM_" ("_PSSTRSBB_")" S PSSTRSFL=1 I ($Y+5)>IOSL D STHD
;
;
STEND ;
I '$G(PSSTRSOT),'$G(PSSTRSFL) W !!,"No drug names found.",!
I $G(PSSTRSDV)="P" W !!,"End of Report.",!
I '$G(PSSTRSOT),$G(PSSTRSDV)="C" W !!,"End of Report." K DIR S DIR(0)="E",DIR("A")="Press Return to continue" D ^DIR K DIR
I $G(PSSTRSDV)="C" W !
E W @IOF
D ^%ZISC S:$D(ZTQUEUED) ZTREQ="@"
Q
;
;
STHD ;Report Header
I $G(PSSTRSDV)="C",$G(PSSTRSPG)'=1 W ! K DIR,Y S DIR(0)="E",DIR("A")="Press Return to continue, '^' to exit" D ^DIR K DIR I 'Y S PSSTRSOT=1 Q
W @IOF
W !,"DRUG NAME TRAILING SPACES REPORT"
W ?68,"PAGE: "_PSSTRSPG,!,PSSTRSLG,! S PSSTRSPG=PSSTRSPG+1
Q
;
;
STST() ;Is strength numeric
I PSSTRSST="" Q 0
I PSSTRSST'?.N&(PSSTRSST'?.N1".".N) Q 0
Q 1
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSSSCHRP 13035 printed Nov 22, 2024@17:44:23 Page 2
PSSSCHRP ;BIR/RTR-Schedule Report ; 10/15/15 4:26pm
+1 ;;1.0;PHARMACY DATA MANAGEMENT;**129,160,189,201**;9/30/97;Build 25
+2 ;External reference to ^PSNAPIS supported by DBIA #2531
+3 ;
EN ;Prompts for Administration File Schedule Report
+1 WRITE !!,"This report displays entries from the ADMINISTRATION SCHEDULE (#51.1) File."
+2 WRITE !,"It can be run for all Schedules, or only Schedules without a FREQUENCY"
+3 WRITE !,"(IN MINUTES). Only schedules with a PSJ Package Prefix will be displayed, since"
+4 WRITE !,"they are the only schedules the software will look at when deriving a FREQUENCY"
+5 WRITE !,"(IN MINUTES) for the daily dosage checks. If a FREQUENCY (IN MINUTES) cannot",!,"be determined for an order, the daily dosage check cannot occur for that order."
+6 NEW DIR,PSSAFRP,PSSALONG,Y,X,DTOUT,DUOUT,DIRUT,DIROUT,IOP,%ZIS,POP,ZTRTN,ZTDESC,ZTSAVE,ZTSK
+7 KILL DIR,Y
SET DIR(0)="SO^A:All Schedules;O:Only Schedules with a missing frequency"
SET DIR("A")="Print All Schedules, or Only Schedules without a frequency"
SET DIR("B")="A"
+8 SET DIR("?")=" "
SET DIR("?",1)=" "
SET DIR("?",2)="Enter 'A' to see all Administration Schedules, enter 'O' to see only"
SET DIR("?",3)="those Administration Schedules without data in the FREQUENCY (IN MINUTES)"
+9 SET DIR("?",4)="(#2) Field. A FREQUENCY (IN MINUTES) must be derived from a Schedule"
SET DIR("?",5)="for the daily dosage check to occur for an order."
+10 WRITE !
DO ^DIR
KILL DIR
IF $DATA(DUOUT)!($DATA(DTOUT))
DO MESS
KILL DIR,Y
SET DIR(0)="E"
SET DIR("A")="Press Return to continue"
DO ^DIR
KILL DIR
QUIT
+11 IF Y'="A"
IF Y'="O"
DO MESS
KILL DIR,Y
SET DIR(0)="E"
SET DIR("A")="Press Return to continue"
DO ^DIR
KILL DIR
QUIT
+12 SET PSSAFRP=Y
+13 KILL DIR,Y
SET DIR(0)="SO^80:80 Column;132:132 Column"
SET DIR("A")="Print report in 80 or 132 column format"
SET DIR("B")="80"
+14 SET DIR("?")=" "
SET DIR("?",1)="Enter 80 to print the report in an 80 column format,"
SET DIR("?",2)="Enter 132 to print the report in an 132 column format."
+15 WRITE !
DO ^DIR
KILL DIR
IF $DATA(DUOUT)!($DATA(DTOUT))
DO MESS
KILL DIR,Y
SET DIR(0)="E"
SET DIR("A")="Press Return to continue"
DO ^DIR
KILL DIR
QUIT
+16 IF Y'="80"
IF Y'="132"
DO MESS
KILL DIR,Y
SET DIR(0)="E"
SET DIR("A")="Press Return to continue"
DO ^DIR
KILL DIR
QUIT
+17 SET PSSALONG=Y
WRITE !
+18 KILL IOP,%ZIS,POP
SET %ZIS="QM"
DO ^%ZIS
IF $GET(POP)>0
DO MESS
KILL DIR,Y
SET DIR(0)="E"
SET DIR("A")="Press Return to continue"
DO ^DIR
KILL DIR,IOP,%ZIS,POP
QUIT
+19 IF $DATA(IO("Q"))
SET ZTRTN="START^PSSSCHRP"
SET ZTDESC="Administration Schedule Report"
SET ZTSAVE("PSSAFRP")=""
SET ZTSAVE("PSSALONG")=""
DO ^%ZTLOAD
KILL %ZIS
WRITE !!,"Report queued to print.",!
KILL DIR,Y
SET DIR(0)="E"
SET DIR("A")="Press Return to continue"
DO ^DIR
KILL DIR
QUIT
+20 ;
+21 ;
START ;Print Administration Schedule File report
+1 USE IO
+2 NEW PSSAFCT,PSSAFOUT,PSSAFDEV,PSSAFLIN,PSSAFQ,PSSAFQEN,PSSAFQS,PSSAFQL,PSSAFQQ,PSSAFQC,PSSAFAA,PSSAFAL,PSSWAS,PSSWASEN,PSSWASNM,PSSWASAD,PSSWASLL,PSSTPE
+3 NEW PSSAFRA,PSSAFRAA,PSSAFROP,PSSAFQL,PSSAFROO,PSSAFRFL,PSSWASX,PSSAFZZZ,PSSAFABC,PSSAFNOF,PSSFD,PSSDFS
+4 SET (PSSAFOUT,PSSAFNOF)=0
SET PSSAFDEV=$SELECT($EXTRACT(IOST,1,2)'="C-":"P",1:"C")
SET PSSAFCT=1
+5 KILL PSSAFLIN
if PSSALONG=132
SET $PIECE(PSSAFLIN,"-",130)=""
if PSSALONG=80
SET $PIECE(PSSAFLIN,"-",78)=""
+6 DO HD
+7 SET PSSAFQ=""
FOR
SET PSSAFQ=$ORDER(^PS(51.1,"B",PSSAFQ))
if PSSAFQ=""!(PSSAFOUT)
QUIT
Begin DoDot:1
+8 FOR PSSAFQEN=0:0
SET PSSAFQEN=$ORDER(^PS(51.1,"B",PSSAFQ,PSSAFQEN))
if 'PSSAFQEN!(PSSAFOUT)
QUIT
Begin DoDot:2
+9 KILL PSSAFRA,PSSAFRAA,PSSAFROP,PSSAFQS,PSSAFROP,PSSAFROO,PSSAFQL,PSSWASX,PSSAFQC,PSSAFQQ
+10 SET PSSAFRA=PSSAFQEN_","
+11 DO GETS^DIQ(51.1,PSSAFRA,".01;1;2;4;8;8.1;9;10;11;11.1*;12;13*","E","PSSAFRAA")
+12 IF $GET(PSSAFRAA(51.1,PSSAFRA,4,"E"))'="PSJ"
QUIT
+13 IF PSSAFRP="O"
IF $GET(PSSAFRAA(51.1,PSSAFRA,2,"E"))
QUIT
+14 SET PSSAFNOF=1
+15 WRITE !!,$GET(PSSAFRAA(51.1,PSSAFRA,.01,"E"))
+16 IF ($Y+5)>IOSL
DO HD
if PSSAFOUT
QUIT
+17 SET PSSAFQS=$GET(PSSAFRAA(51.1,PSSAFRA,1,"E"))
+18 WRITE !?5,"STANDARD ADMINISTRATION TIMES: "
Begin DoDot:3
+19 if PSSAFQS=""
QUIT
+20 SET PSSAFQL=$LENGTH(PSSAFQS)
+21 IF PSSALONG=132
Begin DoDot:4
+22 IF PSSAFQL<96
Begin DoDot:5
+23 WRITE PSSAFQS
+24 IF ($Y+5)>IOSL
DO HD
if PSSAFOUT
QUIT
End DoDot:5
QUIT
+25 KILL PSSAFAA
DO FORMAT(PSSAFQS,96)
+26 SET PSSAFRFL=0
FOR PSSAFAL=0:0
SET PSSAFAL=$ORDER(PSSAFAA(PSSAFAL))
if 'PSSAFAL!(PSSAFOUT)
QUIT
Begin DoDot:5
+27 if 'PSSAFRFL
WRITE ?36,$GET(PSSAFAA(PSSAFAL))
if PSSAFRFL
WRITE !?36,$GET(PSSAFAA(PSSAFAL))
SET PSSAFRFL=1
+28 IF ($Y+5)>IOSL
DO HD
if PSSAFOUT
QUIT
End DoDot:5
End DoDot:4
QUIT
+29 IF PSSAFQL<44
Begin DoDot:4
+30 WRITE PSSAFQS
+31 IF ($Y+5)>IOSL
DO HD
if PSSAFOUT
QUIT
End DoDot:4
QUIT
+32 KILL PSSAFAA
DO FORMAT(PSSAFQS,44)
+33 SET PSSAFRFL=0
FOR PSSAFAL=0:0
SET PSSAFAL=$ORDER(PSSAFAA(PSSAFAL))
if 'PSSAFAL!(PSSAFOUT)
QUIT
Begin DoDot:4
+34 if 'PSSAFRFL
WRITE ?36,$GET(PSSAFAA(PSSAFAL))
if PSSAFRFL
WRITE !?36,$GET(PSSAFAA(PSSAFAL))
SET PSSAFRFL=1
+35 IF ($Y+5)>IOSL
DO HD
if PSSAFOUT
QUIT
End DoDot:4
End DoDot:3
KILL PSSAFAA
if PSSAFOUT
QUIT
+36 IF ($Y+5)>IOSL
DO HD
if PSSAFOUT
QUIT
+37 WRITE !?14,"OUTPATIENT EXPANSION: "
Begin DoDot:3
+38 SET PSSAFROP=$GET(PSSAFRAA(51.1,PSSAFRA,8,"E"))
+39 IF PSSALONG=132
Begin DoDot:4
+40 IF $LENGTH(PSSAFROP)<96
WRITE PSSAFROP,!
QUIT
+41 NEW X,DIWL,DIWR,DIWF
SET X=PSSAFROP
SET DIWL=37
SET DIWR=131
SET DIWF="W"
KILL ^UTILITY($JOB,"W")
DO ^DIWP
DO ^DIWW
KILL ^UTILITY($JOB,"W")
End DoDot:4
QUIT
+42 IF $LENGTH(PSSAFROP)<44
WRITE PSSAFROP,!
QUIT
+43 NEW X,DIWL,DIWR,DIWF
SET X=PSSAFROP
SET DIWL=37
SET DIWR=79
SET DIWF="W"
KILL ^UTILITY($JOB,"W")
DO ^DIWP
DO ^DIWW
KILL ^UTILITY($JOB,"W")
End DoDot:3
+44 IF ($Y+5)>IOSL
DO HD
if PSSAFOUT
QUIT
WRITE !
+45 WRITE ?10,"OTHER LANGUAGE EXPANSION: "
Begin DoDot:3
+46 SET PSSAFROO=$GET(PSSAFRAA(51.1,PSSAFRA,8.1,"E"))
+47 IF PSSALONG=132
Begin DoDot:4
+48 IF $LENGTH(PSSAFROO)<96
WRITE PSSAFROO,!
QUIT
+49 NEW X,DIWL,DIWR,DIWF
SET X=PSSAFROO
SET DIWL=37
SET DIWR=131
SET DIWF="W"
KILL ^UTILITY($JOB,"W")
DO ^DIWP
DO ^DIWW
KILL ^UTILITY($JOB,"W")
End DoDot:4
QUIT
+50 IF $LENGTH(PSSAFROO)<44
WRITE PSSAFROO,!
QUIT
+51 NEW X,DIWL,DIWR,DIWF
SET X=PSSAFROO
SET DIWL=37
SET DIWR=79
SET DIWF="W"
KILL ^UTILITY($JOB,"W")
DO ^DIWP
DO ^DIWW
KILL ^UTILITY($JOB,"W")
End DoDot:3
+52 ;Set PSSAFZZZ=0 if last write had a line feed, PSSAFZZZ=1 if last write did not have a line feed, to use for OLD SCHEDULE NAME(S)
+53 SET PSSAFZZZ=0
IF ($Y+5)>IOSL
DO HD
SET PSSAFZZZ=0
if PSSAFOUT
QUIT
+54 SET PSSAFRFL=0
FOR PSSWAS=0:0
SET PSSWAS=$ORDER(^PS(51.1,PSSAFQEN,1,PSSWAS))
if 'PSSWAS!(PSSAFOUT)
QUIT
Begin DoDot:3
+55 SET PSSWASEN=$PIECE($GET(^PS(51.1,PSSAFQEN,1,PSSWAS,0)),"^")
if 'PSSWASEN
QUIT
+56 SET PSSWASX=PSSWAS_","_PSSAFQEN_","
SET PSSWASNM=$$GET1^DIQ(51.11,PSSWASX,".01")
if PSSWASNM=""
QUIT
+57 ;PSSARFRL=0 if last Write ended in Line Feed, =1 if Last Write did not end in line feed, for writing Wards
+58 if 'PSSAFRFL
WRITE ?30,"WARD: "_PSSWASNM
if PSSAFRFL
WRITE !?30,"WARD: "_PSSWASNM
SET (PSSAFZZZ,PSSAFRFL)=1
+59 IF ($Y+5)>IOSL
DO HD
SET (PSSAFZZZ,PSSAFRFL)=0
if PSSAFOUT
QUIT
+60 WRITE !?9,"WARD ADMINISTRATION TIMES: "
SET (PSSAFZZZ,PSSAFRFL)=1
+61 SET PSSWASAD=$PIECE($GET(^PS(51.1,PSSAFQEN,1,PSSWAS,0)),"^",2)
+62 if PSSWASAD=""
QUIT
+63 SET (PSSWASLL,PSSAFQL)=$LENGTH(PSSWASAD)
+64 IF PSSALONG=132
Begin DoDot:4
+65 IF PSSWASLL<96
Begin DoDot:5
+66 WRITE PSSWASAD
SET (PSSAFZZZ,PSSAFRFL)=1
+67 IF ($Y+5)>IOSL
DO HD
SET (PSSAFZZZ,PSSAFRFL)=0
if PSSAFOUT
QUIT
End DoDot:5
QUIT
+68 KILL PSSAFAA
DO FORMAT(PSSWASAD,96)
+69 SET PSSAFABC=0
FOR PSSAFAL=0:0
SET PSSAFAL=$ORDER(PSSAFAA(PSSAFAL))
if 'PSSAFAL!(PSSAFOUT)
QUIT
Begin DoDot:5
+70 if 'PSSAFABC
WRITE ?36,$GET(PSSAFAA(PSSAFAL))
if PSSAFABC
WRITE !?36,$GET(PSSAFAA(PSSAFAL))
SET PSSAFABC=1
SET (PSSAFZZZ,PSSAFRFL)=1
+71 IF ($Y+5)>IOSL
DO HD
SET (PSSAFZZZ,PSSAFRFL)=0
if PSSAFOUT
QUIT
End DoDot:5
End DoDot:4
QUIT
+72 IF PSSWASLL<37
Begin DoDot:4
+73 WRITE PSSWASAD
SET (PSSAFZZZ,PSSAFRFL)=1
+74 IF ($Y+5)>IOSL
DO HD
SET (PSSAFZZZ,PSSAFRFL)=0
if PSSAFOUT
QUIT
End DoDot:4
QUIT
+75 KILL PSSAFAA
DO FORMAT(PSSWASAD,44)
+76 SET PSSAFABC=0
FOR PSSAFAL=0:0
SET PSSAFAL=$ORDER(PSSAFAA(PSSAFAL))
if 'PSSAFAL!(PSSAFOUT)
QUIT
Begin DoDot:4
+77 if 'PSSAFABC
WRITE ?36,$GET(PSSAFAA(PSSAFAL))
if PSSAFABC
WRITE !?36,$GET(PSSAFAA(PSSAFAL))
SET PSSAFABC=1
SET (PSSAFZZZ,PSSAFRFL)=1
+78 IF ($Y+5)>IOSL
DO HD
SET (PSSAFZZZ,PSSAFRFL)=0
if PSSAFOUT
QUIT
End DoDot:4
End DoDot:3
+79 if PSSAFOUT
QUIT
+80 KILL PSSAFAA
+81 IF ($Y+5)>IOSL
DO HD
SET (PSSAFZZZ,PSSAFRFL)=0
if PSSAFOUT
QUIT
+82 if 'PSSAFZZZ
WRITE ?14,"OLD SCHEDULE NAME(S): "
if PSSAFZZZ
WRITE !?14,"OLD SCHEDULE NAME(S): "
+83 if $DATA(PSSAFRAA(51.113))
SET PSSFD=1
SET PSSDFS=0
IF $DATA(PSSFD)
IF $DATA(PSSDFS)
FOR
SET PSSFD=$ORDER(PSSAFRAA(51.113,PSSFD))
if PSSFD']""!(PSSAFOUT)
QUIT
Begin DoDot:3
+84 if 'PSSDFS
WRITE ?36,$GET(PSSAFRAA(51.113,PSSFD,.01,"E"))
if PSSDFS
WRITE !,?36,$GET(PSSAFRAA(51.113,PSSFD,.01,"E"))
SET PSSDFS=1
+85 IF ($Y+5)>IOSL
DO HD
if PSSAFOUT
QUIT
End DoDot:3
+86 if PSSAFOUT
QUIT
+87 KILL PSSTPE
SET PSSTPE=$$GET1^DIQ(51.1,PSSAFQEN_",",5)
+88 if 'PSSAFZZZ
WRITE !?21,"SCHEDULE TYPE: "_$GET(PSSTPE)
if PSSAFZZZ
WRITE !?21,"SCHEDULE TYPE: "_$GET(PSSTPE)
+89 IF ($Y+5)>IOSL
DO HD
if PSSAFOUT
QUIT
+90 WRITE !?12,"FREQUENCY (IN MINUTES): "_$GET(PSSAFRAA(51.1,PSSAFRA,2,"E"))
+91 IF ($Y+5)>IOSL
DO HD
if PSSAFOUT
QUIT
+92 WRITE !?6,"EXCLUDE FROM ALL DOSE CHECKS: "_$GET(PSSAFRAA(51.1,PSSAFRA,9,"E"))
+93 IF ($Y+5)>IOSL
DO HD
if PSSAFOUT
QUIT
+94 WRITE !?5,"EXCLUDE FROM DAILY DOSE CHECK: "_$GET(PSSAFRAA(51.1,PSSAFRA,10,"E"))
+95 IF ($Y+5)>IOSL
DO HD
if PSSAFOUT
QUIT
+96 WRITE !?12,"DOSING CHECK FREQUENCY: "_$GET(PSSAFRAA(51.1,PSSAFRA,11,"E"))
+97 IF ($Y+5)>IOSL
DO HD
if PSSAFOUT
QUIT
+98 WRITE !?7,"DRUG(S) FOR DOSING CHK FREQ: "
+99 if $DATA(PSSAFRAA(51.111))
SET PSSFD=1
SET PSSDFS=0
IF $DATA(PSSFD)
IF $DATA(PSSDFS)
FOR
SET PSSFD=$ORDER(PSSAFRAA(51.111,PSSFD))
if PSSFD']""!(PSSAFOUT)
QUIT
Begin DoDot:3
+100 if 'PSSDFS
WRITE ?36,$GET(PSSAFRAA(51.111,PSSFD,.01,"E"))
if PSSDFS
WRITE !,?36,$GET(PSSAFRAA(51.111,PSSFD,.01,"E"))
SET PSSDFS=1
+101 IF ($Y+5)>IOSL
DO HD
if PSSAFOUT
QUIT
End DoDot:3
+102 WRITE !?26,"INACTIVE: "_$GET(PSSAFRAA(51.1,PSSAFRA,12,"E"))
+103 IF ($Y+5)>IOSL
DO HD
if PSSAFOUT
QUIT
End DoDot:2
End DoDot:1
+104 ;
END ;
+1 IF '$GET(PSSAFOUT)
IF PSSAFRP="O"
IF '$GET(PSSAFNOF)
WRITE !!,"No schedules found without frequencies.",!
+2 IF $GET(PSSAFDEV)="P"
WRITE !!,"End of Report.",!
+3 IF '$GET(PSSAFOUT)
IF $GET(PSSAFDEV)="C"
WRITE !!,"End of Report."
KILL DIR
SET DIR(0)="E"
SET DIR("A")="Press Return to continue"
DO ^DIR
KILL DIR
+4 IF $GET(PSSAFDEV)="C"
WRITE !
+5 IF '$TEST
WRITE @IOF
+6 KILL PSSAFRP,PSSALONG
+7 DO ^%ZISC
if $DATA(ZTQUEUED)
SET ZTREQ="@"
+8 QUIT
+9 ;
+10 ;
HD ;Report Header
+1 IF $GET(PSSAFDEV)="C"
IF $GET(PSSAFCT)'=1
WRITE !
KILL DIR,Y
SET DIR(0)="E"
SET DIR("A")="Press Return to continue, '^' to exit"
DO ^DIR
KILL DIR
IF 'Y
SET PSSAFOUT=1
QUIT
+2 WRITE @IOF
+3 IF PSSAFRP="A"
WRITE !,"ADMINISTRATION SCHEDULE FILE REPORT (All)"
+4 IF PSSAFRP="O"
WRITE !,"ADMINISTRATION SCHEDULE WITHOUT FREQUENCY REPORT"
+5 WRITE ?$SELECT(PSSALONG=80:68,1:120),"PAGE: "_PSSAFCT,!,PSSAFLIN,!
SET PSSAFCT=PSSAFCT+1
+6 QUIT
+7 ;
+8 ;
MESS ;
+1 WRITE !!,"Nothing queued to print.",!
+2 QUIT
+3 ;
+4 ;
FORMAT(PSSAFQC,PSSAFQQ) ;Format print arrays, breaking on the "-" character
+1 ;PSSAFQC = Administration Times text
+2 ;PSSAFQQ = Character at which to break
+3 NEW PSSAFAC,PSSAFAB,PSSAFAZ,PSSAFAD,PSSAFAF,PSSAFAX
+4 SET PSSAFAC=1
SET PSSAFAZ=0
KILL PSSAFAB
+5 FOR PSSAFAD=1:1:PSSAFQL
IF $EXTRACT(PSSAFQC,PSSAFAD)="-"
SET PSSAFAB(PSSAFAC)=$PIECE(PSSAFQC,"-",PSSAFAC)_"-"
SET PSSAFAC=PSSAFAC+1
SET PSSAFAZ=PSSAFAD+1
+6 IF PSSAFAZ<PSSAFAD
if PSSAFAZ=0
SET PSSAFAZ=1
SET PSSAFAB(PSSAFAC)=$EXTRACT(PSSAFQC,PSSAFAZ,PSSAFQL)
SET PSSAFAC=PSSAFAC+1
+7 SET PSSAFAF=1
+8 FOR PSSAFAX=1:1:PSSAFAC
Begin DoDot:1
+9 if '$DATA(PSSAFAB(PSSAFAX))
QUIT
+10 IF '$DATA(PSSAFAA(PSSAFAF))
SET PSSAFAA(PSSAFAF)=PSSAFAB(PSSAFAX)
QUIT
+11 IF $LENGTH(PSSAFAA(PSSAFAF))+$LENGTH(PSSAFAB(PSSAFAX))<PSSAFQQ
SET PSSAFAA(PSSAFAF)=PSSAFAA(PSSAFAF)_PSSAFAB(PSSAFAX)
QUIT
+12 SET PSSAFAF=PSSAFAF+1
SET PSSAFAA(PSSAFAF)=PSSAFAB(PSSAFAX)
End DoDot:1
+13 QUIT
+14 ;
+15 ;
TRAIL ;Trailing spaces Report
+1 WRITE !!,"This report displays active, multi-ingredient entries from the DRUG (#50) File"
+2 WRITE !,"with Local Possible Dosages defined, with trailing spaces in the name. Entries"
+3 WRITE !,"not matched to National Drug File are also included if there are trailing"
+4 WRITE !,"spaces. Trailing spaces can potentially cause the Dose check to fail, and"
+5 WRITE !,"also possibly cause the conjunction and drug name to become part of the Dosage.",!
+6 NEW DIR,Y,X,DTOUT,DUOUT,DIRUT,DIROUT,IOP,%ZIS,POP,ZTRTN,ZTDESC,ZTSAVE,ZTSK
+7 KILL IOP,%ZIS,POP
SET %ZIS="QM"
DO ^%ZIS
IF $GET(POP)>0
DO MESS
KILL DIR,Y
SET DIR(0)="E"
SET DIR("A")="Press Return to continue"
DO ^DIR
KILL DIR,IOP,%ZIS,POP
QUIT
+8 IF $DATA(IO("Q"))
SET ZTRTN="STRAIL^PSSSCHRP"
SET ZTDESC="Trailing Spaces Report"
DO ^%ZTLOAD
KILL %ZIS
WRITE !!,"Report queued to print.",!
KILL DIR,Y
SET DIR(0)="E"
SET DIR("A")="Press Return to continue"
DO ^DIR
KILL DIR
QUIT
+9 ;
+10 ;
STRAIL ;Print Trailing spaces report
+1 USE IO
+2 NEW PSSTRSOT,PSSTRSLG,PSSTRSFL,PSSTRSDV,PSSTRSPG,PSSTRSAA,PSSTRSBB,PSSTRSNM,PSSTRSIN,PSSTRSST,PSSTRSUN,PSSTRSN1,PSSTRSN3,PSSTRSN9
+3 SET (PSSTRSOT,PSSTRSFL)=0
SET PSSTRSDV=$SELECT($EXTRACT(IOST,1,2)'="C-":"P",1:"C")
SET PSSTRSPG=1
+4 KILL PSSTRSLG
SET $PIECE(PSSTRSLG,"-",78)=""
+5 DO STHD
+6 SET PSSTRSAA=""
FOR
SET PSSTRSAA=$ORDER(^PSDRUG("B",PSSTRSAA))
if PSSTRSAA=""!(PSSTRSOT)
QUIT
Begin DoDot:1
+7 FOR PSSTRSBB=0:0
SET PSSTRSBB=$ORDER(^PSDRUG("B",PSSTRSAA,PSSTRSBB))
if 'PSSTRSBB!(PSSTRSOT)
QUIT
if $ORDER(^PSDRUG(PSSTRSBB,"DOS2",0))
Begin DoDot:2
+8 SET PSSTRSNM=$PIECE($GET(^PSDRUG(PSSTRSBB,0)),"^")
SET PSSTRSIN=$PIECE($GET(^PSDRUG(PSSTRSBB,"I")),"^")
+9 IF $EXTRACT(PSSTRSNM,$LENGTH(PSSTRSNM))'=" "
QUIT
+10 IF PSSTRSIN
IF PSSTRSIN<DT
QUIT
+11 SET PSSTRSN1=$PIECE($GET(^PSDRUG(PSSTRSBB,"ND")),"^")
SET PSSTRSN3=$PIECE($GET(^PSDRUG(PSSTRSBB,"ND")),"^",3)
+12 IF 'PSSTRSN1!('PSSTRSN3)
WRITE !,PSSTRSNM_" ("_PSSTRSBB_")"
SET PSSTRSFL=1
if ($Y+5)>IOSL
DO STHD
QUIT
+13 SET PSSTRSST=$PIECE($GET(^PSDRUG(PSSTRSBB,"DOS")),"^")
SET PSSTRSUN=$PIECE($GET(^PSDRUG(PSSTRSBB,"DOS")),"^",2)
+14 IF PSSTRSST'=""
QUIT
+15 KILL PSSTRSN9
IF PSSTRSST=""!('PSSTRSUN)
SET PSSTRSN9=$$DFSU^PSNAPIS(PSSTRSN1,PSSTRSN3)
+16 SET PSSTRSST=$PIECE($GET(PSSTRSN9),"^",4)
IF $$STST()
QUIT
+17 WRITE !,PSSTRSNM_" ("_PSSTRSBB_")"
SET PSSTRSFL=1
IF ($Y+5)>IOSL
DO STHD
End DoDot:2
End DoDot:1
+18 ;
+19 ;
STEND ;
+1 IF '$GET(PSSTRSOT)
IF '$GET(PSSTRSFL)
WRITE !!,"No drug names found.",!
+2 IF $GET(PSSTRSDV)="P"
WRITE !!,"End of Report.",!
+3 IF '$GET(PSSTRSOT)
IF $GET(PSSTRSDV)="C"
WRITE !!,"End of Report."
KILL DIR
SET DIR(0)="E"
SET DIR("A")="Press Return to continue"
DO ^DIR
KILL DIR
+4 IF $GET(PSSTRSDV)="C"
WRITE !
+5 IF '$TEST
WRITE @IOF
+6 DO ^%ZISC
if $DATA(ZTQUEUED)
SET ZTREQ="@"
+7 QUIT
+8 ;
+9 ;
STHD ;Report Header
+1 IF $GET(PSSTRSDV)="C"
IF $GET(PSSTRSPG)'=1
WRITE !
KILL DIR,Y
SET DIR(0)="E"
SET DIR("A")="Press Return to continue, '^' to exit"
DO ^DIR
KILL DIR
IF 'Y
SET PSSTRSOT=1
QUIT
+2 WRITE @IOF
+3 WRITE !,"DRUG NAME TRAILING SPACES REPORT"
+4 WRITE ?68,"PAGE: "_PSSTRSPG,!,PSSTRSLG,!
SET PSSTRSPG=PSSTRSPG+1
+5 QUIT
+6 ;
+7 ;
STST() ;Is strength numeric
+1 IF PSSTRSST=""
QUIT 0
+2 IF PSSTRSST'?.N&(PSSTRSST'?.N1".".N)
QUIT 0
+3 QUIT 1
