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

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

revised back to 6/30/08 version

File size: 4.0 KB
Line 
1IBCNSU1 ;ALB/AAS - INSURANCE UTILITY ROUTINE ; 19-MAY-93
2 ;;2.0;INTEGRATED BILLING;**103,133,244**;21-MAR-94
3 ;;Per VHA Directive 10-93-142, 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 S IB0=$G(^DPT(+$G(DA(1)),.312,+$G(DA),0))
73 I $P(IB0,"^",6)'="v" G VETQ
74 I +IB0'=+$$GETWNR^IBCNSMM1 S IBY=1 G VETQ
75 I '$D(X),$P(IB0,"^",17)="" S IBY=1
76VETQ Q IBY
77 ;
78 ;
79SUBID ; -- Input Transform for sub-file #2.312, Subscriber ID (#1)
80 N NODE,L,R,CHAR,X1
81 S CHAR="~`!@#$%^&*()_-+={}[]|\/?.,<>;:' """
82 S NODE=^DPT(DA(1),.312,DA,0)
83 ;
84 ; - if the policy is a Medicare policy, make sure the subscriber ID
85 ; is a valid HICN number
86 I $P(NODE,U)=+$$GETWNR^IBCNSMM1 S X=$TR(X,"-","") I '$$VALHIC^IBCNSMM(X) D HLP^IBCNSM32 K X Q
87 ;
88 S R=$P(NODE,U,16)
89 S L=$TR($P(^DPT(DA(1),0),U,9),CHAR,"")
90 S R=$S(R="01":1,R="":1,1:0)
91 ;
92 ; - if subscriber ID is the SSN of patient, remove all extraneous
93 ; characters
94 S X1=$TR(X,CHAR,"") I X1?9N,X1=L S X=X1
95 ;
96 ; - if "SS" is entered, and the policy belongs to the patient,
97 ; convert that string to the patient's SSN
98 I R=1,X="SS" W " ",L S X=L
99 ;
100 K:$L(X)>20!($L(X)<3) X
101 Q
102 ;
103 ;
104HICN(DFN) ; -- return Patient's Medicare HIC number
105 ; Return HICN of Medicare WNR Part A or Part B
106 ; Return -1 if none exits
107 ;
108 N IBWNR,IBX,IBY,IB0
109 S IBWNR=$$GETWNR^IBCNSMM1,IBY=""
110 I '$O(^DPT(DFN,.312,"B",+IBWNR,0)) S IBY=-1 G HICNQ
111 S IBX=0 F S IBX=$O(^DPT(DFN,.312,"B",+IBWNR,IBX)) Q:('IBX)!(IBY]"") D
112 .S IB0=$G(^DPT(DFN,.312,IBX,0))
113 .I $P(IB0,U,18)'=$P(IBWNR,U,3),$P(IB0,U,18)'=$P(IBWNR,U,5) Q
114 .; 8/18/2003 - Added translation code to remove hyphens if they exist.
115 .I $P(IB0,U,2)]"" S IBY=$TR($P(IB0,U,2),"- ","")
116 S:IBY="" IBY=-1
117HICNQ Q IBY
Note: See TracBrowser for help on using the repository browser.