- PSOARCF5 ;BHAM ISC/LGH,SAB,LC - RX ARCHIVE (CNT'D) ; 07/07/92
- ;;7.0;OUTPATIENT PHARMACY;;DEC 1997
- S PSOACP=0 D CLOSE K:'$D(PSOACP) PSOAP K:'$D(PSOACT) PSOAT
- 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
- K %MT,C,POP,SS,TZ,XNEW,XNM,XSS,IOUPAR,IOPAR,IOXY,%,DUSYS,DIRUT,SSN,PSRST,PSOATNM,XX,PSOAPF,IOBS,IOHG
- K %DT,%Y,D0,D1,D2,DA,DI,DIE,DIR,DLAYGO,DQ,DR,PAT,PSOACD,PSOK,RX,RX0,ZZI,IK,STOP,PSOAIO,PSOAIOT,PSOAPAR
- D KILLARC^PSOARCCO L -^PSOARC
- Q
- CLOSE I $D(PSOAT) U IO(0) S IOP=PSOAT D ^%ZIS D ^%ZISC K IOP
- I $D(PSOAP),IO(0)'=PSOAP U PSOAP W @PSOACPF U IO(0) S IOP=PSOAP D ^%ZIS D ^%ZISC K IOP
- L -^PSOARC Q
- ARC ;ARCHIVE INFO - invoked by ^PSOARC
- W !!!,"Are you sure you're ready to PURGE your ARCHIVED PRESCRIPTIONS"
- 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)
- W !!,"If you do not have a current backup, exit and perform the backup"
- 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)
- 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)
- W !!,"Deleting entries from the PENDING file",!
- S PDRX=0 F S PDRX=$O(^PS(52.41,PDRX)) Q:'PDRX D
- .S STAT=$P(^PS(52.41,PDRX,0),"^",3) I $G(STAT)="DC"!($G(STAT)="DE") D
- ..D EN^PSOHLSN($P(^PS(52.41,PDRX,0),"^"),"Z@","PURGE ORDER","""")
- ..S DIK="^PS(52.41,",DA=PDRX D ^DIK K DA,DIK,STAT W "."
- W !!,"Deleting entries from the PRESCRIPTION file",!
- 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 "."
- W $C(7),!!!,"Finished purging old prescriptions"
- 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
- Q
- MES ;sto archived Rx's in Pharmacy Patient file (#55)
- S LL=0,LST=""
- 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
- F S LL=$O(^PS(55,PSOACD,"ARC",DT,1,LL)) Q:'LL S LST=LL
- 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
- S DA=PSOACD,DIE=55,DR="101///"_DT,DR(2,55.13)="1///"_$G(RX1) D ^DIE K DIE
- QMES Q
- TAPE1 ;Invoked from ^PSOARCF4
- 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)
- I D>0 F TI=1:1:D W:$D(T(2,TI)) T(2,TI),!
- I A>0 F TI=1:1:A W:$D(T(3,TI)) T(3,TI),!
- I DG>0 F TI=1:1:DG W:$D(T(4,TI)) T(4,TI),!
- I GD>0 F TI=1:1:GD W:$D(T(5,TI)) T(5,TI),!
- K TI,D,A,DG,GD Q
- PSOAT ;CHECK FOR EOF
- 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
- U PSOAT
- Q
- VAR ;Invoked by ^PSOARCS1 and ^PSOARCF5
- S STOP=0 Q ;*PS*5.6$C(7)
- W !," Check both the 'OPEN PARAMETERS' and 'ASK RIGHT MARGIN' fields of",!," your device file"
- S STOP=1 D ^%ZISC K IOP Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSOARCF5 3273 printed Feb 18, 2025@23:50:42 Page 2
- PSOARCF5 ;BHAM ISC/LGH,SAB,LC - RX ARCHIVE (CNT'D) ; 07/07/92
- +1 ;;7.0;OUTPATIENT PHARMACY;;DEC 1997
- +2 SET PSOACP=0
- DO CLOSE
- if '$DATA(PSOACP)
- KILL PSOAP
- if '$DATA(PSOACT)
- KILL PSOAT
- END KILL PSABS,PSOAC,PSOACP,PSOACT,PSOAF,PSOAM,PSOAPAR,PSOAT,ZI,ZII,J,JJ,K,IOP,PSOACPF,X,X1,X2,^TMP($JOB,"ZRX"),PSOACPL,PSOACPM,PSPRNP,RFDATE,RFL,RM,ST,ST0,LL,KK,NM,PG,PHYS,PI,PSDIS,PSLC,PSOACRS,PSPRCNT,RFL1,PSOAPG,T,PSOAP
- +1 KILL %MT,C,POP,SS,TZ,XNEW,XNM,XSS,IOUPAR,IOPAR,IOXY,%,DUSYS,DIRUT,SSN,PSRST,PSOATNM,XX,PSOAPF,IOBS,IOHG
- +2 KILL %DT,%Y,D0,D1,D2,DA,DI,DIE,DIR,DLAYGO,DQ,DR,PAT,PSOACD,PSOK,RX,RX0,ZZI,IK,STOP,PSOAIO,PSOAIOT,PSOAPAR
- +3 DO KILLARC^PSOARCCO
- LOCK -^PSOARC
- +4 QUIT
- CLOSE IF $DATA(PSOAT)
- USE IO(0)
- SET IOP=PSOAT
- DO ^%ZIS
- DO ^%ZISC
- KILL IOP
- +1 IF $DATA(PSOAP)
- IF IO(0)'=PSOAP
- USE PSOAP
- WRITE @PSOACPF
- USE IO(0)
- SET IOP=PSOAP
- DO ^%ZIS
- DO ^%ZISC
- KILL IOP
- +2 LOCK -^PSOARC
- QUIT
- ARC ;ARCHIVE INFO - invoked by ^PSOARC
- +1 WRITE !!!,"Are you sure you're ready to PURGE your ARCHIVED PRESCRIPTIONS"
- +2 SET DIR("A")="from your on-line prescription global? Y/N "
- SET DIR("T")=DTIME
- SET DIR(0)="YO"
- DO ^DIR
- KILL DIR
- if Y=0
- QUIT
- if $GET(DIRUT)
- QUIT
- +3 WRITE !!,"If you do not have a current backup, exit and perform the backup"
- +4 SET DIR("A")="operation !!! 'Y' to continue 'N' to exit"
- SET DIR("T")=DTIME
- SET DIR(0)="Y"
- DO ^DIR
- KILL DIR
- if Y=0
- QUIT
- if $GET(DIRUT)
- QUIT
- +5 IF ^%ZOSF("OS")'["MSM"
- WRITE !!
- SET DIR("A")="Is JOURNALING DISABLED on the prescription global (^PSRX)? Y/N "
- SET DIR(0)="YO"
- SET DIR("T")=DTIME
- DO ^DIR
- KILL DIR
- if Y=0
- QUIT
- if $GET(DIRUT)
- QUIT
- +6 WRITE !!,"Deleting entries from the PENDING file",!
- +7 SET PDRX=0
- FOR
- SET PDRX=$ORDER(^PS(52.41,PDRX))
- if 'PDRX
- QUIT
- Begin DoDot:1
- +8 SET STAT=$PIECE(^PS(52.41,PDRX,0),"^",3)
- IF $GET(STAT)="DC"!($GET(STAT)="DE")
- Begin DoDot:2
- +9 DO EN^PSOHLSN($PIECE(^PS(52.41,PDRX,0),"^"),"Z@","PURGE ORDER","""")
- +10 SET DIK="^PS(52.41,"
- SET DA=PDRX
- DO ^DIK
- KILL DA,DIK,STAT
- WRITE "."
- End DoDot:2
- End DoDot:1
- +11 WRITE !!,"Deleting entries from the PRESCRIPTION file",!
- +12 SET (RX,RX1)=0
- FOR
- SET RX=$ORDER(^PSRX(RX))
- if 'RX
- QUIT
- SET PSOACD=$PIECE(^PSRX(RX,0),"^",2)
- SET RX1=$PIECE(^(0),"^")
- IF $GET(^PSRX(RX,"ARC"))>0
- DO ^PSOARCDE
- DO MES
- WRITE "."
- +13 WRITE $CHAR(7),!!!,"Finished purging old prescriptions"
- +14 KILL %DT,%Y,D0,D1,D2,DA,DI,DIE,DIR,DLAYGO,DQ,DR,PAT,IK,LL,LST,PNODE,PLGTH,PDRX,PSOACD,PSOK,RX,RX1,ZZI
- +15 QUIT
- MES ;sto archived Rx's in Pharmacy Patient file (#55)
- +1 SET LL=0
- SET LST=""
- +2 IF '$DATA(^PS(55,PSOACD,"ARC",DT))
- SET DA=PSOACD
- SET DIE=55
- SET DR="101///"_DT
- SET DR(2,55.13)="1///"_$GET(RX1)
- DO ^DIE
- KILL DIE
- GOTO QMES
- +3 FOR
- SET LL=$ORDER(^PS(55,PSOACD,"ARC",DT,1,LL))
- if 'LL
- QUIT
- SET LST=LL
- +4 IF $GET(LST)
- IF $DATA(^PS(55,PSOACD,"ARC",DT,1,LST,0))
- SET PNODE=^PS(55,PSOACD,"ARC",DT,1,LST,0)
- SET PLGTH=$LENGTH(PNODE)
- IF $GET(PLGTH)
- IF PLGTH<220
- SET ^PS(55,PSOACD,"ARC",DT,1,LST,0)=PNODE_$SELECT($EXTRACT(PNODE,PLGTH)'="*":"*",1:"")_RX1
- GOTO QMES
- +5 SET DA=PSOACD
- SET DIE=55
- SET DR="101///"_DT
- SET DR(2,55.13)="1///"_$GET(RX1)
- DO ^DIE
- KILL DIE
- QMES QUIT
- TAPE1 ;Invoked from ^PSOARCF4
- +1 DO PSOAT
- WRITE "!",!,T(1),!,T(2),!
- SET D=+$PIECE(T(2),"^",2)
- SET A=+$PIECE(T(2),"^",3)
- SET DG=+$PIECE(T(2),"^",4)
- SET GD=+$PIECE(T(2),"^",5)
- +2 IF D>0
- FOR TI=1:1:D
- if $DATA(T(2,TI))
- WRITE T(2,TI),!
- +3 IF A>0
- FOR TI=1:1:A
- if $DATA(T(3,TI))
- WRITE T(3,TI),!
- +4 IF DG>0
- FOR TI=1:1:DG
- if $DATA(T(4,TI))
- WRITE T(4,TI),!
- +5 IF GD>0
- FOR TI=1:1:GD
- if $DATA(T(5,TI))
- WRITE T(5,TI),!
- +6 KILL TI,D,A,DG,GD
- QUIT
- PSOAT ;CHECK FOR EOF
- +1 USE PSOAT
- if $$STATUS^%ZISH
- SET PSORWND=$$REWIND^%ZIS(PSOAIO,PSOAIOT,PSOAPAR)
- IF $GET(PSORWND)=0
- USE IO(0)
- WRITE !!,"HFS file failed to rewind"
- GOTO CLOSE
- +2 USE PSOAT
- +3 QUIT
- VAR ;Invoked by ^PSOARCS1 and ^PSOARCF5
- +1 ;*PS*5.6$C(7)
- SET STOP=0
- QUIT
- +2 WRITE !," Check both the 'OPEN PARAMETERS' and 'ASK RIGHT MARGIN' fields of",!," your device file"
- +3 SET STOP=1
- DO ^%ZISC
- KILL IOP
- QUIT