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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSOHLSG4 1604 printed Sep 23, 2025@20:06:31 Page 2
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
