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

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

initial load of WorldVistAEHR

File size: 5.2 KB
Line 
1IBCNSU1 ;ALB/AAS - INSURANCE UTILITY ROUTINE ;19-MAY-93
2 ;;2.0;INTEGRATED BILLING;**103,133,244,371**;21-MAR-94;Build 57
3 ;;Per VHA Directive 2004-038, this routine should not be modified.
4 ;
5RCHK(X) ; -- Input transform for different revenue codes in file 36
6 ; Returns 1 if passes, 0 if not pass input transform
7 ;
8 N I,Y,RC,NO S Y=0
9 I $G(X)="" G RCHKQ
10 F I=1:1 S RC=$P(X,",",I) Q:RC="" I $S(RC?3N:0,RC?5N:0,1:1) S NO=1 Q
11 I '$G(NO) S Y=1
12RCHKQ Q Y
13 ;
14BU(DFN,IBCPOL,IBYR,IBCDFN,IBASK) ; -- Return entry in Benefits Used file
15 ; Input: IBCDFN = pointer to patient file policy (2.312)
16 ; DFN = patient pointer
17 ; IBCPOL = pointer to health insurance policy file
18 ; IBYR = fileman internal date, year will be calendar
19 ; year of the internal date, Default = dt
20 ; IBASK = 1 if want to ask okay to add new entry
21 ;
22 ; Output: IBCBU = pointer to Benefits Used file if added,
23 ; else null
24 ;
25 N DIR,IBCBU
26 S IBCBU=""
27 I $G(IBCPOL)="" G BUQ
28 I $G(IBYR)="" S IBYR=DT
29 ;
30 ;if no match display message
31 I '$O(^IBA(355.4,"APY",IBCPOL,-IBYR,0)) W !!,"You cannot add a new Benefits Used BENEFIT YEAR",!! G BUQ
32 ;
33 ; -- try to find entry for policy for year
34 S IBCBU=$O(^IBA(355.5,"APPY",DFN,IBCPOL,-IBYR,IBCDFN,0))
35 ;
36 ; -- if no match add new entry
37 I 'IBCBU D
38 .I $G(IBASK) S DIR(0)="Y",DIR("A")="Are you adding a new Benefits Used YEAR",DIR("B")="YES" D ^DIR I $D(DIRUT)!(Y<1) S VALMQUIT="" Q
39 .S IBCBU=$$ADDBU(DFN,IBCPOL,IBYR,IBCDFN)
40 .Q
41 ;
42BUQ Q IBCBU
43 ;
44ADDBU(DFN,IBCPOL,IBYR,IBCDFN) ; -- add entries to Benefits Used file
45 ; Input: DFN = pointer to patient file
46 ; IBCDFN = point to patient policy (2.312)
47 ; IBCPOL = pointer to health insurance policy file
48 ; IBYR = fileman internal date, year will be calendar
49 ; year of the internal date, Default = dt
50 ;
51 ; Output: IBCBU = pointer to Benefits Used file if added,
52 ; else null
53 ;
54 N %DT,IBN1,IBCBU,DIC,DIE,DR,DA,DLAYGO,DO,DD
55 S IBCBU=""
56 I $G(IBCDFN)="" G ADDBUQ
57 I $G(IBCPOL)="" G ADDBUQ
58 I $G(IBYR)="" S IBYR=DT
59 K DD,DO,DIC,DR S DIC="^IBA(355.5,",DIC(0)="L",DLAYGO=355.5
60 ;
61 ;S IBYR=$E(IBYR,1,3)_"0000"
62 S X=IBCPOL D FILE^DICN I +Y<0 G ADDBUQ
63 S (IBCBU,DA)=+Y,DIE="^IBA(355.5,",DR=".02////"_DFN_";.03////"_IBYR_";.17////"_IBCDFN_";1.01///NOW;1.02////"_DUZ
64 D ^DIE K DIC,DIE,DA,DR
65ADDBUQ Q IBCBU
66 ;
67VET() ; -- Input Transform for sub-file 2.312, Name of Insured (#17)
68 ; Quit 1 to stuff Patient Name
69 ; Quit 0 to not stuff and allow editing
70 ;
71 N IBY,IB0 S IBY=0
72 G VETQ ; IB*2*371 - Allow edits to the patient name in all cases
73 S IB0=$G(^DPT(+$G(DA(1)),.312,+$G(DA),0))
74 I $P(IB0,"^",6)'="v" G VETQ
75 I +IB0'=+$$GETWNR^IBCNSMM1 S IBY=1 G VETQ
76 I '$D(X),$P(IB0,"^",17)="" S IBY=1
77VETQ Q IBY
78 ;
79 ;
80SUBID ; -- Input Transform for sub-file #2.312, Subscriber ID (#1)
81 N NODE,L,R,CHAR,X1
82 S CHAR="~`!@#$%^&*()_-+={}[]|\/?.,<>;:' """
83 S NODE=^DPT(DA(1),.312,DA,0)
84 ;
85 ; - if the policy is a Medicare policy, make sure the subscriber ID
86 ; is a valid HICN number
87 I $P(NODE,U)=+$$GETWNR^IBCNSMM1 S X=$TR(X,"-","") I '$$VALHIC^IBCNSMM(X) D HLP^IBCNSM32 K X Q
88 ;
89 S R=$P(NODE,U,16)
90 S L=$TR($P(^DPT(DA(1),0),U,9),CHAR,"")
91 S R=$S(R="01":1,R="":1,1:0)
92 ;
93 ; - if subscriber ID is the SSN of patient, remove all extraneous
94 ; characters
95 S X1=$TR(X,CHAR,"") I X1?9N,X1=L S X=X1
96 ;
97 K:$L(X)>20!($L(X)<3) X
98 Q
99 ;
100 ;
101HICN(DFN) ; -- return Patient's Medicare HIC number
102 ; Return HICN of Medicare WNR Part A or Part B
103 ; Return -1 if none exits
104 ;
105 N IBWNR,IBX,IBY,IB0
106 S IBWNR=$$GETWNR^IBCNSMM1,IBY=""
107 I '$O(^DPT(DFN,.312,"B",+IBWNR,0)) S IBY=-1 G HICNQ
108 S IBX=0 F S IBX=$O(^DPT(DFN,.312,"B",+IBWNR,IBX)) Q:('IBX)!(IBY]"") D
109 .S IB0=$G(^DPT(DFN,.312,IBX,0))
110 .I $P(IB0,U,18)'=$P(IBWNR,U,3),$P(IB0,U,18)'=$P(IBWNR,U,5) Q
111 .; 8/18/2003 - Added translation code to remove hyphens if they exist.
112 .I $P(IB0,U,2)]"" S IBY=$TR($P(IB0,U,2),"- ","")
113 S:IBY="" IBY=-1
114HICNQ Q IBY
115 ;
116CHKQUAL(DFN,IEN,QUAL,PC1,PC2) ; check for duplicate qualifiers for patient
117 ; and subscriber secondary ID's. All parameters required.
118 ;
119 ; DFN - internal patient#
120 ; IEN - ien of 2.312 subfile
121 ; QUAL - passed in response of the user (this is what is being
122 ; checked to see if it is valid)
123 ; PC1 - this is the piece# for one of the other qualifiers
124 ; PC2 - this is the piece# for one of the other qualifiers
125 ;
126 ; Function returns 1 if the entered qualifier is OK.
127 ; Function returns 0 if the entered qualifier is not OK. It is either
128 ; a duplicate or is otherwise invalid.
129 ;
130 NEW OK,DATA,INS
131 S OK=1
132 I $G(QUAL)="" G CHKQUALX
133 S DATA=$G(^DPT(+$G(DFN),.312,+$G(IEN),5))
134 I $G(QUAL)=$P(DATA,U,+$G(PC1)) D CQ1 G CHKQUALX ; duplicate
135 I $G(QUAL)=$P(DATA,U,+$G(PC2)) D CQ1 G CHKQUALX ; duplicate
136 ;
137 ; prevent the SSN qualifier when Medicare is the payer
138 S INS=+$G(^DPT(+$G(DFN),.312,+$G(IEN),0))
139 I $G(QUAL)="SY",$$MCRWNR^IBEFUNC(INS) D CQ2 G CHKQUALX
140 ;
141CHKQUALX ;
142 Q OK
143 ;
144CQ1 ; specific error message#1
145 S OK=0
146 D EN^DDIOL("You cannot use the same qualifier more than once.",,"!!")
147 D EN^DDIOL("",,"!!?5")
148 Q
149 ;
150CQ2 ; specific error message#2
151 S OK=0
152 D EN^DDIOL("You cannot use qualifier 'SY' for Medicare.",,"!!")
153 D EN^DDIOL("",,"!!?5")
154 Q
155 ;
Note: See TracBrowser for help on using the repository browser.