- 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
