FBFHLP ;WOIFO/SAB-FPPS MESSAGE PURGE ;9/9/2003
;;3.5;FEE BASIS;**61**;JAN 30, 1995
;
W !,"When an invoice is transmitted to FPPS via the HL7 package, a copy of the HL7"
W !,"message text is saved in the FPPS QUEUED INVOICES (#163.5) file."
W !!,"This option purges the message text for invoices transmitted prior to a"
W !,"specified date. Messages that have not been accepted by the VistA Interface"
W !,"Engine will not be purged unless there is a later message for the same"
W !,"invoice number that has been accepted.",!
;
; ask date
S DIR(0)="D^:"_$$FMADD^XLFDT(DT,-30)_":EX"
S DIR("A")="Purge text of messages transmitted prior to"
S DIR("B")=$$FMTE^XLFDT($$FMADD^XLFDT(DT,-60),2)
S DIR("?",1)="The purge date must be at least 30 days ago."
S DIR("?")="This response must be a date. Enter '^' to quit."
D ^DIR K DIR G:$D(DIRUT) EXIT
S FBDTP=Y
;
; ask device
S %ZIS="QM" D ^%ZIS G:POP EXIT
I $D(IO("Q")) D G EXIT
. S ZTRTN="QEN^FBFHLP",ZTDESC="FB FPPS Message Text Purge"
. F FBX="FBDTP" S ZTSAVE(FBX)=""
. D ^%ZTLOAD,HOME^%ZIS K ZTSK
;
QEN ; queued entry
U IO
;
PURGE ; Start Purge
S FBPG=0 D NOW^%DTC S Y=% D DD^%DT S FBDTR=Y
K FBDL S FBDL="",$P(FBDL,"-",IOM)=""
;
; build page header text for selection criteria
S FBHDT(1)=" For Messages Transmitted Prior To "_$$FMTE^XLFDT(FBDTP)
;
D HD
;
S FBQUIT=0
;
; initialize counters
S FBC=0 ; count of messages processed
S FBC("PRG")=0 ; count of message text purged
;
W !,"Starting Purge..."
;
; loop thru entries by MESSAGE DATE/TIME x-ref by date
S FBDT=0
F S FBDT=$O(^FBHL(163.5,"AMD",FBDT)) Q:FBDT=""!($P(FBDT,".")>FBDTP) D Q:FBQUIT
. S FBDA=0 F S FBDA=$O(^FBHL(163.5,"AMD",FBDT,FBDA)) Q:'FBDA D Q:FBQUIT
. . S FBC=FBC+1 ; increment count of records processed
. . ; if tasked then check for stop request
. . I $D(ZTQUEUED),FBC\1000,$$S^%ZTLOAD S ZTSTOP=1,FBQUIT=1 Q
. . Q:$O(^FBHL(163.5,FBDA,1,0))'>0 ; quit if no data in message text
. . ;
. . ; check if OK to purge
. . S FBPRG=0 ; init as NO
. . S FBY=$G(^FBHL(163.5,FBDA,0))
. . I $P(FBY,U,8)="A" S FBPRG=1 ; was accepted
. . I 'FBPRG D
. . . ; check if last entry for invoice was accepted
. . . N FBLDA
. . . S FBLDA=$$LAST^FBFHLU($P(FBY,U))
. . . I FBLDA,FBLDA'=FBDA,$P($G(^FBHL(163.5,FBLDA,0)),U,8)="A" S FBPRG=1
. . ;
. . ; if OK then purge
. . I FBPRG D WP^DIE(163.5,FBDA_",",7,"","@") S FBC("PRG")=FBC("PRG")+1
;
I 'FBQUIT W !,"Purge Completed."
;
W !!,"The message text was purged from ",FBC("PRG")," entr",$S(FBC("PRG")=1:"y",1:"ies")," in file 163.5."
;
I FBQUIT W !!,"REPORT STOPPED AT USER REQUEST"
;
I 'FBQUIT,$E(IOST,1,2)="C-" S DIR(0)="E" D ^DIR K DIR
D ^%ZISC
;
EXIT ;
I $D(ZTQUEUED) S ZTREQ="@"
K FBC,FBDA,FBDL,FBDT,FBDTP,FBDTR,FBHDT,FBPG,FBPRG,FBQUIT,FBX,FBY
K %,DIC,DIR,DIROUT,DIRUT,DTOUT,DUOUT,I,J,POP,X,Y
Q
;
HD ; page header
N FBI
I $D(ZTQUEUED),$$S^%ZTLOAD S ZTSTOP=1,FBQUIT=1 Q
I $E(IOST,1,2)="C-",FBPG S DIR(0)="E" D ^DIR K DIR I 'Y S FBQUIT=1 Q
I $E(IOST,1,2)="C-"!FBPG W @IOF
S FBPG=FBPG+1
W !,"FPPS Message Text Purge",?49,FBDTR,?72,"page ",FBPG
S FBI=0 F S FBI=$O(FBHDT(FBI)) Q:'FBI W !,FBHDT(FBI)
W !,FBDL
Q
;
;FBFHLP
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFBFHLP 3253 printed Nov 22, 2024@17:08:31 Page 2
FBFHLP ;WOIFO/SAB-FPPS MESSAGE PURGE ;9/9/2003
+1 ;;3.5;FEE BASIS;**61**;JAN 30, 1995
+2 ;
+3 WRITE !,"When an invoice is transmitted to FPPS via the HL7 package, a copy of the HL7"
+4 WRITE !,"message text is saved in the FPPS QUEUED INVOICES (#163.5) file."
+5 WRITE !!,"This option purges the message text for invoices transmitted prior to a"
+6 WRITE !,"specified date. Messages that have not been accepted by the VistA Interface"
+7 WRITE !,"Engine will not be purged unless there is a later message for the same"
+8 WRITE !,"invoice number that has been accepted.",!
+9 ;
+10 ; ask date
+11 SET DIR(0)="D^:"_$$FMADD^XLFDT(DT,-30)_":EX"
+12 SET DIR("A")="Purge text of messages transmitted prior to"
+13 SET DIR("B")=$$FMTE^XLFDT($$FMADD^XLFDT(DT,-60),2)
+14 SET DIR("?",1)="The purge date must be at least 30 days ago."
+15 SET DIR("?")="This response must be a date. Enter '^' to quit."
+16 DO ^DIR
KILL DIR
if $DATA(DIRUT)
GOTO EXIT
+17 SET FBDTP=Y
+18 ;
+19 ; ask device
+20 SET %ZIS="QM"
DO ^%ZIS
if POP
GOTO EXIT
+21 IF $DATA(IO("Q"))
Begin DoDot:1
+22 SET ZTRTN="QEN^FBFHLP"
SET ZTDESC="FB FPPS Message Text Purge"
+23 FOR FBX="FBDTP"
SET ZTSAVE(FBX)=""
+24 DO ^%ZTLOAD
DO HOME^%ZIS
KILL ZTSK
End DoDot:1
GOTO EXIT
+25 ;
QEN ; queued entry
+1 USE IO
+2 ;
PURGE ; Start Purge
+1 SET FBPG=0
DO NOW^%DTC
SET Y=%
DO DD^%DT
SET FBDTR=Y
+2 KILL FBDL
SET FBDL=""
SET $PIECE(FBDL,"-",IOM)=""
+3 ;
+4 ; build page header text for selection criteria
+5 SET FBHDT(1)=" For Messages Transmitted Prior To "_$$FMTE^XLFDT(FBDTP)
+6 ;
+7 DO HD
+8 ;
+9 SET FBQUIT=0
+10 ;
+11 ; initialize counters
+12 ; count of messages processed
SET FBC=0
+13 ; count of message text purged
SET FBC("PRG")=0
+14 ;
+15 WRITE !,"Starting Purge..."
+16 ;
+17 ; loop thru entries by MESSAGE DATE/TIME x-ref by date
+18 SET FBDT=0
+19 FOR
SET FBDT=$ORDER(^FBHL(163.5,"AMD",FBDT))
if FBDT=""!($PIECE(FBDT,".")>FBDTP)
QUIT
Begin DoDot:1
+20 SET FBDA=0
FOR
SET FBDA=$ORDER(^FBHL(163.5,"AMD",FBDT,FBDA))
if 'FBDA
QUIT
Begin DoDot:2
+21 ; increment count of records processed
SET FBC=FBC+1
+22 ; if tasked then check for stop request
+23 IF $DATA(ZTQUEUED)
IF FBC\1000
IF $$S^%ZTLOAD
SET ZTSTOP=1
SET FBQUIT=1
QUIT
+24 ; quit if no data in message text
if $ORDER(^FBHL(163.5,FBDA,1,0))'>0
QUIT
+25 ;
+26 ; check if OK to purge
+27 ; init as NO
SET FBPRG=0
+28 SET FBY=$GET(^FBHL(163.5,FBDA,0))
+29 ; was accepted
IF $PIECE(FBY,U,8)="A"
SET FBPRG=1
+30 IF 'FBPRG
Begin DoDot:3
+31 ; check if last entry for invoice was accepted
+32 NEW FBLDA
+33 SET FBLDA=$$LAST^FBFHLU($PIECE(FBY,U))
+34 IF FBLDA
IF FBLDA'=FBDA
IF $PIECE($GET(^FBHL(163.5,FBLDA,0)),U,8)="A"
SET FBPRG=1
End DoDot:3
+35 ;
+36 ; if OK then purge
+37 IF FBPRG
DO WP^DIE(163.5,FBDA_",",7,"","@")
SET FBC("PRG")=FBC("PRG")+1
End DoDot:2
if FBQUIT
QUIT
End DoDot:1
if FBQUIT
QUIT
+38 ;
+39 IF 'FBQUIT
WRITE !,"Purge Completed."
+40 ;
+41 WRITE !!,"The message text was purged from ",FBC("PRG")," entr",$SELECT(FBC("PRG")=1:"y",1:"ies")," in file 163.5."
+42 ;
+43 IF FBQUIT
WRITE !!,"REPORT STOPPED AT USER REQUEST"
+44 ;
+45 IF 'FBQUIT
IF $EXTRACT(IOST,1,2)="C-"
SET DIR(0)="E"
DO ^DIR
KILL DIR
+46 DO ^%ZISC
+47 ;
EXIT ;
+1 IF $DATA(ZTQUEUED)
SET ZTREQ="@"
+2 KILL FBC,FBDA,FBDL,FBDT,FBDTP,FBDTR,FBHDT,FBPG,FBPRG,FBQUIT,FBX,FBY
+3 KILL %,DIC,DIR,DIROUT,DIRUT,DTOUT,DUOUT,I,J,POP,X,Y
+4 QUIT
+5 ;
HD ; page header
+1 NEW FBI
+2 IF $DATA(ZTQUEUED)
IF $$S^%ZTLOAD
SET ZTSTOP=1
SET FBQUIT=1
QUIT
+3 IF $EXTRACT(IOST,1,2)="C-"
IF FBPG
SET DIR(0)="E"
DO ^DIR
KILL DIR
IF 'Y
SET FBQUIT=1
QUIT
+4 IF $EXTRACT(IOST,1,2)="C-"!FBPG
WRITE @IOF
+5 SET FBPG=FBPG+1
+6 WRITE !,"FPPS Message Text Purge",?49,FBDTR,?72,"page ",FBPG
+7 SET FBI=0
FOR
SET FBI=$ORDER(FBHDT(FBI))
if 'FBI
QUIT
WRITE !,FBHDT(FBI)
+8 WRITE !,FBDL
+9 QUIT
+10 ;
+11 ;FBFHLP
