PSSSCHRP ;BIR/RTR-Schedule Report ;07/03/07
;;1.0;PHARMACY DATA MANAGEMENT;**129**;9/30/07;Build 67
;Reference to DIC(42 supported by DBIA 10039
;
;
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
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","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 Schedule Type
..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 dod 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
..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
;
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
PSSSCHRP ;BIR/RTR-Schedule Report ;07/03/07
+1 ;;1.0;PHARMACY DATA MANAGEMENT;**129**;9/30/07;Build 67
+2 ;Reference to DIC(42 supported by DBIA 10039
+3 ;
+4 ;
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
+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","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 Schedule Type
+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 dod 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 KILL PSSTPE
SET PSSTPE=$$GET1^DIQ(51.1,PSSAFQEN_",",5)
+83 IF 'PSSAFZZZ
WRITE ?21,"SCHEDULE TYPE: "_$GET(PSSTPE)
IF PSSAFZZZ
WRITE !?21,"SCHEDULE TYPE: "_$GET(PSSTPE)
+84 IF ($Y+5)>IOSL
DO HD
IF PSSAFOUT
QUIT
+85 WRITE !?12,"FREQUENCY (IN MINUTES): "_$GET(PSSAFRAA(51.1,PSSAFRA,2,"E"))
+86 IF ($Y+5)>IOSL
DO HD
IF PSSAFOUT
QUIT
End DoDot:2
End DoDot:1
+87 ;
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
