PSOARCIN ;BHAM ISC/LGH,SAB - tape index search ; 07/07/92
;;7.0;OUTPATIENT PHARMACY;;DEC 1997
PQ S XNEW=0,PSOATNM=1 S %ZIS("A")="Tape Drive Device: ",%ZIS("B")="" W !! D ^%ZIS K %ZIS("A") G END:POP S PSOAT=IO I IOST'["MAGTAPE" D ^%ZISC U IO(0) W !,"Must select a MAGTAPE device",!! G PQ
U IO(0) W !! S %ZIS("A")="Output Device: " D ^%ZIS K %ZIS("A") S PSOAP=IO G END:POP S PSOACPM=IOM,PSOACPF=IOF,PSOACPL=IOSL W !!
I '$D(%MT("REW")) X ^%ZOSF("MAGTAPE")
R2 S DIR("A")="Do you want to print the tape index",DIR("T")=DTIME,DIR(0)="YO" D ^DIR K DIR G:$D(DTOUT)!$D(DUOUT) END G:'Y RN
F U PSOAT R X:DTIME U PSOAP W !,X Q:X="!"
U PSOAT W @%MT("REW") U IO(0)
RN W !! S DIR("A")="Enter Patient's Name ",DIR("?")="^D QNM^PSOARCIN",DIR("T")=DTIME,DIR(0)="FO" D ^DIR K DIR G:$G(DIRUT) END S DIC=2,DIC(0)="EZM" D ^DIC K DIC S NM=$S(Y=-1:"",1:$P(Y,"^",2)),TZ=1,SS=$S(Y=-1:"",1:$P(Y(0),"^",9))
I Y=-1 S:X?1A.E NM=X S:X?9N SS=X
R U PSOAT R X:DTIME X ^%ZOSF("EOT") G:Y END G:(X="")!(X="!") NOT ;G:X'["&" R S:$P(X,"^",2)="NEW" XNEW=1
I X="&^NEW" S XNEW=1 G R5
I X="&" S XNEW=0 G R5
S XNM=$P($P(X,"^"),"%",1),XSS=$P($P(X,"^"),"%",2) G R5:((NM="")&(SS'=XSS))!((NM'=XNM)&(SS=""))!((SS'="")&(SS'=XSS)) S ^TMP($J,"ZRX",TZ)=X,TZ=TZ+1 G R1
R5 U PSOAT R X:DTIME X ^%ZOSF("EOT") G:Y END G:(X="")!(X="!") NOT S XNM=$P($P(X,"^"),"%",1),XSS=$P($P(X,"^"),"%",2) G R5:((NM="")&(SS'=XSS))!((NM'=XNM)&(SS=""))!((SS'="")&(SS'=XSS)) S ^TMP($J,"ZRX",TZ)=X,TZ=TZ+1
R1 R X:DTIME G:'$T END G P:(X="")!(X="!")!($E(X,1)?1A) S ^TMP($J,"ZRX",TZ)=X,TZ=TZ+1 G R1
P S TZ=TZ-1
U PSOAP W @PSOACPF,!,"The following scripts were archived on this tape for : ",!!
W !,$P(^TMP($J,"ZRX",1),"%",1)," (",$P($P(^(1),"^"),"%",2),") - " S NM=$P(^TMP($J,"ZRX",1),"%",1),SS=$P($P(^(1),"^"),"%",2) F I=1:1:TZ W:I'=1 !?($L(NM)+2) W $P(^TMP($J,"ZRX",I),"^",2)
S PSOAPG=1,PSOACDS="Rx Retrieval for "_NM G:XNEW=0 ^PSOARCRR G:XNEW=1 ^PSOARCR1
Q
NOT U IO(0) W !!,NM_" does not have archived scripts on this tape."
END I $D(PSOAT) U IO(0) S IOP=PSOAT D ^%ZIS D ^%ZISC K IOP
I $D(PSOAP) U IO(0) S IOP=PSOAP D ^%ZIS D ^%ZISC K IOP
K ^TMP($J,"ZRX"),TZ,NMPSOAT,PSOAP,PSOACPM,PSOACPF,PSOACPL,XNEW,PSOAPF,TEST,%MT,DIRUT,I,NM,POP,PSOACDS,PSOAPG,PSOAT,SS,X,XNM,XSS,Y
Q
QNM W !!,"Enter the name or Social Security Number of the patient whose archived",!,"prescriptions you wish to retrieve. Social Security Number must be in the",!,"form : ######### (NO DASHES)!!"
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSOARCIN 2434 printed Dec 13, 2024@02:24:17 Page 2
PSOARCIN ;BHAM ISC/LGH,SAB - tape index search ; 07/07/92
+1 ;;7.0;OUTPATIENT PHARMACY;;DEC 1997
PQ SET XNEW=0
SET PSOATNM=1
SET %ZIS("A")="Tape Drive Device: "
SET %ZIS("B")=""
WRITE !!
DO ^%ZIS
KILL %ZIS("A")
if POP
GOTO END
SET PSOAT=IO
IF IOST'["MAGTAPE"
DO ^%ZISC
USE IO(0)
WRITE !,"Must select a MAGTAPE device",!!
GOTO PQ
+1 USE IO(0)
WRITE !!
SET %ZIS("A")="Output Device: "
DO ^%ZIS
KILL %ZIS("A")
SET PSOAP=IO
if POP
GOTO END
SET PSOACPM=IOM
SET PSOACPF=IOF
SET PSOACPL=IOSL
WRITE !!
+2 IF '$DATA(%MT("REW"))
XECUTE ^%ZOSF("MAGTAPE")
R2 SET DIR("A")="Do you want to print the tape index"
SET DIR("T")=DTIME
SET DIR(0)="YO"
DO ^DIR
KILL DIR
if $DATA(DTOUT)!$DATA(DUOUT)
GOTO END
if 'Y
GOTO RN
+1 FOR
USE PSOAT
READ X:DTIME
USE PSOAP
WRITE !,X
if X="!"
QUIT
+2 USE PSOAT
WRITE @%MT("REW")
USE IO(0)
RN WRITE !!
SET DIR("A")="Enter Patient's Name "
SET DIR("?")="^D QNM^PSOARCIN"
SET DIR("T")=DTIME
SET DIR(0)="FO"
DO ^DIR
KILL DIR
if $GET(DIRUT)
GOTO END
SET DIC=2
SET DIC(0)="EZM"
DO ^DIC
KILL DIC
SET NM=$SELECT(Y=-1:"",1:$PIECE(Y,"^",2))
SET TZ=1
SET SS=$SELECT(Y=-1:"",1:$PIECE(Y(0),"^",9))
+1 IF Y=-1
if X?1A.E
SET NM=X
if X?9N
SET SS=X
R ;G:X'["&" R S:$P(X,"^",2)="NEW" XNEW=1
USE PSOAT
READ X:DTIME
XECUTE ^%ZOSF("EOT")
if Y
GOTO END
if (X="")!(X="!")
GOTO NOT
+1 IF X="&^NEW"
SET XNEW=1
GOTO R5
+2 IF X="&"
SET XNEW=0
GOTO R5
+3 SET XNM=$PIECE($PIECE(X,"^"),"%",1)
SET XSS=$PIECE($PIECE(X,"^"),"%",2)
if ((NM="")&(SS'=XSS))!((NM'=XNM)&(SS=""))!((SS'="")&(SS'=XSS))
GOTO R5
SET ^TMP($JOB,"ZRX",TZ)=X
SET TZ=TZ+1
GOTO R1
R5 USE PSOAT
READ X:DTIME
XECUTE ^%ZOSF("EOT")
if Y
GOTO END
if (X="")!(X="!")
GOTO NOT
SET XNM=$PIECE($PIECE(X,"^"),"%",1)
SET XSS=$PIECE($PIECE(X,"^"),"%",2)
if ((NM="")&(SS'=XSS))!((NM'=XNM)&(SS=""))!((SS'="")&(SS'=XSS))
GOTO R5
SET ^TMP($JOB,"ZRX",TZ)=X
SET TZ=TZ+1
R1 READ X:DTIME
if '$TEST
GOTO END
if (X="")!(X="!")!($EXTRACT(X,1)?1A)
GOTO P
SET ^TMP($JOB,"ZRX",TZ)=X
SET TZ=TZ+1
GOTO R1
P SET TZ=TZ-1
+1 USE PSOAP
WRITE @PSOACPF,!,"The following scripts were archived on this tape for : ",!!
+2 WRITE !,$PIECE(^TMP($JOB,"ZRX",1),"%",1)," (",$PIECE($PIECE(^(1),"^"),"%",2),") - "
SET NM=$PIECE(^TMP($JOB,"ZRX",1),"%",1)
SET SS=$PIECE($PIECE(^(1),"^"),"%",2)
FOR I=1:1:TZ
if I'=1
WRITE !?($LENGTH(NM)+2)
WRITE $PIECE(^TMP($JOB,"ZRX",I),"^",2)
+3 SET PSOAPG=1
SET PSOACDS="Rx Retrieval for "_NM
if XNEW=0
GOTO ^PSOARCRR
if XNEW=1
GOTO ^PSOARCR1
+4 QUIT
NOT USE IO(0)
WRITE !!,NM_" does not have archived scripts on this tape."
END IF $DATA(PSOAT)
USE IO(0)
SET IOP=PSOAT
DO ^%ZIS
DO ^%ZISC
KILL IOP
+1 IF $DATA(PSOAP)
USE IO(0)
SET IOP=PSOAP
DO ^%ZIS
DO ^%ZISC
KILL IOP
+2 KILL ^TMP($JOB,"ZRX"),TZ,NMPSOAT,PSOAP,PSOACPM,PSOACPF,PSOACPL,XNEW,PSOAPF,TEST,%MT,DIRUT,I,NM,POP,PSOACDS,PSOAPG,PSOAT,SS,X,XNM,XSS,Y
+3 QUIT
QNM WRITE !!,"Enter the name or Social Security Number of the patient whose archived",!,"prescriptions you wish to retrieve. Social Security Number must be in the",!,"form : ######### (NO DASHES)!!"
+1 QUIT
