PXRMETXU ; SLC/PJH - Extract utilities ;09/06/2007
;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
;
HELP(CALL) ;General help text routine
N HTEXT
I CALL=1 D
.S HTEXT(1)="Enter 'Y' to overwrite this existing list. Enter 'N' to"
.S HTEXT(2)="use a different patient list name."
;
I CALL=3 D
.S HTEXT(1)="Enter 'Y' to transmit extract. Otherwise enter 'N'."
;
I CALL=4 D
.S HTEXT(1)="The selected period is the same as next scheduled extract."
.S HTEXT(2)="Enter 'Y' if this extract will replace the scheduled"
.S HTEXT(3)="extract. Enter 'N' if you still want the scheduled extract"
.S HTEXT(4)="to run."
;
D HELP^PXRMEUT(.HTEXT)
Q
;
DELETE(IEN) ;Delete an extract summary.
I IEN="" Q
N DA,DELOK,DIK,NAME
S DELOK=1
S NAME=$P(^PXRMXT(810.3,IEN,0),U,1)
;Must have PXRM MANAGER key in order to delete national extracts.
I $P($G(^PXRMXT(810.3,IEN,100)),U,1)="N" D
. S DELOK=$S($D(^XUSEC("PXRM MANAGER",DUZ)):1,1:0)
. I 'DELOK D
.. W !!,NAME," is national."
.. W !,"You cannot delete a national extract summary."
.. H 2
I 'DELOK Q
;Double check the user really wants to delete.
S TEXT="Are you sure you want to delete "_NAME
S DELOK=$$ASKYN^PXRMEUT("N","Are you sure you want to delete "_NAME)
I 'DELOK Q
S DA=IEN
S DIK="^PXRMXT(810.3,"
D ^DIK
W !,"Deleting ",NAME
H 2
Q
;
PRGES ;Delete any Extract Summaries over 5 years old
N DIFF,EDATE,OLD
S OLD=0
F S OLD=$O(^PXRMXT(810.3,OLD)) Q:'OLD D
.I +$G(^PXRMXT(810.3,OLD,50))'=1 Q
.;Extract Date
.S EDATE=$P($G(^PXRMXT(810.3,OLD,0)),U,6)
.;Ignore if < 5 years (1826 days) since creation
.I $$FMDIFF^XLFDT(DT,EDATE,1)<1826 Q
.;Otherwise delete
.N DIK,DA
.S DIK="^PXRMXT(810.3,",DA=OLD D ^DIK
Q
;
PRGPL ;Delete any Patient Lists over 5 years old
N LDATE,OLD
S OLD=0
F S OLD=$O(^PXRMXP(810.5,OLD)) Q:'OLD D
.I +$G(^PXRMXP(810.5,OLD,50))'=1 Q
.;Patient List Date
.S LDATE=$P($G(^PXRMXP(810.5,OLD,0)),U,4)
.;Ignore if < 5 years (1826 days) since creation
.I $$FMDIFF^XLFDT(DT,LDATE,1)<1826 Q
.;Otherwise delete
.N DIK,DA
.S DIK="^PXRMXP(810.5,",DA=OLD D ^DIK
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPXRMETXU 2150 printed Sep 23, 2025@19:20:43 Page 2
PXRMETXU ; SLC/PJH - Extract utilities ;09/06/2007
+1 ;;2.0;CLINICAL REMINDERS;**4,6**;Feb 04, 2005;Build 123
+2 ;
HELP(CALL) ;General help text routine
+1 NEW HTEXT
+2 IF CALL=1
Begin DoDot:1
+3 SET HTEXT(1)="Enter 'Y' to overwrite this existing list. Enter 'N' to"
+4 SET HTEXT(2)="use a different patient list name."
End DoDot:1
+5 ;
+6 IF CALL=3
Begin DoDot:1
+7 SET HTEXT(1)="Enter 'Y' to transmit extract. Otherwise enter 'N'."
End DoDot:1
+8 ;
+9 IF CALL=4
Begin DoDot:1
+10 SET HTEXT(1)="The selected period is the same as next scheduled extract."
+11 SET HTEXT(2)="Enter 'Y' if this extract will replace the scheduled"
+12 SET HTEXT(3)="extract. Enter 'N' if you still want the scheduled extract"
+13 SET HTEXT(4)="to run."
End DoDot:1
+14 ;
+15 DO HELP^PXRMEUT(.HTEXT)
+16 QUIT
+17 ;
DELETE(IEN) ;Delete an extract summary.
+1 IF IEN=""
QUIT
+2 NEW DA,DELOK,DIK,NAME
+3 SET DELOK=1
+4 SET NAME=$PIECE(^PXRMXT(810.3,IEN,0),U,1)
+5 ;Must have PXRM MANAGER key in order to delete national extracts.
+6 IF $PIECE($GET(^PXRMXT(810.3,IEN,100)),U,1)="N"
Begin DoDot:1
+7 SET DELOK=$SELECT($DATA(^XUSEC("PXRM MANAGER",DUZ)):1,1:0)
+8 IF 'DELOK
Begin DoDot:2
+9 WRITE !!,NAME," is national."
+10 WRITE !,"You cannot delete a national extract summary."
+11 HANG 2
End DoDot:2
End DoDot:1
+12 IF 'DELOK
QUIT
+13 ;Double check the user really wants to delete.
+14 SET TEXT="Are you sure you want to delete "_NAME
+15 SET DELOK=$$ASKYN^PXRMEUT("N","Are you sure you want to delete "_NAME)
+16 IF 'DELOK
QUIT
+17 SET DA=IEN
+18 SET DIK="^PXRMXT(810.3,"
+19 DO ^DIK
+20 WRITE !,"Deleting ",NAME
+21 HANG 2
+22 QUIT
+23 ;
PRGES ;Delete any Extract Summaries over 5 years old
+1 NEW DIFF,EDATE,OLD
+2 SET OLD=0
+3 FOR
SET OLD=$ORDER(^PXRMXT(810.3,OLD))
if 'OLD
QUIT
Begin DoDot:1
+4 IF +$GET(^PXRMXT(810.3,OLD,50))'=1
QUIT
+5 ;Extract Date
+6 SET EDATE=$PIECE($GET(^PXRMXT(810.3,OLD,0)),U,6)
+7 ;Ignore if < 5 years (1826 days) since creation
+8 IF $$FMDIFF^XLFDT(DT,EDATE,1)<1826
QUIT
+9 ;Otherwise delete
+10 NEW DIK,DA
+11 SET DIK="^PXRMXT(810.3,"
SET DA=OLD
DO ^DIK
End DoDot:1
+12 QUIT
+13 ;
PRGPL ;Delete any Patient Lists over 5 years old
+1 NEW LDATE,OLD
+2 SET OLD=0
+3 FOR
SET OLD=$ORDER(^PXRMXP(810.5,OLD))
if 'OLD
QUIT
Begin DoDot:1
+4 IF +$GET(^PXRMXP(810.5,OLD,50))'=1
QUIT
+5 ;Patient List Date
+6 SET LDATE=$PIECE($GET(^PXRMXP(810.5,OLD,0)),U,4)
+7 ;Ignore if < 5 years (1826 days) since creation
+8 IF $$FMDIFF^XLFDT(DT,LDATE,1)<1826
QUIT
+9 ;Otherwise delete
+10 NEW DIK,DA
+11 SET DIK="^PXRMXP(810.5,"
SET DA=OLD
DO ^DIK
End DoDot:1
+12 QUIT
+13 ;
