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

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

initial load of WorldVistAEHR

File size: 5.5 KB
Line 
1IBCNEDE1 ;DAOU/DAC - IIV INSURANCE BUFFER EXTRACT ;04-JUN-2002
2 ;;2.0;INTEGRATED BILLING;**184,271**;21-MAR-94
3 ;;Per VHA Directive 10-93-142, this routine should not be modified.
4 ;
5 ;**Program Description**
6 ; This routine loops through the insurance buffer and
7 ; creates IIV transaction queue entries when approriate.
8 ; Periodically check for stop request for background task
9 ;
10 Q ; no direct calls allowed
11 ;
12EN ; Loop through designated cross-references for updates
13 ; Insurance Buffer Extract
14 ;
15 N TODAYSDT,FRESHDAY,LOOPDT,IEN,OVRFRESH,FRESHDT
16 N DFN,PDOD,SRVICEDT,VERIFDDT,PAYERSTR,PAYERID,SYMBOL,PAYRNAME
17 N PIEN,PNIEN,TQIEN,TRIEN,TRSRVCDT,TQCRTDT,TRANSNO,DISYS
18 N ORIGINSR,ORGRPSTR,ORGRPNUM,ORGRPNAM,ORGSUBCR
19 N MAXCNT,CNT,ISYMBOLM,DATA1,DATA2,ORIG,SETSTR,ISYMBOL,IBCNETOT
20 N SIDDATA,SID,SIDACT,BSID,FDA,PASSBUF,SCNT5,SIDCNT,SIDARRAY
21 N TQDT,TQIENS,TQOK,STATIEN
22 ;
23 S SETSTR=$$SETTINGS^IBCNEDE7(1) ; Returns buffer extract settings
24 I 'SETSTR Q ; Quit if extract is not active
25 S MAXCNT=$P(SETSTR,U,4) ; Max # TQ entries that may be created
26 S:MAXCNT="" MAXCNT=9999999999
27 ;
28 S FRESHDAY=$P($G(^IBE(350.9,1,51)),U,1) ; System freshness days
29 ;
30 S CNT=0 ; Initialize count of TQ entries created
31 S IBCNETOT=0 ; Initialize count for periodic TaskMan check
32 ;
33 S LOOPDT="" ; Date used to loop throught the IB global
34 F S LOOPDT=$O(^IBA(355.33,"AEST","E",LOOPDT)) Q:LOOPDT=""!(CNT=MAXCNT) D Q:$G(ZTSTOP)
35 . S IEN=""
36 . F S IEN=$O(^IBA(355.33,"AEST","E",LOOPDT,IEN)) Q:IEN=""!(CNT=MAXCNT) D Q:$G(ZTSTOP)
37 .. ; Update count for periodic check
38 .. S IBCNETOT=IBCNETOT+1
39 .. ; Check for request to stop background job, periodically
40 .. I $D(ZTQUEUED),IBCNETOT#100=0,$$S^%ZTLOAD() S ZTSTOP=1 Q
41 .. ;
42 .. ; Get symbol, if symbol'=" " OR "!" then quit
43 .. S ISYMBOL=$$SYMBOL^IBCNBLL(IEN) ; Insurance buffer symbol
44 .. I (ISYMBOL'=" ")&(ISYMBOL'="!") Q
45 .. ;
46 .. ; Get the IIV STATUS IEN and quit for response related errors
47 .. S STATIEN=+$P($G(^IBA(355.33,IEN,0)),U,12)
48 .. I ",11,12,15,"[(","_STATIEN_",") Q ; Prevent update for response errors
49 .. ;
50 .. S OVRFRESH=$P($G(^IBA(355.33,IEN,0)),U,13) ; Freshness OvrRd flag
51 .. S DFN=$P($G(^IBA(355.33,IEN,60)),U,1) ; Patient DFN
52 .. Q:DFN=""
53 .. I $P($G(^DPT(DFN,0)),U,21) Q ; Exclude if test patient
54 .. ;
55 .. S PDOD=$P($G(^DPT(DFN,.35)),U,1)\1 ; Patient's date of death
56 .. S SRVICEDT=DT I PDOD S SRVICEDT=PDOD ; Service Date
57 .. S FRESHDT=$$FMADD^XLFDT(SRVICEDT,-FRESHDAY)
58 .. S PAYERSTR=$$INSERROR^IBCNEUT3("B",IEN) ; Payer String
59 .. S PAYERID=$P(PAYERSTR,U,3),PIEN=$P(PAYERSTR,U,2) ; Payer ID
60 .. S SYMBOL=+PAYERSTR ; Payer Symbol
61 .. ;
62 .. ; If payer symbol is returned set symbol in Ins. Buffer and quit
63 .. I SYMBOL D BUFF^IBCNEUT2(IEN,SYMBOL) Q
64 .. ;
65 .. D CLEAR^IBCNEUT4(IEN) ; remove any existing symbol
66 .. ;
67 .. ; If no payer ID or no payer IEN is returned quit
68 .. I (PAYERID="")!('PIEN) Q
69 .. ;
70 .. ; Update service date and freshness date based on payer's allowed
71 .. ; date range
72 .. D UPDDTS^IBCNEDE6(PIEN,.SRVICEDT,.FRESHDT)
73 .. ;
74 .. ; Update service dates for inquiries to be transmitted
75 .. D TQUPDSV^IBCNEUT5(DFN,PIEN,SRVICEDT)
76 .. ;
77 .. ; If freshness overide flag is set, file to TQ and quit
78 .. I OVRFRESH=1 D Q
79 ... NEW DIE,X,Y,DISYS
80 ... S FDA(355.33,IEN_",",.13)="" D FILE^DIE("","FDA") K FDA
81 ... D TQ
82 .. ;
83 .. ; If ADDTQ^IBCNEUT5 is 1 set TQ, otherwise stop processing that entry
84 .. I '$$ADDTQ^IBCNEUT5(DFN,PIEN,SRVICEDT,FRESHDAY) Q
85 .. ; Check the existing TQ entries to confirm that this buffer IEN is
86 .. ; not included
87 .. S (TQDT,TQIENS)="",TQOK=1
88 .. F S TQDT=$O(^IBCN(365.1,"AD",DFN,PIEN,TQDT)) Q:'TQDT!'TQOK D
89 ... F S TQIENS=$O(^IBCN(365.1,"AD",DFN,PIEN,TQDT,TQIENS)) Q:'TQIENS!'TQOK D
90 .... I $P($G(^IBCN(365.1,TQIENS,0)),U,5)=IEN S TQOK=0 Q
91 .. I TQOK D TQ
92 Q
93TQ ; Determine how many entries to create in the TQ file and set entries
94 ;
95 S BSID=$P($G(^IBA(355.33,IEN,60)),U,4) ; Subscriber ID from buffer
96 K SIDARRAY
97 S SIDDATA=$$SIDCHK^IBCNEDE5(PIEN,DFN,BSID,.SIDARRAY,FRESHDT) ;determine rules to follow
98 S SIDACT=$P(SIDDATA,U,1)
99 S SIDCNT=$P(SIDDATA,U,2) ;Pull cnt of SIDs - shd be 1
100 ;
101 I SIDACT=3 D BUFF^IBCNEUT2(IEN,18) Q ; update buffer w/ bang & quit
102 S SCNT5=$S(SIDACT=5:1,1:0)
103 I CNT+SCNT5+SIDCNT>MAXCNT Q
104 S SID=""
105 F S SID=$O(SIDARRAY(SID)) Q:SID="" D
106 . I SIDACT=5 D SET(IEN,OVRFRESH,0,$P(SID,"_")) Q ; set TQ w/o 'Pass Buffer' flag
107 . D SET(IEN,OVRFRESH,1,$P(SID,"_")) ; set TQ w/ 'Pass Buffer' flag
108 I SIDACT=4!(SIDACT=5) D SET(IEN,OVRFRESH,1,"") ; set TQ w/ 'Pass Buffer' flag
109 Q
110 ;
111RET ; Record Retrieval - Insurance Buffer
112 ;
113 S ORIGINSR=$P($G(^IBA(355.33,IEN,20)),U,1) ;Original ins. co.
114 S ORGRPSTR=$G(^IBA(355.33,IEN,40)) ; Original group string
115 S ORGRPNUM=$P(ORGRPSTR,U,3) ;Original group number
116 S ORGRPNAM=$P(ORGRPSTR,U,2) ;Original group name
117 S ORGSUBCR=$P($G(^IBA(355.33,IEN,60)),U,4) ; Original subscriber
118 ;
119 Q
120 ;
121SET(BUFFIEN,OVRFRESH,PASSBUF,SID1) ; Set data and check if set already
122 D RET
123 ;
124 ; The hard coded '1' in the 3rd piece of DATA1 sets the Transmission
125 ; status of file 365.1 to "Ready to Transmit"
126 S DATA1=DFN_U_PIEN_U_1_U_$G(BUFFIEN)_U_SID1_U_FRESHDT_U_PASSBUF ; SETTQ parameter 1
127 ;
128 ;The hardcoded '1' in the 1st piece of DATA2 is the value to tell
129 ; the file 365.1 that it is the buffer extract.
130 S DATA2=1_U_"V"_U_SRVICEDT_U_"" ; SETTQ parameter 2
131 ;
132 S ORIG=ORIGINSR_U_ORGRPNUM_U_ORGRPNAM_U_ORGSUBCR ; SETTQ parameter 3
133 S TQIEN=$$SETTQ^IBCNEDE7(DATA1,DATA2,ORIG,$G(OVRFRESH)) ; File TQ entry
134 I TQIEN'="" S CNT=CNT+1 ; If filed increment count
135 ;
136 Q
Note: See TracBrowser for help on using the repository browser.