ABMDVST2 ; IHS/ASDST/DMJ - PCC CLAIM STUFF - PART 3 (PROVIDER) ;
;;2.6;IHS 3P BILLING SYSTEM;;NOV 12, 2009
;Original;TMD;03/26/96 12:12 PM
;This routine loops thru the
;the V Provider file 3 times. First it looks for a valid MD. Then
;it looks for the attendings and operatings.
;Then it looks for additional providers for a total of up to 4
;including looking at ordering providers in V LAB etc.
;The var ABMP("MD") is used in ABMDVST4 to estimate CPT code for a
;doctor's visit.
;IHS/DSD/LSL - 03/24/98 - Undefined error on a global.
;Global AUPNPRV should be AUPNVPRV
;
;IHS/SD/SDR - v2.5 p9 - IM16620
; Removed code to make provider rendering
;
Q:ABMIDONE
N VPRVMD,DOC,DIC,DA,ABMN,ABMPC,ABMPCOD,VPROVC
;
PRV ;
;The following code is a loop that
;goes thru the V provider file until it finds an
;"MD" then it quits the loop
; If it finds an MD it sets ABMP("MD")
S ABMP("MD")=""
S ABMN=0
S ABM=0
F S ABM=$O(^AUPNVPRV("AD",ABMVDFN,ABM)) Q:'ABM D Q:ABMP("MD")
.D PROVMD(ABM)
.I $G(VPROVC) S ABMP("MD")=VPROVC Q
;End of 1st loop
;The 2nd loop looks for attending and operating. If they are found
;they are filed.
PRV2 K DIC,DD,DO
S DA(1)=ABMP("CDFN"),DIC="^ABMDCLM(DUZ(2),"_DA(1)_",41,",DIC(0)="LE"
S ABMOP=0
S ABMAT=0
;First it loops thru the provider file
S ABM=0
F S ABM=$O(^AUPNVPRV("AD",ABMVDFN,ABM)) Q:'ABM D
.Q:'$D(^AUPNVPRV(ABM,0))
.S Y=^AUPNVPRV(ABM,0)
.S ABMAT=$S($P(Y,U,5)="A":ABM,$P(Y,U,4)="P":ABM,1:ABMAT)
.S ABMOP=$S($P(Y,U,5)="O":ABM,1:ABMOP)
I 'ABMAT,ABMOP S ABMAT=ABMOP
D:ABMAT
.D PROVMD(ABMAT)
.I '$G(VPROVC),ABMP("MD") S ABMAT=ABMP("MD")
;If the attending not found check the billing pointer visit
I 'ABMAT D
.N GOODP,P,V
.S V=$P(^AUPNVSIT(ABMVDFN,0),U,28)
.I V D
..S P=""
..F S P=$O(^AUPNVPRV("AD",V,P)) Q:'P D Q:$G(GOODP)
...S Y=^AUPNVPRV(P,0)
...S ABMAT=$S($P(Y,U,5)="A":P,$P(Y,U,4)="P":P,1:ABMAT)
...S ABMOP=$S($P(Y,U,5)="O":P,1:ABMOP)
...S GOODP=$$GOODPRV(ABMAT)
...Q:'GOODP
...S GOODP='$$UBILPRV($$DOCLASS(+Y))
..Q:$G(GOODP)
..I $$GOODPRV(ABMOP),'$$UBILPRV($$DOCLASS(+^AUPNVPRV(ABMOP,0))) D
...S ABMAT=ABMOP
...S GOODP=1
.Q:$G(GOODP)
.;If attending still not found check ordering provider
.D ORDPROV
.Q:'$D(ABMORD)
.S P=""
.F S P=$O(ABMORD(P)) Q:'P D Q:$G(GOODP)
..Q:'ABMORD(P)
..Q:$$UBILPRV(ABMORD(P))
..S GOODP=1
..;Format is diff because ABMAT obtained from provider file is ien
..S ABMAT="^"_P_"^"_ABMORD(P)
N ABMNOFIL
I ABMAT D
.S X=ABMAT,ABMPCAT="A"
.D PRVST
E I $L(ABMAT)>1 D
.S X=$P(ABMAT,U,2)
.Q:'X
.S ABMPCAT="A"
.I $D(^ABMDCLM(DUZ(2),ABMP("CDFN"),41,"C",ABMPCAT)) D Q
..S ABMNOFIL=1
.D FILE
I ABMOP D
.S X=ABMOP,ABMPCAT="O"
.D PRVST
E I ABMP("VTYP")=111!($G(ABMP("BTYP"))=111),+$O(^ABMDCLM(DUZ(2),ABMP("CDFN"),21,0)),ABMAT D
.S X=ABMAT,ABMPCAT="O"
.D PRVST
S:$G(ABMNOFIL) (ABMAT,ABMOP)=""
; End of 2nd loop
;In the 3rd loop we first count the # of providers already filed
;because the max is 4.
S ABM=0,ABMN=0
F S ABM=$O(^ABMDCLM(DUZ(2),ABMP("CDFN"),41,ABM)) Q:'ABM S ABMN=ABMN+1
;3rd loop
;We look for otheR providers not attnd or op that are billable.
K ABMPCAT
S ABM=0
F S ABM=$O(^AUPNVPRV("AD",ABMVDFN,ABM)) Q:'ABM D Q:ABMN>3
.S ABMAT=$G(ABMAT),ABMOP=$G(ABMOP)
.Q:ABMAT=ABM
.Q:ABMOP=ABM
.Q:'$$GOODPRV(ABM)
.Q:$$UBILPRV(ABMPC)
.S X=+^AUPNVPRV(ABM,0)
.S ABMPCAT="T"
.D FILE
G Q:ABMN>3
I '$D(ABMORD) D ORDPROV
G Q:'$D(ABMORD)
S P=""
F S P=$O(ABMORD(P)) Q:'P D Q:ABMN>3
.S X=P
.Q:X=$P(ABMAT,U,2)
.S ABMPCAT="T"
.D FILE
Q K ABMORD,ABMAT,ABMOP,ABMR
Q
;
PRVCHK(X) ;Subrtn to find attending and operating
Q:'$D(^AUPNVPRV(X,0))
;If provider Attending or Primary set ABMAT to ien otherwise 0
I 'ABMAT S ABMAT=$S($P(^AUPNVPRV(X,0),U,5)="A":X,$P(^(0),U,4)="P":X,1:0)
;If provider Operating set ABMOP to ien otherwise 0
I 'ABMOP S ABMOP=$S($P(^AUPNVPRV(X,0),U,5)="O":X,1:0)
Q
;
PRVST ;FILE PROVIDER
;Check to see if Operating/Attending already in claim file
;This code will only allow one attending and one operating to be filed
I $D(^ABMDCLM(DUZ(2),ABMP("CDFN"),41,"C",ABMPCAT)) D Q
.S ABMNOFIL=1
PRVST2 S X=$P(^AUPNVPRV(X,0),U)
;At this point X has been converted from VPRV ien to file 16 or 200 ien
;Checking to see if file 9000010.06 points to file 6
;If so convert X to file 200 ien
;I ^DD(9000010.06,.01,0)["DIC(6" D
FILE Q:$$UBILPRV($$DOCLASS(X))
I ABM("DOCFILE")=6 D
.I $G(^DIC(16,X,"A3")) S X=^("A3") Q
.S ABMR("PNAME")=$P(^DIC(16,X,0),U)
.S X=$O(^VA(200,"B",ABMR("PNAME"),0))
Q:'X
Q:$D(^ABMDCLM(DUZ(2),ABMP("CDFN"),41,"B",X))
S DIC("P")=$P(^DD(9002274.3,41,0),U,2)
S DIC("DR")=".02////"_ABMPCAT
K DD,DO D FILE^DICN
S ABMN=ABMN+1
Q
;
ORDPROV ;EP - Requires ABMVDFN (Visit ien) to be defined.
;Returns all ordering providers in ABMORD(docien)=Prov class ien
N VFILE,L
F VFILE="^AUPNVLAB","^AUPNVMIC","^AUPNVPTH","^AUPNVBB","^AUPNVCYT","^AUPNVMED","^AUPNVRAD" D
.S L=0
.F S L=$O(@VFILE@("AD",ABMVDFN,L)) Q:'L D
..Q:'$D(@VFILE@(L,12))
..S DOC=$P(@VFILE@(L,12),U,2)
..Q:'DOC
..S X=$$DOCLASS(DOC)
..S ABMORD(DOC)=X
Q
;
PROVMD(X) ;
;X contains ien of the V provider file
;Returns the V Provider file ien of the provider if a billable
;physician in var VPROVC
Q:'$P($G(^AUPNVPRV(X,0)),U)
S VPROVC=$$DOCLASS(+^AUPNVPRV(X,0))
;At this point VPROVC contains provider class file ien
Q:'VPROVC
PROVMD2 ;
I $$UBILPRV(VPROVC) S VPROVC="" Q
I '$D(^DIC(7,VPROVC,9999999)) S VPROVC="" Q
S Y=$P(^DIC(7,VPROVC,9999999),U)
;Y contains provider class code
S VPROVC=$S(Y="00"!(Y>69&(Y<87))!(Y=18)!(Y=25)!(Y=33)!(Y=44)!(Y=45)!(Y=49)!(Y=64)!(Y=68):X,1:"")
;Finally VPROVC contains the ien of the provider file if the
;provider class code is one of the accepted codes.
;Codes
;00 = Physician
;18 = Physician (Contract)
;25 = Podiatrist (Contract)
;33 = Podiatrist
;41 = OB/Gyn (Contract)
;44 = Physician (Tribal)
;45 = Osteopath
;49 = Contract Psychiatrist
;64 = Nephrologist
;68 = Emergency Room Physician
;70 to 86 = Various medical specialties
Q
;
DOCLASS(DOC) ;EP - Get provider class from either file 6 or 200
;DOC is the ien of either file 6 or 200 depending on which file is
;pointed to by file 9000010.06
;This function returns the ien of file 7 the provider class
N X1
I $D(ABM("DOCFILE")) D Q X1
.S X1=ABM("DOCFILE")
.S X1=$S(X1=6:$P($G(^DIC(6,DOC,0)),U,4),1:$P($G(^VA(200,DOC,"PS")),U,5))
I ^DD(9000010.06,.01,0)["DIC(6" D Q $P($G(^DIC(6,DOC,0)),U,4)
.S ABM("DOCFILE")=6
I ^DD(9000010.06,.01,0)["VA(200" D Q $P($G(^VA(200,DOC,"PS")),U,5)
.S ABM("DOCFILE")=200
Q ""
;
GOODPRV(ABM) ;Attempts to reject provider that are never valid
;ABM is the ien of V Provider file
;Returns true if accepted provider.
Q:'$P($G(^AUPNVPRV(ABM,0)),U) 0
S (Y,ABMPC)=$$DOCLASS(+^AUPNVPRV(ABM,0))
Q:'Y 0
Q:'$D(^DIC(7,Y,9999999)) 0
S (Y,ABMPCOD)=+^DIC(7,Y,9999999)
Q:Y<40 $S(Y<15:1,Y=15:0,Y<20:1,Y=20:0,Y=21:1,Y<24:0,Y<27:1,Y=27:0,1:1)
Q $S(Y=40:0,Y<56:1,Y<60:0,Y=60:1,Y=61:0,Y<65:1,Y=65:0,Y<88:1,Y=88:0,1:1)
;List of invalid provider class codes
;15
;20
;22-23
;27
;40
;57-59
;61
;65
;88
;
UBILPRV(PCLSS) ;Check for unbillable provider classes
;PCLSS is the ien of the provider class file #7.
;Returns true if files indicate this is an unbillable provider
N INS,PRI,MCOUT,D2B,COV
Q:'PCLSS 1
I $D(^ABMDPARM(DUZ(2),1,17,PCLSS)) Q 1
;Look in the insurer subfile of the claim file
; look at first priority insurer
;The first pri insurer may not be the same as the 1st one in the ABML
;array. Hence the rtn may be able to stuff new providers into the
;claim for a previously created claim.
S D2=0
S D1=$O(^ABMDCLM(DUZ(2),ABMP("CDFN"),13,"C",1,""))
S INS=$P(^ABMDCLM(DUZ(2),ABMP("CDFN"),0),U,8)
I INS="" S INS=$S(ABMACTVI]"":ABMACTVI,1:ABMP("INS"))
;Vis type 111 is inpatient
I ABMP("VTYP")'=111 D
.;Compares prim insurer in claim file with ins in ABML array
.S PRI=0
.F S PRI=$O(ABML(PRI)) Q:'PRI D Q:$D(MCOUT)
..Q:'$D(ABML(PRI,INS))
..S MCOUT=$S($P(ABML(PRI,INS),U,3)?1(1"M",1"R"):1,1:0)
..Q:'MCOUT
..;If there is coverage type B store ien in D2B
..S COV=0,D2B=""
..F S COV=$O(ABML(PRI,INS,"COV",COV)) Q:'COV D
...Q:ABML(PRI,INS,"COV",COV)'="B"
...S D2B=COV
;Get the coverage type
N QFLG
S QFLG=0
I 'D1,INS]"" S D1=$O(^ABMDCLM(DUZ(2),ABMP("CDFN"),13,"B",INS,""))
I 'D1 Q QFLG
F S D2=$O(^ABMDCLM(DUZ(2),ABMP("CDFN"),13,D1,11,D2)) Q:'D2 D
.;If Medicare or RR outpat only look at coverage type B
.I $G(MCOUT),D2'=D2B Q
.;Check if an unbillable provider discipline in coverage file
.I $D(^AUTTPIC(D2,15,PCLSS)) S QFLG=1
.E S QFLG=0
Q QFLG
ABMDVST2 ; IHS/ASDST/DMJ - PCC CLAIM STUFF - PART 3 (PROVIDER) ;
+1 ;;2.6;IHS 3P BILLING SYSTEM;;NOV 12, 2009
+2 ;Original;TMD;03/26/96 12:12 PM
+3 ;This routine loops thru the
+4 ;the V Provider file 3 times. First it looks for a valid MD. Then
+5 ;it looks for the attendings and operatings.
+6 ;Then it looks for additional providers for a total of up to 4
+7 ;including looking at ordering providers in V LAB etc.
+8 ;The var ABMP("MD") is used in ABMDVST4 to estimate CPT code for a
+9 ;doctor's visit.
+10 ;IHS/DSD/LSL - 03/24/98 - Undefined error on a global.
+11 ;Global AUPNPRV should be AUPNVPRV
+12 ;
+13 ;IHS/SD/SDR - v2.5 p9 - IM16620
+14 ; Removed code to make provider rendering
+15 ;
+16 IF ABMIDONE
QUIT
+17 NEW VPRVMD,DOC,DIC,DA,ABMN,ABMPC,ABMPCOD,VPROVC
+18 ;
PRV ;
+1 ;The following code is a loop that
+2 ;goes thru the V provider file until it finds an
+3 ;"MD" then it quits the loop
+4 ; If it finds an MD it sets ABMP("MD")
+5 SET ABMP("MD")=""
+6 SET ABMN=0
+7 SET ABM=0
+8 FOR
SET ABM=$ORDER(^AUPNVPRV("AD",ABMVDFN,ABM))
IF 'ABM
QUIT
Begin DoDot:1
+9 DO PROVMD(ABM)
+10 IF $GET(VPROVC)
SET ABMP("MD")=VPROVC
QUIT
End DoDot:1
IF ABMP("MD")
QUIT
+11 ;End of 1st loop
+12 ;The 2nd loop looks for attending and operating. If they are found
+13 ;they are filed.
PRV2 KILL DIC,DD,DO
+1 SET DA(1)=ABMP("CDFN")
SET DIC="^ABMDCLM(DUZ(2),"_DA(1)_",41,"
SET DIC(0)="LE"
+2 SET ABMOP=0
+3 SET ABMAT=0
+4 ;First it loops thru the provider file
+5 SET ABM=0
+6 FOR
SET ABM=$ORDER(^AUPNVPRV("AD",ABMVDFN,ABM))
IF 'ABM
QUIT
Begin DoDot:1
+7 IF '$DATA(^AUPNVPRV(ABM,0))
QUIT
+8 SET Y=^AUPNVPRV(ABM,0)
+9 SET ABMAT=$SELECT($PIECE(Y,U,5)="A":ABM,$PIECE(Y,U,4)="P":ABM,1:ABMAT)
+10 SET ABMOP=$SELECT($PIECE(Y,U,5)="O":ABM,1:ABMOP)
End DoDot:1
+11 IF 'ABMAT
IF ABMOP
SET ABMAT=ABMOP
+12 IF ABMAT
Begin DoDot:1
+13 DO PROVMD(ABMAT)
+14 IF '$GET(VPROVC)
IF ABMP("MD")
SET ABMAT=ABMP("MD")
End DoDot:1
+15 ;If the attending not found check the billing pointer visit
+16 IF 'ABMAT
Begin DoDot:1
+17 NEW GOODP,P,V
+18 SET V=$PIECE(^AUPNVSIT(ABMVDFN,0),U,28)
+19 IF V
Begin DoDot:2
+20 SET P=""
+21 FOR
SET P=$ORDER(^AUPNVPRV("AD",V,P))
IF 'P
QUIT
Begin DoDot:3
+22 SET Y=^AUPNVPRV(P,0)
+23 SET ABMAT=$SELECT($PIECE(Y,U,5)="A":P,$PIECE(Y,U,4)="P":P,1:ABMAT)
+24 SET ABMOP=$SELECT($PIECE(Y,U,5)="O":P,1:ABMOP)
+25 SET GOODP=$$GOODPRV(ABMAT)
+26 IF 'GOODP
QUIT
+27 SET GOODP='$$UBILPRV($$DOCLASS(+Y))
End DoDot:3
IF $GET(GOODP)
QUIT
+28 IF $GET(GOODP)
QUIT
+29 IF $$GOODPRV(ABMOP)
IF '$$UBILPRV($$DOCLASS(+^AUPNVPRV(ABMOP,0)))
Begin DoDot:3
+30 SET ABMAT=ABMOP
+31 SET GOODP=1
End DoDot:3
End DoDot:2
+32 IF $GET(GOODP)
QUIT
+33 ;If attending still not found check ordering provider
+34 DO ORDPROV
+35 IF '$DATA(ABMORD)
QUIT
+36 SET P=""
+37 FOR
SET P=$ORDER(ABMORD(P))
IF 'P
QUIT
Begin DoDot:2
+38 IF 'ABMORD(P)
QUIT
+39 IF $$UBILPRV(ABMORD(P))
QUIT
+40 SET GOODP=1
+41 ;Format is diff because ABMAT obtained from provider file is ien
+42 SET ABMAT="^"_P_"^"_ABMORD(P)
End DoDot:2
IF $GET(GOODP)
QUIT
End DoDot:1
+43 NEW ABMNOFIL
+44 IF ABMAT
Begin DoDot:1
+45 SET X=ABMAT
SET ABMPCAT="A"
+46 DO PRVST
End DoDot:1
+47 IF '$TEST
IF $LENGTH(ABMAT)>1
Begin DoDot:1
+48 SET X=$PIECE(ABMAT,U,2)
+49 IF 'X
QUIT
+50 SET ABMPCAT="A"
+51 IF $DATA(^ABMDCLM(DUZ(2),ABMP("CDFN"),41,"C",ABMPCAT))
Begin DoDot:2
+52 SET ABMNOFIL=1
End DoDot:2
QUIT
+53 DO FILE
End DoDot:1
+54 IF ABMOP
Begin DoDot:1
+55 SET X=ABMOP
SET ABMPCAT="O"
+56 DO PRVST
End DoDot:1
+57 IF '$TEST
IF ABMP("VTYP")=111!($GET(ABMP("BTYP"))=111)
IF +$ORDER(^ABMDCLM(DUZ(2),ABMP("CDFN"),21,0))
IF ABMAT
Begin DoDot:1
+58 SET X=ABMAT
SET ABMPCAT="O"
+59 DO PRVST
End DoDot:1
+60 IF $GET(ABMNOFIL)
SET (ABMAT,ABMOP)=""
+61 ; End of 2nd loop
+62 ;In the 3rd loop we first count the # of providers already filed
+63 ;because the max is 4.
+64 SET ABM=0
SET ABMN=0
+65 FOR
SET ABM=$ORDER(^ABMDCLM(DUZ(2),ABMP("CDFN"),41,ABM))
IF 'ABM
QUIT
SET ABMN=ABMN+1
+66 ;3rd loop
+67 ;We look for otheR providers not attnd or op that are billable.
+68 KILL ABMPCAT
+69 SET ABM=0
+70 FOR
SET ABM=$ORDER(^AUPNVPRV("AD",ABMVDFN,ABM))
IF 'ABM
QUIT
Begin DoDot:1
+71 SET ABMAT=$GET(ABMAT)
SET ABMOP=$GET(ABMOP)
+72 IF ABMAT=ABM
QUIT
+73 IF ABMOP=ABM
QUIT
+74 IF '$$GOODPRV(ABM)
QUIT
+75 IF $$UBILPRV(ABMPC)
QUIT
+76 SET X=+^AUPNVPRV(ABM,0)
+77 SET ABMPCAT="T"
+78 DO FILE
End DoDot:1
IF ABMN>3
QUIT
+79 IF ABMN>3
GOTO Q
+80 IF '$DATA(ABMORD)
DO ORDPROV
+81 IF '$DATA(ABMORD)
GOTO Q
+82 SET P=""
+83 FOR
SET P=$ORDER(ABMORD(P))
IF 'P
QUIT
Begin DoDot:1
+84 SET X=P
+85 IF X=$PIECE(ABMAT,U,2)
QUIT
+86 SET ABMPCAT="T"
+87 DO FILE
End DoDot:1
IF ABMN>3
QUIT
Q KILL ABMORD,ABMAT,ABMOP,ABMR
+1 QUIT
+2 ;
PRVCHK(X) ;Subrtn to find attending and operating
+1 IF '$DATA(^AUPNVPRV(X,0))
QUIT
+2 ;If provider Attending or Primary set ABMAT to ien otherwise 0
+3 IF 'ABMAT
SET ABMAT=$SELECT($PIECE(^AUPNVPRV(X,0),U,5)="A":X,$PIECE(^(0),U,4)="P":X,1:0)
+4 ;If provider Operating set ABMOP to ien otherwise 0
+5 IF 'ABMOP
SET ABMOP=$SELECT($PIECE(^AUPNVPRV(X,0),U,5)="O":X,1:0)
+6 QUIT
+7 ;
PRVST ;FILE PROVIDER
+1 ;Check to see if Operating/Attending already in claim file
+2 ;This code will only allow one attending and one operating to be filed
+3 IF $DATA(^ABMDCLM(DUZ(2),ABMP("CDFN"),41,"C",ABMPCAT))
Begin DoDot:1
+4 SET ABMNOFIL=1
End DoDot:1
QUIT
PRVST2 SET X=$PIECE(^AUPNVPRV(X,0),U)
+1 ;At this point X has been converted from VPRV ien to file 16 or 200 ien
+2 ;Checking to see if file 9000010.06 points to file 6
+3 ;If so convert X to file 200 ien
+4 ;I ^DD(9000010.06,.01,0)["DIC(6" D
FILE IF $$UBILPRV($$DOCLASS(X))
QUIT
+1 IF ABM("DOCFILE")=6
Begin DoDot:1
+2 IF $GET(^DIC(16,X,"A3"))
SET X=^("A3")
QUIT
+3 SET ABMR("PNAME")=$PIECE(^DIC(16,X,0),U)
+4 SET X=$ORDER(^VA(200,"B",ABMR("PNAME"),0))
End DoDot:1
+5 IF 'X
QUIT
+6 IF $DATA(^ABMDCLM(DUZ(2),ABMP("CDFN"),41,"B",X))
QUIT
+7 SET DIC("P")=$PIECE(^DD(9002274.3,41,0),U,2)
+8 SET DIC("DR")=".02////"_ABMPCAT
+9 KILL DD,DO
DO FILE^DICN
+10 SET ABMN=ABMN+1
+11 QUIT
+12 ;
ORDPROV ;EP - Requires ABMVDFN (Visit ien) to be defined.
+1 ;Returns all ordering providers in ABMORD(docien)=Prov class ien
+2 NEW VFILE,L
+3 FOR VFILE="^AUPNVLAB","^AUPNVMIC","^AUPNVPTH","^AUPNVBB","^AUPNVCYT","^AUPNVMED","^AUPNVRAD"
Begin DoDot:1
+4 SET L=0
+5 FOR
SET L=$ORDER(@VFILE@("AD",ABMVDFN,L))
IF 'L
QUIT
Begin DoDot:2
+6 IF '$DATA(@VFILE@(L,12))
QUIT
+7 SET DOC=$PIECE(@VFILE@(L,12),U,2)
+8 IF 'DOC
QUIT
+9 SET X=$$DOCLASS(DOC)
+10 SET ABMORD(DOC)=X
End DoDot:2
End DoDot:1
+11 QUIT
+12 ;
PROVMD(X) ;
+1 ;X contains ien of the V provider file
+2 ;Returns the V Provider file ien of the provider if a billable
+3 ;physician in var VPROVC
+4 IF '$PIECE($GET(^AUPNVPRV(X,0)),U)
QUIT
+5 SET VPROVC=$$DOCLASS(+^AUPNVPRV(X,0))
+6 ;At this point VPROVC contains provider class file ien
+7 IF 'VPROVC
QUIT
PROVMD2 ;
+1 IF $$UBILPRV(VPROVC)
SET VPROVC=""
QUIT
+2 IF '$DATA(^DIC(7,VPROVC,9999999))
SET VPROVC=""
QUIT
+3 SET Y=$PIECE(^DIC(7,VPROVC,9999999),U)
+4 ;Y contains provider class code
+5 SET VPROVC=$SELECT(Y="00"!(Y>69&(Y<87))!(Y=18)!(Y=25)!(Y=33)!(Y=44)!(Y=45)!(Y=49)!(Y=64)!(Y=68):X,1:"")
+6 ;Finally VPROVC contains the ien of the provider file if the
+7 ;provider class code is one of the accepted codes.
+8 ;Codes
+9 ;00 = Physician
+10 ;18 = Physician (Contract)
+11 ;25 = Podiatrist (Contract)
+12 ;33 = Podiatrist
+13 ;41 = OB/Gyn (Contract)
+14 ;44 = Physician (Tribal)
+15 ;45 = Osteopath
+16 ;49 = Contract Psychiatrist
+17 ;64 = Nephrologist
+18 ;68 = Emergency Room Physician
+19 ;70 to 86 = Various medical specialties
+20 QUIT
+21 ;
DOCLASS(DOC) ;EP - Get provider class from either file 6 or 200
+1 ;DOC is the ien of either file 6 or 200 depending on which file is
+2 ;pointed to by file 9000010.06
+3 ;This function returns the ien of file 7 the provider class
+4 NEW X1
+5 IF $DATA(ABM("DOCFILE"))
Begin DoDot:1
+6 SET X1=ABM("DOCFILE")
+7 SET X1=$SELECT(X1=6:$PIECE($GET(^DIC(6,DOC,0)),U,4),1:$PIECE($GET(^VA(200,DOC,"PS")),U,5))
End DoDot:1
QUIT X1
+8 IF ^DD(9000010.06,.01,0)["DIC(6"
Begin DoDot:1
+9 SET ABM("DOCFILE")=6
End DoDot:1
QUIT $PIECE($GET(^DIC(6,DOC,0)),U,4)
+10 IF ^DD(9000010.06,.01,0)["VA(200"
Begin DoDot:1
+11 SET ABM("DOCFILE")=200
End DoDot:1
QUIT $PIECE($GET(^VA(200,DOC,"PS")),U,5)
+12 QUIT ""
+13 ;
GOODPRV(ABM) ;Attempts to reject provider that are never valid
+1 ;ABM is the ien of V Provider file
+2 ;Returns true if accepted provider.
+3 IF '$PIECE($GET(^AUPNVPRV(ABM,0)),U)
QUIT 0
+4 SET (Y,ABMPC)=$$DOCLASS(+^AUPNVPRV(ABM,0))
+5 IF 'Y
QUIT 0
+6 IF '$DATA(^DIC(7,Y,9999999))
QUIT 0
+7 SET (Y,ABMPCOD)=+^DIC(7,Y,9999999)
+8 IF Y<40
QUIT $SELECT(Y<15:1,Y=15:0,Y<20:1,Y=20:0,Y=21:1,Y<24:0,Y<27:1,Y=27:0,1:1)
+9 QUIT $SELECT(Y=40:0,Y<56:1,Y<60:0,Y=60:1,Y=61:0,Y<65:1,Y=65:0,Y<88:1,Y=88:0,1:1)
+10 ;List of invalid provider class codes
+11 ;15
+12 ;20
+13 ;22-23
+14 ;27
+15 ;40
+16 ;57-59
+17 ;61
+18 ;65
+19 ;88
+20 ;
UBILPRV(PCLSS) ;Check for unbillable provider classes
+1 ;PCLSS is the ien of the provider class file #7.
+2 ;Returns true if files indicate this is an unbillable provider
+3 NEW INS,PRI,MCOUT,D2B,COV
+4 IF 'PCLSS
QUIT 1
+5 IF $DATA(^ABMDPARM(DUZ(2),1,17,PCLSS))
QUIT 1
+6 ;Look in the insurer subfile of the claim file
+7 ; look at first priority insurer
+8 ;The first pri insurer may not be the same as the 1st one in the ABML
+9 ;array. Hence the rtn may be able to stuff new providers into the
+10 ;claim for a previously created claim.
+11 SET D2=0
+12 SET D1=$ORDER(^ABMDCLM(DUZ(2),ABMP("CDFN"),13,"C",1,""))
+13 SET INS=$PIECE(^ABMDCLM(DUZ(2),ABMP("CDFN"),0),U,8)
+14 IF INS=""
SET INS=$SELECT(ABMACTVI]"":ABMACTVI,1:ABMP("INS"))
+15 ;Vis type 111 is inpatient
+16 IF ABMP("VTYP")'=111
Begin DoDot:1
+17 ;Compares prim insurer in claim file with ins in ABML array
+18 SET PRI=0
+19 FOR
SET PRI=$ORDER(ABML(PRI))
IF 'PRI
QUIT
Begin DoDot:2
+20 IF '$DATA(ABML(PRI,INS))
QUIT
+21 SET MCOUT=$SELECT($PIECE(ABML(PRI,INS),U,3)?1(1"M",1"R"):1,1:0)
+22 IF 'MCOUT
QUIT
+23 ;If there is coverage type B store ien in D2B
+24 SET COV=0
SET D2B=""
+25 FOR
SET COV=$ORDER(ABML(PRI,INS,"COV",COV))
IF 'COV
QUIT
Begin DoDot:3
+26 IF ABML(PRI,INS,"COV",COV)'="B"
QUIT
+27 SET D2B=COV
End DoDot:3
End DoDot:2
IF $DATA(MCOUT)
QUIT
End DoDot:1
+28 ;Get the coverage type
+29 NEW QFLG
+30 SET QFLG=0
+31 IF 'D1
IF INS]""
SET D1=$ORDER(^ABMDCLM(DUZ(2),ABMP("CDFN"),13,"B",INS,""))
+32 IF 'D1
QUIT QFLG
+33 FOR
SET D2=$ORDER(^ABMDCLM(DUZ(2),ABMP("CDFN"),13,D1,11,D2))
IF 'D2
QUIT
Begin DoDot:1
+34 ;If Medicare or RR outpat only look at coverage type B
+35 IF $GET(MCOUT)
IF D2'=D2B
QUIT
+36 ;Check if an unbillable provider discipline in coverage file
+37 IF $DATA(^AUTTPIC(D2,15,PCLSS))
SET QFLG=1
+38 IF '$TEST
SET QFLG=0
End DoDot:1
+39 QUIT QFLG
