- 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 Feb 18, 2025@23:50:35 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