| 1 | PSOARCF5 ;BHAM ISC/LGH,SAB,LC - RX ARCHIVE (CNT'D) ; 07/07/92
|
|---|
| 2 | ;;7.0;OUTPATIENT PHARMACY;;DEC 1997
|
|---|
| 3 | S PSOACP=0 D CLOSE K:'$D(PSOACP) PSOAP K:'$D(PSOACT) PSOAT
|
|---|
| 4 | END K PSABS,PSOAC,PSOACP,PSOACT,PSOAF,PSOAM,PSOAPAR,PSOAT,ZI,ZII,J,JJ,K,IOP,PSOACPF,X,X1,X2,^TMP($J,"ZRX"),PSOACPL,PSOACPM,PSPRNP,RFDATE,RFL,RM,ST,ST0,LL,KK,NM,PG,PHYS,PI,PSDIS,PSLC,PSOACRS,PSPRCNT,RFL1,PSOAPG,T,PSOAP
|
|---|
| 5 | K %MT,C,POP,SS,TZ,XNEW,XNM,XSS,IOUPAR,IOPAR,IOXY,%,DUSYS,DIRUT,SSN,PSRST,PSOATNM,XX,PSOAPF,IOBS,IOHG
|
|---|
| 6 | K %DT,%Y,D0,D1,D2,DA,DI,DIE,DIR,DLAYGO,DQ,DR,PAT,PSOACD,PSOK,RX,RX0,ZZI,IK,STOP,PSOAIO,PSOAIOT,PSOAPAR
|
|---|
| 7 | D KILLARC^PSOARCCO L -^PSOARC
|
|---|
| 8 | Q
|
|---|
| 9 | CLOSE I $D(PSOAT) U IO(0) S IOP=PSOAT D ^%ZIS D ^%ZISC K IOP
|
|---|
| 10 | I $D(PSOAP),IO(0)'=PSOAP U PSOAP W @PSOACPF U IO(0) S IOP=PSOAP D ^%ZIS D ^%ZISC K IOP
|
|---|
| 11 | L -^PSOARC Q
|
|---|
| 12 | ARC ;ARCHIVE INFO - invoked by ^PSOARC
|
|---|
| 13 | W !!!,"Are you sure you're ready to PURGE your ARCHIVED PRESCRIPTIONS"
|
|---|
| 14 | S DIR("A")="from your on-line prescription global? Y/N ",DIR("T")=DTIME,DIR(0)="YO" D ^DIR K DIR Q:Y=0 Q:$G(DIRUT)
|
|---|
| 15 | W !!,"If you do not have a current backup, exit and perform the backup"
|
|---|
| 16 | S DIR("A")="operation !!! 'Y' to continue 'N' to exit",DIR("T")=DTIME,DIR(0)="Y" D ^DIR K DIR Q:Y=0 Q:$G(DIRUT)
|
|---|
| 17 | I ^%ZOSF("OS")'["MSM" W !! S DIR("A")="Is JOURNALING DISABLED on the prescription global (^PSRX)? Y/N ",DIR(0)="YO",DIR("T")=DTIME D ^DIR K DIR Q:Y=0 Q:$G(DIRUT)
|
|---|
| 18 | W !!,"Deleting entries from the PENDING file",!
|
|---|
| 19 | S PDRX=0 F S PDRX=$O(^PS(52.41,PDRX)) Q:'PDRX D
|
|---|
| 20 | .S STAT=$P(^PS(52.41,PDRX,0),"^",3) I $G(STAT)="DC"!($G(STAT)="DE") D
|
|---|
| 21 | ..D EN^PSOHLSN($P(^PS(52.41,PDRX,0),"^"),"Z@","PURGE ORDER","""")
|
|---|
| 22 | ..S DIK="^PS(52.41,",DA=PDRX D ^DIK K DA,DIK,STAT W "."
|
|---|
| 23 | W !!,"Deleting entries from the PRESCRIPTION file",!
|
|---|
| 24 | S (RX,RX1)=0 F S RX=$O(^PSRX(RX)) Q:'RX S PSOACD=$P(^PSRX(RX,0),"^",2),RX1=$P(^(0),"^") I $G(^PSRX(RX,"ARC"))>0 D ^PSOARCDE,MES W "."
|
|---|
| 25 | W $C(7),!!!,"Finished purging old prescriptions"
|
|---|
| 26 | K %DT,%Y,D0,D1,D2,DA,DI,DIE,DIR,DLAYGO,DQ,DR,PAT,IK,LL,LST,PNODE,PLGTH,PDRX,PSOACD,PSOK,RX,RX1,ZZI
|
|---|
| 27 | Q
|
|---|
| 28 | MES ;sto archived Rx's in Pharmacy Patient file (#55)
|
|---|
| 29 | S LL=0,LST=""
|
|---|
| 30 | I '$D(^PS(55,PSOACD,"ARC",DT)) S DA=PSOACD,DIE=55,DR="101///"_DT,DR(2,55.13)="1///"_$G(RX1) D ^DIE K DIE G QMES
|
|---|
| 31 | F S LL=$O(^PS(55,PSOACD,"ARC",DT,1,LL)) Q:'LL S LST=LL
|
|---|
| 32 | I $G(LST),$D(^PS(55,PSOACD,"ARC",DT,1,LST,0)) S PNODE=^PS(55,PSOACD,"ARC",DT,1,LST,0) S PLGTH=$L(PNODE) I $G(PLGTH),PLGTH<220 S ^PS(55,PSOACD,"ARC",DT,1,LST,0)=PNODE_$S($E(PNODE,PLGTH)'="*":"*",1:"")_RX1 G QMES
|
|---|
| 33 | S DA=PSOACD,DIE=55,DR="101///"_DT,DR(2,55.13)="1///"_$G(RX1) D ^DIE K DIE
|
|---|
| 34 | QMES Q
|
|---|
| 35 | TAPE1 ;Invoked from ^PSOARCF4
|
|---|
| 36 | D PSOAT W "!",!,T(1),!,T(2),! S D=+$P(T(2),"^",2),A=+$P(T(2),"^",3),DG=+$P(T(2),"^",4),GD=+$P(T(2),"^",5)
|
|---|
| 37 | I D>0 F TI=1:1:D W:$D(T(2,TI)) T(2,TI),!
|
|---|
| 38 | I A>0 F TI=1:1:A W:$D(T(3,TI)) T(3,TI),!
|
|---|
| 39 | I DG>0 F TI=1:1:DG W:$D(T(4,TI)) T(4,TI),!
|
|---|
| 40 | I GD>0 F TI=1:1:GD W:$D(T(5,TI)) T(5,TI),!
|
|---|
| 41 | K TI,D,A,DG,GD Q
|
|---|
| 42 | PSOAT ;CHECK FOR EOF
|
|---|
| 43 | U PSOAT S:$$STATUS^%ZISH PSORWND=$$REWIND^%ZIS(PSOAIO,PSOAIOT,PSOAPAR) I $G(PSORWND)=0 U IO(0) W !!,"HFS file failed to rewind" G CLOSE
|
|---|
| 44 | U PSOAT
|
|---|
| 45 | Q
|
|---|
| 46 | VAR ;Invoked by ^PSOARCS1 and ^PSOARCF5
|
|---|
| 47 | S STOP=0 Q ;*PS*5.6$C(7)
|
|---|
| 48 | W !," Check both the 'OPEN PARAMETERS' and 'ASK RIGHT MARGIN' fields of",!," your device file"
|
|---|
| 49 | S STOP=1 D ^%ZISC K IOP Q
|
|---|
