- Timestamp:
- Dec 4, 2009, 12:11:15 AM (14 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCNSU1.m
r613 r623 1 IBCNSU1 ;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 ; 5 RCHK(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 12 RCHKQ Q Y 13 ; 14 BU(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 ; 42 BUQ Q IBCBU 43 ; 44 ADDBU(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 65 ADDBUQ Q IBCBU 66 ; 67 VET() ; -- 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 77 VETQ Q IBY 78 ; 79 ; 80 SUBID ; -- 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 ; 101 HICN(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 114 HICNQ Q IBY 115 ; 116 CHKQUAL(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 ; 141 CHKQUALX ; 142 Q OK 143 ; 144 CQ1 ; 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 ; 150 CQ2 ; 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 ; 1 IBCNSU1 ;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 ; 5 RCHK(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 12 RCHKQ Q Y 13 ; 14 BU(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 ; 42 BUQ Q IBCBU 43 ; 44 ADDBU(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 65 ADDBUQ Q IBCBU 66 ; 67 VET() ; -- 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 76 VETQ Q IBY 77 ; 78 ; 79 SUBID ; -- 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 ; 104 HICN(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 117 HICNQ Q IBY
Note:
See TracChangeset
for help on using the changeset viewer.
