PSOARCCO ;BHAM ISC/LGH - find rxs that to be archived ; 07/07/92
;;7.0;OUTPATIENT PHARMACY;**268**;DEC 1997;Build 9
S X1=DT,X2=-121 D C^%DTC S %DT(0)=-X
AC S PSOAPG=1,PG=1,X2=-360,X1=DT D C^%DTC S Y=X X ^DD("DD") S %DT("B")=Y
L +^PSOARC:$S(+$G(^DD("DILOCKTM"))>0:+^DD("DILOCKTM"),1:3) I '$T W !!,"Archive global locked by another user!",! K PSOALAST,PSOAC,Y,PSOAPG Q
W !! S %DT("A")="Archive all scripts which expired on or before: "
DT S %DT="AEXP" D ^%DT G:Y=-1 EXIT S PSOAC=Y
ST G:$D(PSOACRS) RST^PSOARCSV
S LC=0,LC=$O(^PSOARC(LC)) I $G(LC) W !!,"WARNING!! There are entries in the ",$P(^PSOARC(0),"^")," file!",! S DIR("?")="^D STQ^ZPSOARCC"
I $G(LC) S DIR("A")="Do you want to delete these entries ",DIR(0)="YO",DIR("B")="No" D ^DIR G:$D(DIRUT)!('Y) EXIT
D:$G(LC) KILLARC W !!,"Collecting Rx Information",!
S ZI=0 F J=1:1 S ZI=$O(^PSRX(ZI)) Q:+ZI'>0 I $D(^PSRX(ZI,0)),$P($G(^(2)),"^",6)]"",$P($G(^(2)),"^",6)'>PSOAC,$P(^(0),"^",2)'="" D COLLECT W "."
S LC=0,LC=$O(^PSOARC(LC))
W !!,$S($G(LC):"I'm finished finding things!!",1:"I didn't find anything!!"),$C(7) G EXIT
;
COLLECT S PSDFN=+$P(^PSRX(ZI,0),"^",2) I '$D(^DPT(PSDFN,0))#2 Q
S SSN=$P(^DPT(PSDFN,0),"^",9) Q:SSN="" S $P(^PSOARC(0),"^",4)=($P(^PSOARC(0),"^",4)+1),$P(^PSOARC(0),"^",3)=ZI
S ^PSOARC(ZI,0)=ZI_"^"_PSDFN,^PSOARC("B",$P(^DPT(PSDFN,0),"^"),SSN,ZI)="",^PSOARC("C",PSDFN,ZI)=""
Q
KILLARC ;delete all entries in ^PSOARC
S DIK="^PSOARC(",DA=0 F S DA=$O(^PSOARC(DA)) Q:'DA D ^DIK
K ^PSOARC("B"),^PSOARC("C"),DA,DIK
Q
STQ W !,"The entries that are currently in the file should probably be archived before",!,"continuing. Use the archive 'SAVE' option to write the entries to file or"
W !,"tape and then return to this option. If you delete the entries now, this"
W !,"archive 'FIND' option will re-enter them and then you should use the 'SAVE'",!,"option to archive them.",!
Q
CONT S DIR("A")="Do you want to continue? ",DIR(0)="Y",DIR("T")=DTIME D ^DIR K DIR G:'Y EXIT ;G:Y EN01^PSOARCS1
;
EXIT K PSABS,PSOAC,PSOACP,PSOACT,PSOAF,PSOAM,PSOAPAR,PSOAT,IOP,PSOACPF,X,X1,X2,Y,PSOACPL,PSOACPM,PSPRNP,RFDATE,RFL,RM,ST,ST0,PSOACRS,PSPRCNT,RFL1,PSOAPG,PSOAP,D,J,K,PG,PSDFN,SSZ,Z,ZI,DIR,PSOAC1,%DT,PSOALAST,LC
K DIRUT,DUOUT,DTOUT
L -^PSOARC
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSOARCCO 2267 printed Dec 13, 2024@02:24:09 Page 2
PSOARCCO ;BHAM ISC/LGH - find rxs that to be archived ; 07/07/92
+1 ;;7.0;OUTPATIENT PHARMACY;**268**;DEC 1997;Build 9
+2 SET X1=DT
SET X2=-121
DO C^%DTC
SET %DT(0)=-X
AC SET PSOAPG=1
SET PG=1
SET X2=-360
SET X1=DT
DO C^%DTC
SET Y=X
XECUTE ^DD("DD")
SET %DT("B")=Y
+1 LOCK +^PSOARC:$SELECT(+$GET(^DD("DILOCKTM"))>0:+^DD("DILOCKTM"),1:3)
IF '$TEST
WRITE !!,"Archive global locked by another user!",!
KILL PSOALAST,PSOAC,Y,PSOAPG
QUIT
+2 WRITE !!
SET %DT("A")="Archive all scripts which expired on or before: "
DT SET %DT="AEXP"
DO ^%DT
if Y=-1
GOTO EXIT
SET PSOAC=Y
ST if $DATA(PSOACRS)
GOTO RST^PSOARCSV
+1 SET LC=0
SET LC=$ORDER(^PSOARC(LC))
IF $GET(LC)
WRITE !!,"WARNING!! There are entries in the ",$PIECE(^PSOARC(0),"^")," file!",!
SET DIR("?")="^D STQ^ZPSOARCC"
+2 IF $GET(LC)
SET DIR("A")="Do you want to delete these entries "
SET DIR(0)="YO"
SET DIR("B")="No"
DO ^DIR
if $DATA(DIRUT)!('Y)
GOTO EXIT
+3 if $GET(LC)
DO KILLARC
WRITE !!,"Collecting Rx Information",!
+4 SET ZI=0
FOR J=1:1
SET ZI=$ORDER(^PSRX(ZI))
if +ZI'>0
QUIT
IF $DATA(^PSRX(ZI,0))
IF $PIECE($GET(^(2)),"^",6)]""
IF $PIECE($GET(^(2)),"^",6)'>PSOAC
IF $PIECE(^(0),"^",2)'=""
DO COLLECT
WRITE "."
+5 SET LC=0
SET LC=$ORDER(^PSOARC(LC))
+6 WRITE !!,$SELECT($GET(LC):"I'm finished finding things!!",1:"I didn't find anything!!"),$CHAR(7)
GOTO EXIT
+7 ;
COLLECT SET PSDFN=+$PIECE(^PSRX(ZI,0),"^",2)
IF '$DATA(^DPT(PSDFN,0))#2
QUIT
+1 SET SSN=$PIECE(^DPT(PSDFN,0),"^",9)
if SSN=""
QUIT
SET $PIECE(^PSOARC(0),"^",4)=($PIECE(^PSOARC(0),"^",4)+1)
SET $PIECE(^PSOARC(0),"^",3)=ZI
+2 SET ^PSOARC(ZI,0)=ZI_"^"_PSDFN
SET ^PSOARC("B",$PIECE(^DPT(PSDFN,0),"^"),SSN,ZI)=""
SET ^PSOARC("C",PSDFN,ZI)=""
+3 QUIT
KILLARC ;delete all entries in ^PSOARC
+1 SET DIK="^PSOARC("
SET DA=0
FOR
SET DA=$ORDER(^PSOARC(DA))
if 'DA
QUIT
DO ^DIK
+2 KILL ^PSOARC("B"),^PSOARC("C"),DA,DIK
+3 QUIT
STQ WRITE !,"The entries that are currently in the file should probably be archived before",!,"continuing. Use the archive 'SAVE' option to write the entries to file or"
+1 WRITE !,"tape and then return to this option. If you delete the entries now, this"
+2 WRITE !,"archive 'FIND' option will re-enter them and then you should use the 'SAVE'",!,"option to archive them.",!
+3 QUIT
CONT ;G:Y EN01^PSOARCS1
SET DIR("A")="Do you want to continue? "
SET DIR(0)="Y"
SET DIR("T")=DTIME
DO ^DIR
KILL DIR
if 'Y
GOTO EXIT
+1 ;
EXIT KILL PSABS,PSOAC,PSOACP,PSOACT,PSOAF,PSOAM,PSOAPAR,PSOAT,IOP,PSOACPF,X,X1,X2,Y,PSOACPL,PSOACPM,PSPRNP,RFDATE,RFL,RM,ST,ST0,PSOACRS,PSPRCNT,RFL1,PSOAPG,PSOAP,D,J,K,PG,PSDFN,SSZ,Z,ZI,DIR,PSOAC1,%DT,PSOALAST,LC
+1 KILL DIRUT,DUOUT,DTOUT
+2 LOCK -^PSOARC
+3 QUIT
