PSOHLSG4.m

PSOHLSG4 ;BIR/LC-Purge entries from file 52.51 ;03/20/96

 ;;7.0;OUTPATIENT PHARMACY;**26**;DEC 1997

PURGE ;Purge data from the External Interface file

 I $D(ZTQUEUED) G DQ

 S X1=DT,X2=-7 D C^%DTC S Y=X X ^DD("DD") S DIR("B")=Y

 S DIR(0)="D^:"_X_":EX",DIR("A")="Enter cutoff date for purge",DIR("?")="The cutoff date must be at least seven days before today"

 D ^DIR G Q:$D(DIRUT) S PDT=Y_.999999

 S DIR(0)="YA",DIR("B")="NO",DIR("A")="Purge entries that were not successfully processed?  ",DIR("?",1)="Enter 'Yes' to purge entries whose status is 'process failed'."

 S DIR("?",2)="If you have reviewed/resolved the cause of the problem of those entries",DIR("?")="with an 'error' status answer 'Yes'.  Otherwise answer 'No'."

 W ! D ^DIR G Q:$D(DIRUT) K DIR S PERR=Y

 S ZTRTN="DQ^PSOHLSG4",ZTSAVE("PERR")="",ZTSAVE("PDT")="",ZTIO="",ZTSAVE("DA1")="",ZTSAVE("DA")=""

 S ZTDESC="Purge External Interface file entries on or before "_$E(PDT,4,5)_"/"_$E(PDT,6,7)_"/"_$E(PDT,2,3) D ^%ZTLOAD

 ;W !!,"Purge queued to run in background." G Q

 G Q

DQ ;Taskman entry point for running purge of External Interface file

 S:'$D(PERR) PERR=0 I '$D(PDT) S X1=DT,X2=-7 D C^%DTC S PDT=X_.999999

 F PDATE=0:0 S PDATE=$O(^PS(52.51,"AC1",PDATE)) Q:'PDATE!(PDATE>PDT)  D

 .F PSOIN=0:0 S PSOIN=$O(^PS(52.51,"AC1",PDATE,PSOIN)) Q:'PSOIN  D

 ..S PSOTR=$P($G(^PS(52.51,PSOIN,0)),"^",10)

 ..I 'PERR,PSOTR=3 Q

 ..I PSOTR=1!(PSOTR=4) Q

 ..S DIK="^PS(52.51,",DA=PSOIN D ^DIK

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

Q K %H,DA,DIR,DIRUT,DIK,PDT,PERR,PTR,X,X1,X2,XMDUZ,XMK,XMZ,Y,ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE,DELCNT

 ;

 Q

PSOHLSG4  ;BIR/LC-Purge entries from file 52.51 ;03/20/96

 +1       ;;7.0;OUTPATIENT PHARMACY;**26**;DEC 1997

PURGE     ;Purge data from the External Interface file

 +1        IF $DATA(ZTQUEUED)

               GOTO DQ

 +2        SET X1=DT

           SET X2=-7

           DO C^%DTC

           SET Y=X

           XECUTE ^DD("DD")

           SET DIR("B")=Y

 +3        SET DIR(0)="D^:"_X_":EX"

           SET DIR("A")="Enter cutoff date for purge"

           SET DIR("?")="The cutoff date must be at least seven days before today"

 +4        DO ^DIR

           IF $DATA(DIRUT)

               GOTO Q

           SET PDT=Y_.999999

 +5        SET DIR(0)="YA"

           SET DIR("B")="NO"

           SET DIR("A")="Purge entries that were not successfully processed?  "

           SET DIR("?",1)="Enter 'Yes' to purge entries whose status is 'process failed'."

 +6        SET DIR("?",2)="If you have reviewed/resolved the cause of the problem of those entries"

           SET DIR("?")="with an 'error' status answer 'Yes'.  Otherwise answer 'No'."

 +7        WRITE !

           DO ^DIR

           IF $DATA(DIRUT)

               GOTO Q

           KILL DIR

           SET PERR=Y

 +8        SET ZTRTN="DQ^PSOHLSG4"

           SET ZTSAVE("PERR")=""

           SET ZTSAVE("PDT")=""

           SET ZTIO=""

           SET ZTSAVE("DA1")=""

           SET ZTSAVE("DA")=""

 +9        SET ZTDESC="Purge External Interface file entries on or before "_$EXTRACT(PDT,4,5)_"/"_$EXTRACT(PDT,6,7)_"/"_$EXTRACT(PDT,2,3)

           DO ^%ZTLOAD

 +10      ;W !!,"Purge queued to run in background." G Q

 +11       GOTO Q

DQ        ;Taskman entry point for running purge of External Interface file

 +1        IF '$DATA(PERR)

               SET PERR=0

           IF '$DATA(PDT)

               SET X1=DT

               SET X2=-7

               DO C^%DTC

               SET PDT=X_.999999

 +2        FOR PDATE=0:0

               SET PDATE=$ORDER(^PS(52.51,"AC1",PDATE))

               IF 'PDATE!(PDATE>PDT)

                   QUIT 

               Begin DoDot:1

 +3                FOR PSOIN=0:0

                       SET PSOIN=$ORDER(^PS(52.51,"AC1",PDATE,PSOIN))

                       IF 'PSOIN

                           QUIT 

                       Begin DoDot:2

 +4                        SET PSOTR=$PIECE($GET(^PS(52.51,PSOIN,0)),"^",10)

 +5                        IF 'PERR

                               IF PSOTR=3

                                   QUIT 

 +6                        IF PSOTR=1!(PSOTR=4)

                               QUIT 

 +7                        SET DIK="^PS(52.51,"

                           SET DA=PSOIN

                           DO ^DIK

                       End DoDot:2

               End DoDot:1

 +8        IF $DATA(ZTQUEUED)

               SET ZTREQ="@"

Q          KILL %H,DA,DIR,DIRUT,DIK,PDT,PERR,PTR,X,X1,X2,XMDUZ,XMK,XMZ,Y,ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE,DELCNT

 +1       ;

 +2        QUIT