PSOARCS2.m

PSOARCS2 ;BHAM ISC/LGH,SAB - Rx archive (cont'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,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

 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

 K DIR,DIRUT S DIR("A",1)="Are you sure you're ready to Purge your Archived Prescriptions from your"

 S DIR("A",2)="on-line prescription global?  If you do not have a current backup, exit"

 S DIR("A")="and perform the backup operation",DIR(0)="YO",DIR("B")="NO"

 D ^DIR K DIR Q:'Y!($D(DIRUT))

 K DIR,DIRUT

 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))

 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  D MES W "."

 .Q:'$D(^PSRX(RX))

 .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

 .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

 .S DIK="^PS(52.4,",DA=RX D ^DIK K DA,DIK

 .S DA=$O(^PS(52.5,"B",RX,"")) Q:DA']""  S DIK="^PS(52.5," D ^DIK K DIK

 W $C(7),!!!,"Finished purging old prescriptions"

 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 "."

 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 ;store 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 ^PSOARCSV

 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)

 I D>0 F TI=1:1:D D PSOAT G:PSOAEOT TAPE1 W:$D(T(2,TI)) T(2,TI)

 I A>0 F TI=1:1:A D PSOAT G:PSOAEOT TAPE1 W:$D(T(3,TI)) T(3,TI)

 I DG>0 F TI=1:1:DG D PSOAT G:PSOAEOT TAPE1 W:$D(T(4,TI)) T(4,TI)

 I GD>0 F TI=1:1:GD D PSOAT G:PSOAEOT TAPE1 W:$D(T(5,TI)) T(5,TI)

 K TI,D,A,DG,GD Q

PSOAT ;check for eot return psoaeot=1 if eot found

 U PSOAT S PSOAEOT=0 X ^%ZOSF("EOT") I Y D EOT S PSOAEOT=1

 U PSOAT Q

EOT U IO(0) W !!?5,"** End of tape detected **",!?5,"After current tape rewinds, mount next tape" U PSOAT W ^%ZOSF("REW")

READ U IO(0) W !?5,"Type <CR> to continue" R XX:DTIME I '$T G READ

 W !!,"Recording information" S PSOATNM=PSOATNM+1

 Q

VAR ;Invoked by ^PSOARCS1 and ^PSOARCS2

 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

PSOARCS2  ;BHAM ISC/LGH,SAB - Rx archive (cont'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,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

 +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        KILL DIR,DIRUT

           SET DIR("A",1)="Are you sure you're ready to Purge your Archived Prescriptions from your"

 +2        SET DIR("A",2)="on-line prescription global?  If you do not have a current backup, exit"

 +3        SET DIR("A")="and perform the backup operation"

           SET DIR(0)="YO"

           SET DIR("B")="NO"

 +4        DO ^DIR

           KILL DIR

           IF 'Y!($DATA(DIRUT))

               QUIT 

 +5        KILL DIR,DIRUT

 +6        IF ^%ZOSF("OS")'["MSM"

               WRITE !!

               SET DIR("A")="Is Journaling Disabled on the prescription global (^PSRX)? Y/N "

               SET DIR(0)="YO"

               DO ^DIR

               KILL DIR

               IF 'Y!($DATA(DIRUT))

                   QUIT 

 +7        WRITE !!,"Deleting entries from the PRESCRIPTION file",!

 +8        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

                   Begin DoDot:1

 +9                    IF '$DATA(^PSRX(RX))

                           QUIT 

 +10                   SET PSOSUSPA=1

                       DO EN^PSOHLSN1(RX,"Z@","","Purge order.","")

                       SET PAT=$PIECE(^PSRX(RX,0),"^",2)

                       SET DIK="^PSRX("

                       SET DA=RX

                       DO ^DIK

                       KILL PSOSUSPA

 +11                   IF $DATA(^PS(55,PAT,0))

                           SET DA(1)=PAT

                           SET DIK="^PS(55,"_DA(1)_",""P"","

                           FOR X=0:0

                               SET X=$ORDER(^PS(55,PAT,"P",X))

                               IF 'X

                                   QUIT 

                               IF ^PS(55,PAT,"P",X,0)=RX

                                   SET DA=X

                                   DO ^DIK

                                   KILL DA,DIK

 +12                   SET DIK="^PS(52.4,"

                       SET DA=RX

                       DO ^DIK

                       KILL DA,DIK

 +13                   SET DA=$ORDER(^PS(52.5,"B",RX,""))

                       IF DA']""

                           QUIT 

                       SET DIK="^PS(52.5,"

                       DO ^DIK

                       KILL DIK

                   End DoDot:1

                   DO MES

                   WRITE "."

 +14       WRITE $CHAR(7),!!!,"Finished purging old prescriptions"

 +15       WRITE !!,"Deleting entries from the PENDING file",!

 +16       SET PDRX=0

           FOR 

               SET PDRX=$ORDER(^PS(52.41,PDRX))

               IF 'PDRX

                   QUIT 

               Begin DoDot:1

 +17               SET STAT=$PIECE(^PS(52.41,PDRX,0),"^",3)

                   IF $GET(STAT)="DC"!($GET(STAT)="DE")

                       Begin DoDot:2

 +18                       DO EN^PSOHLSN($PIECE(^PS(52.41,PDRX,0),"^"),"Z@","PURGE ORDER","""")

 +19                       SET DIK="^PS(52.41,"

                           SET DA=PDRX

                           DO ^DIK

                           KILL DA,DIK,STAT

                           WRITE "."

                       End DoDot:2

               End DoDot:1

 +20       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

 +21       QUIT 

MES       ;store 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 ^PSOARCSV

 +1        DO PSOAT

           WRITE "!"

           DO PSOAT

           IF PSOAEOT

               GOTO TAPE1

           WRITE T(1)

           DO PSOAT

           IF PSOAEOT

               GOTO TAPE1

           WRITE 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

                   DO PSOAT

                   IF PSOAEOT

                       GOTO TAPE1

                   IF $DATA(T(2,TI))

                       WRITE T(2,TI)

 +3        IF A>0

               FOR TI=1:1:A

                   DO PSOAT

                   IF PSOAEOT

                       GOTO TAPE1

                   IF $DATA(T(3,TI))

                       WRITE T(3,TI)

 +4        IF DG>0

               FOR TI=1:1:DG

                   DO PSOAT

                   IF PSOAEOT

                       GOTO TAPE1

                   IF $DATA(T(4,TI))

                       WRITE T(4,TI)

 +5        IF GD>0

               FOR TI=1:1:GD

                   DO PSOAT

                   IF PSOAEOT

                       GOTO TAPE1

                   IF $DATA(T(5,TI))

                       WRITE T(5,TI)

 +6        KILL TI,D,A,DG,GD

           QUIT 

PSOAT     ;check for eot return psoaeot=1 if eot found

 +1        USE PSOAT

           SET PSOAEOT=0

           XECUTE ^%ZOSF("EOT")

           IF Y

               DO EOT

               SET PSOAEOT=1

 +2        USE PSOAT

           QUIT 

EOT        USE IO(0)

           WRITE !!?5,"** End of tape detected **",!?5,"After current tape rewinds, mount next tape"

           USE PSOAT

           WRITE ^%ZOSF("REW")

READ       USE IO(0)

           WRITE !?5,"Type <CR> to continue"

           READ XX:DTIME

           IF '$TEST

               GOTO READ

 +1        WRITE !!,"Recording information"

           SET PSOATNM=PSOATNM+1

 +2        QUIT 

VAR       ;Invoked by ^PSOARCS1 and ^PSOARCS2

 +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