PSOARCR1 ;BHAM ISC/LGH - Rx retrieve ; 07/07/92
;;7.0;OUTPATIENT PHARMACY;;DEC 1997
U PSOAT W @%MT("REW")
S PSOAPF=0
R D PSOAT R X:DTIME G END:X="" G:X'="!" R
PAR D PSOAT R X:DTIME G:'$T END G:$P(X,"^")=NM&($G(SS)=$P(X,"^",2)) PR G PAR
END I $D(PSOAT) U IO(0) S IOP=PSOAT D ^%ZIS D ^%ZISC K IOP
Q I $D(PSOAP) U IO(0) S IOP=PSOAP D ^%ZIS D ^%ZISC K IOP
K PSOACPM,PSOACPL,PSOACPF,NM,T,PSOAP,PSOAT,^TMP($J,"ZRX"),A,DG,GD,I,PSOACDS,PSOAEOT,Y,RX,%MT,D,PSOAPF,PSOATNM,X,XX
Q
PR ;patient read
S T(1)=X D READT S T(2)=X,D=$P(T(2),"^",2),A=$P(T(2),"^",3),DG=$P(T(2),"^",4),GD=$P(T(2),"^",5)
I D>"" F I=1:1:D D READT S T(2,I)=X
I A>"" F I=1:1:A D READT S T(3,I)=X
I DG>"" F I=1:1:DG D READT S T(4,I)=X
I GD>"" F I=1:1:GD D READT S T(5,I)=X
D:'PSOAPF DPR,HD1^PSOARCSV S PSOAPF=1 ;display demo info
RXR D READT G:(X="!")!(X="") END G:$P(X,"^",2)'=NM PAR G:X="" END
RXR2 I $P($G(X),"^",2)'=NM D READT G:($G(X)="!")!($G(X)="") END
G:(X="!")!(X="")!($P(X,"^",2)'=NM) END S RX(0)=X D READT
I (X["$$"),$P(X,"$$",1)["1," D NODE1
I (X["$$"),$P(X,"$$",1)["4," D NODE4
I (X["$$"),$P(X,"$$",1)["5," D NODE5
S RX(2)=X D READT S RX(3)=X D READT
I (X["$$"),$P(X,"$$",1)["A," D NODEA
I (X["$$"),$P(X,"$$",1)["L," D NODEL
I (X["$$"),$P(X,"$$",1)["P," D NODEP
I (X["$$"),$P(X,"$$",1)["IB" S RX("IB")=$P(X,"$$",2) D READT
I (X["$$"),$P(X,"$$",1)["C," S RX("C")=$P(X,"$$",2) D READT
I (X["$$"),$P(X,"$$",1)["D," S RX("D")=$P(X,"$$",2) D READT
I (X["$$"),$P(X,"$$",1)["S," S RX("S")=$P(X,"$$",2) D READT
RXR1 U PSOAP D ^PSOARCR2 D PAGE U PSOAT G RXR2
DPR U PSOAP W !!,NM,?55,"ID#: ",$P(T(1),"^",2),?75,"ELIG: ",$P(T(1),"^",3),!,$P(T(1),"^",4),?55,"DOB: ",$P(T(1),"^",5),?75,"PHONE: ",$P(T(1),"^",6)
W !,$P(T(1),"^",7),!,$P(T(1),"^",8)," ",$P(T(1),"^",9)
I +$P(T(1),"^",10) W !,"CANNOT USE SAFETY CAPS." I +$P(T(1),"^",11) W ?40,"DIALYSIS PATIENT"
I $P(T(2),"^")'="" W !,$P(T(2),"^")
W !,"DISABILITIES: " G MA:D'>0
F I=1:1:D W:($Y+$L(T(2,I))+1)>PSOACPM !?15 W T(2,I),","
MA W !!,"REACTIONS: ",$S(((A'>0)&(DG'>0)&(GD'>0)):"UNKNOWN",1:"")
I A>0 F I=1:1:A W:($Y+$L(T(3,I))+1)>PSOACPM !?15 W T(3,I),","
I DG>0 F I=1:1:DG W:($Y+$L(T(4,I))+1)>PSOACPM !?15 W T(4,I),","
I GD>0 F I=1:1:GD W:($Y+$L(T(5,I))+1)>PSOACPM !?15 W T(5,I),","
K T Q
PAGE Q:$Y'>(PSOACPL-22)
D HD1^PSOARCSV Q
PSOAT ;check for eot, return psoaeot=1 if found
U PSOAT S PSOAEOT=0 X ^%ZOSF("EOT") I Y D EOT S PSOAEOT=1
U PSOAT Q
EOT U IO(0) W !!?5,"** End of tape detected **",!?5,"After current tape rewinds, mount next tape" U PSOAT W @%MT("REW")
READ U IO(0) W !?5,"Type <CR> to continue" R XX:DTIME I '$T W $C(7) G READ
W !!,"continuing" S PSOATNM=PSOATNM+1
Q
NODE1 S XX=$P(X,"$$",1) S RX(XX)=$P(X,"$$",2)
F D READT Q:($P(X,"^")'["$")!($P(X,"$$",1)'["1,") S XX=$P(X,"$$",1) S RX(XX)=$P(X,"$$",2)
Q
NODE4 S XX=$P(X,"$$",1) S RX(XX)=$P(X,"$$",2)
F D READT Q:($P(X,"^")'["$")!($P(X,"$$",1)'["4,") S XX=$P(X,"$$",1) S RX(XX)=$P(X,"$$",2)
Q
NODE5 S XX=$P(X,"$$",1) S RX(XX)=$P(X,"$$",2)
F D READT Q:($P(X,"^")'["$")!($P(X,"$$",1)'["5,") S XX=$P(X,"$$",1) S RX(XX)=$P(X,"$$",2)
Q
NODEA S XX=$P(X,"$$",1) S RX(XX)=$P(X,"$$",2)
F D READT Q:($P(X,"^")'["$$")!($P(X,"$$",1)'["A,") S XX=$P(X,"$$",1) S RX(XX)=$P(X,"$$",2)
Q
NODEL S XX=$P(X,"$$",1) S RX(XX)=$P(X,"$$",2)
F D READT Q:($P(X,"^")'["$")!($P(X,"$$",1)'["L,") S XX=$P(X,"$$",1) S RX(XX)=$P(X,"$$",2)
Q
NODEP S XX=$P(X,"$$",1) S RX(XX)=$P(X,"$$",2)
F D READT Q:($P(X,"^")'["$$")!($P(X,"$$",1)'["P,") S XX=$P(X,"$$",1) S RX(XX)=$P(X,"$$",2)
Q
READT D PSOAT R X:DTIME G:'$T END G END:X="" Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSOARCR1 3605 printed Sep 23, 2025@20:00:32 Page 2
PSOARCR1 ;BHAM ISC/LGH - Rx retrieve ; 07/07/92
+1 ;;7.0;OUTPATIENT PHARMACY;;DEC 1997
+2 USE PSOAT
WRITE @%MT("REW")
+3 SET PSOAPF=0
R DO PSOAT
READ X:DTIME
if X=""
GOTO END
if X'="!"
GOTO R
PAR DO PSOAT
READ X:DTIME
if '$TEST
GOTO END
if $PIECE(X,"^")=NM&($GET(SS)=$PIECE(X,"^",2))
GOTO PR
GOTO PAR
END IF $DATA(PSOAT)
USE IO(0)
SET IOP=PSOAT
DO ^%ZIS
DO ^%ZISC
KILL IOP
Q IF $DATA(PSOAP)
USE IO(0)
SET IOP=PSOAP
DO ^%ZIS
DO ^%ZISC
KILL IOP
+1 KILL PSOACPM,PSOACPL,PSOACPF,NM,T,PSOAP,PSOAT,^TMP($JOB,"ZRX"),A,DG,GD,I,PSOACDS,PSOAEOT,Y,RX,%MT,D,PSOAPF,PSOATNM,X,XX
+2 QUIT
PR ;patient read
+1 SET T(1)=X
DO READT
SET T(2)=X
SET D=$PIECE(T(2),"^",2)
SET A=$PIECE(T(2),"^",3)
SET DG=$PIECE(T(2),"^",4)
SET GD=$PIECE(T(2),"^",5)
+2 IF D>""
FOR I=1:1:D
DO READT
SET T(2,I)=X
+3 IF A>""
FOR I=1:1:A
DO READT
SET T(3,I)=X
+4 IF DG>""
FOR I=1:1:DG
DO READT
SET T(4,I)=X
+5 IF GD>""
FOR I=1:1:GD
DO READT
SET T(5,I)=X
+6 ;display demo info
if 'PSOAPF
DO DPR
DO HD1^PSOARCSV
SET PSOAPF=1
RXR DO READT
if (X="!")!(X="")
GOTO END
if $PIECE(X,"^",2)'=NM
GOTO PAR
if X=""
GOTO END
RXR2 IF $PIECE($GET(X),"^",2)'=NM
DO READT
if ($GET(X)="!")!($GET(X)="")
GOTO END
+1 if (X="!")!(X="")!($PIECE(X,"^",2)'=NM)
GOTO END
SET RX(0)=X
DO READT
+2 IF (X["$$")
IF $PIECE(X,"$$",1)["1,"
DO NODE1
+3 IF (X["$$")
IF $PIECE(X,"$$",1)["4,"
DO NODE4
+4 IF (X["$$")
IF $PIECE(X,"$$",1)["5,"
DO NODE5
+5 SET RX(2)=X
DO READT
SET RX(3)=X
DO READT
+6 IF (X["$$")
IF $PIECE(X,"$$",1)["A,"
DO NODEA
+7 IF (X["$$")
IF $PIECE(X,"$$",1)["L,"
DO NODEL
+8 IF (X["$$")
IF $PIECE(X,"$$",1)["P,"
DO NODEP
+9 IF (X["$$")
IF $PIECE(X,"$$",1)["IB"
SET RX("IB")=$PIECE(X,"$$",2)
DO READT
+10 IF (X["$$")
IF $PIECE(X,"$$",1)["C,"
SET RX("C")=$PIECE(X,"$$",2)
DO READT
+11 IF (X["$$")
IF $PIECE(X,"$$",1)["D,"
SET RX("D")=$PIECE(X,"$$",2)
DO READT
+12 IF (X["$$")
IF $PIECE(X,"$$",1)["S,"
SET RX("S")=$PIECE(X,"$$",2)
DO READT
RXR1 USE PSOAP
DO ^PSOARCR2
DO PAGE
USE PSOAT
GOTO RXR2
DPR USE PSOAP
WRITE !!,NM,?55,"ID#: ",$PIECE(T(1),"^",2),?75,"ELIG: ",$PIECE(T(1),"^",3),!,$PIECE(T(1),"^",4),?55,"DOB: ",$PIECE(T(1),"^",5),?75,"PHONE: ",$PIECE(T(1),"^",6)
+1 WRITE !,$PIECE(T(1),"^",7),!,$PIECE(T(1),"^",8)," ",$PIECE(T(1),"^",9)
+2 IF +$PIECE(T(1),"^",10)
WRITE !,"CANNOT USE SAFETY CAPS."
IF +$PIECE(T(1),"^",11)
WRITE ?40,"DIALYSIS PATIENT"
+3 IF $PIECE(T(2),"^")'=""
WRITE !,$PIECE(T(2),"^")
+4 WRITE !,"DISABILITIES: "
if D'>0
GOTO MA
+5 FOR I=1:1:D
if ($Y+$LENGTH(T(2,I))+1)>PSOACPM
WRITE !?15
WRITE T(2,I),","
MA WRITE !!,"REACTIONS: ",$SELECT(((A'>0)&(DG'>0)&(GD'>0)):"UNKNOWN",1:"")
+1 IF A>0
FOR I=1:1:A
if ($Y+$LENGTH(T(3,I))+1)>PSOACPM
WRITE !?15
WRITE T(3,I),","
+2 IF DG>0
FOR I=1:1:DG
if ($Y+$LENGTH(T(4,I))+1)>PSOACPM
WRITE !?15
WRITE T(4,I),","
+3 IF GD>0
FOR I=1:1:GD
if ($Y+$LENGTH(T(5,I))+1)>PSOACPM
WRITE !?15
WRITE T(5,I),","
+4 KILL T
QUIT
PAGE if $Y'>(PSOACPL-22)
QUIT
+1 DO HD1^PSOARCSV
QUIT
PSOAT ;check for eot, return psoaeot=1 if found
+1 USE PSOAT
SET PSOAEOT=0
XECUTE ^%ZOSF("EOT")
IF Y
DO EOT
SET PSOAEOT=1
+2 USE PSOAT
QUIT
EOT USE IO(0)
WRITE !!?5,"** End of tape detected **",!?5,"After current tape rewinds, mount next tape"
USE PSOAT
WRITE @%MT("REW")
READ USE IO(0)
WRITE !?5,"Type <CR> to continue"
READ XX:DTIME
IF '$TEST
WRITE $CHAR(7)
GOTO READ
+1 WRITE !!,"continuing"
SET PSOATNM=PSOATNM+1
+2 QUIT
NODE1 SET XX=$PIECE(X,"$$",1)
SET RX(XX)=$PIECE(X,"$$",2)
+1 FOR
DO READT
if ($PIECE(X,"^")'["$")!($PIECE(X,"$$",1)'["1,")
QUIT
SET XX=$PIECE(X,"$$",1)
SET RX(XX)=$PIECE(X,"$$",2)
+2 QUIT
NODE4 SET XX=$PIECE(X,"$$",1)
SET RX(XX)=$PIECE(X,"$$",2)
+1 FOR
DO READT
if ($PIECE(X,"^")'["$")!($PIECE(X,"$$",1)'["4,")
QUIT
SET XX=$PIECE(X,"$$",1)
SET RX(XX)=$PIECE(X,"$$",2)
+2 QUIT
NODE5 SET XX=$PIECE(X,"$$",1)
SET RX(XX)=$PIECE(X,"$$",2)
+1 FOR
DO READT
if ($PIECE(X,"^")'["$")!($PIECE(X,"$$",1)'["5,")
QUIT
SET XX=$PIECE(X,"$$",1)
SET RX(XX)=$PIECE(X,"$$",2)
+2 QUIT
NODEA SET XX=$PIECE(X,"$$",1)
SET RX(XX)=$PIECE(X,"$$",2)
+1 FOR
DO READT
if ($PIECE(X,"^")'["$$")!($PIECE(X,"$$",1)'["A,")
QUIT
SET XX=$PIECE(X,"$$",1)
SET RX(XX)=$PIECE(X,"$$",2)
+2 QUIT
NODEL SET XX=$PIECE(X,"$$",1)
SET RX(XX)=$PIECE(X,"$$",2)
+1 FOR
DO READT
if ($PIECE(X,"^")'["$")!($PIECE(X,"$$",1)'["L,")
QUIT
SET XX=$PIECE(X,"$$",1)
SET RX(XX)=$PIECE(X,"$$",2)
+2 QUIT
NODEP SET XX=$PIECE(X,"$$",1)
SET RX(XX)=$PIECE(X,"$$",2)
+1 FOR
DO READT
if ($PIECE(X,"^")'["$$")!($PIECE(X,"$$",1)'["P,")
QUIT
SET XX=$PIECE(X,"$$",1)
SET RX(XX)=$PIECE(X,"$$",2)
+2 QUIT
READT DO PSOAT
READ X:DTIME
if '$TEST
GOTO END
if X=""
GOTO END
QUIT
