- 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/IBCNSU.m
r613 r623 1 IBCNSU ;ALB/AAS - INSURANCE UTILITY ROUTINE ;19-MAY-93 2 ;;2.0;INTEGRATED BILLING;**28,103,371**; 21-MAR-94;Build 57 3 ;;Per VHA Directive 2004-038, this routine should not be modified. 4 ; 5 AB(IBCPOL,IBYR,IBASK) ; -- Return entry in Annual Benefits file 6 ; Input: IBCPOL = pointer to health insurance policy file 7 ; IBYR = fileman internal date, Default = dt 8 ; IBASK = 1 if want to ask okay to add new entry 9 ; 10 ; Output: IBCAB = pointer to Annual Benefits file if added, else null 11 ; 12 N DIR,IBCAB 13 S IBCAB="" 14 I $G(IBCPOL)="" G ABQ 15 I $G(IBYR)="" S IBYR=DT 16 ;S IBYR=$E(IBYR,1,3)_"0000" 17 ; 18 ; -- try to find entry for policy for year 19 S IBCAB=$O(^IBA(355.4,"APY",IBCPOL,-IBYR,0)) 20 ; 21 ; -- if no match add new entry 22 I 'IBCAB D 23 .I $G(IBASK) S DIR(0)="Y",DIR("A")="Are you adding a new Annual Benefits YEAR",DIR("B")="YES" D ^DIR I $D(DIRUT)!(Y<1) S VALMQUIT="" Q 24 .S IBCAB=$$ADDB(IBCPOL,IBYR) 25 .Q 26 ABQ Q IBCAB 27 ; 28 ADDB(IBCPOL,IBYR) ; -- add entries to Annual Benefits file 29 ; Input: IBCPOL = pointer to health insurance policy file 30 ; IBYR = fileman internal date, Default = dt 31 ; 32 ; Output: IBCAB = pointer to Annual Benefits file if added, else null 33 ; 34 N %DT,IBN1,IBCAB,DIC,DIE,DR,DA,DLAYGO,DO,DD 35 S IBCAB="" 36 I $G(IBCPOL)="" G ADDBQ 37 I $G(IBYR)="" S IBYR=DT 38 K DD,DO,DIC,DR S DIC="^IBA(355.4,",DIC(0)="L",DLAYGO=355.4 39 ; 40 ;S X=$E(IBYR,1,3)_"0000" 41 S X=IBYR D FILE^DICN I +Y<0 G ADDBQ 42 S (IBCAB,DA)=+Y,DIE="^IBA(355.4,",DR=".02////"_IBCPOL 43 D ^DIE K DIC,DIE,DA,DR 44 ADDBQ Q IBCAB 45 ; 46 CHIP(IBCDFND) ; -- convert node with no hip pointer to one with hip pointer 47 ; Input: IBCDFND = zeroth node of insurance type multiple 48 ; = ^dpt(dfn,.312,ibcdfn,0) 49 ; 50 ; Output: IBCPOL = pointer to policy file 51 ; 52 N IBCNS,IBGRP,IBGRNA,IBGRNU 53 S IBCNS=+IBCDFND,IBGRNA=$P(IBCDFND,"^",15),IBGRNU=$P(IBCDFND,"^",3),IBGRP=0 54 I IBGRNA'=""!(IBGRNU'="") S IBGRP=1 55 S IBCPOL=$$HIP(IBCNS,IBGRP,IBGRNA,IBGRNU) 56 CHIPQ Q IBCPOL 57 ; 58 HIP(IBCNS,IBGRP,IBGRNA,IBGRNU) ; -- find internal entry number in policy file 59 ; Input: IBCNS = pointer to ins co file 60 ; IBGRP = 1 if group policy, 0 if not 61 ; IBGRNA = group name 62 ; IBGRNU = group number 63 ; 64 ; Output: IBCPOL = pointer to policy file 65 ; 66 N %DT 67 S IBCPOL="" 68 I $G(^DIC(36,+$G(IBCNS),0))="" G HIPQ 69 S IBGRP=+$G(IBGRP) ; if undefine, is not a group policy 70 I 'IBGRP S IBCPOL=$$ADDH(IBCNS,IBGRP) G HIPQ 71 ; 72 S:$G(IBGRNU)="" IBGRNU="IB ZZZZZ" 73 I IBGRNU'="IB ZZZZZ" S IBCPOL=$O(^IBA(355.3,"AGNU",IBCNS,IBGRNU,0)) 74 I IBCPOL,$P($G(^IBA(355.3,+IBCPOL,0)),"^",3)=IBGRNA G HIPQ ; match both 75 ; 76 S:$G(IBGRNA)="" IBGRNA="IB ZZZZZ" 77 S IBCPOL=$O(^IBA(355.3,"AGNA",IBCNS,IBGRNA,0)) 78 I IBCPOL,$P($G(^IBA(355.3,+IBCPOL,0)),"^",4)=IBGRNU G HIPQ ; match both 79 ; 80 I 'IBCPOL S IBCPOL=$$ADDH(IBCNS,IBGRP) D 81 .I IBGRNA="",IBGRNU="" Q 82 .S:IBGRNA="IB ZZZZZ" IBGRNA="" S:IBGRNU="IB ZZZZZ" IBGRNU="" 83 .S DA=IBCPOL,DIE="^IBA(355.3,",DR=".03////"_$$STRIP(IBGRNA,";")_";.04////"_$$STRIP(IBGRNU,";") 84 .D ^DIE K DA,DR,DIC,DIE 85 HIPQ Q IBCPOL 86 ; 87 ADDH(IBCNS,IBGRP,IBGNA,IBGNU) ; -- add entries to health insurance policy file (355.3) 88 ; Input: IBCNS = pointer to ins co file 89 ; IBGRP = 1 if group policy, 0 if no 90 ; 91 ; Output: IBCPOL = pointer to policy file, if added else null 92 ; 93 N %DT,IBN1,IBCAB,DIC,DIE,DR,DA,DLAYGO,DO,DD 94 S IBCPOL="" 95 I $G(IBCNS)="" G ADDHQ 96 K DD,DO,DIC,DR S DIC="^IBA(355.3,",DIC(0)="L",DLAYGO=355.3 97 ; 98 S X=IBCNS D FILE^DICN I +Y<0 G ADDHQ 99 S (DA,IBCPOL)=+Y,DIE="^IBA(355.3,",DR=".02////"_+$G(IBGRP) 100 I IBGRP=0,$G(DFN) S DR=DR_";.1////"_DFN 101 I $D(IBGNU) S DR=DR_";.04///^S X=IBGNU" 102 I $D(IBGNA) S DR=DR_";.03///^S X=IBGNA" 103 D ^DIE K DA,DR,DIE,DIC 104 I $G(IBCNTP)'="" S IBCNTP=IBCNTP+1 105 ADDHQ Q IBCPOL 106 ; 107 ODELP(DFN,INS) ; -- can an insurance policy be deleted 108 ; -- called by ^dd(2.312,0,"del",.01) and by ibcnsm 109 ; -- input dfn: ien of patient in file 2. 110 ; ins: ien of ins. co in file 36 111 ; 112 ; -- output 1 if no deletion allowed 113 ; 0 if deletion allowed 114 N I,X,Y S X=0 115 ; 116 ; -- do not delete if any uncancelled bills 117 S J=0 F S J=$O(^DGCR(399,"AE",DFN,INS,J)) Q:'J I $P(^DGCR(399,J,"S"),"^",17)="" S X=1 Q 118 ODELPQ Q X 119 ; 120 STRIP(X,X1) ; -- strip characters from string 121 ; input: x = string 122 ; x1 = character to strip (default is ";" 123 N I,X2 124 S X2="" S:$G(X1)="" X1=";" 125 S X1=$E(X1) 126 F I=1:1 S X2=X2_$P(X,X1,I) Q:($P(X,X1,I+1,999)'[X1) 127 Q X2 128 ; 129 ; 130 DELP(DFN,INS,IBC) ; -- can an insurance policy be deleted 131 ; -- called by ^dd(2.312,0,"del",.01) and by ibcnsm 132 ; -- input dfn: ien of patient in file 2. 133 ; ins: ien of ins. co in file 36 134 ; ibc: ien of policy in file 2.312 to do a match 135 ; 136 ; -- output 1 if no deletion allowed 137 ; 0 if deletion allowed 138 ; 139 N ARR,J,ONEPOL,X 140 ; 141 ; - check input 142 I '$G(DFN)!'$G(INS) S X=1 G DELPQ 143 ; 144 ; - see if vet has more than one policy with carrier; set flag 145 ; - also, if no policy is passed, assume the patient has one policy 146 I $G(IBC) D 147 .S J=0 F S J=$O(^DPT("AB",IBC,DFN,J)) Q:'J S ARR(J)=$G(^DPT(DFN,.312,J,0)) 148 .S (J,ONEPOL)=0 S J=$O(ARR(J)) I J,'$O(ARR(J)) S ONEPOL=1 149 E S ONEPOL=1 150 ; 151 ; 152 ; -- do not delete if any uncancelled bills 153 S (J,X)=0 F S J=$O(^DGCR(399,"AE",DFN,INS,J)) Q:'J D Q:X 154 .; 155 .N ARRP,POL,K,L,M,MP,S,Z 156 .S Z=$G(^DGCR(399,J,0)),M=$G(^("M")),MP=$G(^("MP")),S=$G(^("S")) 157 .; 158 .; - skip cancelled bills 159 .I $P(S,"^",17)'="" Q 160 .; 161 .; - set flag if the patient has just one policy with the company 162 .I ONEPOL S X=1 Q 163 .; 164 .; - if there are no policy pointers in the claim, 165 .I '$P(M,"^",12),'$P(M,"^",13),'$P(M,"^",14),'$P(MP,"^",2) D Q 166 ..; 167 ..; - find all policies effective on the event date 168 ..S K=0 F S K=$O(ARR(K)) Q:'K S POL=ARR(K) D 169 ...I $P(POL,"^",8) Q:$P(Z,"^",3)<$P(POL,"^",8) 170 ...I $P(POL,"^",4) Q:$P(Z,"^",3)>$P(POL,"^",4) 171 ...S ARRP(K)="" 172 ..; 173 ..; - if there are two such policies, trust user judgement and assume 174 ..; - policy is not related to this claim. 175 ..S L=$O(ARRP(0)) I L,$O(ARR(L)) Q 176 ..; 177 ..; - if there is just one policy, and it is the same as the one 178 ..; - passed in, do not allow deletion. 179 ..I L=IBC S X=1 180 .; 181 .; - if one of the claim policy pointers is the same as the policy 182 .; - passed in, do not allow deletion. 183 .I $P(MP,"^",2)=IBC S X=1 Q 184 .I $P(M,"^",12)=IBC!($P(M,"^",13)=IBC)!($P(M,"^",14)=IBC) S X=1 185 ; 186 ; 187 DELPQ Q X 188 ; 189 DUPADDRL(DATA,IBCNS,FLD1,FLD2) ; Insurance address lines can not be duplicated 190 ; DATA - Value being compared 191 ; FLD1 - First field to check against 192 ; FLD2 - Second field to check against (OPTIONAL) 193 ; 194 ; Returns 1 if this field is a duplicate of another field. 195 ; 196 N Z1,Z2 197 Q:$G(DATA)="" 0 ; should not happen because this is invoked as an input transform 198 Q:'$G(IBCNS) 1 ; stop from editing through fileman 199 S DATA=$$UP^XLFSTR($G(DATA)),DATA=$$TRIM^XLFSTR(DATA) 200 S Z1=$$GET1^DIQ(36,+$G(IBCNS),+$G(FLD1),"I") 201 S Z1=$$UP^XLFSTR(Z1),Z1=$$TRIM^XLFSTR(Z1) 202 S Z2=$$GET1^DIQ(36,+$G(IBCNS),+$G(FLD2),"I") 203 S Z2=$$UP^XLFSTR(Z2),Z2=$$TRIM^XLFSTR(Z2) 204 I DATA=Z1 D CLEAN^DILF Q 1 205 I DATA=Z2 D CLEAN^DILF Q 1 206 D CLEAN^DILF 207 Q 0 208 ; 1 IBCNSU ;ALB/AAS - INSURANCE UTILITY ROUTINE ; 19-MAY-93 2 ;;2.0;INTEGRATED BILLING;**28,103**; 21-MAR-94 3 ;;Per VHA Directive 10-93-142, this routine should not be modified. 4 ; 5 AB(IBCPOL,IBYR,IBASK) ; -- Return entry in Annual Benefits file 6 ; Input: IBCPOL = pointer to health insurance policy file 7 ; IBYR = fileman internal date, Default = dt 8 ; IBASK = 1 if want to ask okay to add new entry 9 ; 10 ; Output: IBCAB = pointer to Annual Benefits file if added, else null 11 ; 12 N DIR,IBCAB 13 S IBCAB="" 14 I $G(IBCPOL)="" G ABQ 15 I $G(IBYR)="" S IBYR=DT 16 ;S IBYR=$E(IBYR,1,3)_"0000" 17 ; 18 ; -- try to find entry for policy for year 19 S IBCAB=$O(^IBA(355.4,"APY",IBCPOL,-IBYR,0)) 20 ; 21 ; -- if no match add new entry 22 I 'IBCAB D 23 .I $G(IBASK) S DIR(0)="Y",DIR("A")="Are you adding a new Annual Benefits YEAR",DIR("B")="YES" D ^DIR I $D(DIRUT)!(Y<1) S VALMQUIT="" Q 24 .S IBCAB=$$ADDB(IBCPOL,IBYR) 25 .Q 26 ABQ Q IBCAB 27 ; 28 ADDB(IBCPOL,IBYR) ; -- add entries to Annual Benefits file 29 ; Input: IBCPOL = pointer to health insurance policy file 30 ; IBYR = fileman internal date, Default = dt 31 ; 32 ; Output: IBCAB = pointer to Annual Benefits file if added, else null 33 ; 34 N %DT,IBN1,IBCAB,DIC,DIE,DR,DA,DLAYGO,DO,DD 35 S IBCAB="" 36 I $G(IBCPOL)="" G ADDBQ 37 I $G(IBYR)="" S IBYR=DT 38 K DD,DO,DIC,DR S DIC="^IBA(355.4,",DIC(0)="L",DLAYGO=355.4 39 ; 40 ;S X=$E(IBYR,1,3)_"0000" 41 S X=IBYR D FILE^DICN I +Y<0 G ADDBQ 42 S (IBCAB,DA)=+Y,DIE="^IBA(355.4,",DR=".02////"_IBCPOL 43 D ^DIE K DIC,DIE,DA,DR 44 ADDBQ Q IBCAB 45 ; 46 CHIP(IBCDFND) ; -- convert node with no hip pointer to one with hip pointer 47 ; Input: IBCDFND = zeroth node of insurance type multiple 48 ; = ^dpt(dfn,.312,ibcdfn,0) 49 ; 50 ; Output: IBCPOL = pointer to policy file 51 ; 52 N IBCNS,IBGRP,IBGRNA,IBGRNU 53 S IBCNS=+IBCDFND,IBGRNA=$P(IBCDFND,"^",15),IBGRNU=$P(IBCDFND,"^",3),IBGRP=0 54 I IBGRNA'=""!(IBGRNU'="") S IBGRP=1 55 S IBCPOL=$$HIP(IBCNS,IBGRP,IBGRNA,IBGRNU) 56 CHIPQ Q IBCPOL 57 ; 58 HIP(IBCNS,IBGRP,IBGRNA,IBGRNU) ; -- find internal entry number in policy file 59 ; Input: IBCNS = pointer to ins co file 60 ; IBGRP = 1 if group policy, 0 if not 61 ; IBGRNA = group name 62 ; IBGRNU = group number 63 ; 64 ; Output: IBCPOL = pointer to policy file 65 ; 66 N %DT 67 S IBCPOL="" 68 I $G(^DIC(36,+$G(IBCNS),0))="" G HIPQ 69 S IBGRP=+$G(IBGRP) ; if undefine, is not a group policy 70 I 'IBGRP S IBCPOL=$$ADDH(IBCNS,IBGRP) G HIPQ 71 ; 72 S:$G(IBGRNU)="" IBGRNU="IB ZZZZZ" 73 I IBGRNU'="IB ZZZZZ" S IBCPOL=$O(^IBA(355.3,"AGNU",IBCNS,IBGRNU,0)) 74 I IBCPOL,$P($G(^IBA(355.3,+IBCPOL,0)),"^",3)=IBGRNA G HIPQ ; match both 75 ; 76 S:$G(IBGRNA)="" IBGRNA="IB ZZZZZ" 77 S IBCPOL=$O(^IBA(355.3,"AGNA",IBCNS,IBGRNA,0)) 78 I IBCPOL,$P($G(^IBA(355.3,+IBCPOL,0)),"^",4)=IBGRNU G HIPQ ; match both 79 ; 80 I 'IBCPOL S IBCPOL=$$ADDH(IBCNS,IBGRP) D 81 .I IBGRNA="",IBGRNU="" Q 82 .S:IBGRNA="IB ZZZZZ" IBGRNA="" S:IBGRNU="IB ZZZZZ" IBGRNU="" 83 .S DA=IBCPOL,DIE="^IBA(355.3,",DR=".03////"_$$STRIP(IBGRNA,";")_";.04////"_$$STRIP(IBGRNU,";") 84 .D ^DIE K DA,DR,DIC,DIE 85 HIPQ Q IBCPOL 86 ; 87 ADDH(IBCNS,IBGRP,IBGNA,IBGNU) ; -- add entries to health insurance policy file (355.3) 88 ; Input: IBCNS = pointer to ins co file 89 ; IBGRP = 1 if group policy, 0 if no 90 ; 91 ; Output: IBCPOL = pointer to policy file, if added else null 92 ; 93 N %DT,IBN1,IBCAB,DIC,DIE,DR,DA,DLAYGO,DO,DD 94 S IBCPOL="" 95 I $G(IBCNS)="" G ADDHQ 96 K DD,DO,DIC,DR S DIC="^IBA(355.3,",DIC(0)="L",DLAYGO=355.3 97 ; 98 S X=IBCNS D FILE^DICN I +Y<0 G ADDHQ 99 S (DA,IBCPOL)=+Y,DIE="^IBA(355.3,",DR=".02////"_+$G(IBGRP) 100 I IBGRP=0,$G(DFN) S DR=DR_";.1////"_DFN 101 I $D(IBGNU) S DR=DR_";.04///^S X=IBGNU" 102 I $D(IBGNA) S DR=DR_";.03///^S X=IBGNA" 103 D ^DIE K DA,DR,DIE,DIC 104 I $G(IBCNTP)'="" S IBCNTP=IBCNTP+1 105 ADDHQ Q IBCPOL 106 ; 107 ODELP(DFN,INS) ; -- can an insurance policy be deleted 108 ; -- called by ^dd(2.312,0,"del",.01) and by ibcnsm 109 ; -- input dfn: ien of patient in file 2. 110 ; ins: ien of ins. co in file 36 111 ; 112 ; -- output 1 if no deletion allowed 113 ; 0 if deletion allowed 114 N I,X,Y S X=0 115 ; 116 ; -- do not delete if any uncancelled bills 117 S J=0 F S J=$O(^DGCR(399,"AE",DFN,INS,J)) Q:'J I $P(^DGCR(399,J,"S"),"^",17)="" S X=1 Q 118 ODELPQ Q X 119 ; 120 STRIP(X,X1) ; -- strip characters from string 121 ; input: x = string 122 ; x1 = character to strip (default is ";" 123 N I,X2 124 S X2="" S:$G(X1)="" X1=";" 125 S X1=$E(X1) 126 F I=1:1 S X2=X2_$P(X,X1,I) Q:($P(X,X1,I+1,999)'[X1) 127 Q X2 128 ; 129 ; 130 DELP(DFN,INS,IBC) ; -- can an insurance policy be deleted 131 ; -- called by ^dd(2.312,0,"del",.01) and by ibcnsm 132 ; -- input dfn: ien of patient in file 2. 133 ; ins: ien of ins. co in file 36 134 ; ibc: ien of policy in file 2.312 to do a match 135 ; 136 ; -- output 1 if no deletion allowed 137 ; 0 if deletion allowed 138 ; 139 N ARR,J,ONEPOL,X 140 ; 141 ; - check input 142 I '$G(DFN)!'$G(INS) S X=1 G DELPQ 143 ; 144 ; - see if vet has more than one policy with carrier; set flag 145 ; - also, if no policy is passed, assume the patient has one policy 146 I $G(IBC) D 147 .S J=0 F S J=$O(^DPT("AB",IBC,DFN,J)) Q:'J S ARR(J)=$G(^DPT(DFN,.312,J,0)) 148 .S (J,ONEPOL)=0 S J=$O(ARR(J)) I J,'$O(ARR(J)) S ONEPOL=1 149 E S ONEPOL=1 150 ; 151 ; 152 ; -- do not delete if any uncancelled bills 153 S (J,X)=0 F S J=$O(^DGCR(399,"AE",DFN,INS,J)) Q:'J D Q:X 154 .; 155 .N ARRP,POL,K,L,M,MP,S,Z 156 .S Z=$G(^DGCR(399,J,0)),M=$G(^("M")),MP=$G(^("MP")),S=$G(^("S")) 157 .; 158 .; - skip cancelled bills 159 .I $P(S,"^",17)'="" Q 160 .; 161 .; - set flag if the patient has just one policy with the company 162 .I ONEPOL S X=1 Q 163 .; 164 .; - if there are no policy pointers in the claim, 165 .I '$P(M,"^",12),'$P(M,"^",13),'$P(M,"^",14),'$P(MP,"^",2) D Q 166 ..; 167 ..; - find all policies effective on the event date 168 ..S K=0 F S K=$O(ARR(K)) Q:'K S POL=ARR(K) D 169 ...I $P(POL,"^",8) Q:$P(Z,"^",3)<$P(POL,"^",8) 170 ...I $P(POL,"^",4) Q:$P(Z,"^",3)>$P(POL,"^",4) 171 ...S ARRP(K)="" 172 ..; 173 ..; - if there are two such policies, trust user judgement and assume 174 ..; - policy is not related to this claim. 175 ..S L=$O(ARRP(0)) I L,$O(ARR(L)) Q 176 ..; 177 ..; - if there is just one policy, and it is the same as the one 178 ..; - passed in, do not allow deletion. 179 ..I L=IBC S X=1 180 .; 181 .; - if one of the claim policy pointers is the same as the policy 182 .; - passed in, do not allow deletion. 183 .I $P(MP,"^",2)=IBC S X=1 Q 184 .I $P(M,"^",12)=IBC!($P(M,"^",13)=IBC)!($P(M,"^",14)=IBC) S X=1 185 ; 186 ; 187 DELPQ Q X
Note:
See TracChangeset
for help on using the changeset viewer.
