APSPRXD.m

APSPRXD ; IHS/DSD/ENM - DELETE PRESCRIPTIONS UP TO CERTAIN DATE ;  [ 09/03/97   1:30 PM ]

 ;;6.0;IHS PHARMACY MODIFICATIONS;;09/03/97

 ;

 ; This routine deletes prescriptions up to a user specified number

 ; of months from the day it is run.  It it meant to be run from

 ; the background but could be called at ENQUE if APSPRXD("ED") was

 ; defined with a Fileman formatted date.  This deletes entries

 ; from the PSRX,PS(55,PS(52.5, globals which correspond to the

 ; Prescription, Pharmacy Patient, RX Suspense files.

 ; When checking the prescriptions for deletion it checks for

 ; refills that were done for the prescription and if any of the

 ; refills were filled after the APSPRXD("ED") date, the prescription

 ; entry is not deleted.

 ;--------------------------------------------------------------------

START ;

 S MWR=0

 D ASK G ENQUE ;IHS/ANMC/MWR 03/17/92

 Q

 D QUE G END

ENQUE ; EP

 D PROCESS

END D EOJ

 Q

 ;---------------------------------------------------------------------

ASK ;

 S DIR(0)="NO^6:24",DIR("B")=15

 S DIR("A")="Number of months of prescriptions to keep"

 S DIR("?")="If you enter a 15, all prescriptions older than 15 months will be deleted."

 D ^DIR

 I $D(DTOUT)!($D(DUOUT)) S APSPRXD("QFLG")=1 G ASKX

 S X="T-"_Y_"M" D ^%DT S APSPRXD("ED")=Y

ASKX K DIR,X,Y

 Q

 ;

QUE ;

 S ZTRTN="ENQUE^APSPRXD",ZTIO="",ZTSAVE("APSPRXD(""ED"")")=""

 S ZTDESC="PRESCRIPTION DELETION"

 D ^%ZTLOAD

 Q

 ;

PROCESS ;

 F APSPRXD("DATE")=0:0 S APSPRXD("DATE")=$O(^PSRX("AD",APSPRXD("DATE"))) Q:APSPRXD("DATE")'<APSPRXD("ED")  D RX

 Q

RX ;

 ;APSPRXD("IRXN") IS THE SUBSCRIPT PRESCRIPTION NUMBER

 F APSPRXD("IRXN")=0:0 S APSPRXD("IRXN")=$O(^PSRX("AD",APSPRXD("DATE"),APSPRXD("IRXN"))) Q:APSPRXD("IRXN")=""  D CHECK

 Q

 ;

CHECK ;

 ; IF THE ENTRY DOES NOT EXIST, KILL THE XREF.    ;IHS/ANMC/MWR 03/19/92

 I '$D(^PSRX(APSPRXD("IRXN"))) K ^PSRX("AD",APSPRXD("DATE"),APSPRXD("IRXN")) Q  ;IHS/ANMC/MWR 03/19/92

 ;

 ;

 S APSPRXD("CHECK QFLG")=0

 I $O(^PSRX(APSPRXD("IRXN"),1,0)) F %=0:0 S %=$O(^PSRX(APSPRXD("IRXN"),1,%)) Q:'%!(APSPRXD("CHECK QFLG"))  S:+^(%,0)'<APSPRXD("ED") APSPRXD("CHECK QFLG")=1

 D:'APSPRXD("CHECK QFLG") DELETE

 Q

 ;

DELETE ;

 K APSPRXDI S APSPRXD("PAT")=$P(^PSRX(APSPRXD("IRXN"),0),U,2)

 I APSPRXD("PAT") F APSPRXDI=0:0 S APSPRXDI=$O(^PS(55,APSPRXD("PAT"),"P",APSPRXDI)) Q:'APSPRXDI  I +^(APSPRXDI,0)=APSPRXD("IRXN") D

 . S ^PS(55,APSPRXD("PAT"),"P",0)=$P(^PS(55,APSPRXD("PAT"),"P",0),U,1,3)_U_($P(^(0),U,4)-1)

 . K ^PS(55,APSPRXD("PAT"),"P",APSPRXDI)

 . F %=0:0 S %=$O(^PS(55,APSPRXD("PAT"),"P","A",%)) Q:'%  I $D(^(%,APSPRXD("IRXN"))) K ^(APSPRXD("IRXN"))

 . K:$D(^PS(55,APSPRXD("PAT"),"P","CP",APSPRXD("IRXN"))) ^(APSPRXD("IRXN"))

 . Q

 ;

 I $D(^PS(52.5,"B",APSPRXD("IRXN"))) S DA=$O(^PS(52.5,"B",APSPRXD("IRXN"),0)),DIK="^PS(52.5," D ^DIK K DIK,DA

 S DIK="^PSRX(",DA=APSPRXD("IRXN") D ^DIK K DIK,DA

 S MWR=MWR+1

 Q

 ;

EOJ ;

 K APSPRXD,ZTSK

 S:$D(ZTQUEUED) ZTREQ="@"

 Q

APSPRXD   ; IHS/DSD/ENM - DELETE PRESCRIPTIONS UP TO CERTAIN DATE ;  [ 09/03/97   1:30 PM ]

 +1       ;;6.0;IHS PHARMACY MODIFICATIONS;;09/03/97

 +2       ;

 +3       ; This routine deletes prescriptions up to a user specified number

 +4       ; of months from the day it is run.  It it meant to be run from

 +5       ; the background but could be called at ENQUE if APSPRXD("ED") was

 +6       ; defined with a Fileman formatted date.  This deletes entries

 +7       ; from the PSRX,PS(55,PS(52.5, globals which correspond to the

 +8       ; Prescription, Pharmacy Patient, RX Suspense files.

 +9       ; When checking the prescriptions for deletion it checks for

 +10      ; refills that were done for the prescription and if any of the

 +11      ; refills were filled after the APSPRXD("ED") date, the prescription

 +12      ; entry is not deleted.

 +13      ;--------------------------------------------------------------------

START     ;

 +1        SET MWR=0

 +2       ;IHS/ANMC/MWR 03/17/92

           DO ASK

           GOTO ENQUE

 +3        QUIT 

 +4        DO QUE

           GOTO END

ENQUE     ; EP

 +1        DO PROCESS

END        DO EOJ

 +1        QUIT 

 +2       ;---------------------------------------------------------------------

ASK       ;

 +1        SET DIR(0)="NO^6:24"

           SET DIR("B")=15

 +2        SET DIR("A")="Number of months of prescriptions to keep"

 +3        SET DIR("?")="If you enter a 15, all prescriptions older than 15 months will be deleted."

 +4        DO ^DIR

 +5        IF $DATA(DTOUT)!($DATA(DUOUT))

               SET APSPRXD("QFLG")=1

               GOTO ASKX

 +6        SET X="T-"_Y_"M"

           DO ^%DT

           SET APSPRXD("ED")=Y

ASKX       KILL DIR,X,Y

 +1        QUIT 

 +2       ;

QUE       ;

 +1        SET ZTRTN="ENQUE^APSPRXD"

           SET ZTIO=""

           SET ZTSAVE("APSPRXD(""ED"")")=""

 +2        SET ZTDESC="PRESCRIPTION DELETION"

 +3        DO ^%ZTLOAD

 +4        QUIT 

 +5       ;

PROCESS   ;

 +1        FOR APSPRXD("DATE")=0:0

               SET APSPRXD("DATE")=$ORDER(^PSRX("AD",APSPRXD("DATE")))

               IF APSPRXD("DATE")'<APSPRXD("ED")

                   QUIT 

               DO RX

 +2        QUIT 

RX        ;

 +1       ;APSPRXD("IRXN") IS THE SUBSCRIPT PRESCRIPTION NUMBER

 +2        FOR APSPRXD("IRXN")=0:0

               SET APSPRXD("IRXN")=$ORDER(^PSRX("AD",APSPRXD("DATE"),APSPRXD("IRXN")))

               IF APSPRXD("IRXN")=""

                   QUIT 

               DO CHECK

 +3        QUIT 

 +4       ;

CHECK     ;

 +1       ; IF THE ENTRY DOES NOT EXIST, KILL THE XREF.    ;IHS/ANMC/MWR 03/19/92

 +2       ;IHS/ANMC/MWR 03/19/92

           IF '$DATA(^PSRX(APSPRXD("IRXN")))

               KILL ^PSRX("AD",APSPRXD("DATE"),APSPRXD("IRXN"))

               QUIT 

 +3       ;

 +4       ;

 +5        SET APSPRXD("CHECK QFLG")=0

 +6        IF $ORDER(^PSRX(APSPRXD("IRXN"),1,0))

               FOR %=0:0

                   SET %=$ORDER(^PSRX(APSPRXD("IRXN"),1,%))

                   IF '%!(APSPRXD("CHECK QFLG"))

                       QUIT 

                   IF +^(%,0)'<APSPRXD("ED")

                       SET APSPRXD("CHECK QFLG")=1

 +7        IF 'APSPRXD("CHECK QFLG")

               DO DELETE

 +8        QUIT 

 +9       ;

DELETE    ;

 +1        KILL APSPRXDI

           SET APSPRXD("PAT")=$PIECE(^PSRX(APSPRXD("IRXN"),0),U,2)

 +2        IF APSPRXD("PAT")

               FOR APSPRXDI=0:0

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

                   IF 'APSPRXDI

                       QUIT 

                   IF +^(APSPRXDI,0)=APSPRXD("IRXN")

                       Begin DoDot:1

 +3                        SET ^PS(55,APSPRXD("PAT"),"P",0)=$PIECE(^PS(55,APSPRXD("PAT"),"P",0),U,1,3)_U_($PIECE(^(0),U,4)-1)

 +4                        KILL ^PS(55,APSPRXD("PAT"),"P",APSPRXDI)

 +5                        FOR %=0:0

                               SET %=$ORDER(^PS(55,APSPRXD("PAT"),"P","A",%))

                               IF '%

                                   QUIT 

                               IF $DATA(^(%,APSPRXD("IRXN")))

                                   KILL ^(APSPRXD("IRXN"))

 +6                        IF $DATA(^PS(55,APSPRXD("PAT"),"P","CP",APSPRXD("IRXN")))

                               KILL ^(APSPRXD("IRXN"))

 +7                        QUIT 

                       End DoDot:1

 +8       ;

 +9        IF $DATA(^PS(52.5,"B",APSPRXD("IRXN")))

               SET DA=$ORDER(^PS(52.5,"B",APSPRXD("IRXN"),0))

               SET DIK="^PS(52.5,"

               DO ^DIK

               KILL DIK,DA

 +10       SET DIK="^PSRX("

           SET DA=APSPRXD("IRXN")

           DO ^DIK

           KILL DIK,DA

 +11       SET MWR=MWR+1

 +12       QUIT 

 +13      ;

EOJ       ;

 +1        KILL APSPRXD,ZTSK

 +2        IF $DATA(ZTQUEUED)

               SET ZTREQ="@"

 +3        QUIT