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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSOARX1 2568 printed Sep 23, 2025@20:00:40 Page 2
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
