PSOARCSV ;BIR/SAB/LGH-archiving save option ;07/07/92
;;7.0;OUTPATIENT PHARMACY;**27,130,268**;DEC 1997;Build 9
;External reference to ^DPT("SSN" supported by DBIA 10035
;External references PSOL and PSOUL^PSSLOCK supported by DBIA 2789
AC L +^PSOARC:$S(+$G(^DD("DILOCKTM"))>0:+^DD("DILOCKTM"),1:3) I '$T W !!!,$C(7),"Archiving is currently in progress on another terminal!...",!!! Q
G:'+$P($G(^PSOARC(0)),"^",4) EX S PSOACRS="",PG=1,PSOAPG=1,PSOION=ION
W !!! S DIR("A")=$P(^PSOARC(0),"^",4)_" Rx's will be archived. Ok to continue Y/N",DIR(0)="YO",DIR("B")="NO" D ^DIR K DIR G EX1:$G(DIRUT),EX1:'Y
EN01 S DIR("A",1)="",DIR("A")="Do you want a hardcopy of your archived prescriptions",DIR("B")="NO",DIR(0)="YO" D ^DIR K DIR G:$D(DIRUT) EX1 G:'Y TDV
PDV S STOP=0 K PSOAP,PSOACPF,PSOACPL,PSOACPM,PSOATNM
K IOP,POP,%ZIS S %ZIS("A")="Printer: ",%ZIS="M" D ^%ZIS I POP S IOP=PSOION D ^%ZIS K PSOION G EX1
D:$E(IOST)'["P" PDVQ G:STOP END1 S PSOAP=IO,PSOACPF=IOF,PSOACPL=IOSL,PSOACPM=IOM,PSOATNM=1
PDV1 I $D(PSOAP) D G:$D(DUOUT) END1 G:$D(DTOUT) EX1
.K DIR S DIR("A")="PRINTOUT HEADER LABEL: ",DIR(0)="FO^1:64",DIR("?",1)=" ...Enter 1 to 64 characters.",DIR("?")="These characters will appear at top of every page of your printout." D ^DIR K DIR S PSOACDS=$G(X) K X
TDV W !! K %ZIS S %ZIS("A")="Tape Drive Device:",%ZIS("B")="" D ^%ZIS K %ZIS("A")
I POP S IOP=PSOION D ^%ZIS K IOP,%ZIS,POP G EX1
I IOST'["MAGTAPE" D ^%ZISC W !,"Must select a MAGTAPE device" G TDV
X ^%ZOSF("MAGTAPE") S PSOAT=IO,PSOABS=IOBS,PSOAF=IOF,PSOAM=IOM,PSOAPAR=IOPAR,PSOATNM=1
RST ;Invoked from ^PSOARCCO
W !!,"Recording Information" D:$D(PSOAP) HD D:$D(PSOAT) HDT 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 GAT
FILE1 S ZI=0 F J=0:0 S ZI=$O(^PSOARC("B",ZI)) Q:ZI="" S SSN=0 F PSOK=0:0 S SSN=$O(^PSOARC("B",$G(ZI),SSN)) Q:+SSN'>0 D ARC
W "!",@%MT("WEL")
K DA,DFN,I,I1,LMI,PSOABS,PSOAEOT,PSOK,RX0,TA,VAR1,XAR1,XTYPE
G ^PSOARCS2
Q
END1 S DIR("A")="Do you wish to continue? Y/N",DIR(0)="YO" D ^DIR K DIR G:$D(DIRUT)!('Y) EXIT^PSOARCCO S STOP=0 G EN01
PDVQ S DIR("A",1)="Are you sure you want to print archived information",DIR("A")="to the device that you are currently on (...this device)",DIR(0)="YO" D ^DIR K DIR S:'Y!($D(DIRUT)) STOP=1 Q
ARC S DA=$O(^DPT("SSN",SSN,0)) Q:+DA'>0 D:$D(PSOAT) ^PSOARCTG D:$D(PSOAT) TAPE1^PSOARCS2 S ZII=0 F JJ=0:0 S ZII=$O(^PSOARC("B",ZI,SSN,ZII)) Q:ZII'>"" D RX,ARCRX
Q
RX Q:'($D(^PSRX(+ZII,0))#2) S (RX0,DA)=ZII U IO(0) W "." I $D(PSOAP) U PSOAP D:$Y>(PSOACPL-20) HD1 D ^PSOARX
I $D(PSOAT) D ^PSOARCCV,TAPE^PSOARCTP
Q
ARCRX ;Mark Rx as archived in 52 by setting field 36
N DA,DR,DIE
S (DA,PSOARCRX,PSOARCDA)=RX0,DR="36////1",DIE="^PSRX(" D PSOL^PSSLOCK(PSOARCRX) S DA=PSOARCDA K PSOARCDA I '$G(PSOMSG) W !!,$C(7),$S($P($G(PSOMSG),"^",2)'="":$P(PSOMSG,"^",2),1:"Entry is being edited by another user!"),! K PSOARCRX,PSOMSG Q
D ^DIE K DIE D PSOUL^PSSLOCK(PSOARCRX) K PSOMSG,PSOARCRX
Q
;
GAT 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
I $D(PSOAP) D
.U PSOAP D:($Y+(LL\132))>PSOACPL HD 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)>(PSOACPM-5) !?($L(NM)+3) W $P(^PSRX(ZII,0),"^"),","
D:$D(PSOAT) TAP0 Q
HD U PSOAP W @PSOACPF,!!?58,"Archiving Index",?120,"Page "_PG,!,?62,$E(DT,4,5),"/",$E(DT,6,7),"/",$E(DT,2,3),!! S PG=PG+1
Q
HD1 ;Invoked from ^PSOARCRR,PSOARCR1
W @PSOACPF,?(66-($L(PSOACDS)\2)),PSOACDS,?112,$E(DT,4,5),"/",$E(DT,6,7),"/",$E(DT,2,3),?122,"Page "_PSOAPG S PSOAPG=PSOAPG+1 W !
Q
HDT U PSOAT W "&^NEW" Q
DEVICE W !!,?10,"Device not available, try again later!"
D ^%ZISC G EXIT^PSOARCCO
Q
TAP0 ;prints index to tape
U PSOAT S VAR1=NM_"%"_SS_"^",ZII=0 F KK=1:1 S ZII=$O(^TMP($J,"ZRX",ZII)) Q:+ZII'>0 D TAP1
I $L(VAR1)>0 U PSOAT W VAR1,!
S XAR1="" Q
TAP1 ;print "name-rx list"
I ($L(VAR1)+$L($P(^PSRX(ZII,0),"^"))+1)<255 S VAR1=VAR1_$P(^PSRX(ZII,0),"^")_"," Q
U PSOAT W VAR1,! S VAR1="^"_$P(^PSRX(ZII,0),"^")_"," Q
EX W !!,"THE "_$P(^PSOARC(0),"^",1)_" file is empty. Archiving will not be done."
EX1 K PSOACRS,PSOAPG,PG,%MT,DA,DFN,DIR,DIRUT,DTOUT,DUOUT,I,I1,J,JJ,KK,LL,LMI,NM,PG,PSOABS,PSOACDS,PSOACPF,PSOACPL,PSOACPM,PSOACRS,PSOACEOT,PSOAF
K PSOAM,PSOAP,PSOAPAR,PSOAT,PSOATNM,PSOION,PSOK,RX0,SS,SSN,STOP,TA,VAR1,X,XAR1,XTYPE,Y,ZI,ZII D KVA^VADPT
L -^PSOARC
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSOARCSV 4546 printed Sep 23, 2025@20:00:36 Page 2
PSOARCSV ;BIR/SAB/LGH-archiving save option ;07/07/92
+1 ;;7.0;OUTPATIENT PHARMACY;**27,130,268**;DEC 1997;Build 9
+2 ;External reference to ^DPT("SSN" supported by DBIA 10035
+3 ;External references PSOL and PSOUL^PSSLOCK supported by DBIA 2789
AC LOCK +^PSOARC:$SELECT(+$GET(^DD("DILOCKTM"))>0:+^DD("DILOCKTM"),1:3)
IF '$TEST
WRITE !!!,$CHAR(7),"Archiving is currently in progress on another terminal!...",!!!
QUIT
+1 if '+$PIECE($GET(^PSOARC(0)),"^",4)
GOTO EX
SET PSOACRS=""
SET PG=1
SET PSOAPG=1
SET PSOION=ION
+2 WRITE !!!
SET DIR("A")=$PIECE(^PSOARC(0),"^",4)_" Rx's will be archived. Ok to continue Y/N"
SET DIR(0)="YO"
SET DIR("B")="NO"
DO ^DIR
KILL DIR
if $GET(DIRUT)
GOTO EX1
if 'Y
GOTO EX1
EN01 SET DIR("A",1)=""
SET DIR("A")="Do you want a hardcopy of your archived prescriptions"
SET DIR("B")="NO"
SET DIR(0)="YO"
DO ^DIR
KILL DIR
if $DATA(DIRUT)
GOTO EX1
if 'Y
GOTO TDV
PDV SET STOP=0
KILL PSOAP,PSOACPF,PSOACPL,PSOACPM,PSOATNM
+1 KILL IOP,POP,%ZIS
SET %ZIS("A")="Printer: "
SET %ZIS="M"
DO ^%ZIS
IF POP
SET IOP=PSOION
DO ^%ZIS
KILL PSOION
GOTO EX1
+2 if $EXTRACT(IOST)'["P"
DO PDVQ
if STOP
GOTO END1
SET PSOAP=IO
SET PSOACPF=IOF
SET PSOACPL=IOSL
SET PSOACPM=IOM
SET PSOATNM=1
PDV1 IF $DATA(PSOAP)
Begin DoDot:1
+1 KILL DIR
SET DIR("A")="PRINTOUT HEADER LABEL: "
SET DIR(0)="FO^1:64"
SET DIR("?",1)=" ...Enter 1 to 64 characters."
SET DIR("?")="These characters will appear at top of every page of your printout."
DO ^DIR
KILL DIR
SET PSOACDS=$GET(X)
KILL X
End DoDot:1
if $DATA(DUOUT)
GOTO END1
if $DATA(DTOUT)
GOTO EX1
TDV WRITE !!
KILL %ZIS
SET %ZIS("A")="Tape Drive Device:"
SET %ZIS("B")=""
DO ^%ZIS
KILL %ZIS("A")
+1 IF POP
SET IOP=PSOION
DO ^%ZIS
KILL IOP,%ZIS,POP
GOTO EX1
+2 IF IOST'["MAGTAPE"
DO ^%ZISC
WRITE !,"Must select a MAGTAPE device"
GOTO TDV
+3 XECUTE ^%ZOSF("MAGTAPE")
SET PSOAT=IO
SET PSOABS=IOBS
SET PSOAF=IOF
SET PSOAM=IOM
SET PSOAPAR=IOPAR
SET PSOATNM=1
RST ;Invoked from ^PSOARCCO
+1 WRITE !!,"Recording Information"
if $DATA(PSOAP)
DO HD
if $DATA(PSOAT)
DO HDT
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
DO GAT
FILE1 SET ZI=0
FOR J=0:0
SET ZI=$ORDER(^PSOARC("B",ZI))
if ZI=""
QUIT
SET SSN=0
FOR PSOK=0:0
SET SSN=$ORDER(^PSOARC("B",$GET(ZI),SSN))
if +SSN'>0
QUIT
DO ARC
+1 WRITE "!",@%MT("WEL")
+2 KILL DA,DFN,I,I1,LMI,PSOABS,PSOAEOT,PSOK,RX0,TA,VAR1,XAR1,XTYPE
+3 GOTO ^PSOARCS2
+4 QUIT
END1 SET DIR("A")="Do you wish to continue? Y/N"
SET DIR(0)="YO"
DO ^DIR
KILL DIR
if $DATA(DIRUT)!('Y)
GOTO EXIT^PSOARCCO
SET STOP=0
GOTO EN01
PDVQ SET DIR("A",1)="Are you sure you want to print archived information"
SET DIR("A")="to the device that you are currently on (...this device)"
SET DIR(0)="YO"
DO ^DIR
KILL DIR
if 'Y!($DATA(DIRUT))
SET STOP=1
QUIT
ARC SET DA=$ORDER(^DPT("SSN",SSN,0))
if +DA'>0
QUIT
if $DATA(PSOAT)
DO ^PSOARCTG
if $DATA(PSOAT)
DO TAPE1^PSOARCS2
SET ZII=0
FOR JJ=0:0
SET ZII=$ORDER(^PSOARC("B",ZI,SSN,ZII))
if ZII'>""
QUIT
DO RX
DO ARCRX
+1 QUIT
RX if '($DATA(^PSRX(+ZII,0))#2)
QUIT
SET (RX0,DA)=ZII
USE IO(0)
WRITE "."
IF $DATA(PSOAP)
USE PSOAP
if $Y>(PSOACPL-20)
DO HD1
DO ^PSOARX
+1 IF $DATA(PSOAT)
DO ^PSOARCCV
DO TAPE^PSOARCTP
+2 QUIT
ARCRX ;Mark Rx as archived in 52 by setting field 36
+1 NEW DA,DR,DIE
+2 SET (DA,PSOARCRX,PSOARCDA)=RX0
SET DR="36////1"
SET DIE="^PSRX("
DO PSOL^PSSLOCK(PSOARCRX)
SET DA=PSOARCDA
KILL PSOARCDA
IF '$GET(PSOMSG)
WRITE !!,$CHAR(7),$SELECT($PIECE($GET(PSOMSG),"^",2)'="":$PIECE(PSOMSG,"^",2),1:"Entry is being edited by another user!"),!
KILL PSOARCRX,PSOMSG
QUIT
+3 DO ^DIE
KILL DIE
DO PSOUL^PSSLOCK(PSOARCRX)
KILL PSOMSG,PSOARCRX
+4 QUIT
+5 ;
GAT SET NM=ZI
SET ZII=0
SET SS=SSN
SET LL=$LENGTH(NM)+$LENGTH(SS)+6
+1 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
+2 IF $DATA(PSOAP)
Begin DoDot:1
+3 USE PSOAP
if ($Y+(LL\132))>PSOACPL
DO HD
WRITE !,NM_" ("_$EXTRACT(SSN,1,3)_"-"_$EXTRACT(SSN,4,5)_"-"_$EXTRACT(SSN,6,9)_") - "
SET ZII=0
+4 FOR KK=1:1
SET ZII=$ORDER(^TMP($JOB,"ZRX",ZII))
if +ZII'>0
QUIT
if ($X+$LENGTH(ZII)+1)>(PSOACPM-5)
WRITE !?($LENGTH(NM)+3)
WRITE $PIECE(^PSRX(ZII,0),"^"),","
End DoDot:1
+5 if $DATA(PSOAT)
DO TAP0
QUIT
HD USE PSOAP
WRITE @PSOACPF,!!?58,"Archiving Index",?120,"Page "_PG,!,?62,$EXTRACT(DT,4,5),"/",$EXTRACT(DT,6,7),"/",$EXTRACT(DT,2,3),!!
SET PG=PG+1
+1 QUIT
HD1 ;Invoked from ^PSOARCRR,PSOARCR1
+1 WRITE @PSOACPF,?(66-($LENGTH(PSOACDS)\2)),PSOACDS,?112,$EXTRACT(DT,4,5),"/",$EXTRACT(DT,6,7),"/",$EXTRACT(DT,2,3),?122,"Page "_PSOAPG
SET PSOAPG=PSOAPG+1
WRITE !
+2 QUIT
HDT USE PSOAT
WRITE "&^NEW"
QUIT
DEVICE WRITE !!,?10,"Device not available, try again later!"
+1 DO ^%ZISC
GOTO EXIT^PSOARCCO
+2 QUIT
TAP0 ;prints index to tape
+1 USE PSOAT
SET VAR1=NM_"%"_SS_"^"
SET ZII=0
FOR KK=1:1
SET ZII=$ORDER(^TMP($JOB,"ZRX",ZII))
if +ZII'>0
QUIT
DO TAP1
+2 IF $LENGTH(VAR1)>0
USE PSOAT
WRITE VAR1,!
+3 SET XAR1=""
QUIT
TAP1 ;print "name-rx list"
+1 IF ($LENGTH(VAR1)+$LENGTH($PIECE(^PSRX(ZII,0),"^"))+1)<255
SET VAR1=VAR1_$PIECE(^PSRX(ZII,0),"^")_","
QUIT
+2 USE PSOAT
WRITE VAR1,!
SET VAR1="^"_$PIECE(^PSRX(ZII,0),"^")_","
QUIT
EX WRITE !!,"THE "_$PIECE(^PSOARC(0),"^",1)_" file is empty. Archiving will not be done."
EX1 KILL PSOACRS,PSOAPG,PG,%MT,DA,DFN,DIR,DIRUT,DTOUT,DUOUT,I,I1,J,JJ,KK,LL,LMI,NM,PG,PSOABS,PSOACDS,PSOACPF,PSOACPL,PSOACPM,PSOACRS,PSOACEOT,PSOAF
+1 KILL PSOAM,PSOAP,PSOAPAR,PSOAT,PSOATNM,PSOION,PSOK,RX0,SS,SSN,STOP,TA,VAR1,X,XAR1,XTYPE,Y,ZI,ZII
DO KVA^VADPT
+2 LOCK -^PSOARC
+3 QUIT
