source: WorldVistAEHR/trunk/r/FEE_BASIS-FB/FBFHLP.m@ 1520

Last change on this file since 1520 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR

File size: 3.1 KB
Line 
1FBFHLP ;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 ;
27QEN ; queued entry
28 U IO
29 ;
30PURGE ; 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 ;
78EXIT ;
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 ;
84HD ; 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
Note: See TracBrowser for help on using the repository browser.