- 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/IBCEP5.m
r613 r623 1 IBCEP5 ;ALB/TMP - EDI UTILITIES for provider ID ;29-SEP-00 2 ;;2.0;INTEGRATED BILLING;**137,232,320,348,349,377**;21-MAR-94;Build 23 3 ;;Per VHA Directive 2004-038, this routine should not be modified. 4 ; 5 EN ; -- main entry point for IBCE PRV MAINT 6 N IBPRV,IBINS 7 EN1 ; Entrypoint for non-VA provider ID maintenance hook 8 N IBSLEV,DIR,Y,X,IBPRMPT,IBNVAFL,IBIF 9 K IBFASTXT 10 S IBIF="" I $G(IBPRV) S IBIF=$$GET1^DIQ(355.93,IBPRV,.02,"I") 11 D FULL^VALM1 12 S IBPRMPT=$S(IBIF=1:"LAB OR FACILITY",1:"PROVIDER") 13 S DIR(0)="SA^1:"_IBPRMPT_"'S OWN IDS;2:"_IBPRMPT_" IDS FURNISHED BY AN INSURANCE COMPANY" 14 S DIR("A")="SELECT SOURCE OF ID: ",DIR("B")=$P($P(DIR(0),":",2),";") 15 W ! D ^DIR K DIR W ! 16 I Y'>0 Q 17 S IBSLEV=+Y 18 D EN^VALM("IBCE PRVPRV MAINT") 19 Q 20 ; 21 HDR ; -- header code 22 N IBC,Z,IBIF 23 S IBIF="" I $G(IBNPRV) S IBIF=$$GET1^DIQ(355.93,IBNPRV,.02,"I") 24 K VALMHDR 25 S IBC=1 26 S IBPRMPT=$S(IBIF=1:"Lab or Facility",1:"Performing Provider") 27 S Z="** "_$S($G(IBSLEV)=1:IBPRMPT_"'s Own IDs (No Specific Insurance Co)",1:IBPRMPT_" IDs from Insurance Co")_" **" 28 S VALMHDR(IBC)=$J("",80-$L(Z)\2)_Z,IBC=IBC+1 29 I $G(IBPRV),'+IBIF S VALMHDR(IBC)="PROVIDER : "_$$EXPAND^IBTRE(355.9,.01,IBPRV)_$S(IBPRV["VA(200":" (VA PROVIDER)",1:" (NON-VA PROVIDER)"),IBC=IBC+1 30 I $G(IBPRV),+IBIF S VALMHDR(IBC)="Provider: "_$$EXPAND^IBTRE(355.9,.01,IBPRV)_$S(IBIF=1:"(Non-VA Lab or Facility)",1:""),IBC=IBC+1 31 I $G(IBINS) D 32 . N PCF,PCDISP 33 . S PCF=$P($G(^DIC(36,+IBINS,3)),"^",13) 34 . S PCDISP=$S($G(IBSLEV)'=2!($G(IBPRV)'["VA(200,"):"",PCF="C":"(Child)",PCF="P":"(Parent)",1:"") 35 . S VALMHDR(IBC)=$S(IBIF:"Insurance Co: ",1:"INSURANCE CO: ")_$P($G(^DIC(36,+IBINS,0)),U)_" "_PCDISP 36 Q 37 ; 38 INIT ; -- init variables and list array 39 N IBFILE,DIR,DIC,Y,X,DTOUT,DUOUT,IBIF,AGAIN 40 ; 41 K ^TMP("IB_EDITED_IDS",$J) ; This will be to keep track of ID's edited during this session 42 S IBIF="" I $G(IBNPRV) S IBIF=$$GET1^DIQ(355.93,IBNPRV,.02,"I") 43 ; 44 ; Removing Care Unit under certain conditions 45 ; This list is used for multiple purposes and not all have Care Units Associated with them 46 ; Also, a different protocol menu is used with these 47 ; IBNPRV is a non VA provider 48 ; IBIF = 1 means this is a group or facility, not an individual. 49 ; 50 I $G(IBNPRV),$G(IBIF)=1 D 51 . S VALM("TITLE")="Secondary Provider ID" 52 . K VALMDDF("CAREUNIT") 53 . I VALMCAP["Care Unit" S VALMCAP=$P(VALMCAP,"Care Unit")_" "_$P(VALMCAP,"Care Unit",2) 54 . K VALM("PROTOCOL") 55 . S Y=$$FIND1^DIC(101,,,"IBCE PRVNVA LOF MAINT") 56 . I Y S VALM("PROTOCOL")=+Y_";ORD(101," 57 ; 58 I $G(IBPRV) S IBFILE="IBA(355.93,",IBPRV=+IBPRV_";"_IBFILE 59 I '$G(IBPRV) D G:$G(VALMQUIT) INITQ 60 . S DIR(0)="SAO^V:VA PROVIDER;N:NON-VA PROVIDER",DIR("A")="(V)A or (N)on-VA provider: ",DIR("B")="V" 61 . D ^DIR K DIR 62 . I "NV"'[Y!(Y="") S VALMQUIT=1 Q 63 . S IBFILE=$S(Y="V":"VA(200,",1:"IBA(355.93,") 64 . S DIC=U_IBFILE,DIC(0)="AEMQ"_$S(IBFILE["355.93":"L",1:"") 65 . S DIC("A")="Select "_$S(IBFILE["355.93":"NON-",1:"")_"V.A. PROVIDER NAME: " 66 . S:IBFILE["355.93" DIC("DR")=".02////2;.03;.04" 67 . F D I $G(IBPRV)!$G(VALMQUIT) K DIC Q 68 .. D ^DIC 69 .. I $D(DTOUT)!$D(DUOUT) S VALMQUIT=1 Q 70 .. I Y'>0 W !,*7,"This is a required response. Enter '^' to exit" Q 71 .. S IBPRV=+Y_";"_IBFILE 72 ; 73 AGAIN I $G(IBSLEV)=2 D G:$G(AGAIN) AGAIN G:$G(VALMQUIT) INITQ 74 . S AGAIN=0 75 . S DIR(0)="PA^DIC(36,:AEMQ",DIR("A")="Select INSURANCE CO: ",DIR("?",1)="Select an INSURANCE CO to display its provider ID's" 76 . D ^DIR K DIR 77 . I $D(DTOUT)!$D(DUOUT) S VALMQUIT=1 Q 78 . S IBINS=$S(Y>0:+Y,1:"NO") 79 . I $G(IBPRV)'["VA(200," Q ; Only VA providers 80 . I $P($G(^DIC(36,+IBINS,3)),"^",13)="C" D S AGAIN=1 Q 81 .. W !,*7,"This is a Child Insurance Company. Editing IDs is not permitted." 82 ; 83 E D 84 . S IBINS="NO" 85 D BLD 86 INITQ Q 87 ; 88 BLD ; Build initial display 89 ; Assumes IBPRV = the variable ptr for prov id file (355.9) 90 ; IBINS = the ien of the ins co or if null, ALL is assumed 91 ; IBSLEV = 1 to display only provider default ids 92 ; = 2 to display all provider/insurance co ids 93 N IB,IBLCT,IBCT,CT,PT,CU,INS,FT,Z,IBENT,IB1,IBIF 94 ; 95 S IBIF="" I $G(IBPRV)[355.93 S IBIF=$$GET1^DIQ(355.93,+IBPRV,.02,"I") 96 ; 97 K ^TMP("IBPRV_",$J),^TMP("IBPRV_SORT",$J) 98 K Z0 99 S (IBENT,IBCT,IBLCT)=0,INS="",IB1=1 100 F S INS=$S($G(IBINS):IBINS,IBSLEV=1:"*ALL*",1:$O(^IBA(355.9,"AUNIQ",IBPRV,INS))) Q:$S(INS="":1,$G(IBINS)!(IBSLEV=1):$D(CU),1:0) S CU="",IB1=0 F S CU=$O(^IBA(355.9,"AUNIQ",IBPRV,INS,CU)) Q:CU="" D 101 . S FT="" F S FT=$O(^IBA(355.9,"AUNIQ",IBPRV,INS,CU,FT)) Q:FT="" S CT="" F S CT=$O(^IBA(355.9,"AUNIQ",IBPRV,INS,CU,FT,CT)) Q:CT="" S PT=0 F S PT=$O(^IBA(355.9,"AUNIQ",IBPRV,INS,CU,FT,CT,PT)) Q:'PT D 102 .. S Z=0 F S Z=$O(^IBA(355.9,"AUNIQ",IBPRV,INS,CU,FT,CT,PT,Z)) Q:'Z S IB=$G(^IBA(355.9,Z,0)) D 103 ... S ^TMP("IBPRV_SORT",$J,$S(INS:$P($G(^DIC(36,+INS,0)),U)_" ",1:" ALL"),PT,FT,CT,CU,Z)=$P(IB,U,7) 104 ; 105 I IBSLEV=1,IBPRV["IBA(355.93",$P($G(^IBA(355.93,+IBPRV,0)),U,12)'="" S ^TMP("IBPRV_SORT",$J," ALL",+$$STLIC^IBCEP8(),0,0,"*N/A*",0)=$P(^IBA(355.93,+IBPRV,0),U,12) 106 S INS="" F S INS=$O(^TMP("IBPRV_SORT",$J,INS)) Q:INS="" D 107 . I '$G(IBINS),'IBIF D:IBLCT SET^VALM10(IBLCT+1," ",IBCT) S IBLCT=$S(IBLCT:IBLCT+2,1:1) D SET^VALM10(IBLCT,"INSURANCE CO: "_$S($E(INS)=" ":"ALL INSURANCE",1:INS),$S(IBCT:IBCT,1:1)) 108 . S PT="" 109 . F S PT=$O(^TMP("IBPRV_SORT",$J,INS,PT)) Q:PT="" S FT="" F S FT=$O(^TMP("IBPRV_SORT",$J,INS,PT,FT)) Q:FT="" S CT="" F S CT=$O(^TMP("IBPRV_SORT",$J,INS,PT,FT,CT)) Q:CT="" D 110 .. S CU="" F S CU=$O(^TMP("IBPRV_SORT",$J,INS,PT,FT,CT,CU)) Q:CU="" S Z="" F S Z=$O(^TMP("IBPRV_SORT",$J,INS,PT,FT,CT,CU,Z)) Q:Z="" S IB=$G(^(Z)) D 111 ... S IBLCT=IBLCT+1,IBCT=IBCT+1 112 ... S Z0=$E(IBCT_" ",1,4)_" "_$E($$EXPAND^IBTRE(355.9,.06,PT)_$S(PT=$$STLIC^IBCEP8():"("_$P($G(^DIC(5,+$P($G(^IBA(355.93,+IBPRV,0)),U,7),0)),U,2)_")",1:"")_$J("",20),1,20)_" "_$S(FT=1:"UB-04",FT=2:"1500 ",1:"BOTH ") 113 ... S Z0=Z0_" "_$E($S(CT=3:"RX",CT=1:"INPT",CT=2:"OUTPT",1:"INPT/OUTPT")_$J("",11),1,11) 114 ... S Z0=Z0_" "_$E($S(CU'="*N/A*":$P($G(^IBA(355.95,+$G(^IBA(355.96,CU,0)),0)),U),1:"")_$J("",15),1,15) I Z0["MEDICINE" X "*" 115 ... D SET^VALM10(IBLCT,Z0_" "_IB,IBCT) 116 ... S ^TMP("IBPRV_",$J,"ZIDX",IBCT)=$S(Z'=0:Z,1:"LIC^"_IBPRV) 117 I IBSLEV=1,IBPRV["VA(200" D 118 . N IBP 119 . S IBP=+IBPRV 120 . Q:'$$GETLIC^IBCEP5D(.IBP) 121 . I IBCT S IBLCT=IBLCT+1 D SET^VALM10(IBLCT," ",IBCT) 122 . S Z=0 F S Z=$O(IBP(Z)) Q:'Z D 123 .. S IBLCT=IBLCT+1,IBCT=IBCT+1 124 .. D SET^VALM10(IBLCT,$E(IBCT_" ",1,4)_$E($P($G(^DIC(5,+Z,0)),U,2)_" STATE LICENSE #"_$J("",20),1,20)_$J("",39)_IBP(Z),IBCT) 125 .. S ^TMP("IBPRV_",$J,"ZIDX",IBCT)="LIC^"_+IBPRV 126 K ^TMP("IBPRV_SORT",$J) 127 ; 128 I IBLCT=0 D G BLDQ ; No entries for ins co selected 129 . D SET^VALM10(1," ") 130 . D SET^VALM10(2," No ID's found for provider "_$S('$G(IBINS):"",1:"and selected insurance co")) 131 . S IBLCT=2 132 ; 133 BLDQ K VALMCNT,VALMBG 134 S VALMCNT=IBLCT,VALMBG=1 135 Q 136 ; 137 HELP ; -- help code 138 S X="?" D DISP^XQORM1 W !! 139 Q 140 ; 141 EXIT ; -- exit code 142 D COPYPROV^IBCEP5A(IBINS) 143 K IBPRV 144 D CLEAN^VALM10 145 K ^TMP("IBPRV_",$J),^TMP("IBPRV_SORT",$J),IBINS,IBALL 146 Q 147 ; 148 EXPND ; -- expand code 149 Q 150 ; 151 SEL(IBDA,MANY) ; Select from provider id list 152 ; IBDA is passed by reference and IBDA(1) returned containing 153 ; ien's of the provider id records selected (file 355.9). 154 ; If > 1 entry can be selected, MANY is set to 1 155 N Z 156 S IBDA=0 157 D EN^VALM2($G(XQORNOD(0)),$S($G(MANY):"",1:"S")) 158 S Z=0 F S Z=$O(VALMY(Z)) Q:'Z S IBDA=IBDA+1,IBDA(IBDA)=$G(^TMP("IBPRV_",$J,"ZIDX",Z)) 159 Q 160 ; 1 IBCEP5 ;ALB/TMP - EDI UTILITIES for provider ID ;29-SEP-00 2 ;;2.0;INTEGRATED BILLING;**137,232,320,348,349**;21-MAR-94;Build 46 3 ;;Per VHA Directive 2004-038, this routine should not be modified. 4 ; 5 EN ; -- main entry point for IBCE PRV MAINT 6 N IBPRV,IBINS 7 EN1 ; Entrypoint for non-VA provider ID maintenance hook 8 N IBSLEV,DIR,Y,X,IBPRMPT,IBNVAFL,IBIF 9 K IBFASTXT 10 S IBIF="" I $G(IBPRV) S IBIF=$$GET1^DIQ(355.93,IBPRV,.02,"I") 11 D FULL^VALM1 12 S IBPRMPT=$S(IBIF=1:"LAB OR FACILITY",1:"PROVIDER") 13 S DIR(0)="SA^1:"_IBPRMPT_"'S OWN IDS;2:"_IBPRMPT_" IDS FURNISHED BY AN INSURANCE COMPANY" 14 S DIR("A")="SELECT SOURCE OF ID: ",DIR("B")=$P($P(DIR(0),":",2),";") 15 W ! D ^DIR K DIR W ! 16 I Y'>0 Q 17 S IBSLEV=+Y 18 D EN^VALM("IBCE PRVPRV MAINT") 19 Q 20 ; 21 HDR ; -- header code 22 N IBC,Z,IBIF 23 S IBIF="" I $G(IBNPRV) S IBIF=$$GET1^DIQ(355.93,IBNPRV,.02,"I") 24 K VALMHDR 25 S IBC=1 26 S IBPRMPT=$S(IBIF=1:"Lab or Facility",1:"Performing Provider") 27 S Z="** "_$S($G(IBSLEV)=1:IBPRMPT_"'s Own IDs (No Specific Insurance Co)",1:IBPRMPT_" IDs from Insurance Co")_" **" 28 S VALMHDR(IBC)=$J("",80-$L(Z)\2)_Z,IBC=IBC+1 29 I $G(IBPRV),'+IBIF S VALMHDR(IBC)="PROVIDER : "_$$EXPAND^IBTRE(355.9,.01,IBPRV)_$S(IBPRV["VA(200":" (VA PROVIDER)",1:" (NON-VA PROVIDER)"),IBC=IBC+1 30 I $G(IBPRV),+IBIF S VALMHDR(IBC)="Provider: "_$$EXPAND^IBTRE(355.9,.01,IBPRV)_$S(IBIF=1:"(Non-VA Lab or Facility)",1:""),IBC=IBC+1 31 I $G(IBINS) D 32 . N PCF,PCDISP 33 . S PCF=$P($G(^DIC(36,+IBINS,3)),"^",13) 34 . S PCDISP=$S($G(IBSLEV)'=2!($G(IBPRV)'["VA(200,"):"",PCF="C":"(Child)",PCF="P":"(Parent)",1:"") 35 . S VALMHDR(IBC)=$S(IBIF:"Insurance Co: ",1:"INSURANCE CO: ")_$P($G(^DIC(36,+IBINS,0)),U)_" "_PCDISP 36 Q 37 ; 38 INIT ; -- init variables and list array 39 N IBFILE,DIR,DIC,Y,X,DTOUT,DUOUT,IBIF,AGAIN 40 ; 41 K ^TMP("IB_EDITED_IDS",$J) ; This will be to keep track of ID's edited during this session 42 S IBIF="" I $G(IBNPRV) S IBIF=$$GET1^DIQ(355.93,IBNPRV,.02,"I") 43 ; 44 ; Removing Care Unit under certain conditions 45 ; This list is used for multiple purposes and not all have Care Units Associated with them 46 ; Also, a different protocol menu is used with these 47 ; IBNPRV is a non VA provider 48 ; IBIF = 1 means this is a group or facility, not an individual. 49 ; 50 I $G(IBNPRV),$G(IBIF)=1 D 51 . S VALM("TITLE")="Secondary Provider ID" 52 . K VALMDDF("CAREUNIT") 53 . I VALMCAP["Care Unit" S VALMCAP=$P(VALMCAP,"Care Unit")_" "_$P(VALMCAP,"Care Unit",2) 54 . K VALM("PROTOCOL") 55 . S Y=$$FIND1^DIC(101,,,"IBCE PRVNVA LOF MAINT") 56 . I Y S VALM("PROTOCOL")=+Y_";ORD(101," 57 ; 58 I $G(IBPRV) S IBFILE="IBA(355.93,",IBPRV=+IBPRV_";"_IBFILE 59 I '$G(IBPRV) D G:$G(VALMQUIT) INITQ 60 . S DIR(0)="SAO^V:VA PROVIDER;N:NON-VA PROVIDER",DIR("A")="(V)A or (N)on-VA provider: ",DIR("B")="V" 61 . D ^DIR K DIR 62 . I "NV"'[Y!(Y="") S VALMQUIT=1 Q 63 . S IBFILE=$S(Y="V":"VA(200,",1:"IBA(355.93,") 64 . S DIC=U_IBFILE,DIC(0)="AEMQ"_$S(IBFILE["355.93":"L",1:"") 65 . S DIC("A")="Select "_$S(IBFILE["355.93":"NON-",1:"")_"V.A. PROVIDER NAME: " 66 . S:IBFILE["355.93" DIC("DR")=".02////2;.03;.04" 67 . F D I $G(IBPRV)!$G(VALMQUIT) K DIC Q 68 .. D ^DIC 69 .. I $D(DTOUT)!$D(DUOUT) S VALMQUIT=1 Q 70 .. I Y'>0 W !,*7,"This is a required response. Enter '^' to exit" Q 71 .. S IBPRV=+Y_";"_IBFILE 72 ; 73 AGAIN I $G(IBSLEV)=2 D G:$G(AGAIN) AGAIN G:$G(VALMQUIT) INITQ 74 . S AGAIN=0 75 . S DIR(0)="PA^DIC(36,:AEMQ",DIR("A")="Select INSURANCE CO: ",DIR("?",1)="Select an INSURANCE CO to display its provider ID's" 76 . D ^DIR K DIR 77 . I $D(DTOUT)!$D(DUOUT) S VALMQUIT=1 Q 78 . S IBINS=$S(Y>0:+Y,1:"NO") 79 . I $G(IBPRV)'["VA(200," Q ; Only VA providers 80 . I $P($G(^DIC(36,+IBINS,3)),"^",13)="C" D S AGAIN=1 Q 81 .. W !,*7,"This is a Child Insurance Company. Editing IDs is not permitted." 82 ; 83 E D 84 . S IBINS="NO" 85 D BLD 86 INITQ Q 87 ; 88 BLD ; Build initial display 89 ; Assumes IBPRV = the variable ptr for prov id file (355.9) 90 ; IBINS = the ien of the ins co or if null, ALL is assumed 91 ; IBSLEV = 1 to display only provider default ids 92 ; = 2 to display all provider/insurance co ids 93 N IB,IBLCT,IBCT,CT,PT,CU,INS,FT,Z,IBENT,IB1,IBIF 94 ; 95 S IBIF="" I $G(IBPRV)[355.93 S IBIF=$$GET1^DIQ(355.93,+IBPRV,.02,"I") 96 ; 97 K ^TMP("IBPRV_",$J),^TMP("IBPRV_SORT",$J) 98 K Z0 99 S (IBENT,IBCT,IBLCT)=0,INS="",IB1=1 100 F S INS=$S($G(IBINS):IBINS,IBSLEV=1:"*ALL*",1:$O(^IBA(355.9,"AUNIQ",IBPRV,INS))) Q:$S(INS="":1,$G(IBINS)!(IBSLEV=1):$D(CU),1:0) S CU="",IB1=0 F S CU=$O(^IBA(355.9,"AUNIQ",IBPRV,INS,CU)) Q:CU="" D 101 . S FT="" F S FT=$O(^IBA(355.9,"AUNIQ",IBPRV,INS,CU,FT)) Q:FT="" S CT="" F S CT=$O(^IBA(355.9,"AUNIQ",IBPRV,INS,CU,FT,CT)) Q:CT="" S PT=0 F S PT=$O(^IBA(355.9,"AUNIQ",IBPRV,INS,CU,FT,CT,PT)) Q:'PT D 102 .. S Z=0 F S Z=$O(^IBA(355.9,"AUNIQ",IBPRV,INS,CU,FT,CT,PT,Z)) Q:'Z S IB=$G(^IBA(355.9,Z,0)) D 103 ... S ^TMP("IBPRV_SORT",$J,$S(INS:$P($G(^DIC(36,+INS,0)),U)_" ",1:" ALL"),PT,FT,CT,CU,Z)=$P(IB,U,7) 104 ; 105 I IBSLEV=1,IBPRV["IBA(355.93",$P($G(^IBA(355.93,+IBPRV,0)),U,12)'="" S ^TMP("IBPRV_SORT",$J," ALL",+$$STLIC^IBCEP8(),0,0,"*N/A*",0)=$P(^IBA(355.93,+IBPRV,0),U,12) 106 S INS="" F S INS=$O(^TMP("IBPRV_SORT",$J,INS)) Q:INS="" D 107 . I '$G(IBINS),'IBIF D:IBLCT SET^VALM10(IBLCT+1," ",IBCT) S IBLCT=$S(IBLCT:IBLCT+2,1:1) D SET^VALM10(IBLCT,"INSURANCE CO: "_$S($E(INS)=" ":"ALL INSURANCE",1:INS),$S(IBCT:IBCT,1:1)) 108 . S PT="" 109 . F S PT=$O(^TMP("IBPRV_SORT",$J,INS,PT)) Q:PT="" S FT="" F S FT=$O(^TMP("IBPRV_SORT",$J,INS,PT,FT)) Q:FT="" S CT="" F S CT=$O(^TMP("IBPRV_SORT",$J,INS,PT,FT,CT)) Q:CT="" D 110 .. S CU="" F S CU=$O(^TMP("IBPRV_SORT",$J,INS,PT,FT,CT,CU)) Q:CU="" S Z="" F S Z=$O(^TMP("IBPRV_SORT",$J,INS,PT,FT,CT,CU,Z)) Q:Z="" S IB=$G(^(Z)) D 111 ... S IBLCT=IBLCT+1,IBCT=IBCT+1 112 ... S Z0=$E(IBCT_" ",1,4)_" "_$E($$EXPAND^IBTRE(355.9,.06,PT)_$S(PT=$$STLIC^IBCEP8():"("_$P($G(^DIC(5,+$P($G(^IBA(355.93,+IBPRV,0)),U,7),0)),U,2)_")",1:"")_$J("",20),1,20)_" "_$S(FT=1:"UB-04",FT=2:"1500 ",1:"BOTH ") 113 ... S Z0=Z0_" "_$E($S(CT=3:"RX",CT=1:"INPT",CT=2:"OUTPT",1:"INPT/OUTPT")_$J("",11),1,11) 114 ... S Z0=Z0_" "_$E($S(CU'="*N/A*":$P($G(^IBA(355.95,+$G(^IBA(355.96,CU,0)),0)),U),1:"")_$J("",15),1,15) I Z0["MEDICINE" X "*" 115 ... D SET^VALM10(IBLCT,Z0_" "_IB,IBCT) 116 ... S ^TMP("IBPRV_",$J,"ZIDX",IBCT)=$S(Z'=0:Z,1:"LIC^"_IBPRV) 117 I IBSLEV=1,IBPRV["VA(200" D 118 . N IBP 119 . S IBP=+IBPRV 120 . Q:'$$GETLIC^IBCEP5D(.IBP) 121 . I IBCT S IBLCT=IBLCT+1 D SET^VALM10(IBLCT," ",IBCT) 122 . S Z=0 F S Z=$O(IBP(Z)) Q:'Z D 123 .. S IBLCT=IBLCT+1,IBCT=IBCT+1 124 .. D SET^VALM10(IBLCT,$E(IBCT_" ",1,4)_$E($P($G(^DIC(5,+Z,0)),U,2)_" STATE LICENSE #"_$J("",20),1,20)_$J("",39)_IBP(Z),IBCT) 125 .. S ^TMP("IBPRV_",$J,"ZIDX",IBCT)="LIC^"_+IBPRV 126 K ^TMP("IBPRV_SORT",$J) 127 ; 128 I IBLCT=0 D G BLDQ ; No entries for ins co selected 129 . D SET^VALM10(1," ") 130 . D SET^VALM10(2," No ID's found for provider "_$S('$G(IBINS):"",1:"and selected insurance co")) 131 . S IBLCT=2 132 ; 133 BLDQ K VALMCNT,VALMBG 134 S VALMCNT=IBLCT,VALMBG=1 135 Q 136 ; 137 HELP ; -- help code 138 S X="?" D DISP^XQORM1 W !! 139 Q 140 ; 141 EXIT ; -- exit code 142 K IBFASTXT 143 D COPYPROV^IBCEP5A(IBINS) 144 K IBPRV 145 D CLEAN^VALM10 146 K ^TMP("IBPRV_",$J),^TMP("IBPRV_SORT",$J),IBINS,IBALL 147 Q 148 ; 149 EXPND ; -- expand code 150 Q 151 ; 152 SEL(IBDA,MANY) ; Select from provider id list 153 ; IBDA is passed by reference and IBDA(1) returned containing 154 ; ien's of the provider id records selected (file 355.9). 155 ; If > 1 entry can be selected, MANY is set to 1 156 N Z 157 S IBDA=0 158 D EN^VALM2($G(XQORNOD(0)),$S($G(MANY):"",1:"S")) 159 S Z=0 F S Z=$O(VALMY(Z)) Q:'Z S IBDA=IBDA+1,IBDA(IBDA)=$G(^TMP("IBPRV_",$J,"ZIDX",Z)) 160 Q 161 ;
Note:
See TracChangeset
for help on using the changeset viewer.
