source: WorldVistAEHR/trunk/r/ACCOUNTS_RECEIVABLE-PRCA-PRY-RC/RCXVUTIL.m@ 1608

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

initial load of WorldVistAEHR
File size: 4.2 KB
RevLine 
[613]1RCXVUTIL ;DAOU/ALA-AR Data Extract Utility Program ;29-JUL-03
2 ;;4.5;Accounts Receivable;**201**;Mar 20, 1995
3 ;
4SPAR(REF) ; HL7 Segment Parsing
5 ; Input Parameter
6 ; REF = Array or global reference
7 ; Global or array should end with ')'
8 ; e.g. ^TMP($J,"XXX",#)
9 ;
10 ; Output Parameters
11 ; RCXSEG(#) = Each sequence of the segment in the array
12 ;
13 NEW ISCT,II,IJ,IK,ISDATA,ISPEC,ISBEG,ISEND,IS,LSDATA,IM,NPC
14 ;
15 S ISCT="",II=0,IS=0
16 F S ISCT=$O(@REF@(ISCT)) Q:ISCT="" D
17 . S IS=IS+1
18 . S ISDATA(IS)=$G(@REF@(ISCT))
19 . I $O(@REF@(ISCT))="" S ISDATA(IS)=ISDATA(IS)_HLFS
20 . S ISPEC(IS)=$L(ISDATA(IS),HLFS)
21 ;
22 S IM=0,LSDATA=""
23LP S IM=IM+1 Q:IM>IS
24 S LSDATA=LSDATA_ISDATA(IM),NPC=ISPEC(IM)
25 F IJ=1:1:NPC-1 D
26 . S II=II+1,RCXSEG(II)=$$CLNSTR($P(LSDATA,HLFS,IJ),HL("ECH"),$E(HL("ECH")))
27 S LSDATA=$P(LSDATA,HLFS,NPC)
28 G LP
29 ;
30CLNSTR(STRING,CHARS,SUBSEP) ; Remove extra trailing components and subcomponents
31 ; in the HL7 segment
32 ;
33 ; Input parameters
34 ; STRING - The data value to be 'cleansed'
35 ; CHARS - The component character to be removed
36 ; SUSEP - The subcomponent character to be removed
37 ;
38 N RTSTRING,NUMPEC,PEC
39 S RTSTRING=$$RTRIMCH(STRING,CHARS)
40 ; Now we have string without trailing chars, remove from subs
41 S NUMPEC=$L(RTSTRING,SUBSEP)
42 F PEC=1:1:NUMPEC S $P(RTSTRING,SUBSEP,PEC)=$$RTRIMCH($P(RTSTRING,SUBSEP,PEC),CHARS)
43 Q RTSTRING
44 ;
45RTRIMCH(STR,CHRS) ; Remove the trailing chars from string
46 N R,L
47 S L=1,CHRS=$G(CHRS," ")
48 F R=$L(STR):-1:1 Q:CHRS'[$E(STR,R)
49 I L=R,(CHRS[$E(STR)) S STR=""
50 Q $E(STR,L,R)
51 ;
52DFP(IBN) ; Date of First Payment Function
53 ; Input Parameter
54 ; IBN = IEN of the bill number from file 430
55 ;
56 N VAL,IBPAY,IBT,IBT0,IBT1
57 S VAL=0
58 ; No payments made.
59 I '$P($G(^PRCA(430,IBN,7)),U,7) Q ""
60 S (IBPAY,IBT)=0 F S IBT=$O(^PRCA(433,"C",IBN,IBT)) Q:'IBT D Q:IBPAY
61 . S IBT0=$G(^PRCA(433,IBT,0)),IBT1=$G(^(1))
62 . I $P(IBT0,U,4)'=2 Q ; Not complete.
63 . I $P(IBT1,U,2)'=2,$P(IBT1,U,2)'=34 Q ; Not a payment.
64 . S X=$S(+IBT1:+IBT1,1:$P(IBT1,U,9)\1),$P(VAL,U,4)=X,IBPAY=1
65 Q $P(VAL,U,4)
66 ;
67DATE(X) ; Pass in External Date and get FileMan date format
68 ;
69 ; Input Parameter
70 ; X = a date in any regular date format
71 ; Output Parameter
72 ; Y = a date in FileMan format
73 ; Parameters
74 ; DIC(0) = FileMan date parameter
75 ;
76 I X["@" S %DT="T"
77 I $G(DIC(0))="" S DIC(0)=""
78 D ^%DT
79 I Y=-1 S Y=""
80 K DIC,%DT
81 Q Y
82 ;
83TASK(RCDSC) ; Check on Task Status
84 ;
85 ; Input Parameter
86 ; RCDSC = Task Description
87 ;
88 NEW RTASKS,RTSK,ZTSK,ZTKEY
89 D DESC^%ZTLOAD(RCDSC,"RTASKS")
90 S RTSK=""
91 F S RTSK=$O(RTASKS(RTSK)) Q:RTSK="" D
92 . S ZTSK=RTSK D STAT^%ZTLOAD
93 ;
94 K RTASKS
95 I $G(ZTSK(2))="Inactive: Finished" Q 0
96 I $G(ZTSK(2))="Inactive: Interrupted" Q 0
97 I $G(ZTSK(2))="Active: Pending" Q 1
98 Q 0
99 ;
100SAT(RDATE) ; Find the next Saturday date from the passed in date
101 NEW CDOW,FDATE,NDAYS
102 S CDOW=$$DOW^XLFDT(RDATE,1),NDAYS=6-CDOW
103 I NDAYS=0 S NDAYS=7
104 S FDATE=$$FMADD^XLFDT(RDATE,NDAYS)
105 Q FDATE
106 ;
107CARE(RCXVIEN) ; Is bill VA or NON-VA care?
108 ;
109 ; Input parameter
110 ; RCXVIEN = Bill ien
111 ;
112 ; Output parameter
113 ; RCXVCFL = Care Flag
114 ; 0 = Non-VA Care
115 ; 1 = VA Care
116 ;
117 NEW RCXVCARE,RCXVRATE,RCXVODT,RPTF
118 S RCXVCFL=0
119 ;
120 ; If not Reimbursable Insurance, it's VA CARE
121 S RCXVRATE=$O(^DGCR(399.3,"B","REIMBURSABLE INS.",""))
122 I $P($G(^DGCR(399,RCXVIEN,0)),U,7)'=RCXVRATE S RCXVCFL=1 Q
123 ;
124 ; If prescription, it's VA Care
125 I $D(^IBA(362.4,"C",RCXVIEN))>0 S RCXVCFL=1 Q
126 ;
127 I $P($G(^DGCR(399,RCXVIEN,0)),U,16)'="" Q
128 ;
129 S RCXVCARE=$G(^DGCR(399,RCXVIEN,"U2"))
130 I $P(RCXVCARE,U,10)'="" Q
131 I $P(RCXVCARE,U,11)'="" Q
132 I $P(RCXVCARE,U,12)'="" Q
133 I $P(RCXVCARE,U,13)'="" Q
134 I $P(RCXVCARE,U,14)'="" Q
135 I $P(RCXVCARE,U,15)'="" Q
136 ;
137 ; Check inpatient
138 I $P($G(^DGCR(399,RCXVIEN,0)),U,5)<3 D Q:RCXVCFL
139 . S RPTF=$P($G(^DGCR(399,RCXVIEN,0)),U,8)
140 . I RPTF="" Q
141 . I $P($G(^DGPT(RPTF,0)),U,4)=1 Q
142 . S RCXVCFL=1
143 ;
144 ; Check outpatient encounter
145 NEW IBCBK,IBVAL
146 S IBCBK="I '$P(Y0,U,6) S ^TMP(""RCXVOE"",$J,+$P(Y0,U,8),Y)=Y0"
147 S IBVAL("DFN")=$P(^DGCR(399,RCXVIEN,0),U,2)
148 S RCXVODT=0 K ^TMP("RCXVOE",$J)
149 F S RCXVODT=$O(^DGCR(399,RCXVIEN,"OP",RCXVODT)) Q:'RCXVODT D
150 . S IBVAL("BDT")=RCXVODT,IBVAL("EDT")=RCXVODT+.9999
151 . D SCAN^IBSDU("PATIENT/DATE",.IBVAL,"",IBCBK,1)
152 I $O(^TMP("RCXVOE",$J,""))'="" S RCXVCFL=1 K ^TMP("RCXVOE",$J) Q
153 Q
Note: See TracBrowser for help on using the repository browser.