| 1 | FBFHLP ;WOIFO/SAB-FPPS MESSAGE PURGE ;9/9/2003
|
|---|
| 2 | ;;3.5;FEE BASIS;**61**;JAN 30, 1995
|
|---|
| 3 | ;
|
|---|
| 4 | W !,"When an invoice is transmitted to FPPS via the HL7 package, a copy of the HL7"
|
|---|
| 5 | W !,"message text is saved in the FPPS QUEUED INVOICES (#163.5) file."
|
|---|
| 6 | W !!,"This option purges the message text for invoices transmitted prior to a"
|
|---|
| 7 | W !,"specified date. Messages that have not been accepted by the VistA Interface"
|
|---|
| 8 | W !,"Engine will not be purged unless there is a later message for the same"
|
|---|
| 9 | W !,"invoice number that has been accepted.",!
|
|---|
| 10 | ;
|
|---|
| 11 | ; ask date
|
|---|
| 12 | S DIR(0)="D^:"_$$FMADD^XLFDT(DT,-30)_":EX"
|
|---|
| 13 | S DIR("A")="Purge text of messages transmitted prior to"
|
|---|
| 14 | S DIR("B")=$$FMTE^XLFDT($$FMADD^XLFDT(DT,-60),2)
|
|---|
| 15 | S DIR("?",1)="The purge date must be at least 30 days ago."
|
|---|
| 16 | S DIR("?")="This response must be a date. Enter '^' to quit."
|
|---|
| 17 | D ^DIR K DIR G:$D(DIRUT) EXIT
|
|---|
| 18 | S FBDTP=Y
|
|---|
| 19 | ;
|
|---|
| 20 | ; ask device
|
|---|
| 21 | S %ZIS="QM" D ^%ZIS G:POP EXIT
|
|---|
| 22 | I $D(IO("Q")) D G EXIT
|
|---|
| 23 | . S ZTRTN="QEN^FBFHLP",ZTDESC="FB FPPS Message Text Purge"
|
|---|
| 24 | . F FBX="FBDTP" S ZTSAVE(FBX)=""
|
|---|
| 25 | . D ^%ZTLOAD,HOME^%ZIS K ZTSK
|
|---|
| 26 | ;
|
|---|
| 27 | QEN ; queued entry
|
|---|
| 28 | U IO
|
|---|
| 29 | ;
|
|---|
| 30 | PURGE ; Start Purge
|
|---|
| 31 | S FBPG=0 D NOW^%DTC S Y=% D DD^%DT S FBDTR=Y
|
|---|
| 32 | K FBDL S FBDL="",$P(FBDL,"-",IOM)=""
|
|---|
| 33 | ;
|
|---|
| 34 | ; build page header text for selection criteria
|
|---|
| 35 | S FBHDT(1)=" For Messages Transmitted Prior To "_$$FMTE^XLFDT(FBDTP)
|
|---|
| 36 | ;
|
|---|
| 37 | D HD
|
|---|
| 38 | ;
|
|---|
| 39 | S FBQUIT=0
|
|---|
| 40 | ;
|
|---|
| 41 | ; initialize counters
|
|---|
| 42 | S FBC=0 ; count of messages processed
|
|---|
| 43 | S FBC("PRG")=0 ; count of message text purged
|
|---|
| 44 | ;
|
|---|
| 45 | W !,"Starting Purge..."
|
|---|
| 46 | ;
|
|---|
| 47 | ; loop thru entries by MESSAGE DATE/TIME x-ref by date
|
|---|
| 48 | S FBDT=0
|
|---|
| 49 | F S FBDT=$O(^FBHL(163.5,"AMD",FBDT)) Q:FBDT=""!($P(FBDT,".")>FBDTP) D Q:FBQUIT
|
|---|
| 50 | . S FBDA=0 F S FBDA=$O(^FBHL(163.5,"AMD",FBDT,FBDA)) Q:'FBDA D Q:FBQUIT
|
|---|
| 51 | . . S FBC=FBC+1 ; increment count of records processed
|
|---|
| 52 | . . ; if tasked then check for stop request
|
|---|
| 53 | . . I $D(ZTQUEUED),FBC\1000,$$S^%ZTLOAD S ZTSTOP=1,FBQUIT=1 Q
|
|---|
| 54 | . . Q:$O(^FBHL(163.5,FBDA,1,0))'>0 ; quit if no data in message text
|
|---|
| 55 | . . ;
|
|---|
| 56 | . . ; check if OK to purge
|
|---|
| 57 | . . S FBPRG=0 ; init as NO
|
|---|
| 58 | . . S FBY=$G(^FBHL(163.5,FBDA,0))
|
|---|
| 59 | . . I $P(FBY,U,8)="A" S FBPRG=1 ; was accepted
|
|---|
| 60 | . . I 'FBPRG D
|
|---|
| 61 | . . . ; check if last entry for invoice was accepted
|
|---|
| 62 | . . . N FBLDA
|
|---|
| 63 | . . . S FBLDA=$$LAST^FBFHLU($P(FBY,U))
|
|---|
| 64 | . . . I FBLDA,FBLDA'=FBDA,$P($G(^FBHL(163.5,FBLDA,0)),U,8)="A" S FBPRG=1
|
|---|
| 65 | . . ;
|
|---|
| 66 | . . ; if OK then purge
|
|---|
| 67 | . . I FBPRG D WP^DIE(163.5,FBDA_",",7,"","@") S FBC("PRG")=FBC("PRG")+1
|
|---|
| 68 | ;
|
|---|
| 69 | I 'FBQUIT W !,"Purge Completed."
|
|---|
| 70 | ;
|
|---|
| 71 | W !!,"The message text was purged from ",FBC("PRG")," entr",$S(FBC("PRG")=1:"y",1:"ies")," in file 163.5."
|
|---|
| 72 | ;
|
|---|
| 73 | I FBQUIT W !!,"REPORT STOPPED AT USER REQUEST"
|
|---|
| 74 | ;
|
|---|
| 75 | I 'FBQUIT,$E(IOST,1,2)="C-" S DIR(0)="E" D ^DIR K DIR
|
|---|
| 76 | D ^%ZISC
|
|---|
| 77 | ;
|
|---|
| 78 | EXIT ;
|
|---|
| 79 | I $D(ZTQUEUED) S ZTREQ="@"
|
|---|
| 80 | K FBC,FBDA,FBDL,FBDT,FBDTP,FBDTR,FBHDT,FBPG,FBPRG,FBQUIT,FBX,FBY
|
|---|
| 81 | K %,DIC,DIR,DIROUT,DIRUT,DTOUT,DUOUT,I,J,POP,X,Y
|
|---|
| 82 | Q
|
|---|
| 83 | ;
|
|---|
| 84 | HD ; page header
|
|---|
| 85 | N FBI
|
|---|
| 86 | I $D(ZTQUEUED),$$S^%ZTLOAD S ZTSTOP=1,FBQUIT=1 Q
|
|---|
| 87 | I $E(IOST,1,2)="C-",FBPG S DIR(0)="E" D ^DIR K DIR I 'Y S FBQUIT=1 Q
|
|---|
| 88 | I $E(IOST,1,2)="C-"!FBPG W @IOF
|
|---|
| 89 | S FBPG=FBPG+1
|
|---|
| 90 | W !,"FPPS Message Text Purge",?49,FBDTR,?72,"page ",FBPG
|
|---|
| 91 | S FBI=0 F S FBI=$O(FBHDT(FBI)) Q:'FBI W !,FBHDT(FBI)
|
|---|
| 92 | W !,FBDL
|
|---|
| 93 | Q
|
|---|
| 94 | ;
|
|---|
| 95 | ;FBFHLP
|
|---|
