source: WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCNEDE.m@ 1766

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

initial load of WorldVistAEHR

File size: 5.3 KB
Line 
1IBCNEDE ;DAOU/DAC - IIV DATA EXTRACTS ;04-JUN-2002
2 ;;2.0;INTEGRATED BILLING;**184,271,300**;21-MAR-94
3 ;;Per VHA Directive 10-93-142, this routine should not be modified.
4 ;
5 ;**Program Description**
6 ; This program is the main driver for all data extracts associated
7 ; with the Insurance Identification and Verification interface.
8 ; This program will run each extract in the specified order, which
9 ; populates the IIV Transmission File (sometimes it creates/updates
10 ; an entry in the insurance buffer as well). It then begins to
11 ; process the inquiries in the IIV Transmission File.
12 ; 08-08-2002
13 ; As this program will run in the background the variable ZTSTOP
14 ; can be returned from any of the extracts should a TaskMan stop
15 ; request occur. Also, clear out the task record before exiting.
16 ; 08-09-2002
17 ; Added check for "~NO PAYER", if it does not exist, build it
18 ;
19 Q
20 ;
21EN ; Entry Point
22 ; Prevent simultaneous runs
23 ; Set error trap to ensure that lock is released
24 N $ES,$ET
25 S $ET="D ER^IBCNEDE"
26 ; Check lock
27 L +^TMP("IBCNEDE"):1 I '$T D G ENX
28 . I '$D(ZTSK) W !!,"The IIV Nightly Task is already running, please retry later." D PAUSE^VALM1
29 ; Reset reg ack flag
30 S $P(^IBE(350.9,1,51),U,22)=""
31 ; If "~NO PAYER" is not a valid Payer File entry, rebuild it from
32 ; the existing utility
33 I '$$FIND1^DIC(365.12,,"X","~NO PAYER") D PAYR^IBCNEUT2
34 ;
35 ; Confirm that all necessary tables have been loaded
36 ; before the extract is run
37 I '$$TBLCHK() G EN1
38 ;
39 D AMCHECK^IBCNEUT6 ; ensure Auto Match entries are valid
40 ;
41 ; Run All 4 extracts and launch IBCNEDEP(Inquiries)
42 D EN^IBCNEDE1 ; Insurance Buffer Extract
43 ; Check to see if background process has been stopped, if so quit.
44 I $G(ZTSTOP) G ENX
45 D EN^IBCNEDE2 ; Pre Reg Extract
46 ; Check to see if background process has been stopped, if so quit.
47 I $G(ZTSTOP) G ENX
48 D EN^IBCNEDE3 ; Non Verified Extract
49 ; Check to see if background process has been stopped, if so quit.
50 I $G(ZTSTOP) G ENX
51 D EN^IBCNEDE4 ; No Insurance Extract
52 ; Check to see if background process has been stopped, if so quit.
53EN1 I $G(ZTSTOP) G ENX
54 ; Send enrollment message
55 D ^IBCNEHLM
56 I $G(ZTSTOP) G ENX
57 I '$G(QFL) D
58 . ; Wait for 'AA' acknowledgement
59 . D WAIT Q:'+QFL
60 . KILL QFL
61 . ;
62 . D ^IBCNEDEP ; Inquiries Processing
63 ;
64 ; Check to see if background process has been stopped, if so quit.
65 I $G(ZTSTOP) G ENX
66 D MMQ ; Queue the Daily MailMan message
67 ; Send MailMan message if first of month to report on records
68 ; eligible to be purged
69 I +$E($P($$NOW^XLFDT(),"."),6,7)=1 D MMPURGE^IBCNEKI2
70 ;
71ENX ; Purge task record - if queued
72 I $D(ZTQUEUED) S ZTREQ="@"
73 L -^TMP("IBCNEDE")
74 Q
75 ;
76TBLCHK() ;
77 ; Confirm that at least one IIV payer and that all X12 tables
78 ; have been loaded
79 N PAY,PAYIEN,PAYOK,TBLOK,II
80 S (PAY,PAYIEN,PAYOK)="",TBLOK=1
81 F S PAY=$O(^IBE(365.12,"B",PAY)) Q:PAY=""!PAYOK I PAY'="~NO PAYER" D
82 . F S PAYIEN=$O(^IBE(365.12,"B",PAY,PAYIEN)) Q:PAYIEN=""!PAYOK D
83 .. I $$PYRAPP^IBCNEUT5("IIV",PAYIEN) S PAYOK=1 Q
84 I PAYOK D
85 . F II=11:1:18,21 I $O(^IBE(II*.001+365,"B",""))="" S TBLOK="" Q
86 Q PAYOK&TBLOK
87 ;
88WAIT ; Wait for acknowledgement comes back from EC
89 ; Hang for 60 seconds and check status again
90 ; Try 360 times for a total of 21600 seconds (6 hours)
91 S QFL=0,CT=0
92 F D Q:QFL'=""!(CT>360)
93 . S QFL=$$GET1^DIQ(350.9,"1,",51.22,"I")
94 . Q:QFL'=""
95 . HANG 60 S CT=CT+1
96 KILL CT
97 Q
98 ;
99FRESHDT(EXT,STALEDYS) ; Calculate Freshness
100 ; Ext - ien of extract for future purposes
101 ; Staledys - # of days in the past in which an insurance verification
102 ; is considered still valid/current
103 N STALEDT
104 S STALEDT=$$FMADD^XLFDT(DT,-STALEDYS)
105 Q STALEDT
106 ;
107 ; ---------------------------------------------------
108MMQ ; This procedure is responsible for scheduling the creation and
109 ; sending of the daily MailMan statistical message if the site has
110 ; defined this appropriately in the IIV site parameters.
111 ;
112 NEW IIV,CURRTIME,MTIME,MSG,Y,MGRP
113 NEW ZTRTN,ZTDESC,ZTDTH,ZTIO,ZTUCI,ZTCPU,ZTPRI,ZTSAVE,ZTKIL,ZTSYNC,ZTSK
114 ;
115 S IIV=$G(^IBE(350.9,1,51))
116 I '$P(IIV,U,2) G MMQX ; site does not want daily messages
117 I '$P(IIV,U,3) G MMQX ; MM message time is not defined
118 I '$P(IIV,U,4) G MMQX ; Mail Group is not defined
119 ;
120 S CURRTIME=$P($H,",",2) ; current $H time
121 S MTIME=DT_"."_$P(IIV,U,3) ; build a FileMan date/time
122 S MTIME=$$FMTH^XLFDT(MTIME) ; convert to $H format
123 S MTIME=$P(MTIME,",",2) ; $H time of MM message
124 ;
125 ; If the current time is after the MailMan message time, then
126 ; schedule the MM message for tomorrow at that time.
127 I CURRTIME>MTIME S ZTDTH=($H+1)_","_MTIME
128 ;
129 ; Otherwise, schedule it for later today
130 E S ZTDTH=+$H_","_MTIME
131 ;
132 ; Set up the other TaskManager variables
133 S ZTRTN="MAILMSG^IBCNERP7"
134 S ZTDESC="IIV Daily Statistics E-Mail"
135 S ZTIO=""
136 D ^%ZTLOAD ; Call TaskManager
137 I $G(ZTSK) G MMQX ; Task# is OK so get out
138 ;
139 ; Send a MailMan message if this Task could not get scheduled
140 S MSG(1)="TaskManager could not schedule the daily IIV MailMan message"
141 S MSG(2)="at the specified time of "_$E($P(IIV,U,3),1,2)_":"_$E($P(IIV,U,3),3,4)_"."
142 S MSG(3)="This is defined in the IIV Site Parameters option."
143 ; Set to IB site parameter MAILGROUP
144 S MGRP=$$MGRP^IBCNEUT5()
145 D MSG^IBCNEUT5(MGRP,"IIV Statistical Message Not Sent","MSG(")
146 ;
147MMQX ;
148 Q
149 ;
150ER ; Unlock the IIV Nightly Task and return to log error
151 L -^TMP("IBCNEDE")
152 D ^%ZTER
153 D UNWIND^%ZTER
154 Q
155 ;
Note: See TracBrowser for help on using the repository browser.