source: FOIAVistA/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOARCSV.m@ 1635

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