PSOARX1.m

PSOARX1 ;BHAM ISC/SAB prints archive index only ; 01/20/95

 ;;7.0;OUTPATIENT PHARMACY;;DEC 1997

 W ! K ^TMP($J) I '$O(^PSOARC(0)) D  G:'OUT EX G HDR

 .D ^PSOARCCO I '$O(^PSOARC(0)) W !,$C(7),"There is no data to print!" S OUT=0 Q

 .S OUT=1

 I $O(^PSOARC(0)) S OUT=1 D  G:'$G(OUT)!($D(DIRUT)) EX

 .K DIR S DIR(0)="Y" S DIR("B")="NO",DIR("A",1)="There is data in the Pharmacy Archive file."

 .S DIR("A")="Do you want to re-compile this data" D ^DIR Q:$D(DIRUT)!('Y)  D ^PSOARCCO

 .I '$O(^PSOARC(0)) W !,$C(7),"There is no data to print!" S OUT=0 Q

HDR W ! K DIR S DIR("A")="Printout Header Label",DIR(0)="F^1:64",DIR("?",1)="  ...Enter 1 to 64 characters.",DIR("?")="This Header will print at top of every page of your index."

 S DIR("B")="Prescription Archive Data Index" D ^DIR K DIR G:$D(DIRUT) EX S PSOACDS=X K X

 K %ZIS,IO("Q"),ZTSK,ZTQUEUED S PSOION=ION,%ZIS="QM" D ^%ZIS I POP S IOP=PSOION D ^%ZIS K %ZIS,PSOION G EX

 I $D(IO("Q")) S ZTRTN="EN^PSOARX1",ZTSAVE("PSOACDS")="" D ^%ZTLOAD W:$D(ZTSK) !,"Task queued to print",! K ZTSK G EX

EN K PSOQUIT S PSOAPG=1 D HD G:$G(PSQUIT) EX I '$O(^PSOARC(0)) U IO W !!,"**************There is no data to print****************",! G EX

 S ZI="" F  S ZI=$O(^PSOARC("B",ZI)) Q:ZI=""  S SSN=0 F PSOK=0:0 S SSN=$O(^PSOARC("B",ZI,SSN)) Q:SSN'>0  D  G:$G(PSQUIT) EX

 .S NM=ZI,ZII=0,SS=SSN,LL=$L(NM)+$L(SS)+6

 .K ^TMP($J,"ZRX") F KK=0:0 S ZII=$O(^PSOARC("B",ZI,SSN,ZII)) Q:+ZII'>0  S ^TMP($J,"ZRX",ZII)="",LL=LL+$L(ZII)+1

 .U IO D:($Y+4)>IOSL HD Q:$G(PSQUIT)

 .W !,NM_" ("_$E(SSN,1,3)_"-"_$E(SSN,4,5)_"-"_$E(SSN,6,9)_") - " S ZII=0

 .F KK=1:1 S ZII=$O(^TMP($J,"ZRX",ZII)) Q:+ZII'>0  W:($X+$L(ZII)+1)>(IOM-5) !?($L(NM)+3) D:($Y+2)>IOSL HD Q:$G(PSQUIT)  W $P(^PSRX(ZII,0),"^"),","

 ;print rx info

 S PSOP=IO,PSOACPF=IOF,PSOACPL=IOSL,PSOACPM=IOM,PSOATNM=1

 D HD Q:$G(PSQUIT)

 S ZI="" F  S ZI=$O(^PSOARC("B",ZI)) Q:ZI=""  S SSN=0 F PSOK=0:0 S SSN=$O(^PSOARC("B",ZI,SSN)) Q:SSN'>0  D  G:$G(PSQUIT) EX

 .F ZII=0:0 S ZII=$O(^PSOARC("B",ZI,SSN,ZII)) Q:'ZII  S (RX0,DA)=ZII U IO D:$Y+20>IOSL HD Q:$G(PSQUIT)  D ^PSOARX

EX D ^%ZISC K PSOPAG,PSOP,PSOACPF,PSOACPL,PSOACPM,PSOATNM,DIRUT,DUOUT,DTOUT,PG,PSOAC,PSOAC1,PSOACDS,PSOAPG,Y D:$D(ZTQUEUED) KILL^%ZTLOAD

 K POP,OUT,IO("Q"),%X,%Y,X,PSQUIT

 Q

HD I IOST["C-" K DIR S DIR("A")="Press Return to Continue",DIR(0)="E" D ^DIR S:$D(DIRUT) PSQUIT=1 K DIR,DIRUT,DUOUT Q:$G(PSQUIT)

 U IO W @IOF,!!?(IOM-$L(PSOACDS)\2),PSOACDS,?$X+10," Page: "_PSOAPG

 W !?(IOM-$L($E(DT,4,5)_"/"_$E(DT,6,7)_"/"_$E(DT,2,3))\2),$E(DT,4,5)_"/"_$E(DT,6,7)_"/"_$E(DT,2,3),! S PSOAPG=PSOAPG+1 Q

PSOARX1   ;BHAM ISC/SAB prints archive index only ; 01/20/95

 +1       ;;7.0;OUTPATIENT PHARMACY;;DEC 1997

 +2        WRITE !

           KILL ^TMP($JOB)

           IF '$ORDER(^PSOARC(0))

               Begin DoDot:1

 +3                DO ^PSOARCCO

                   IF '$ORDER(^PSOARC(0))

                       WRITE !,$CHAR(7),"There is no data to print!"

                       SET OUT=0

                       QUIT 

 +4                SET OUT=1

               End DoDot:1

               IF 'OUT

                   GOTO EX

               GOTO HDR

 +5        IF $ORDER(^PSOARC(0))

               SET OUT=1

               Begin DoDot:1

 +6                KILL DIR

                   SET DIR(0)="Y"

                   SET DIR("B")="NO"

                   SET DIR("A",1)="There is data in the Pharmacy Archive file."

 +7                SET DIR("A")="Do you want to re-compile this data"

                   DO ^DIR

                   IF $DATA(DIRUT)!('Y)

                       QUIT 

                   DO ^PSOARCCO

 +8                IF '$ORDER(^PSOARC(0))

                       WRITE !,$CHAR(7),"There is no data to print!"

                       SET OUT=0

                       QUIT 

               End DoDot:1

               IF '$GET(OUT)!($DATA(DIRUT))

                   GOTO EX

HDR        WRITE !

           KILL DIR

           SET DIR("A")="Printout Header Label"

           SET DIR(0)="F^1:64"

           SET DIR("?",1)="  ...Enter 1 to 64 characters."

           SET DIR("?")="This Header will print at top of every page of your index."

 +1        SET DIR("B")="Prescription Archive Data Index"

           DO ^DIR

           KILL DIR

           IF $DATA(DIRUT)

               GOTO EX

           SET PSOACDS=X

           KILL X

 +2        KILL %ZIS,IO("Q"),ZTSK,ZTQUEUED

           SET PSOION=ION

           SET %ZIS="QM"

           DO ^%ZIS

           IF POP

               SET IOP=PSOION

               DO ^%ZIS

               KILL %ZIS,PSOION

               GOTO EX

 +3        IF $DATA(IO("Q"))

               SET ZTRTN="EN^PSOARX1"

               SET ZTSAVE("PSOACDS")=""

               DO ^%ZTLOAD

               IF $DATA(ZTSK)

                   WRITE !,"Task queued to print",!

               KILL ZTSK

               GOTO EX

EN         KILL PSOQUIT

           SET PSOAPG=1

           DO HD

           IF $GET(PSQUIT)

               GOTO EX

           IF '$ORDER(^PSOARC(0))

               USE IO

               WRITE !!,"**************There is no data to print****************",!

               GOTO EX

 +1        SET ZI=""

           FOR 

               SET ZI=$ORDER(^PSOARC("B",ZI))

               IF ZI=""

                   QUIT 

               SET SSN=0

               FOR PSOK=0:0

                   SET SSN=$ORDER(^PSOARC("B",ZI,SSN))

                   IF SSN'>0

                       QUIT 

                   Begin DoDot:1

 +2                    SET NM=ZI

                       SET ZII=0

                       SET SS=SSN

                       SET LL=$LENGTH(NM)+$LENGTH(SS)+6

 +3                    KILL ^TMP($JOB,"ZRX")

                       FOR KK=0:0

                           SET ZII=$ORDER(^PSOARC("B",ZI,SSN,ZII))

                           IF +ZII'>0

                               QUIT 

                           SET ^TMP($JOB,"ZRX",ZII)=""

                           SET LL=LL+$LENGTH(ZII)+1

 +4                    USE IO

                       IF ($Y+4)>IOSL

                           DO HD

                       IF $GET(PSQUIT)

                           QUIT 

 +5                    WRITE !,NM_" ("_$EXTRACT(SSN,1,3)_"-"_$EXTRACT(SSN,4,5)_"-"_$EXTRACT(SSN,6,9)_") - "

                       SET ZII=0

 +6                    FOR KK=1:1

                           SET ZII=$ORDER(^TMP($JOB,"ZRX",ZII))

                           IF +ZII'>0

                               QUIT 

                           IF ($X+$LENGTH(ZII)+1)>(IOM-5)

                               WRITE !?($LENGTH(NM)+3)

                           IF ($Y+2)>IOSL

                               DO HD

                           IF $GET(PSQUIT)

                               QUIT 

                           WRITE $PIECE(^PSRX(ZII,0),"^"),","

                   End DoDot:1

                   IF $GET(PSQUIT)

                       GOTO EX

 +7       ;print rx info

 +8        SET PSOP=IO

           SET PSOACPF=IOF

           SET PSOACPL=IOSL

           SET PSOACPM=IOM

           SET PSOATNM=1

 +9        DO HD

           IF $GET(PSQUIT)

               QUIT 

 +10       SET ZI=""

           FOR 

               SET ZI=$ORDER(^PSOARC("B",ZI))

               IF ZI=""

                   QUIT 

               SET SSN=0

               FOR PSOK=0:0

                   SET SSN=$ORDER(^PSOARC("B",ZI,SSN))

                   IF SSN'>0

                       QUIT 

                   Begin DoDot:1

 +11                   FOR ZII=0:0

                           SET ZII=$ORDER(^PSOARC("B",ZI,SSN,ZII))

                           IF 'ZII

                               QUIT 

                           SET (RX0,DA)=ZII

                           USE IO

                           IF $Y+20>IOSL

                               DO HD

                           IF $GET(PSQUIT)

                               QUIT 

                           DO ^PSOARX

                   End DoDot:1

                   IF $GET(PSQUIT)

                       GOTO EX

EX         DO ^%ZISC

           KILL PSOPAG,PSOP,PSOACPF,PSOACPL,PSOACPM,PSOATNM,DIRUT,DUOUT,DTOUT,PG,PSOAC,PSOAC1,PSOACDS,PSOAPG,Y

           IF $DATA(ZTQUEUED)

               DO KILL^%ZTLOAD

 +1        KILL POP,OUT,IO("Q"),%X,%Y,X,PSQUIT

 +2        QUIT 

HD         IF IOST["C-"

               KILL DIR

               SET DIR("A")="Press Return to Continue"

               SET DIR(0)="E"

               DO ^DIR

               IF $DATA(DIRUT)

                   SET PSQUIT=1

               KILL DIR,DIRUT,DUOUT

               IF $GET(PSQUIT)

                   QUIT 

 +1        USE IO

           WRITE @IOF,!!?(IOM-$LENGTH(PSOACDS)\2),PSOACDS,?$X+10," Page: "_PSOAPG

 +2        WRITE !?(IOM-$LENGTH($EXTRACT(DT,4,5)_"/"_$EXTRACT(DT,6,7)_"/"_$EXTRACT(DT,2,3))\2),$EXTRACT(DT,4,5)_"/"_$EXTRACT(DT,6,7)_"/"_$EXTRACT(DT,2,3),!

           SET PSOAPG=PSOAPG+1

           QUIT