PSOARCCO.m

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 

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