- 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/IBCEP0.m
r613 r623 1 IBCEP0 ;ALB/TMP - Functions for PROVIDER ID MAINTENANCE ;13-DEC-99 2 ;;2.0;INTEGRATED BILLING;**137,191,239,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 INS ID 6 N IBINS,IBDSP,IBSORT,IBPRV ; Variables should be available throughout actions 7 K IBFASTXT 8 D FULL^VALM1 9 D EN^VALM("IBCE PRVINS ID") 10 Q 11 ; 12 EN1(IBINS) ; Entrypoint from insurance co maintenance 13 N IBDSP,IBSORT ; Variables should be available throughout actions 14 D FULL^VALM1 15 D EN^VALM("IBCE PRVINS ID FROM INS MAINT") 16 Q 17 ; 18 HDR ; -- header code 19 N Z,Z0,Z1,IBCT,IBPPTYP,IBEMCTYP 20 S IBCT=1 21 K VALMHDR 22 I $G(IBINS) D 23 . N PCF,PCDISP 24 . S PCF=$P($G(^DIC(36,+IBINS,3)),U,13) 25 . S PCDISP=$S(PCF="C":"(Child)",PCF="P":"(Parent)",1:"") 26 . S VALMHDR(1)="Insurance Co: "_$P($G(^DIC(36,+IBINS,0)),U)_" "_PCDISP 27 . ; Get performing provider id type for insurance co 28 . S IBPPTYP=$$PPTYP(IBINS) 29 . ; Get ien of EMC ID from file 355.97 30 . S IBEMCTYP=+$$EMCID^IBCEP() 31 . I $G(IBSORT)="ALL"!($G(IBDSP)="I")!($G(IBSORT)=IBPPTYP)!($G(IBSORT)=IBEMCTYP) D 32 .. ; Look for care unit in either of these id types - if there, report on line 2 of header 33 .. I $G(IBSORT)=IBPPTYP S IBEMCTYP=0 34 .. I $G(IBSORT)=IBEMCTYP S IBPPTYP=0 35 .. F Z0=IBPPTYP_"P",IBEMCTYP_"E" S Z1="" F S Z1=$O(^IBA(355.96,"D",+IBINS,+Z0,Z1)) Q:Z1="" I Z1'="*N/A*" S Z($E(Z0,$L(Z0)))=1 Q 36 .. I $D(Z("P"))!$D(Z("E")) D 37 ... S IBCT=IBCT+1 38 ... S VALMHDR(IBCT)=" "_$S($D(Z("P")):"PERFORMING PROV ID"_$S($D(Z("E")):" AND ",1:""),1:"")_$S($D(Z("E")):"EMC PROV ID",1:"")_" MAY REQUIRE CARE UNIT" 39 . I $D(Z("P"))!$D(Z("E")) S IBCT=IBCT+1,VALMHDR(IBCT)=" " 40 . S IBCT=IBCT+1,VALMHDR(IBCT)=" PROVIDER "_$S($G(IBDSP)="I":"ID TYPE",1:"NAME ")_$J("",6)_"FORM CARE TYPE CARE UNIT ID#" 41 Q 42 ; 43 INIT ; Initialization 44 K ^TMP("IB_EDITED_IDS",$J) ; This will be to keep track of ID's edited during this session 45 D INSID(.IBINS,.IBDSP,.IBSORT) 46 I $G(IBDSP)="I",$G(IBSORT) S IBPRV=IBSORT 47 I '$G(IBINS) S VALMQUIT=1 48 Q 49 ; 50 INSID(IBINS,IBDSP,IBSORT) ; 51 N DIC,DIR,DA,X,Y,IBOK,DTOUT,DUOUT 52 S IBOK=1 53 I '$G(IBINS) D 54 . S DIC(0)="AEMQ",DIC="^DIC(36," D ^DIC 55 . I Y'>0 S IBOK=0 Q 56 . S IBINS=+Y 57 I '$G(IBINS) S IBOK=0 58 I 'IBOK G INSIDQ 59 ; 60 S DIR(0)="SA^D:INSURANCE CO DEFAULT IDS;I:INDIVIDUAL PROVIDER IDS FURNISHED BY THE INS CO;A:ALL IDS FURNISHED BY THE INS CO BY PROVIDER TYPE" 61 S DIR("A")="SELECT DISPLAY CONTENT: ",DIR("B")="A" 62 S DIR("?",1)="(D) DISPLAY CONTAINS ONLY THOSE IDS ASSIGNED AS DEFAULTS TO THE FACILITY BY",DIR("?",2)=" THE INSURANCE COMPANY" 63 S DIR("?",3)="(I) DISPLAY CONTAINS ONLY THOSE IDS ASSIGNED TO INDIVIDUAL PROVIDERS BY THE",DIR("?",4)=" INSURANCE COMPANY" 64 S DIR("?",5)="(A) DISPLAY CONTAINS ALL IDS ASSIGNED BY THE INSURANCE COMPANY FOR ONE OR ALL",DIR("?")=" PROVIDER ID TYPES" 65 W ! D ^DIR K DIR W ! 66 I $D(DTOUT)!$D(DUOUT)!("DIA"'[Y) S IBOK=0 G INSIDQ 67 S IBDSP=Y,IBSORT="" 68 I IBDSP="A"!(IBDSP="I") F D Q:'IBOK!(IBSORT'="") 69 . ; 70 . I IBDSP="A" D 71 .. S DIR("A")="Display only IDs with a specific ID Qualifier?: " 72 .. S DIR("?",1)="Answer Yes to select a specific ID Qualifier by which to display IDs." 73 .. S DIR("?")="Answer No to display all IDs." 74 .. Q 75 . ; 76 . I IBDSP="I" D 77 .. S DIR("A")="Display IDs for a specific Provider?: " 78 .. S DIR("?",1)="Answer Yes to select a specific Provider." 79 .. S DIR("?")="Answer No to display all Providers." 80 .. Q 81 . ; 82 . S DIR("B")="NO",DIR(0)="YA" 83 . W ! D ^DIR K DIR W ! 84 . I $D(DTOUT)!$D(DUOUT) S IBOK=0 Q 85 . I Y'=1 S IBSORT="ALL" Q 86 . ; 87 . I IBDSP="A" D Q 88 .. S DIC(0)="AEMQ",DIC="^IBE(355.97,",DIC("S")="I $S('$P(^(0),U,2):1,1:$P(^(0),U,2)=3)" 89 .. S DIC("A")="Select type of ID Qualifier: " 90 .. D ^DIC K DIC 91 .. I Y>0 S IBSORT=+Y Q 92 .. I $D(DTOUT)!$D(DUOUT) S IBOK=0 93 . ; 94 . I IBDSP="I" D Q 95 .. N DA 96 .. S DIR(0)="399.0222,.02A",DIR("A")="SELECT PROVIDER: " 97 .. W ! D ^DIR K DIR W ! 98 .. I Y>0 S IBSORT=Y Q 99 .. I $D(DTOUT)!$D(DUOUT) S IBOK=0 Q 100 . S IBOK=0 Q 101 ; 102 G:'IBOK INSIDQ 103 D BLD(IBINS,IBDSP,IBSORT) 104 INSIDQ I 'IBOK S VALMQUIT=1 105 Q 106 ; 107 BLD(IBINS,IBDSP,IBSORT) ; Build display for Insurance co level provider ID's 108 N IB,IBENT,IBLCT,IBCT,IBPRV,IBSRT1,IBSRT2,IBOSRT1,IBOSRT2,CU,FT,PT,CT,Z,Z0 109 K ^TMP("IBPRV_INS_ID",$J),^TMP("IBPRV_INS_SORT",$J) 110 ; 111 S (IBENT,IBCT,IBLCT)=0 112 ; 113 I "DA"[$G(IBDSP) D 114 . S CU="" F S CU=$O(^IBA(355.91,"AUNIQ",IBINS,CU)) Q:CU="" S FT="" F S FT=$O(^IBA(355.91,"AUNIQ",IBINS,CU,FT)) Q:FT="" D 115 .. S CT="" F S CT=$O(^IBA(355.91,"AUNIQ",IBINS,CU,FT,CT)) Q:CT="" S PT=0 F S PT=$S(IBDSP="A"&IBSORT:IBSORT,1:$O(^IBA(355.91,"AUNIQ",IBINS,CU,FT,CT,PT))) Q:'PT D Q:IBDSP="A"&IBSORT 116 ... S Z=0 F S Z=$O(^IBA(355.91,"AUNIQ",IBINS,CU,FT,CT,PT,Z)) Q:'Z S IB=$G(^IBA(355.91,Z,0)) S ^TMP("IBPRV_INS_SORT",$J,PT,"^<<INS CO DEFAULT>>",FT,CT,CU,Z)=$P(IB,U,7)_U 117 ; 118 I "IA"[$G(IBDSP) D 119 . S IBPRV="" 120 . N IB1,IB2 121 . F S IBPRV=$O(^IBA(355.9,"AE",IBINS,IBPRV)) Q:'IBPRV S Z=0 F S Z=$O(^IBA(355.9,"AE",IBINS,IBPRV,Z)) Q:'Z S IB=$G(^IBA(355.9,Z,0)) D 122 .. Q:$P(IB,U,4)=""!($P(IB,U,5)="")!($P(IB,U,6)="")!($P(IB,U,16)="") 123 .. I IBSORT,$S(IBDSP="I":IBPRV'=IBSORT,1:$P(IB,U,6)'=IBSORT) Q 124 .. S IB1=$S(IBDSP="A":$P(IB,U,6),1:U_$$EXPAND^IBTRE(355.9,.01,IBPRV)_U_IBPRV) 125 .. S IB2=$S(IBDSP="I":$P(IB,U,6),1:U_$$EXPAND^IBTRE(355.9,.01,IBPRV)_U_IBPRV) 126 .. S ^TMP("IBPRV_INS_SORT",$J,IB1,IB2,$P(IB,U,4),$P(IB,U,5),$P(IB,U,16),Z)=$P(IB,U,7)_U_IBPRV 127 ; 128 S IBOSRT1="" 129 S IBSRT1="" F S IBSRT1=$O(^TMP("IBPRV_INS_SORT",$J,IBSRT1)) Q:IBSRT1="" D 130 . S IBSRT2="",IBOSRT2="" 131 . F S IBSRT2=$O(^TMP("IBPRV_INS_SORT",$J,IBSRT1,IBSRT2)) Q:IBSRT2="" D 132 .. I IBOSRT1'=IBSRT1 D 133 ... I IBOSRT1'="" S IBLCT=IBLCT+1 D SET^VALM10(IBLCT," ",IBCT+1) 134 ... S IBLCT=IBLCT+1 D SET^VALM10(IBLCT,$S(IBDSP'="I":"ID Qualifier",1:"Provider")_": "_$S(IBDSP'="I":$$EXPAND^IBTRE(355.91,.06,IBSRT1),1:$P(IBSRT1,U,2_$S($P(IBSRT2,U,3)["VA(200":" (VA)",1:"(NON-VA)"))),IBCT+1) 135 ... S IBOSRT1=IBSRT1 136 .. ; 137 .. S FT="" F S FT=$O(^TMP("IBPRV_INS_SORT",$J,IBSRT1,IBSRT2,FT)) Q:FT="" S CT="" F S CT=$O(^TMP("IBPRV_INS_SORT",$J,IBSRT1,IBSRT2,FT,CT)) Q:CT="" D 138 ... S CU="" F S CU=$O(^TMP("IBPRV_INS_SORT",$J,IBSRT1,IBSRT2,FT,CT,CU)) Q:CU="" S Z=0 F S Z=$O(^TMP("IBPRV_INS_SORT",$J,IBSRT1,IBSRT2,FT,CT,CU,Z)) Q:'Z S IB=$G(^(Z)) D 139 .... S IBLCT=IBLCT+1,IBCT=IBCT+1 140 .... S Z0=$E(IBCT_$J("",4),1,4)_" " 141 .... I IBDSP'="I" S Z0=Z0_$E($S(IBOSRT2'=IBSRT2:$P(IBSRT2,U,2),1:"")_$J("",20),1,20) 142 .... I IBDSP="I" S Z0=Z0_$E($S(IBOSRT2'=IBSRT2:$$EXPAND^IBTRE(355.9,.06,IBSRT2),1:"")_$J("",20),1,20) 143 .... S IBOSRT2=IBSRT2 144 .... S Z0=Z0_" "_$S(FT=1:"UB-04",FT=2:"1500 ",1:"BOTH ")_" "_$E($S(CT=3:"RX",CT=1:"INPT",CT=2:"OUTPT",1:"INPT/OUTPT")_$J("",11),1,11)_" "_$E($S(CU'="*N/A*":$P($G(^IBA(355.95,+$P($G(^IBA(355.96,+CU,0)),U),0)),U),1:"")_$J("",15),1,15) 145 .... D SET^VALM10(IBLCT,Z0_" "_$P(IB,U),IBCT) 146 .... S ^TMP("IBPRV_INS_ID",$J,"ZIDX",IBCT)=Z,^(IBCT,"PRV")=$P(IB,U,2) 147 .... I '$D(^TMP("IBPRV_INS_ID",$J,$S(IBDSP="I":"ZXPRV",1:"ZXPTYP"),IBSRT1)) S ^(IBSRT1)=IBLCT-1 148 K ^TMP("IBPRV_INS_SORT",$J) 149 ; 150 I IBLCT=0 D G BLDQ ; No entries found 151 . D SET^VALM10(1," ") 152 . S Z=" No "_$S(IBDSP="D":"default ",1:"") 153 . S Z=Z_"ID's found for "_$S(IBDSP="I":"provider "_$S(IBSORT:"("_$$EXPAND^IBTRE(355.9,.01,IBSORT)_") ",1:"")_"and ",IBDSP="A":"provider type "_$S(IBSORT:"("_$$EXPAND^IBTRE(355.9,.06,IBSORT)_") ",1:"")_"and ",1:"")_"insurance co" 154 . D SET^VALM10(2,Z) 155 . S IBLCT=2 156 ; 157 BLDQ S VALMCNT=IBLCT,VALMBG=1 158 Q 159 ; 160 EXPND ; 161 Q 162 ; 163 HELP ; 164 Q 165 ; 166 EXIT ; 167 K IBFASTXT 168 D COPYPROV^IBCEP5A(IBINS) 169 K ^TMP("IBPRV_INS_ID",$J) 170 D CLEAN^VALM10 171 Q 172 ; 173 SEL(IBDA,MANY) ; Select from provider id list 174 ; IBDA is passed by reference and IBDA(1) returned containing 175 ; ien's of the provider id records selected (file 355.9). 176 ; If > 1 entry can be selected, MANY is set to 1 177 N Z 178 S IBDA=0 179 D EN^VALM2($G(XQORNOD(0)),$S($G(MANY):"",1:"S")) 180 S Z=0 F S Z=$O(VALMY(Z)) Q:'Z S IBDA=IBDA+1,IBDA(IBDA)=+$G(^TMP("IBPRV_INS_ID",$J,"ZIDX",Z))_U_$G(^(Z,"PRV")) 181 Q 182 ; 183 ENX(IBINS1) ; Insurance co level defaults for all providers or 184 ; for all providers by care unit 185 N DIC,DIE,DR,DA,X,Y,DLAYGO 186 I '$G(IBINS1) D G:'$G(IBINS1) ENQ 187 . S DIC="^IBA(355.91,",DIC(0)="AELMQ",DLAYGO=355.91 D ^DIC 188 . I Y>0 S IBINS1=+Y 189 S DIE="^IBA(355.91,",DA=IBINS1,DR=".01;.06;.04;.05;.03;.07" D ^DIE 190 ; 191 ENQ Q 192 ; 193 PPTYP(IBINS) ; Returns the ien of the default performing provider type for 194 ; insurance company IBINS (ien file 36) 195 Q +$G(^DIC(36,+IBINS,4)) 196 ; 197 SCREEN(WHICH) ; This screen is used the menu protocol to screen out the ID functions if it is a child ins co 198 Q:'$G(DA) 0 199 Q:'$G(DA(1)) 0 200 N FILE,IENS,FIELD,FLAG,TARGET 201 S FILE=101.01,IENS=DA_","_DA(1),FIELD=".01",FLAG="I" 202 D GETS^DIQ(FILE,IENS,FIELD,FLAG,"TARGET") 203 Q:'$D(TARGET) 0 204 N IEN 205 S IEN=$G(TARGET(FILE,IENS_",",FIELD,FLAG)) 206 Q:'+IEN 0 207 S FILE=101,FIELD=1,FLAG="E" 208 K TARGET 209 D GETS^DIQ(FILE,IEN,FIELD,FLAG,"TARGET") 210 Q:'$D(TARGET) 0 211 I $G(TARGET(FILE,IEN_",",FIELD,FLAG))'[WHICH Q 1 212 Q:'$G(IBINS) 0 213 N PCF 214 S PCF=$P($G(^DIC(36,+IBINS,3)),U,13) 215 I PCF="C" Q 0 216 Q 1 1 IBCEP0 ;ALB/TMP - Functions for PROVIDER ID MAINTENANCE ;13-DEC-99 2 ;;2.0;INTEGRATED BILLING;**137,191,239,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 INS ID 6 N IBINS,IBDSP,IBSORT,IBPRV ; Variables should be available throughout actions 7 K IBFASTXT 8 D FULL^VALM1 9 D EN^VALM("IBCE PRVINS ID") 10 Q 11 ; 12 EN1(IBINS) ; Entrypoint from insurance co maintenance 13 N IBDSP,IBSORT ; Variables should be available throughout actions 14 D FULL^VALM1 15 D EN^VALM("IBCE PRVINS ID FROM INS MAINT") 16 Q 17 ; 18 HDR ; -- header code 19 N Z,Z0,Z1,IBCT,IBPPTYP,IBEMCTYP 20 S IBCT=1 21 K VALMHDR 22 I $G(IBINS) D 23 . N PCF,PCDISP 24 . S PCF=$P($G(^DIC(36,+IBINS,3)),U,13) 25 . S PCDISP=$S(PCF="C":"(Child)",PCF="P":"(Parent)",1:"") 26 . S VALMHDR(1)="Insurance Co: "_$P($G(^DIC(36,+IBINS,0)),U)_" "_PCDISP 27 . ; Get performing provider id type for insurance co 28 . S IBPPTYP=$$PPTYP(IBINS) 29 . ; Get ien of EMC ID from file 355.97 30 . S IBEMCTYP=+$$EMCID^IBCEP() 31 . I $G(IBSORT)="ALL"!($G(IBDSP)="I")!($G(IBSORT)=IBPPTYP)!($G(IBSORT)=IBEMCTYP) D 32 .. ; Look for care unit in either of these id types - if there, report on line 2 of header 33 .. I $G(IBSORT)=IBPPTYP S IBEMCTYP=0 34 .. I $G(IBSORT)=IBEMCTYP S IBPPTYP=0 35 .. F Z0=IBPPTYP_"P",IBEMCTYP_"E" S Z1="" F S Z1=$O(^IBA(355.96,"D",+IBINS,+Z0,Z1)) Q:Z1="" I Z1'="*N/A*" S Z($E(Z0,$L(Z0)))=1 Q 36 .. I $D(Z("P"))!$D(Z("E")) D 37 ... S IBCT=IBCT+1 38 ... S VALMHDR(IBCT)=" "_$S($D(Z("P")):"PERFORMING PROV ID"_$S($D(Z("E")):" AND ",1:""),1:"")_$S($D(Z("E")):"EMC PROV ID",1:"")_" MAY REQUIRE CARE UNIT" 39 . I $D(Z("P"))!$D(Z("E")) S IBCT=IBCT+1,VALMHDR(IBCT)=" " 40 . S IBCT=IBCT+1,VALMHDR(IBCT)=" PROVIDER "_$S($G(IBDSP)="I":"ID TYPE",1:"NAME ")_$J("",6)_"FORM CARE TYPE CARE UNIT ID#" 41 Q 42 ; 43 INIT ; Initialization 44 K ^TMP("IB_EDITED_IDS",$J) ; This will be to keep track of ID's edited during this session 45 D INSID(.IBINS,.IBDSP,.IBSORT) 46 I $G(IBDSP)="I",$G(IBSORT) S IBPRV=IBSORT 47 I '$G(IBINS) S VALMQUIT=1 48 Q 49 ; 50 INSID(IBINS,IBDSP,IBSORT) ; 51 N DIC,DIR,DA,X,Y,IBOK,DTOUT,DUOUT 52 S IBOK=1 53 I '$G(IBINS) D 54 . S DIC(0)="AEMQ",DIC="^DIC(36," D ^DIC 55 . I Y'>0 S IBOK=0 Q 56 . S IBINS=+Y 57 I '$G(IBINS) S IBOK=0 58 I 'IBOK G INSIDQ 59 ; 60 S DIR(0)="SA^D:INSURANCE CO DEFAULT IDS;I:INDIVIDUAL PROVIDER IDS FURNISHED BY THE INS CO;A:ALL IDS FURNISHED BY THE INS CO BY PROVIDER TYPE" 61 S DIR("A")="SELECT DISPLAY CONTENT: ",DIR("B")="A" 62 S DIR("?",1)="(D) DISPLAY CONTAINS ONLY THOSE IDS ASSIGNED AS DEFAULTS TO THE FACILITY BY",DIR("?",2)=" THE INSURANCE COMPANY" 63 S DIR("?",3)="(I) DISPLAY CONTAINS ONLY THOSE IDS ASSIGNED TO INDIVIDUAL PROVIDERS BY THE",DIR("?",4)=" INSURANCE COMPANY" 64 S DIR("?",5)="(A) DISPLAY CONTAINS ALL IDS ASSIGNED BY THE INSURANCE COMPANY FOR ONE OR ALL",DIR("?")=" PROVIDER ID TYPES" 65 W ! D ^DIR K DIR W ! 66 I $D(DTOUT)!$D(DUOUT)!("DIA"'[Y) S IBOK=0 G INSIDQ 67 S IBDSP=Y,IBSORT="" 68 I IBDSP="A"!(IBDSP="I") F D Q:'IBOK!(IBSORT'="") 69 . N Z 70 . S Z=$S(IBDSP="I":"",1:" ID TYPE") 71 . S DIR("A")="DO YOU WANT TO DISPLAY IDS FOR A SPECIFIC PROVIDER"_Z_"?: ",DIR("B")="NO",DIR(0)="YA" 72 . S DIR("?",1)="IF YOU ANSWER YES TO THIS QUESTION, YOU MAY SELECT A SPECIFIC PROVIDER"_Z,DIR("?")=" TO DISPLAY, OTHERWISE, ALL PROVIDER"_Z_"S FOUND WILL BE DISPLAYED" 73 . W ! D ^DIR K DIR W ! 74 . I $D(DTOUT)!$D(DUOUT) S IBOK=0 Q 75 . I Y'=1 S IBSORT="ALL" Q 76 . ; 77 . I IBDSP="A" D Q 78 .. S DIC(0)="AEMQ",DIC="^IBE(355.97,",DIC("S")="I $S('$P(^(0),U,2):1,1:$P(^(0),U,2)=3)" D ^DIC K DIC 79 .. I Y>0 S IBSORT=+Y Q 80 .. I $D(DTOUT)!$D(DUOUT) S IBOK=0 81 . ; 82 . I IBDSP="I" D Q 83 .. N DA 84 .. S DIR(0)="399.0222,.02A",DIR("A")="SELECT PROVIDER: " 85 .. W ! D ^DIR K DIR W ! 86 .. I Y>0 S IBSORT=Y Q 87 .. I $D(DTOUT)!$D(DUOUT) S IBOK=0 Q 88 . S IBOK=0 Q 89 ; 90 G:'IBOK INSIDQ 91 D BLD(IBINS,IBDSP,IBSORT) 92 INSIDQ I 'IBOK S VALMQUIT=1 93 Q 94 ; 95 BLD(IBINS,IBDSP,IBSORT) ; Build display for Insurance co level provider ID's 96 N IB,IBENT,IBLCT,IBCT,IBPRV,IBSRT1,IBSRT2,IBOSRT1,IBOSRT2,CU,FT,PT,CT,Z,Z0 97 K ^TMP("IBPRV_INS_ID",$J),^TMP("IBPRV_INS_SORT",$J) 98 ; 99 S (IBENT,IBCT,IBLCT)=0 100 ; 101 I "DA"[$G(IBDSP) D 102 . S CU="" F S CU=$O(^IBA(355.91,"AUNIQ",IBINS,CU)) Q:CU="" S FT="" F S FT=$O(^IBA(355.91,"AUNIQ",IBINS,CU,FT)) Q:FT="" D 103 .. S CT="" F S CT=$O(^IBA(355.91,"AUNIQ",IBINS,CU,FT,CT)) Q:CT="" S PT=0 F S PT=$S(IBDSP="A"&IBSORT:IBSORT,1:$O(^IBA(355.91,"AUNIQ",IBINS,CU,FT,CT,PT))) Q:'PT D Q:IBDSP="A"&IBSORT 104 ... S Z=0 F S Z=$O(^IBA(355.91,"AUNIQ",IBINS,CU,FT,CT,PT,Z)) Q:'Z S IB=$G(^IBA(355.91,Z,0)) S ^TMP("IBPRV_INS_SORT",$J,PT,"^<<INS CO DEFAULT>>",FT,CT,CU,Z)=$P(IB,U,7)_U 105 ; 106 I "IA"[$G(IBDSP) D 107 . S IBPRV="" 108 . N IB1,IB2 109 . F S IBPRV=$O(^IBA(355.9,"AE",IBINS,IBPRV)) Q:'IBPRV S Z=0 F S Z=$O(^IBA(355.9,"AE",IBINS,IBPRV,Z)) Q:'Z S IB=$G(^IBA(355.9,Z,0)) D 110 .. Q:$P(IB,U,4)=""!($P(IB,U,5)="")!($P(IB,U,6)="")!($P(IB,U,16)="") 111 .. I IBSORT,$S(IBDSP="I":IBPRV'=IBSORT,1:$P(IB,U,6)'=IBSORT) Q 112 .. S IB1=$S(IBDSP="A":$P(IB,U,6),1:U_$$EXPAND^IBTRE(355.9,.01,IBPRV)_U_IBPRV) 113 .. S IB2=$S(IBDSP="I":$P(IB,U,6),1:U_$$EXPAND^IBTRE(355.9,.01,IBPRV)_U_IBPRV) 114 .. S ^TMP("IBPRV_INS_SORT",$J,IB1,IB2,$P(IB,U,4),$P(IB,U,5),$P(IB,U,16),Z)=$P(IB,U,7)_U_IBPRV 115 ; 116 S IBOSRT1="" 117 S IBSRT1="" F S IBSRT1=$O(^TMP("IBPRV_INS_SORT",$J,IBSRT1)) Q:IBSRT1="" D 118 . S IBSRT2="",IBOSRT2="" 119 . F S IBSRT2=$O(^TMP("IBPRV_INS_SORT",$J,IBSRT1,IBSRT2)) Q:IBSRT2="" D 120 .. I IBOSRT1'=IBSRT1 D 121 ... I IBOSRT1'="" S IBLCT=IBLCT+1 D SET^VALM10(IBLCT," ",IBCT+1) 122 ... S IBLCT=IBLCT+1 D SET^VALM10(IBLCT,$S(IBDSP'="I":"ID Qualifier",1:"Provider")_": "_$S(IBDSP'="I":$$EXPAND^IBTRE(355.91,.06,IBSRT1),1:$P(IBSRT1,U,2_$S($P(IBSRT2,U,3)["VA(200":" (VA)",1:"(NON-VA)"))),IBCT+1) 123 ... S IBOSRT1=IBSRT1 124 .. ; 125 .. S FT="" F S FT=$O(^TMP("IBPRV_INS_SORT",$J,IBSRT1,IBSRT2,FT)) Q:FT="" S CT="" F S CT=$O(^TMP("IBPRV_INS_SORT",$J,IBSRT1,IBSRT2,FT,CT)) Q:CT="" D 126 ... S CU="" F S CU=$O(^TMP("IBPRV_INS_SORT",$J,IBSRT1,IBSRT2,FT,CT,CU)) Q:CU="" S Z=0 F S Z=$O(^TMP("IBPRV_INS_SORT",$J,IBSRT1,IBSRT2,FT,CT,CU,Z)) Q:'Z S IB=$G(^(Z)) D 127 .... S IBLCT=IBLCT+1,IBCT=IBCT+1 128 .... S Z0=$E(IBCT_$J("",4),1,4)_" " 129 .... I IBDSP'="I" S Z0=Z0_$E($S(IBOSRT2'=IBSRT2:$P(IBSRT2,U,2),1:"")_$J("",20),1,20) 130 .... I IBDSP="I" S Z0=Z0_$E($S(IBOSRT2'=IBSRT2:$$EXPAND^IBTRE(355.9,.06,IBSRT2),1:"")_$J("",20),1,20) 131 .... S IBOSRT2=IBSRT2 132 .... S Z0=Z0_" "_$S(FT=1:"UB-04",FT=2:"1500 ",1:"BOTH ")_" "_$E($S(CT=3:"RX",CT=1:"INPT",CT=2:"OUTPT",1:"INPT/OUTPT")_$J("",11),1,11)_" "_$E($S(CU'="*N/A*":$P($G(^IBA(355.95,+$P($G(^IBA(355.96,+CU,0)),U),0)),U),1:"")_$J("",15),1,15) 133 .... D SET^VALM10(IBLCT,Z0_" "_$P(IB,U),IBCT) 134 .... S ^TMP("IBPRV_INS_ID",$J,"ZIDX",IBCT)=Z,^(IBCT,"PRV")=$P(IB,U,2) 135 .... I '$D(^TMP("IBPRV_INS_ID",$J,$S(IBDSP="I":"ZXPRV",1:"ZXPTYP"),IBSRT1)) S ^(IBSRT1)=IBLCT-1 136 K ^TMP("IBPRV_INS_SORT",$J) 137 ; 138 I IBLCT=0 D G BLDQ ; No entries found 139 . D SET^VALM10(1," ") 140 . S Z=" No "_$S(IBDSP="D":"default ",1:"") 141 . S Z=Z_"ID's found for "_$S(IBDSP="I":"provider "_$S(IBSORT:"("_$$EXPAND^IBTRE(355.9,.01,IBSORT)_") ",1:"")_"and ",IBDSP="A":"provider type "_$S(IBSORT:"("_$$EXPAND^IBTRE(355.9,.06,IBSORT)_") ",1:"")_"and ",1:"")_"insurance co" 142 . D SET^VALM10(2,Z) 143 . S IBLCT=2 144 ; 145 BLDQ S VALMCNT=IBLCT,VALMBG=1 146 Q 147 ; 148 EXPND ; 149 Q 150 ; 151 HELP ; 152 Q 153 ; 154 EXIT ; 155 K IBFASTXT 156 D COPYPROV^IBCEP5A(IBINS) 157 K ^TMP("IBPRV_INS_ID",$J) 158 D CLEAN^VALM10 159 Q 160 ; 161 SEL(IBDA,MANY) ; Select from provider id list 162 ; IBDA is passed by reference and IBDA(1) returned containing 163 ; ien's of the provider id records selected (file 355.9). 164 ; If > 1 entry can be selected, MANY is set to 1 165 N Z 166 S IBDA=0 167 D EN^VALM2($G(XQORNOD(0)),$S($G(MANY):"",1:"S")) 168 S Z=0 F S Z=$O(VALMY(Z)) Q:'Z S IBDA=IBDA+1,IBDA(IBDA)=+$G(^TMP("IBPRV_INS_ID",$J,"ZIDX",Z))_U_$G(^(Z,"PRV")) 169 Q 170 ; 171 ENX(IBINS1) ; Insurance co level defaults for all providers or 172 ; for all providers by care unit 173 N DIC,DIE,DR,DA,X,Y,DLAYGO 174 I '$G(IBINS1) D G:'$G(IBINS1) ENQ 175 . S DIC="^IBA(355.91,",DIC(0)="AELMQ",DLAYGO=355.91 D ^DIC 176 . I Y>0 S IBINS1=+Y 177 S DIE="^IBA(355.91,",DA=IBINS1,DR=".01;.06;.04;.05;.03;.07" D ^DIE 178 ; 179 ENQ Q 180 ; 181 PPTYP(IBINS) ; Returns the ien of the default performing provider type for 182 ; insurance company IBINS (ien file 36) 183 Q +$G(^DIC(36,+IBINS,4)) 184 ; 185 SCREEN(WHICH) ; This screen is used the menu protocol to screen out the ID functions if it is a child ins co 186 Q:'$G(DA) 0 187 Q:'$G(DA(1)) 0 188 N FILE,IENS,FIELD,FLAG,TARGET 189 S FILE=101.01,IENS=DA_","_DA(1),FIELD=".01",FLAG="I" 190 D GETS^DIQ(FILE,IENS,FIELD,FLAG,"TARGET") 191 Q:'$D(TARGET) 0 192 N IEN 193 S IEN=$G(TARGET(FILE,IENS_",",FIELD,FLAG)) 194 Q:'+IEN 0 195 S FILE=101,FIELD=1,FLAG="E" 196 K TARGET 197 D GETS^DIQ(FILE,IEN,FIELD,FLAG,"TARGET") 198 Q:'$D(TARGET) 0 199 I $G(TARGET(FILE,IEN_",",FIELD,FLAG))'[WHICH Q 1 200 Q:'$G(IBINS) 0 201 N PCF 202 S PCF=$P($G(^DIC(36,+IBINS,3)),U,13) 203 I PCF="C" Q 0 204 Q 1
Note:
See TracChangeset
for help on using the changeset viewer.
