- Timestamp:
- Dec 4, 2009, 12:11:15 AM (15 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
WorldVistAEHR/trunk/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBCNSC1.m
r613 r623 1 IBCNSC1 ;ALB/NLR - IBCNS INSURANCE COMPANY ;23-MAR-93 2 ;;2.0;INTEGRATED BILLING;**62,137,232,291,320,348,349,371**;21-MAR-94;Build 57 3 ;;Per VHA Directive 2004-038, this routine should not be modified. 4 ; 5 % G EN^IBCNSC 6 ; 7 AI ; -- (In)Activate Company 8 D FULL^VALM1 W !! 9 I '$D(^XUSEC("IB INSURANCE SUPERVISOR",DUZ)) D SORRY G EXIT 10 D ^IBCNSC2 11 G EXIT 12 CC ; -- Change Insurance Company 13 D FULL^VALM1 W !! 14 S IBCNS1=IBCNS K IBCNS D INSCO^IBCNSC 15 I '$D(IBCNS) S IBCNS=IBCNS1 16 K IBCNS1,VALMQUIT 17 G EXIT 18 EA ; -- Billing,Claims,Appeals,Inquiry,Telephone,Main,Remarks,Synonyms 19 D FULL^VALM1 20 ; 21 ; IB*2*320 - check key for associate company action 22 I $G(IBY)=",13,",'$$KCHK^XUSRB("IB EDI INSURANCE EDIT") D G EXIT 23 . W !!?5,"You must hold the IB EDI INSURANCE EDIT key to access this option." 24 . D PAUSE^VALM1 25 . Q 26 ; 27 W !! 28 D MAIN 29 ; 30 ; -- was company deleted 31 I '$D(^DIC(36,IBCNS)) W !!,"<DELETED>",!! S VALMQUIT="" Q 32 ; 33 EXIT ; 34 D HDR^IBCNSC,BLD^IBCNSC 35 S VALMBCK="R" 36 Q 37 MAIN ; -- Call edit template 38 N IBEDIKEY,Z 39 L +^DIC(36,+IBCNS):5 I '$T D LOCKED^IBTRCD1 G MAINQ 40 I $G(IBY)=",12," D FACID 41 F Z=1,2,4,9,13,14 S IBEDIKEY(Z)=$P($G(^DIC(36,+IBCNS,3)),U,Z) ; save EDI data fields 42 F Z=1:1:8 S IBEDIKEY(Z,6)=$P($G(^DIC(36,+IBCNS,6)),U,Z) ; save EDI data fields 43 I $G(IBY)'=",12," N DIE,DA,DR S DIE="^DIC(36,",(DA,Y)=IBCNS,DR="[IBEDIT INS CO1]" D ^DIE K DIE S:$D(Y) IB("^")=1 D:$TR($P($G(^DIC(36,IBCNS,6)),U,1,8),U)]"" CUIDS(IBCNS) 44 I $G(IBY)=",12," D EDITID^IBCEP(+IBCNS) 45 I $F(",6,13,",$G(IBY)) D PARENT^IBCNSC02(+IBCNS) ; parent/child management 46 L -^DIC(36,+IBCNS) 47 MAINQ Q 48 ; 49 FACID ; -- Edit facility ids 50 D FACID^IBCEP2B(+IBCNS,"E") 51 Q 52 ; 53 SORRY ; -- can't inactivate, don't have key 54 W !!,"You do not have access to Inactivate entries. See your application coordinator.",! D PAUSE^VALM1 55 Q 56 PRESCR ; 57 N OFFSET,START,IBCNS18,IBADD 58 S IBCNS18=$$ADDRESS^IBCNSC0(IBCNS,.18,11) 59 S START=41,OFFSET=2 60 D SET^IBCNSP(START,OFFSET+19," Prescription Claims Office Information ",IORVON,IORVOFF) 61 D SET^IBCNSP(START+1,OFFSET," Company Name: "_$P($G(^DIC(36,+$P(IBCNS18,"^",7),0)),"^",1)) 62 D SET^IBCNSP(START+2,OFFSET," Street: "_$P(IBCNS18,"^",1)) 63 D SET^IBCNSP(START+3,OFFSET," Street 2: "_$P(IBCNS18,"^",2)) 64 ; D SET^IBCNSP(START+4,OFFSET,"Claim Off. ID: "_$P(IBCNS18,"^",11)) 65 N OFFSET S OFFSET=45 66 D SET^IBCNSP(START+1,OFFSET," Street 3: "_$P(IBCNS18,"^",3)) S IBADD=1 67 D SET^IBCNSP(START+1+IBADD,OFFSET," City/State: "_$E($P(IBCNS18,"^",4),1,15)_$S($P(IBCNS18,"^",4)="":"",1:", ")_$P($G(^DIC(5,+$P(IBCNS18,"^",5),0)),"^",2)_" "_$E($P(IBCNS18,"^",6),1,5)) 68 D SET^IBCNSP(START+2+IBADD,OFFSET," Phone: "_$P(IBCNS18,"^",8)) 69 D SET^IBCNSP(START+3+IBADD,OFFSET," Fax: "_$P(IBCNS18,"^",9)) 70 Q 71 ; 72 PROVID N OFFSET,START,IBCNS4,IBCNS3,IBDISP,Z,LINE 73 S START=$O(^TMP("IBCNSC",$J,""),-1)+1 74 S (IB1ST("PROVID"),LINE)=START 75 S OFFSET=2,IBCNS4=$G(^DIC(36,IBCNS,4)),IBCNS3=$G(^(3)) 76 ; 77 D SET^IBCNSP(LINE,OFFSET+25,"Provider IDs",IORVON,IORVOFF) 78 N OFFSET 79 S LINE=LINE+1,OFFSET=1 80 D SET^IBCNSP(LINE,OFFSET,"Billing Provider Secondary ID") 81 ; 82 N Z,Z0,Z1,IBS,I,DIV,FT,CU,CUF,DIVISION,FORMTYPE,PIDT 83 S Z=0 F S Z=$O(^IBA(355.92,"B",+IBCNS,Z)) Q:'Z D 84 . S Z0=$G(^IBA(355.92,Z,0)) 85 . Q:'$P(Z0,U,6)!($P(Z0,U,7)="") ; Quit if no provider id or id type 86 . Q:'($P(Z0,U,8)="E") 87 . S IBS(+$P(Z0,U,5),+$P(Z0,U,3),+$P(Z0,U,4))=$P(Z0,U,6)_U_$P(Z0,U,7) 88 ; 89 S DIV="" F S DIV=$O(IBS(DIV)) Q:DIV="" D 90 . S DIVISION=$$DIV^IBCEP7(DIV) 91 . S CU="",CUF=0 F S CU=$O(IBS(DIV,CU)) Q:CU="" D 92 .. S FT="" F S FT=$O(IBS(DIV,CU,FT)) Q:FT="" D 93 ... S FORMTYPE=$S(FT=1:"UB-04",FT=2:"1500",1:"UNKNOWN") 94 ... S LINE=LINE+1 95 ... I 'CUF,+CU S CUF=1 S TEXT=$P(DIVISION,"/")_" Care Units :",OFFSET=5 D SET^IBCNSP(LINE,OFFSET,TEXT) S LINE=LINE+1 96 ... I CU=0 S TEXT=DIVISION_"/"_FORMTYPE_": "_$$GET1^DIQ(355.97,$P(IBS(DIV,CU,FT),U),.03,"E")_" "_$P(IBS(DIV,CU,FT),U,2),OFFSET=2 97 ... I +CU S TEXT=$$EXPAND^IBTRE(355.92,.03,CU)_"/"_FORMTYPE_": "_$$GET1^DIQ(355.97,$P(IBS(DIV,CU,FT),U),.03,"E")_" "_$P(IBS(DIV,CU,FT),U,2),OFFSET=5 98 ... D SET^IBCNSP(LINE,OFFSET,TEXT) 99 ; 100 S LINE=LINE+1 D SET^IBCNSP(LINE,2," ") 101 ; 102 K IBS 103 S OFFSET=1,LINE=LINE+1 104 D SET^IBCNSP(LINE,OFFSET,"Additional Billing Provider Secondary IDs") 105 S Z=0 F S Z=$O(^IBA(355.92,"B",+IBCNS,Z)) Q:'Z D 106 . S Z0=$G(^IBA(355.92,Z,0)) 107 . Q:'$P(Z0,U,6)!($P(Z0,U,7)="") ; Quit if no provider id or id type 108 . Q:'($P(Z0,U,8)="A") 109 . ; IBS(DIVISION,FORMTYPE,IDTYPE)=ID 110 . S IBS(+$P(Z0,U,5),+$P(Z0,U,4),+$P(Z0,U,6))=$P(Z0,U,7) 111 ; 112 S DIVISION=$$DIV^IBCEP7(0) 113 S DIV="" F S DIV=$O(IBS(DIV)) Q:DIV="" D 114 . S FT="" F S FT=$O(IBS(DIV,FT)) Q:FT="" D 115 .. S FORMTYPE=$S(FT=1:"UB-04",FT=2:"1500",1:"UNKNOWN") 116 .. S TEXT=DIVISION_"/"_FORMTYPE_": " 117 .. S LINE=LINE+1,OFFSET=2 118 .. D SET^IBCNSP(LINE,OFFSET,TEXT) 119 .. S PIDT="" F S PIDT=$O(IBS(DIV,FT,PIDT)) Q:PIDT="" D 120 ... S LINE=LINE+1 121 ... S TEXT=$$GET1^DIQ(355.97,PIDT,.03,"E")_" "_IBS(DIV,FT,PIDT),OFFSET=5 122 ... D SET^IBCNSP(LINE,OFFSET,TEXT) 123 ; 124 S LINE=LINE+1 D SET^IBCNSP(LINE,2," ") 125 ; 126 K IBS 127 S OFFSET=1,LINE=LINE+1 128 D SET^IBCNSP(LINE,OFFSET,"VA-Laboratory or Facility Secondary IDs") 129 S Z=0 F S Z=$O(^IBA(355.92,"B",+IBCNS,Z)) Q:'Z D 130 . S Z0=$G(^IBA(355.92,Z,0)) 131 . Q:'$P(Z0,U,6)!($P(Z0,U,7)="") ; Quit if no provider id or id type 132 . Q:'($P(Z0,U,8)="LF") 133 . ; IBS(DIVISION,FORMTYPE,IDTYPE)=ID 134 . S IBS(+$P(Z0,U,5),+$P(Z0,U,4),+$P(Z0,U,6))=$P(Z0,U,7) 135 ; 136 S DIVISION=$$DIV^IBCEP7(0) 137 S DIV="" F S DIV=$O(IBS(DIV)) Q:DIV="" D 138 . S FT="" F S FT=$O(IBS(DIV,FT)) Q:FT="" D 139 .. S FORMTYPE=$S(FT=1:"UB-04",FT=2:"1500",1:"UNKNOWN") 140 .. S TEXT=DIVISION_"/"_FORMTYPE_": " 141 .. S LINE=LINE+1,OFFSET=2 142 .. D SET^IBCNSP(LINE,OFFSET,TEXT) 143 .. S PIDT="" F S PIDT=$O(IBS(DIV,FT,PIDT)) Q:PIDT="" D 144 ... S LINE=LINE+1 145 ... ;S TEXT=$$EXPAND^IBTRE(355.92,.06,PIDT)_" "_IBS(DIV,FT,PIDT),OFFSET=5 146 ... S TEXT=$$GET1^DIQ(355.97,PIDT,.03,"E")_" "_IBS(DIV,FT,PIDT),OFFSET=5 147 ... D SET^IBCNSP(LINE,OFFSET,TEXT) 148 ; 149 ; 150 S LINE=LINE+1 D SET^IBCNSP(LINE,2," ") 151 S LINE=LINE+1 D SET^IBCNSP(LINE,2," ") 152 S OFFSET=2 153 S LINE=LINE+1 D SET^IBCNSP(LINE,OFFSET+25,"ID Parameters",IORVON,IORVOFF) 154 ; 155 S IBCNS4=$G(^DIC(36,IBCNS,4)),IBCNS3=$G(^(3)),OFFSET=1 156 S TEXT="Attending/Rendering Provider Secondary ID Qualifier (1500): "_$$EXPAND^IBTRE(36,4.01,+$P(IBCNS4,U)) 157 S LINE=LINE+1 158 D SET^IBCNSP(LINE,OFFSET,TEXT) 159 ; 160 S TEXT="Attending/Rendering Provider Secondary ID Qualifier (UB-04): "_$$EXPAND^IBTRE(36,4.02,+$P(IBCNS4,U,2)) 161 S LINE=LINE+1 162 D SET^IBCNSP(LINE,OFFSET,TEXT) 163 ; 164 S TEXT="Attending/Rendering Secondary ID Requirement: "_$$EXPAND^IBTRE(36,4.03,+$P(IBCNS4,U,3)) 165 S LINE=LINE+1 166 D SET^IBCNSP(LINE,OFFSET,TEXT) 167 ; 168 S TEXT="Referring Provider Secondary ID Qualifier (1500): "_$$EXPAND^IBTRE(36,4.04,+$P(IBCNS4,U,4)) 169 S LINE=LINE+1 170 D SET^IBCNSP(LINE,OFFSET,TEXT) 171 ; 172 S TEXT="Referring Provider Secondary ID Requirement: "_$$EXPAND^IBTRE(36,4.05,+$P(IBCNS4,U,5)) 173 S LINE=LINE+1 174 D SET^IBCNSP(LINE,OFFSET,TEXT) 175 ; 176 S TEXT="Use Att/Rend ID as Billing Provider Sec. ID (1500): "_$$EXPAND^IBTRE(36,4.06,+$P(IBCNS4,U,6)) 177 S LINE=LINE+1 178 D SET^IBCNSP(LINE,OFFSET,TEXT) 179 ; 180 S TEXT="Use Att/Rend ID as Billing Provider Sec. ID (UB-04): "_$$EXPAND^IBTRE(36,4.08,+$P(IBCNS4,U,8)) 181 S LINE=LINE+1 182 D SET^IBCNSP(LINE,OFFSET,TEXT) 183 ; 184 S TEXT="Send VA Lab/Facility IDs or Facility Data for VAMC?: "_$$EXPAND^IBTRE(36,4.07,+$P(IBCNS4,U,7)) 185 S LINE=LINE+1 186 D SET^IBCNSP(LINE,OFFSET,TEXT) 187 ; 188 S TEXT="Transmit no Billing Provider Sec. ID for the Electronic Plan Types: " 189 S LINE=LINE+1 190 D SET^IBCNSP(LINE,OFFSET,TEXT) 191 ; 192 N TAR,ERR,IBCT 193 D LIST^DIC(36.013,","_IBCNS_",",".01",,10,,,,,,"TAR","ERR") 194 F IBCT=1:1:+$G(TAR("DILIST",0)) D 195 . S TEXT=TAR("DILIST",1,IBCT) 196 . S LINE=LINE+1 197 . D SET^IBCNSP(LINE,OFFSET,TEXT) 198 ; 199 S LINE=LINE+1 D SET^IBCNSP(LINE,2," ") 200 S LINE=LINE+1 D SET^IBCNSP(LINE,2," ") 201 Q 202 ; 203 INSDEF(IBINS,IBPTYP) ; Returns the default id # for an ins co, if possible 204 N X 205 S X="" 206 I IBINS,IBPTYP S X=$P($G(^IBA(355.91,+$O(^IBA(355.91,"AC",IBINS,IBPTYP,"*N/A*","")),0)),U,7) 207 Q X 208 ; 209 CUIDS(IBCNS) ; 210 N DIE,DA,DR,PIECE,DAT6,Y 211 S DAT6=$P(^DIC(36,IBCNS,6),U,1,8) ; get the Payer IDs 212 ; 213 ; Make sure each qualifier has an ID and vice versa 214 F PIECE=1,3,5,7 D 215 . I $TR($P(DAT6,U,PIECE,PIECE+1),U)="" Q ; both blank 216 . I $P(DAT6,U,PIECE)]"",$P(DAT6,U,PIECE+1)]"" Q ; both have data 217 . S DIE="^DIC(36,",(DA,Y)=IBCNS,DR="6.0"_$S($P(DAT6,U,PIECE)]"":PIECE,1:PIECE+1)_"////@" 218 . D ^DIE K DIE 219 ; 220 S DAT6=$P($G(^DIC(36,IBCNS,6)),U,1,8) ; get the Payer IDs again since they may have changed above. 221 ; 222 ; Make sure the first pair of ID/Qual are populated if the 2nd pair is. If not, move em over. 223 ; This is done for institutional then professional 224 F PIECE=1,5 D 225 . I $P(DAT6,U,PIECE)]"" Q ; already has set one 226 . I $P(DAT6,U,PIECE+2)="" Q ; has no second set 227 . S DIE="^DIC(36,",(DA,Y)=IBCNS 228 . ; deleting the qualifier triggers deletion of the ID 229 . S DR="6.0"_PIECE_"////"_$P(DAT6,U,PIECE+2)_";6.0"_(PIECE+1)_"////"_$P(DAT6,U,PIECE+3)_";6.0"_(PIECE+2)_"////@" 230 . D ^DIE K DIE 231 Q 1 IBCNSC1 ;ALB/NLR - IBCNS INSURANCE COMPANY ;23-MAR-93 2 ;;2.0;INTEGRATED BILLING;**62,137,232,291,320,348,349**;21-MAR-94;Build 46 3 ;;Per VHA Directive 2004-038, this routine should not be modified. 4 ; 5 % G EN^IBCNSC 6 ; 7 AI ; -- (In)Activate Company 8 D FULL^VALM1 W !! 9 I '$D(^XUSEC("IB INSURANCE SUPERVISOR",DUZ)) D SORRY G EXIT 10 D ^IBCNSC2 11 G EXIT 12 CC ; -- Change Insurance Company 13 D FULL^VALM1 W !! 14 S IBCNS1=IBCNS K IBCNS D INSCO^IBCNSC 15 I '$D(IBCNS) S IBCNS=IBCNS1 16 K IBCNS1,VALMQUIT 17 G EXIT 18 EA ; -- Billing,Claims,Appeals,Inquiry,Telephone,Main,Remarks,Synonyms 19 D FULL^VALM1 20 ; 21 ; IB*2*320 - check key for associate company action 22 I $G(IBY)=",13,",'$$KCHK^XUSRB("IB EDI INSURANCE EDIT") D G EXIT 23 . W !!?5,"You must hold the IB EDI INSURANCE EDIT key to access this option." 24 . D PAUSE^VALM1 25 . Q 26 ; 27 W !! 28 D MAIN 29 ; 30 ; -- was company deleted 31 I '$D(^DIC(36,IBCNS)) W !!,"<DELETED>",!! S VALMQUIT="" Q 32 ; 33 EXIT ; 34 D HDR^IBCNSC,BLD^IBCNSC 35 S VALMBCK="R" 36 Q 37 MAIN ; -- Call edit template 38 N IBEDIKEY,Z 39 L +^DIC(36,+IBCNS):5 I '$T D LOCKED^IBTRCD1 G MAINQ 40 I $G(IBY)=",12," D FACID 41 F Z=1,2,4,9,13,14 S IBEDIKEY(Z)=$P($G(^DIC(36,+IBCNS,3)),U,Z) ; save EDI data fields 42 I $G(IBY)'=",12," N DIE,DA,DR S DIE="^DIC(36,",(DA,Y)=IBCNS,DR="[IBEDIT INS CO1]" D ^DIE K DIE I $D(Y) S IB("^")=1 43 I $G(IBY)=",12," D EDITID^IBCEP(+IBCNS) 44 I $F(",6,13,",$G(IBY)) D PARENT^IBCNSC02(+IBCNS) ; parent/child management 45 L -^DIC(36,+IBCNS) 46 MAINQ Q 47 ; 48 FACID ; -- Edit facility ids 49 D FACID^IBCEP2B(+IBCNS,"E") 50 Q 51 ; 52 SORRY ; -- can't inactivate, don't have key 53 W !!,"You do not have access to Inactivate entries. See your application coordinator.",! D PAUSE^VALM1 54 Q 55 PRESCR ; 56 N OFFSET,START,IBCNS18,IBADD 57 S IBCNS18=$$ADDRESS^IBCNSC0(IBCNS,.18,11) 58 S START=34,OFFSET=2 59 D SET^IBCNSP(START,OFFSET+19," Prescription Claims Office Information ",IORVON,IORVOFF) 60 D SET^IBCNSP(START+1,OFFSET," Company Name: "_$P($G(^DIC(36,+$P(IBCNS18,"^",7),0)),"^",1)) 61 D SET^IBCNSP(START+2,OFFSET," Street: "_$P(IBCNS18,"^",1)) 62 D SET^IBCNSP(START+3,OFFSET," Street 2: "_$P(IBCNS18,"^",2)) 63 ; D SET^IBCNSP(START+4,OFFSET,"Claim Off. ID: "_$P(IBCNS18,"^",11)) 64 N OFFSET S OFFSET=45 65 D SET^IBCNSP(START+1,OFFSET," Street 3: "_$P(IBCNS18,"^",3)) S IBADD=1 66 D SET^IBCNSP(START+1+IBADD,OFFSET," City/State: "_$E($P(IBCNS18,"^",4),1,15)_$S($P(IBCNS18,"^",4)="":"",1:", ")_$P($G(^DIC(5,+$P(IBCNS18,"^",5),0)),"^",2)_" "_$E($P(IBCNS18,"^",6),1,5)) 67 D SET^IBCNSP(START+2+IBADD,OFFSET," Phone: "_$P(IBCNS18,"^",8)) 68 D SET^IBCNSP(START+3+IBADD,OFFSET," Fax: "_$P(IBCNS18,"^",9)) 69 Q 70 ; 71 PROVID N OFFSET,START,IBCNS4,IBCNS3,IBDISP,Z,LINE 72 S START=$O(^TMP("IBCNSC",$J,""),-1)+1 73 S (IB1ST("PROVID"),LINE)=START 74 S OFFSET=2,IBCNS4=$G(^DIC(36,IBCNS,4)),IBCNS3=$G(^(3)) 75 ; 76 D SET^IBCNSP(LINE,OFFSET+25,"Provider IDs",IORVON,IORVOFF) 77 N OFFSET 78 S LINE=LINE+1,OFFSET=1 79 D SET^IBCNSP(LINE,OFFSET,"Billing Provider Secondary ID") 80 ; 81 N Z,Z0,Z1,IBS,I,DIV,FT,CU,CUF,DIVISION,FORMTYPE,PIDT 82 S Z=0 F S Z=$O(^IBA(355.92,"B",+IBCNS,Z)) Q:'Z D 83 . S Z0=$G(^IBA(355.92,Z,0)) 84 . Q:'$P(Z0,U,6)!($P(Z0,U,7)="") ; Quit if no provider id or id type 85 . Q:'($P(Z0,U,8)="E") 86 . S IBS(+$P(Z0,U,5),+$P(Z0,U,3),+$P(Z0,U,4))=$P(Z0,U,6)_U_$P(Z0,U,7) 87 ; 88 S DIV="" F S DIV=$O(IBS(DIV)) Q:DIV="" D 89 . S DIVISION=$$DIV^IBCEP7(DIV) 90 . S CU="",CUF=0 F S CU=$O(IBS(DIV,CU)) Q:CU="" D 91 .. S FT="" F S FT=$O(IBS(DIV,CU,FT)) Q:FT="" D 92 ... S FORMTYPE=$S(FT=1:"UB-04",FT=2:"1500",1:"UNKNOWN") 93 ... S LINE=LINE+1 94 ... I 'CUF,+CU S CUF=1 S TEXT=$P(DIVISION,"/")_" Care Units :",OFFSET=5 D SET^IBCNSP(LINE,OFFSET,TEXT) S LINE=LINE+1 95 ... I CU=0 S TEXT=DIVISION_"/"_FORMTYPE_": "_$$GET1^DIQ(355.97,$P(IBS(DIV,CU,FT),U),.03,"E")_" "_$P(IBS(DIV,CU,FT),U,2),OFFSET=2 96 ... I +CU S TEXT=$$EXPAND^IBTRE(355.92,.03,CU)_"/"_FORMTYPE_": "_$$GET1^DIQ(355.97,$P(IBS(DIV,CU,FT),U),.03,"E")_" "_$P(IBS(DIV,CU,FT),U,2),OFFSET=5 97 ... D SET^IBCNSP(LINE,OFFSET,TEXT) 98 ; 99 S LINE=LINE+1 D SET^IBCNSP(LINE,2," ") 100 ; 101 K IBS 102 S OFFSET=1,LINE=LINE+1 103 D SET^IBCNSP(LINE,OFFSET,"Additional Billing Provider Secondary IDs") 104 S Z=0 F S Z=$O(^IBA(355.92,"B",+IBCNS,Z)) Q:'Z D 105 . S Z0=$G(^IBA(355.92,Z,0)) 106 . Q:'$P(Z0,U,6)!($P(Z0,U,7)="") ; Quit if no provider id or id type 107 . Q:'($P(Z0,U,8)="A") 108 . ; IBS(DIVISION,FORMTYPE,IDTYPE)=ID 109 . S IBS(+$P(Z0,U,5),+$P(Z0,U,4),+$P(Z0,U,6))=$P(Z0,U,7) 110 ; 111 S DIVISION=$$DIV^IBCEP7(0) 112 S DIV="" F S DIV=$O(IBS(DIV)) Q:DIV="" D 113 . S FT="" F S FT=$O(IBS(DIV,FT)) Q:FT="" D 114 .. S FORMTYPE=$S(FT=1:"UB-04",FT=2:"1500",1:"UNKNOWN") 115 .. S TEXT=DIVISION_"/"_FORMTYPE_": " 116 .. S LINE=LINE+1,OFFSET=2 117 .. D SET^IBCNSP(LINE,OFFSET,TEXT) 118 .. S PIDT="" F S PIDT=$O(IBS(DIV,FT,PIDT)) Q:PIDT="" D 119 ... S LINE=LINE+1 120 ... S TEXT=$$GET1^DIQ(355.97,PIDT,.03,"E")_" "_IBS(DIV,FT,PIDT),OFFSET=5 121 ... D SET^IBCNSP(LINE,OFFSET,TEXT) 122 ; 123 S LINE=LINE+1 D SET^IBCNSP(LINE,2," ") 124 ; 125 K IBS 126 S OFFSET=1,LINE=LINE+1 127 D SET^IBCNSP(LINE,OFFSET,"VA-Laboratory or Facility Secondary IDs") 128 S Z=0 F S Z=$O(^IBA(355.92,"B",+IBCNS,Z)) Q:'Z D 129 . S Z0=$G(^IBA(355.92,Z,0)) 130 . Q:'$P(Z0,U,6)!($P(Z0,U,7)="") ; Quit if no provider id or id type 131 . Q:'($P(Z0,U,8)="LF") 132 . ; IBS(DIVISION,FORMTYPE,IDTYPE)=ID 133 . S IBS(+$P(Z0,U,5),+$P(Z0,U,4),+$P(Z0,U,6))=$P(Z0,U,7) 134 ; 135 S DIVISION=$$DIV^IBCEP7(0) 136 S DIV="" F S DIV=$O(IBS(DIV)) Q:DIV="" D 137 . S FT="" F S FT=$O(IBS(DIV,FT)) Q:FT="" D 138 .. S FORMTYPE=$S(FT=1:"UB-04",FT=2:"1500",1:"UNKNOWN") 139 .. S TEXT=DIVISION_"/"_FORMTYPE_": " 140 .. S LINE=LINE+1,OFFSET=2 141 .. D SET^IBCNSP(LINE,OFFSET,TEXT) 142 .. S PIDT="" F S PIDT=$O(IBS(DIV,FT,PIDT)) Q:PIDT="" D 143 ... S LINE=LINE+1 144 ... ;S TEXT=$$EXPAND^IBTRE(355.92,.06,PIDT)_" "_IBS(DIV,FT,PIDT),OFFSET=5 145 ... S TEXT=$$GET1^DIQ(355.97,PIDT,.03,"E")_" "_IBS(DIV,FT,PIDT),OFFSET=5 146 ... D SET^IBCNSP(LINE,OFFSET,TEXT) 147 ; 148 ; 149 S LINE=LINE+1 D SET^IBCNSP(LINE,2," ") 150 S LINE=LINE+1 D SET^IBCNSP(LINE,2," ") 151 S OFFSET=2 152 S LINE=LINE+1 D SET^IBCNSP(LINE,OFFSET+25,"ID Parameters",IORVON,IORVOFF) 153 ; 154 S IBCNS4=$G(^DIC(36,IBCNS,4)),IBCNS3=$G(^(3)),OFFSET=1 155 S TEXT="Attending/Rendering Provider Secondary ID Qualifier (1500): "_$$EXPAND^IBTRE(36,4.01,+$P(IBCNS4,U)) 156 S LINE=LINE+1 157 D SET^IBCNSP(LINE,OFFSET,TEXT) 158 ; 159 S TEXT="Attending/Rendering Provider Secondary ID Qualifier (UB-04): "_$$EXPAND^IBTRE(36,4.02,+$P(IBCNS4,U,2)) 160 S LINE=LINE+1 161 D SET^IBCNSP(LINE,OFFSET,TEXT) 162 ; 163 S TEXT="Attending/Rendering Secondary ID Requirement: "_$$EXPAND^IBTRE(36,4.03,+$P(IBCNS4,U,3)) 164 S LINE=LINE+1 165 D SET^IBCNSP(LINE,OFFSET,TEXT) 166 ; 167 S TEXT="Referring Provider Secondary ID Qualifier (1500): "_$$EXPAND^IBTRE(36,4.04,+$P(IBCNS4,U,4)) 168 S LINE=LINE+1 169 D SET^IBCNSP(LINE,OFFSET,TEXT) 170 ; 171 S TEXT="Referring Provider Secondary ID Requirement: "_$$EXPAND^IBTRE(36,4.05,+$P(IBCNS4,U,5)) 172 S LINE=LINE+1 173 D SET^IBCNSP(LINE,OFFSET,TEXT) 174 ; 175 S TEXT="Use Att/Rend ID as Billing Provider Sec. ID (1500): "_$$EXPAND^IBTRE(36,4.06,+$P(IBCNS4,U,6)) 176 S LINE=LINE+1 177 D SET^IBCNSP(LINE,OFFSET,TEXT) 178 ; 179 S TEXT="Use Att/Rend ID as Billing Provider Sec. ID (UB-04): "_$$EXPAND^IBTRE(36,4.08,+$P(IBCNS4,U,8)) 180 S LINE=LINE+1 181 D SET^IBCNSP(LINE,OFFSET,TEXT) 182 ; 183 S TEXT="Send VA Lab/Facility IDs or Facility Data for VAMC?: "_$$EXPAND^IBTRE(36,4.07,+$P(IBCNS4,U,7)) 184 S LINE=LINE+1 185 D SET^IBCNSP(LINE,OFFSET,TEXT) 186 ; 187 S TEXT="Transmit no Billing Provider Sec. ID for the Electronic Plan Types: " 188 S LINE=LINE+1 189 D SET^IBCNSP(LINE,OFFSET,TEXT) 190 ; 191 N TAR,ERR,IBCT 192 D LIST^DIC(36.013,","_IBCNS_",",".01",,10,,,,,,"TAR","ERR") 193 F IBCT=1:1:+$G(TAR("DILIST",0)) D 194 . S TEXT=TAR("DILIST",1,IBCT) 195 . S LINE=LINE+1 196 . D SET^IBCNSP(LINE,OFFSET,TEXT) 197 ; 198 S LINE=LINE+1 D SET^IBCNSP(LINE,2," ") 199 S LINE=LINE+1 D SET^IBCNSP(LINE,2," ") 200 Q 201 ; 202 INSDEF(IBINS,IBPTYP) ; Returns the default id # for an ins co, if possible 203 N X 204 S X="" 205 I IBINS,IBPTYP S X=$P($G(^IBA(355.91,+$O(^IBA(355.91,"AC",IBINS,IBPTYP,"*N/A*","")),0)),U,7) 206 Q X
Note:
See TracChangeset
for help on using the changeset viewer.
