Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: IBCEP5

IBCEP5.m

Go to the documentation of this file.
  1. IBCEP5 ;ALB/TMP - EDI UTILITIES for provider ID ;29-SEP-00
  1. ;;2.0;INTEGRATED BILLING;**137,232,320,348,349,377,592**;21-MAR-94;Build 58
  1. ;;Per VA Directive 6402, this routine should not be modified.
  1. ;
  1. EN ; -- main entry point for IBCE PRV MAINT
  1. N IBPRV,IBINS
  1. EN1 ; Entrypoint for non-VA provider ID maintenance hook
  1. N IBSLEV,DIR,Y,X,IBPRMPT,IBNVAFL,IBIF
  1. K IBFASTXT
  1. S IBIF="" I $G(IBPRV) S IBIF=$$GET1^DIQ(355.93,IBPRV,.02,"I")
  1. D FULL^VALM1
  1. S IBPRMPT=$S(IBIF=1:"LAB OR FACILITY",1:"PROVIDER")
  1. S DIR(0)="SA^1:"_IBPRMPT_"'S OWN IDS;2:"_IBPRMPT_" IDS FURNISHED BY AN INSURANCE COMPANY"
  1. S DIR("A")="SELECT SOURCE OF ID: ",DIR("B")=$P($P(DIR(0),":",2),";")
  1. W ! D ^DIR K DIR W !
  1. I Y'>0 Q
  1. S IBSLEV=+Y
  1. D EN^VALM("IBCE PRVPRV MAINT")
  1. Q
  1. ;
  1. HDR ; -- header code
  1. N IBC,Z,IBIF
  1. S IBIF="" I $G(IBNPRV) S IBIF=$$GET1^DIQ(355.93,IBNPRV,.02,"I")
  1. K VALMHDR
  1. S IBC=1
  1. S IBPRMPT=$S(IBIF=1:"Lab or Facility",1:"Performing Provider")
  1. S Z="** "_$S($G(IBSLEV)=1:IBPRMPT_"'s Own IDs (No Specific Insurance Co)",1:IBPRMPT_" IDs from Insurance Co")_" **"
  1. S VALMHDR(IBC)=$J("",80-$L(Z)\2)_Z,IBC=IBC+1
  1. 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
  1. 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
  1. I $G(IBINS) D
  1. . N PCF,PCDISP
  1. . S PCF=$P($G(^DIC(36,+IBINS,3)),"^",13)
  1. . S PCDISP=$S($G(IBSLEV)'=2!($G(IBPRV)'["VA(200,"):"",PCF="C":"(Child)",PCF="P":"(Parent)",1:"")
  1. . S VALMHDR(IBC)=$S(IBIF:"Insurance Co: ",1:"INSURANCE CO: ")_$P($G(^DIC(36,+IBINS,0)),U)_" "_PCDISP
  1. Q
  1. ;
  1. INIT ; -- init variables and list array
  1. N IBFILE,DIR,DIC,Y,X,DTOUT,DUOUT,IBIF,AGAIN
  1. ;
  1. K ^TMP("IB_EDITED_IDS",$J) ; This will be to keep track of ID's edited during this session
  1. S IBIF="" I $G(IBNPRV) S IBIF=$$GET1^DIQ(355.93,IBNPRV,.02,"I")
  1. ;
  1. ; Removing Care Unit under certain conditions
  1. ; This list is used for multiple purposes and not all have Care Units Associated with them
  1. ; Also, a different protocol menu is used with these
  1. ; IBNPRV is a non VA provider
  1. ; IBIF = 1 means this is a group or facility, not an individual.
  1. ;
  1. I $G(IBNPRV),$G(IBIF)=1 D
  1. . S VALM("TITLE")="Secondary Provider ID"
  1. . K VALMDDF("CAREUNIT")
  1. . I VALMCAP["Care Unit" S VALMCAP=$P(VALMCAP,"Care Unit")_" "_$P(VALMCAP,"Care Unit",2)
  1. . K VALM("PROTOCOL")
  1. . S Y=$$FIND1^DIC(101,,,"IBCE PRVNVA LOF MAINT")
  1. . I Y S VALM("PROTOCOL")=+Y_";ORD(101,"
  1. ;
  1. I $G(IBPRV) S IBFILE="IBA(355.93,",IBPRV=+IBPRV_";"_IBFILE
  1. I '$G(IBPRV) D G:$G(VALMQUIT) INITQ
  1. . S DIR(0)="SAO^V:VA PROVIDER;N:NON-VA PROVIDER",DIR("A")="(V)A or (N)on-VA provider: ",DIR("B")="V"
  1. . D ^DIR K DIR
  1. . I "NV"'[Y!(Y="") S VALMQUIT=1 Q
  1. . S IBFILE=$S(Y="V":"VA(200,",1:"IBA(355.93,")
  1. . S DIC=U_IBFILE,DIC(0)="AEMQ"_$S(IBFILE["355.93":"L",1:"")
  1. . S DIC("A")="Select "_$S(IBFILE["355.93":"NON-",1:"")_"V.A. PROVIDER NAME: "
  1. . S:IBFILE["355.93" DIC("DR")=".02////2;.03;.04"
  1. . F D I $G(IBPRV)!$G(VALMQUIT) K DIC Q
  1. .. D ^DIC
  1. .. I $D(DTOUT)!$D(DUOUT) S VALMQUIT=1 Q
  1. .. I Y'>0 W !,*7,"This is a required response. Enter '^' to exit" Q
  1. .. S IBPRV=+Y_";"_IBFILE
  1. ;
  1. AGAIN I $G(IBSLEV)=2 D G:$G(AGAIN) AGAIN G:$G(VALMQUIT) INITQ
  1. . S AGAIN=0
  1. . S DIR(0)="PA^DIC(36,:AEMQ",DIR("A")="Select INSURANCE CO: ",DIR("?",1)="Select an INSURANCE CO to display its provider ID's"
  1. . D ^DIR K DIR
  1. . I $D(DTOUT)!$D(DUOUT) S VALMQUIT=1 Q
  1. . S IBINS=$S(Y>0:+Y,1:"NO")
  1. . I $G(IBPRV)'["VA(200," Q ; Only VA providers
  1. . I $P($G(^DIC(36,+IBINS,3)),"^",13)="C" D S AGAIN=1 Q
  1. .. W !,*7,"This is a Child Insurance Company. Editing IDs is not permitted."
  1. ;
  1. E D
  1. . S IBINS="NO"
  1. D BLD
  1. INITQ Q
  1. ;
  1. BLD ; Build initial display
  1. ; Assumes IBPRV = the variable ptr for prov id file (355.9)
  1. ; IBINS = the ien of the ins co or if null, ALL is assumed
  1. ; IBSLEV = 1 to display only provider default ids
  1. ; = 2 to display all provider/insurance co ids
  1. N IB,IBLCT,IBCT,CT,PT,CU,INS,FT,Z,IBENT,IB1,IBIF,FORM,CAREUNT,CARETYP ;JRA IB*2.0*592 Added: FORM,CAREUNT,CARETYP
  1. ;
  1. S IBIF="" I $G(IBPRV)[355.93 S IBIF=$$GET1^DIQ(355.93,+IBPRV,.02,"I")
  1. ;
  1. K ^TMP("IBPRV_",$J),^TMP("IBPRV_SORT",$J)
  1. K Z0
  1. S (IBENT,IBCT,IBLCT)=0,INS="",IB1=1
  1. 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
  1. . 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
  1. .. 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
  1. ... 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)
  1. ;
  1. 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)
  1. S INS="" F S INS=$O(^TMP("IBPRV_SORT",$J,INS)) Q:INS="" D
  1. . 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))
  1. . S PT=""
  1. . 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
  1. .. 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
  1. ... S IBLCT=IBLCT+1,IBCT=IBCT+1
  1. ... ;JRA IB*2.0*592 Modify to accommodate Dental Form 7 (FT=4)
  1. ... ;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 ") ;JRA IB*2.0*592 ';'
  1. ... S FORM=$S(FT=1:"UB-04",FT=2:"1500",1:"BOTH")
  1. ... 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)_" "_FORM ;JRA IB*2.0*592
  1. ... ;S Z0=Z0_" "_$E($S(CT=3:"RX",CT=1:"INPT",CT=2:"OUTPT",1:"INPT/OUTPT")_$J("",11),1,11) ;JRA IB*2.0*592 ';'
  1. ... S CARETYP=$E($S(CT=3:"RX",CT=1:"INPT",CT=2:"OUTPT",1:"INPT/OUTPT"),1,10) ;JRA IB*2.0*592
  1. ... S Z0=Z0_$J("",11-$L(FORM))_CARETYP ;JRA IB*2.0*592
  1. ... ;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 "*" ;JRA IB*2.0*592 ';'
  1. ... S CAREUNT=$E($S(CU'="*N/A*":$P($G(^IBA(355.95,+$G(^IBA(355.96,CU,0)),0)),U),1:""),1,12) ;JRA IB*2.0*592
  1. ... S CAREUNT=CAREUNT_$J("",12-$L(CAREUNT)+1) ;JRA IB*2.0*592
  1. ... S Z0=Z0_($J("",(12-$L(CARETYP)+1))) ;JRA IB*2.0*592
  1. ... S Z0=Z0_CAREUNT ;JRA IB*2.0*592
  1. ... ;D SET^VALM10(IBLCT,Z0_" "_IB,IBCT) ;JRA IB*2.0*592 ';'
  1. ... ;IA# 10117;IB*2.0*592
  1. ... D SET^VALM10(IBLCT,Z0_IB,IBCT) ;JRA IB*2.0*592
  1. ... S ^TMP("IBPRV_",$J,"ZIDX",IBCT)=$S(Z'=0:Z,1:"LIC^"_IBPRV)
  1. I IBSLEV=1,IBPRV["VA(200" D
  1. . N IBP
  1. . S IBP=+IBPRV
  1. . Q:'$$GETLIC^IBCEP5D(.IBP)
  1. . I IBCT S IBLCT=IBLCT+1 D SET^VALM10(IBLCT," ",IBCT)
  1. . S Z=0 F S Z=$O(IBP(Z)) Q:'Z D
  1. .. S IBLCT=IBLCT+1,IBCT=IBCT+1
  1. .. 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)
  1. .. S ^TMP("IBPRV_",$J,"ZIDX",IBCT)="LIC^"_+IBPRV
  1. K ^TMP("IBPRV_SORT",$J)
  1. ;
  1. I IBLCT=0 D G BLDQ ; No entries for ins co selected
  1. . D SET^VALM10(1," ")
  1. . D SET^VALM10(2," No ID's found for provider "_$S('$G(IBINS):"",1:"and selected insurance co"))
  1. . S IBLCT=2
  1. ;
  1. BLDQ K VALMCNT,VALMBG
  1. S VALMCNT=IBLCT,VALMBG=1
  1. Q
  1. ;
  1. HELP ; -- help code
  1. S X="?" D DISP^XQORM1 W !!
  1. Q
  1. ;
  1. EXIT ; -- exit code
  1. D COPYPROV^IBCEP5A(IBINS)
  1. K IBPRV
  1. D CLEAN^VALM10
  1. K ^TMP("IBPRV_",$J),^TMP("IBPRV_SORT",$J),IBINS,IBALL
  1. Q
  1. ;
  1. EXPND ; -- expand code
  1. Q
  1. ;
  1. SEL(IBDA,MANY) ; Select from provider id list
  1. ; IBDA is passed by reference and IBDA(1) returned containing
  1. ; ien's of the provider id records selected (file 355.9).
  1. ; If > 1 entry can be selected, MANY is set to 1
  1. N Z
  1. S IBDA=0
  1. D EN^VALM2($G(XQORNOD(0)),$S($G(MANY):"",1:"S"))
  1. S Z=0 F S Z=$O(VALMY(Z)) Q:'Z S IBDA=IBDA+1,IBDA(IBDA)=$G(^TMP("IBPRV_",$J,"ZIDX",Z))
  1. Q
  1. ;