source: FOIAVistA/trunk/r/OUTPATIENT_PHARMACY-PSO-APSP-HUIP/PSOARCS2.m@ 1607

Last change on this file since 1607 was 628, checked in by George Lilly, 15 years ago

initial load of FOIAVistA 6/30/08 version

File size: 3.7 KB
Line 
1PSOARCS2 ;BHAM ISC/LGH,SAB - Rx archive (cont'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
4END K PSABS,PSOAC,PSOACP,PSOACT,PSOAF,PSOAM,PSOAPAR,PSOAT,ZI,ZII,J,JJ,K,IOP,PSOACPF,X,X1,X2,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
7 D KILLARC^PSOARCCO L -^PSOARC
8 Q
9CLOSE 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
12ARC ;archive info - invoked by ^PSOARC
13 K DIR,DIRUT S DIR("A",1)="Are you sure you're ready to Purge your Archived Prescriptions from your"
14 S DIR("A",2)="on-line prescription global? If you do not have a current backup, exit"
15 S DIR("A")="and perform the backup operation",DIR(0)="YO",DIR("B")="NO"
16 D ^DIR K DIR Q:'Y!($D(DIRUT))
17 K DIR,DIRUT
18 I ^%ZOSF("OS")'["MSM" W !! S DIR("A")="Is Journaling Disabled on the prescription global (^PSRX)? Y/N ",DIR(0)="YO" D ^DIR K DIR Q:'Y!($D(DIRUT))
19 W !!,"Deleting entries from the PRESCRIPTION file",!
20 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 D MES W "."
21 .Q:'$D(^PSRX(RX))
22 .S PSOSUSPA=1 D EN^PSOHLSN1(RX,"Z@","","Purge order.","") S PAT=$P(^PSRX(RX,0),"^",2),DIK="^PSRX(",DA=RX D ^DIK K PSOSUSPA
23 .I $D(^PS(55,PAT,0)) S DA(1)=PAT,DIK="^PS(55,"_DA(1)_",""P""," F X=0:0 S X=$O(^PS(55,PAT,"P",X)) Q:'X I ^PS(55,PAT,"P",X,0)=RX S DA=X D ^DIK K DA,DIK
24 .S DIK="^PS(52.4,",DA=RX D ^DIK K DA,DIK
25 .S DA=$O(^PS(52.5,"B",RX,"")) Q:DA']"" S DIK="^PS(52.5," D ^DIK K DIK
26 W $C(7),!!!,"Finished purging old prescriptions"
27 W !!,"Deleting entries from the PENDING file",!
28 S PDRX=0 F S PDRX=$O(^PS(52.41,PDRX)) Q:'PDRX D
29 .S STAT=$P(^PS(52.41,PDRX,0),"^",3) I $G(STAT)="DC"!($G(STAT)="DE") D
30 ..D EN^PSOHLSN($P(^PS(52.41,PDRX,0),"^"),"Z@","PURGE ORDER","""")
31 ..S DIK="^PS(52.41,",DA=PDRX D ^DIK K DA,DIK,STAT W "."
32 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
33 Q
34MES ;store archived Rx's in Pharmacy Patient file (#55)
35 S LL=0,LST=""
36 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
37 F S LL=$O(^PS(55,PSOACD,"ARC",DT,1,LL)) Q:'LL S LST=LL
38 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
39 S DA=PSOACD,DIE=55,DR="101///"_DT,DR(2,55.13)="1///"_$G(RX1) D ^DIE K DIE
40QMES Q
41TAPE1 ;Invoked from ^PSOARCSV
42 D PSOAT W "!" D PSOAT G:PSOAEOT TAPE1 W T(1) D PSOAT G:PSOAEOT TAPE1 W T(2) S D=+$P(T(2),"^",2),A=+$P(T(2),"^",3),DG=+$P(T(2),"^",4),GD=+$P(T(2),"^",5)
43 I D>0 F TI=1:1:D D PSOAT G:PSOAEOT TAPE1 W:$D(T(2,TI)) T(2,TI)
44 I A>0 F TI=1:1:A D PSOAT G:PSOAEOT TAPE1 W:$D(T(3,TI)) T(3,TI)
45 I DG>0 F TI=1:1:DG D PSOAT G:PSOAEOT TAPE1 W:$D(T(4,TI)) T(4,TI)
46 I GD>0 F TI=1:1:GD D PSOAT G:PSOAEOT TAPE1 W:$D(T(5,TI)) T(5,TI)
47 K TI,D,A,DG,GD Q
48PSOAT ;check for eot return psoaeot=1 if eot found
49 U PSOAT S PSOAEOT=0 X ^%ZOSF("EOT") I Y D EOT S PSOAEOT=1
50 U PSOAT Q
51EOT U IO(0) W !!?5,"** End of tape detected **",!?5,"After current tape rewinds, mount next tape" U PSOAT W ^%ZOSF("REW")
52READ U IO(0) W !?5,"Type <CR> to continue" R XX:DTIME I '$T G READ
53 W !!,"Recording information" S PSOATNM=PSOATNM+1
54 Q
55VAR ;Invoked by ^PSOARCS1 and ^PSOARCS2
56 S STOP=0 Q ;*PS*5.6$C(7)
57 W !," Check both the 'OPEN PARAMETERS' and 'ASK RIGHT MARGIN' fields of",!," your device file"
58 S STOP=1 D ^%ZISC K IOP Q
Note: See TracBrowser for help on using the repository browser.