BUDERPC3 ;IHS/CMI/LAB - UDS TABLE 1-6A;
;;12.0;IHS/RPMS UNIFORM DATA SYSTEM;;NOV 22, 2017;Build 75
T9D ;EP
NEW BUDAIEN,BUDDATE,BUD0,BUDREC,BUDDILL,Z,BUDPIEC
S BUDAIEN=0
F S BUDAIEN=$O(^BARTR(DUZ(2),"AF",DFN,BUDAIEN)) Q:BUDAIEN'=+BUDAIEN D
.Q:'$D(^BARTR(DUZ(2),BUDAIEN))
.Q:'$D(^BARTR(DUZ(2),BUDAIEN,0))
.S BUD0=^BARTR(DUZ(2),BUDAIEN,0)
.S BUDDATE=$P(BUD0,U,12)
.Q:$P(BUDDATE,".")<BUDBD ;ONLY UDS DATE RANGE
.Q:$P(BUDDATE,".")>BUDED
.S BUDREC="",BUDPIEC=0
.;DATE
.S BUDPIEC=BUDPIEC+1
.S $P(BUDREC,U,BUDPIEC)=$$FMTE^XLFDT(BUDDATE)
.;BILL NUMBER
.S BUDPIEC=BUDPIEC+1
.S $P(BUDREC,U,BUDPIEC)=$$VAL^XBDIQ1(90050.03,BUDAIEN,4)
.;TRANSACTION TYPE
.S BUDPIEC=BUDPIEC+1
.S $P(BUDREC,U,BUDPIEC)=$$VAL^XBDIQ1(90050.03,BUDAIEN,101)
.;CREDIT 2 A/R TRANSACTION FILE
.S BUDPIEC=BUDPIEC+1
.S $P(BUDREC,U,BUDPIEC)=$P(BUD0,U,2)
.;DEBIT 3 A/R TRANSACTION FILE
.S BUDPIEC=BUDPIEC+1
.S $P(BUDREC,U,BUDPIEC)=$P(BUD0,U,3)
.;PRIME BILL AMOUNT
.S BUDPIEC=BUDPIEC+1
.S $P(BUDREC,U,BUDPIEC)=$$VAL^XBDIQ1(90050.03,BUDAIEN,3.2)
.;PAYMENT
.S BUDPIEC=BUDPIEC+1
.S $P(BUDREC,U,BUDPIEC)=$$VAL^XBDIQ1(90050.03,BUDAIEN,3.6)
.;ADJUSTMENT
.S BUDPIEC=BUDPIEC+1
.S $P(BUDREC,U,BUDPIEC)=$$VAL^XBDIQ1(90050.03,BUDAIEN,3.7)
.;ADJUSTMENT CATEGORY
.S BUDPIEC=BUDPIEC+1
.S $P(BUDREC,U,BUDPIEC)=$$VAL^XBDIQ1(90050.03,BUDAIEN,102)
.;ADJUSTMENT TYPE
.S BUDPIEC=BUDPIEC+1
.S $P(BUDREC,U,BUDPIEC)=$$VAL^XBDIQ1(90050.03,BUDAIEN,103)
.;A/R ACCOUNT
.S BUDPIEC=BUDPIEC+1
.S $P(BUDREC,U,BUDPIEC)=$$VAL^XBDIQ1(90050.03,BUDAIEN,6)
.;PATIENT
.S BUDPIEC=BUDPIEC+1
.S $P(BUDREC,U,BUDPIEC)=$$VAL^XBDIQ1(90050.03,BUDAIEN,5)
.;VISIT LOCATION
.S BUDDILL=$$VALI^XBDIQ1(90050.03,BUDAIEN,4)
.I BUDDILL S Z=$$VAL^XBDIQ1(90050.01,BUDDILL,108)
.S BUDPIEC=BUDPIEC+1
.S $P(BUDREC,U,BUDPIEC)=Z
.;CLINIC TYPE
.I BUDDILL S Z=$$VAL^XBDIQ1(90050.01,BUDDILL,112)
.S BUDPIEC=BUDPIEC+1
.S $P(BUDREC,U,BUDPIEC)=Z
.;DOS BEGIN
.I BUDDILL S Z=$$VAL^XBDIQ1(90050.01,BUDDILL,102)
.S BUDPIEC=BUDPIEC+1
.S $P(BUDREC,U,BUDPIEC)=Z
.;BILL TYPE
.I BUDDILL S Z=$$VAL^XBDIQ1(90050.01,BUDDILL,4)
.S BUDPIEC=BUDPIEC+1
.S $P(BUDREC,U,BUDPIEC)=Z
.;PRIMARY PROVIDER
.I BUDDILL S Z=$$VAL^XBDIQ1(90050.01,BUDDILL,113)
.S BUDPIEC=BUDPIEC+1
.S $P(BUDREC,U,BUDPIEC)=Z
.;HRN
.S BUDPIEC=BUDPIEC+1
.S $P(BUDREC,U,BUDPIEC)=$$HRN^AUPNPAT(DFN,DUZ(2))
.;DOB
.S BUDPIEC=BUDPIEC+1
.S $P(BUDREC,U,BUDPIEC)=$$FMTE^XLFDT($$DOB^AUPNPAT(DFN))
.;COMMUNITY
.S BUDPIEC=BUDPIEC+1
.S $P(BUDREC,U,BUDPIEC)=$$COMMRES^AUPNPAT(DFN,"E")
.D SET
.Q
Q
SET ;
S BUDT9C=BUDT9C+1
S ^XTMP("BUDARP9DEL",BUDJ,BUDH,BUDDATE,BUDT9C)=BUDREC
Q
OPIC ;EP
; I = IEN
; Y = 1:yes, 0:no
; X = Pointer to INSURER file.
I '$G(P) Q 0
I '$G(D) Q 0
NEW I,Y,X,G
S Y=0,U="^"
I '$D(^DPT(P,0)) G OPICX
I $P(^DPT(P,0),U,19) G OPICX
I '$D(^AUPNPAT(P,0)) G OPICX
I '$D(^AUPNPRVT(P,11)) G OPICX
I $D(^DPT(P,.35)),$P(^(.35),U)]"",$P(^(.35),U)<D G OPICX
S I=0,G=0
F S I=$O(^AUPNPRVT(P,11,I)) Q:I'=+I D
. Q:$P(^AUPNPRVT(P,11,I,0),U)=""
. S G=0
. S X=$P(^AUPNPRVT(P,11,I,0),U) Q:X=""
. I X,$D(^BUDESITE(BUDSITE,12,"B",X)),$P(^BUDESITE(BUDSITE,12,X,0),U,2)="NI" Q
. I $D(^BUDESITE(BUDSITE,12,"B",X)) S T=$P(^BUDESITE(BUDSITE,12,X,0),U,2) I T'="P" Q
. I $P($G(^AUTNINS(X,2)),U,1)=T S G=1
. Q:'G
. Q:$P(^AUPNPRVT(P,11,I,0),U,6)>D
. I $P(^AUPNPRVT(P,11,I,0),U,7)]"",$P(^(0),U,7)<D Q
. S Y=1
.Q
I Y Q Y
OPICX ;EP
Q Y
OPI ;EP
; I = IEN
; Y = 1:yes, 0:no
; X = Pointer to INSURER file.
I '$G(P) Q 0
I '$G(D) Q 0
NEW I,Y,X,G
S Y=0,U="^"
I '$D(^DPT(P,0)) G OPIX
I $P(^DPT(P,0),U,19) G OPIX
I '$D(^AUPNPAT(P,0)) G OPIX
I '$D(^AUPNPRVT(P,11)) G OPIX
I $D(^DPT(P,.35)),$P(^(.35),U)]"",$P(^(.35),U)<D G OPIX
S I=0,G=0
F S I=$O(^AUPNPRVT(P,11,I)) Q:I'=+I D
. Q:$P(^AUPNPRVT(P,11,I,0),U)=""
. S G=0
. S X=$P(^AUPNPRVT(P,11,I,0),U) Q:X=""
. I $D(^BUDESITE(BUDSITE,12,"B",X)) S T=$P(^BUDESITE(BUDSITE,12,X,0),U,2) I T'="P" Q
. I X,$D(^BUDESITE(BUDSITE,12,"B",X)),$P(^BUDESITE(BUDSITE,12,X,0),U,2)="NI" Q
. ;I $P($G(^AUTNINS(X,2)),U,1)="G" S G=1
. I $P($G(^AUTNINS(X,2)),U,1)="I" S G=1
. I $P($G(^AUTNINS(X,2)),U,1)="SEP" S G=1
. I $P($G(^AUTNINS(X,2)),U,1)="T" S G=1
. Q:$P(^AUPNPRVT(P,11,I,0),U,6)>D
. I $P(^AUPNPRVT(P,11,I,0),U,7)]"",$P(^(0),U,7)<D Q
. S Y=1
.Q
I Y Q Y
OPIX ;
Q Y
PI ;EP
; I = IEN
; Y = 1:yes, 0:no
; X = Pointer to INSURER file.
I '$G(P) Q 0
I '$G(D) Q 0
NEW I,Y,X,G,Z,T,HOLDT
S Y=0,U="^"
I '$D(^DPT(P,0)) G PIX
I $P(^DPT(P,0),U,19) G PIX
I '$D(^AUPNPAT(P,0)) G PIX
I '$D(^AUPNPRVT(P,11)) G PIX
I $D(^DPT(P,.35)),$P(^(.35),U)]"",$P(^(.35),U)<D G PIX
S I=0,T="",HOLDT=""
F S I=$O(^AUPNPRVT(P,11,I)) Q:I'=+I D
. Q:$P(^AUPNPRVT(P,11,I,0),U)=""
. S X=$P(^AUPNPRVT(P,11,I,0),U) Q:X=""
. I X,$D(^BUDESITE(BUDSITE,12,"B",X)),$P(^BUDESITE(BUDSITE,12,X,0),U,2)="NI" Q
. I $D(^BUDESITE(BUDSITE,12,"B",X)) S T=$P(^BUDESITE(BUDSITE,12,X,0),U,2) I T'="P" Q
. Q:$P(^AUTNINS(X,0),U)["AHCCCS"
. S G=0
. I $P($G(^AUTNINS(X,2)),U,1)="C" S G=1
. I $P($G(^AUTNINS(X,2)),U,1)="F" S G=1
. I $P($G(^AUTNINS(X,2)),U,1)="H" S G=1
. I $P($G(^AUTNINS(X,2)),U,1)="M" S G=1
. I $P($G(^AUTNINS(X,2)),U,1)="P" S G=1
. I $P($G(^AUTNINS(X,2)),U,1)="W" S G=1
. Q:'G
. Q:$P(^AUPNPRVT(P,11,I,0),U,6)>D
. I $P(^AUPNPRVT(P,11,I,0),U,7)]"",$P(^(0),U,7)<D Q
. S Y=1
.Q
PIX ;
I Y Q Y
;now check medicare eligible if any overrides to medicare
I '$$OV(BUDSITE,"P") Q Y
S I=0
F S I=$O(^AUPNMCR(P,11,I)) Q:I'=+I D
. Q:$P(^AUPNMCR(P,11,I,0),U)>D
. S Z=$P(^AUPNMCR(P,11,I,0),U,4)
. Q:'Z
. Q:'$D(^BUDESITE(BUDSITE,12,"B",Z))
. Q:$P(^BUDESITE(BUDSITE,12,Z,0),U,2)'="P"
. I $P(^AUPNMCR(P,11,I,0),U,2)]"",$P(^(0),U,2)<D Q
. S Y=1
.Q
I Y Q Y
;now check medicaid file
S I=0 F S I=$O(^AUPNMCD("B",P,I)) Q:I'=+I D
.Q:'$D(^AUPNMCD(I,11))
.;S Z=$P(^AUPNMCD(I,0),U,2)
.;get plan name/INSURER TYPE OF PLAN NAME
.S N=$$VALI^XBDIQ1(9000004,I,.11)
.Q:'N
.Q:'$D(^BUDESITE(BUDSITE,12,"B",N))
.Q:$P(^BUDESITE(BUDSITE,12,N,0),U,2)'="P" ;not to be counted as PI
.;I N S N=$$VALI^XBDIQ1(9999999.18,N,.21)
.;I T="K" Q:N'="K"
.;I T="" Q:N="K"
.S J=0 F S J=$O(^AUPNMCD(I,11,J)) Q:J'=+J D
..Q:J>D
..I $P(^AUPNMCD(I,11,J,0),U,2)]"",$P(^(0),U,2)<D Q
..S Y=1
..Q
.Q
Q Y
OV(BUDSITE,T) ;
NEW X,G,Y
S G=""
S X=0 F S X=$O(^BUDESITE(BUDSITE,12,X)) Q:X'=+X!(G) D
.S Y=$P(^BUDESITE(BUDSITE,12,X,0),U,2)
.I Y=T S G=1
Q G
ZIPINS(DFN,BUDLASTV) ;EP - ZIP INSURANCE
NEW BUDHAS
S BUDHAS=0
S BUDHAS=$$PI^BUDERPC2(DFN,$$VD^APCLV(BUDLASTV))
I BUDHAS=1 Q "e"
S BUDHAS=$$MCR^BUDERPC2(DFN,$$VD^APCLV(BUDLASTV))
I BUDHAS=1 Q "d"
;S BUDHAS=$$OPI(DFN,$$VD^APCLV(BUDLASTV),"W")
;I BUDHAS=1 D TINS(BUDAGE,"10a") Q
S BUDHAS=$$RR^AUPNPAT(DFN,$$VD^APCLV(BUDLASTV))
I BUDHAS=1 Q "c"
S BUDHAS=$$OPI^BUDERPC2(DFN,$$VD^APCLV(BUDLASTV))
I BUDHAS=1 Q "c"
S BUDHAS=$$OPIC^BUDERPC2(DFN,$$VD^APCLV(BUDLASTV),"K")
I BUDHAS=1 Q "c"
S BUDHAS=$$MCD^BUDERPC2(DFN,$$VD^APCLV(BUDLASTV),"D")
I BUDHAS=1 Q "c"
S BUDHAS=$$MCD^BUDERPC2(DFN,$$VD^APCLV(BUDLASTV),"K")
I BUDHAS=1 Q "c"
;now check workman's comp and 3rd party liability
S BUDHAS=$$WC^BUDERPC2(DFN,BUDBD,BUDED)
I BUDHAS=1 Q "e"
S BUDHAS=$$TPL^BUDERPC2(DFN,BUDBD,BUDED)
I BUDHAS=1 Q "c"
;now check guarantor file
;S BUDHAS=$$GUAR(DFN,BUDBD,BUDED)
;I BUDHAS=1 D TINS(BUDAGE,"7") Q
Q "b"
BUDERPC3 ;IHS/CMI/LAB - UDS TABLE 1-6A;
+1 ;;12.0;IHS/RPMS UNIFORM DATA SYSTEM;;NOV 22, 2017;Build 75
T9D ;EP
+1 NEW BUDAIEN,BUDDATE,BUD0,BUDREC,BUDDILL,Z,BUDPIEC
+2 SET BUDAIEN=0
+3 FOR
SET BUDAIEN=$ORDER(^BARTR(DUZ(2),"AF",DFN,BUDAIEN))
IF BUDAIEN'=+BUDAIEN
QUIT
Begin DoDot:1
+4 IF '$DATA(^BARTR(DUZ(2),BUDAIEN))
QUIT
+5 IF '$DATA(^BARTR(DUZ(2),BUDAIEN,0))
QUIT
+6 SET BUD0=^BARTR(DUZ(2),BUDAIEN,0)
+7 SET BUDDATE=$PIECE(BUD0,U,12)
+8 ;ONLY UDS DATE RANGE
IF $PIECE(BUDDATE,".")<BUDBD
QUIT
+9 IF $PIECE(BUDDATE,".")>BUDED
QUIT
+10 SET BUDREC=""
SET BUDPIEC=0
+11 ;DATE
+12 SET BUDPIEC=BUDPIEC+1
+13 SET $PIECE(BUDREC,U,BUDPIEC)=$$FMTE^XLFDT(BUDDATE)
+14 ;BILL NUMBER
+15 SET BUDPIEC=BUDPIEC+1
+16 SET $PIECE(BUDREC,U,BUDPIEC)=$$VAL^XBDIQ1(90050.03,BUDAIEN,4)
+17 ;TRANSACTION TYPE
+18 SET BUDPIEC=BUDPIEC+1
+19 SET $PIECE(BUDREC,U,BUDPIEC)=$$VAL^XBDIQ1(90050.03,BUDAIEN,101)
+20 ;CREDIT 2 A/R TRANSACTION FILE
+21 SET BUDPIEC=BUDPIEC+1
+22 SET $PIECE(BUDREC,U,BUDPIEC)=$PIECE(BUD0,U,2)
+23 ;DEBIT 3 A/R TRANSACTION FILE
+24 SET BUDPIEC=BUDPIEC+1
+25 SET $PIECE(BUDREC,U,BUDPIEC)=$PIECE(BUD0,U,3)
+26 ;PRIME BILL AMOUNT
+27 SET BUDPIEC=BUDPIEC+1
+28 SET $PIECE(BUDREC,U,BUDPIEC)=$$VAL^XBDIQ1(90050.03,BUDAIEN,3.2)
+29 ;PAYMENT
+30 SET BUDPIEC=BUDPIEC+1
+31 SET $PIECE(BUDREC,U,BUDPIEC)=$$VAL^XBDIQ1(90050.03,BUDAIEN,3.6)
+32 ;ADJUSTMENT
+33 SET BUDPIEC=BUDPIEC+1
+34 SET $PIECE(BUDREC,U,BUDPIEC)=$$VAL^XBDIQ1(90050.03,BUDAIEN,3.7)
+35 ;ADJUSTMENT CATEGORY
+36 SET BUDPIEC=BUDPIEC+1
+37 SET $PIECE(BUDREC,U,BUDPIEC)=$$VAL^XBDIQ1(90050.03,BUDAIEN,102)
+38 ;ADJUSTMENT TYPE
+39 SET BUDPIEC=BUDPIEC+1
+40 SET $PIECE(BUDREC,U,BUDPIEC)=$$VAL^XBDIQ1(90050.03,BUDAIEN,103)
+41 ;A/R ACCOUNT
+42 SET BUDPIEC=BUDPIEC+1
+43 SET $PIECE(BUDREC,U,BUDPIEC)=$$VAL^XBDIQ1(90050.03,BUDAIEN,6)
+44 ;PATIENT
+45 SET BUDPIEC=BUDPIEC+1
+46 SET $PIECE(BUDREC,U,BUDPIEC)=$$VAL^XBDIQ1(90050.03,BUDAIEN,5)
+47 ;VISIT LOCATION
+48 SET BUDDILL=$$VALI^XBDIQ1(90050.03,BUDAIEN,4)
+49 IF BUDDILL
SET Z=$$VAL^XBDIQ1(90050.01,BUDDILL,108)
+50 SET BUDPIEC=BUDPIEC+1
+51 SET $PIECE(BUDREC,U,BUDPIEC)=Z
+52 ;CLINIC TYPE
+53 IF BUDDILL
SET Z=$$VAL^XBDIQ1(90050.01,BUDDILL,112)
+54 SET BUDPIEC=BUDPIEC+1
+55 SET $PIECE(BUDREC,U,BUDPIEC)=Z
+56 ;DOS BEGIN
+57 IF BUDDILL
SET Z=$$VAL^XBDIQ1(90050.01,BUDDILL,102)
+58 SET BUDPIEC=BUDPIEC+1
+59 SET $PIECE(BUDREC,U,BUDPIEC)=Z
+60 ;BILL TYPE
+61 IF BUDDILL
SET Z=$$VAL^XBDIQ1(90050.01,BUDDILL,4)
+62 SET BUDPIEC=BUDPIEC+1
+63 SET $PIECE(BUDREC,U,BUDPIEC)=Z
+64 ;PRIMARY PROVIDER
+65 IF BUDDILL
SET Z=$$VAL^XBDIQ1(90050.01,BUDDILL,113)
+66 SET BUDPIEC=BUDPIEC+1
+67 SET $PIECE(BUDREC,U,BUDPIEC)=Z
+68 ;HRN
+69 SET BUDPIEC=BUDPIEC+1
+70 SET $PIECE(BUDREC,U,BUDPIEC)=$$HRN^AUPNPAT(DFN,DUZ(2))
+71 ;DOB
+72 SET BUDPIEC=BUDPIEC+1
+73 SET $PIECE(BUDREC,U,BUDPIEC)=$$FMTE^XLFDT($$DOB^AUPNPAT(DFN))
+74 ;COMMUNITY
+75 SET BUDPIEC=BUDPIEC+1
+76 SET $PIECE(BUDREC,U,BUDPIEC)=$$COMMRES^AUPNPAT(DFN,"E")
+77 DO SET
+78 QUIT
End DoDot:1
+79 QUIT
SET ;
+1 SET BUDT9C=BUDT9C+1
+2 SET ^XTMP("BUDARP9DEL",BUDJ,BUDH,BUDDATE,BUDT9C)=BUDREC
+3 QUIT
OPIC ;EP
+1 ; I = IEN
+2 ; Y = 1:yes, 0:no
+3 ; X = Pointer to INSURER file.
+4 IF '$GET(P)
QUIT 0
+5 IF '$GET(D)
QUIT 0
+6 NEW I,Y,X,G
+7 SET Y=0
SET U="^"
+8 IF '$DATA(^DPT(P,0))
GOTO OPICX
+9 IF $PIECE(^DPT(P,0),U,19)
GOTO OPICX
+10 IF '$DATA(^AUPNPAT(P,0))
GOTO OPICX
+11 IF '$DATA(^AUPNPRVT(P,11))
GOTO OPICX
+12 IF $DATA(^DPT(P,.35))
IF $PIECE(^(.35),U)]""
IF $PIECE(^(.35),U)<D
GOTO OPICX
+13 SET I=0
SET G=0
+14 FOR
SET I=$ORDER(^AUPNPRVT(P,11,I))
IF I'=+I
QUIT
Begin DoDot:1
+15 IF $PIECE(^AUPNPRVT(P,11,I,0),U)=""
QUIT
+16 SET G=0
+17 SET X=$PIECE(^AUPNPRVT(P,11,I,0),U)
IF X=""
QUIT
+18 IF X
IF $DATA(^BUDESITE(BUDSITE,12,"B",X))
IF $PIECE(^BUDESITE(BUDSITE,12,X,0),U,2)="NI"
QUIT
+19 IF $DATA(^BUDESITE(BUDSITE,12,"B",X))
SET T=$PIECE(^BUDESITE(BUDSITE,12,X,0),U,2)
IF T'="P"
QUIT
+20 IF $PIECE($GET(^AUTNINS(X,2)),U,1)=T
SET G=1
+21 IF 'G
QUIT
+22 IF $PIECE(^AUPNPRVT(P,11,I,0),U,6)>D
QUIT
+23 IF $PIECE(^AUPNPRVT(P,11,I,0),U,7)]""
IF $PIECE(^(0),U,7)<D
QUIT
+24 SET Y=1
+25 QUIT
End DoDot:1
+26 IF Y
QUIT Y
OPICX ;EP
+1 QUIT Y
OPI ;EP
+1 ; I = IEN
+2 ; Y = 1:yes, 0:no
+3 ; X = Pointer to INSURER file.
+4 IF '$GET(P)
QUIT 0
+5 IF '$GET(D)
QUIT 0
+6 NEW I,Y,X,G
+7 SET Y=0
SET U="^"
+8 IF '$DATA(^DPT(P,0))
GOTO OPIX
+9 IF $PIECE(^DPT(P,0),U,19)
GOTO OPIX
+10 IF '$DATA(^AUPNPAT(P,0))
GOTO OPIX
+11 IF '$DATA(^AUPNPRVT(P,11))
GOTO OPIX
+12 IF $DATA(^DPT(P,.35))
IF $PIECE(^(.35),U)]""
IF $PIECE(^(.35),U)<D
GOTO OPIX
+13 SET I=0
SET G=0
+14 FOR
SET I=$ORDER(^AUPNPRVT(P,11,I))
IF I'=+I
QUIT
Begin DoDot:1
+15 IF $PIECE(^AUPNPRVT(P,11,I,0),U)=""
QUIT
+16 SET G=0
+17 SET X=$PIECE(^AUPNPRVT(P,11,I,0),U)
IF X=""
QUIT
+18 IF $DATA(^BUDESITE(BUDSITE,12,"B",X))
SET T=$PIECE(^BUDESITE(BUDSITE,12,X,0),U,2)
IF T'="P"
QUIT
+19 IF X
IF $DATA(^BUDESITE(BUDSITE,12,"B",X))
IF $PIECE(^BUDESITE(BUDSITE,12,X,0),U,2)="NI"
QUIT
+20 ;I $P($G(^AUTNINS(X,2)),U,1)="G" S G=1
+21 IF $PIECE($GET(^AUTNINS(X,2)),U,1)="I"
SET G=1
+22 IF $PIECE($GET(^AUTNINS(X,2)),U,1)="SEP"
SET G=1
+23 IF $PIECE($GET(^AUTNINS(X,2)),U,1)="T"
SET G=1
+24 IF $PIECE(^AUPNPRVT(P,11,I,0),U,6)>D
QUIT
+25 IF $PIECE(^AUPNPRVT(P,11,I,0),U,7)]""
IF $PIECE(^(0),U,7)<D
QUIT
+26 SET Y=1
+27 QUIT
End DoDot:1
+28 IF Y
QUIT Y
OPIX ;
+1 QUIT Y
PI ;EP
+1 ; I = IEN
+2 ; Y = 1:yes, 0:no
+3 ; X = Pointer to INSURER file.
+4 IF '$GET(P)
QUIT 0
+5 IF '$GET(D)
QUIT 0
+6 NEW I,Y,X,G,Z,T,HOLDT
+7 SET Y=0
SET U="^"
+8 IF '$DATA(^DPT(P,0))
GOTO PIX
+9 IF $PIECE(^DPT(P,0),U,19)
GOTO PIX
+10 IF '$DATA(^AUPNPAT(P,0))
GOTO PIX
+11 IF '$DATA(^AUPNPRVT(P,11))
GOTO PIX
+12 IF $DATA(^DPT(P,.35))
IF $PIECE(^(.35),U)]""
IF $PIECE(^(.35),U)<D
GOTO PIX
+13 SET I=0
SET T=""
SET HOLDT=""
+14 FOR
SET I=$ORDER(^AUPNPRVT(P,11,I))
IF I'=+I
QUIT
Begin DoDot:1
+15 IF $PIECE(^AUPNPRVT(P,11,I,0),U)=""
QUIT
+16 SET X=$PIECE(^AUPNPRVT(P,11,I,0),U)
IF X=""
QUIT
+17 IF X
IF $DATA(^BUDESITE(BUDSITE,12,"B",X))
IF $PIECE(^BUDESITE(BUDSITE,12,X,0),U,2)="NI"
QUIT
+18 IF $DATA(^BUDESITE(BUDSITE,12,"B",X))
SET T=$PIECE(^BUDESITE(BUDSITE,12,X,0),U,2)
IF T'="P"
QUIT
+19 IF $PIECE(^AUTNINS(X,0),U)["AHCCCS"
QUIT
+20 SET G=0
+21 IF $PIECE($GET(^AUTNINS(X,2)),U,1)="C"
SET G=1
+22 IF $PIECE($GET(^AUTNINS(X,2)),U,1)="F"
SET G=1
+23 IF $PIECE($GET(^AUTNINS(X,2)),U,1)="H"
SET G=1
+24 IF $PIECE($GET(^AUTNINS(X,2)),U,1)="M"
SET G=1
+25 IF $PIECE($GET(^AUTNINS(X,2)),U,1)="P"
SET G=1
+26 IF $PIECE($GET(^AUTNINS(X,2)),U,1)="W"
SET G=1
+27 IF 'G
QUIT
+28 IF $PIECE(^AUPNPRVT(P,11,I,0),U,6)>D
QUIT
+29 IF $PIECE(^AUPNPRVT(P,11,I,0),U,7)]""
IF $PIECE(^(0),U,7)<D
QUIT
+30 SET Y=1
+31 QUIT
End DoDot:1
PIX ;
+1 IF Y
QUIT Y
+2 ;now check medicare eligible if any overrides to medicare
+3 IF '$$OV(BUDSITE,"P")
QUIT Y
+4 SET I=0
+5 FOR
SET I=$ORDER(^AUPNMCR(P,11,I))
IF I'=+I
QUIT
Begin DoDot:1
+6 IF $PIECE(^AUPNMCR(P,11,I,0),U)>D
QUIT
+7 SET Z=$PIECE(^AUPNMCR(P,11,I,0),U,4)
+8 IF 'Z
QUIT
+9 IF '$DATA(^BUDESITE(BUDSITE,12,"B",Z))
QUIT
+10 IF $PIECE(^BUDESITE(BUDSITE,12,Z,0),U,2)'="P"
QUIT
+11 IF $PIECE(^AUPNMCR(P,11,I,0),U,2)]""
IF $PIECE(^(0),U,2)<D
QUIT
+12 SET Y=1
+13 QUIT
End DoDot:1
+14 IF Y
QUIT Y
+15 ;now check medicaid file
+16 SET I=0
FOR
SET I=$ORDER(^AUPNMCD("B",P,I))
IF I'=+I
QUIT
Begin DoDot:1
+17 IF '$DATA(^AUPNMCD(I,11))
QUIT
+18 ;S Z=$P(^AUPNMCD(I,0),U,2)
+19 ;get plan name/INSURER TYPE OF PLAN NAME
+20 SET N=$$VALI^XBDIQ1(9000004,I,.11)
+21 IF 'N
QUIT
+22 IF '$DATA(^BUDESITE(BUDSITE,12,"B",N))
QUIT
+23 ;not to be counted as PI
IF $PIECE(^BUDESITE(BUDSITE,12,N,0),U,2)'="P"
QUIT
+24 ;I N S N=$$VALI^XBDIQ1(9999999.18,N,.21)
+25 ;I T="K" Q:N'="K"
+26 ;I T="" Q:N="K"
+27 SET J=0
FOR
SET J=$ORDER(^AUPNMCD(I,11,J))
IF J'=+J
QUIT
Begin DoDot:2
+28 IF J>D
QUIT
+29 IF $PIECE(^AUPNMCD(I,11,J,0),U,2)]""
IF $PIECE(^(0),U,2)<D
QUIT
+30 SET Y=1
+31 QUIT
End DoDot:2
+32 QUIT
End DoDot:1
+33 QUIT Y
OV(BUDSITE,T) ;
+1 NEW X,G,Y
+2 SET G=""
+3 SET X=0
FOR
SET X=$ORDER(^BUDESITE(BUDSITE,12,X))
IF X'=+X!(G)
QUIT
Begin DoDot:1
+4 SET Y=$PIECE(^BUDESITE(BUDSITE,12,X,0),U,2)
+5 IF Y=T
SET G=1
End DoDot:1
+6 QUIT G
ZIPINS(DFN,BUDLASTV) ;EP - ZIP INSURANCE
+1 NEW BUDHAS
+2 SET BUDHAS=0
+3 SET BUDHAS=$$PI^BUDERPC2(DFN,$$VD^APCLV(BUDLASTV))
+4 IF BUDHAS=1
QUIT "e"
+5 SET BUDHAS=$$MCR^BUDERPC2(DFN,$$VD^APCLV(BUDLASTV))
+6 IF BUDHAS=1
QUIT "d"
+7 ;S BUDHAS=$$OPI(DFN,$$VD^APCLV(BUDLASTV),"W")
+8 ;I BUDHAS=1 D TINS(BUDAGE,"10a") Q
+9 SET BUDHAS=$$RR^AUPNPAT(DFN,$$VD^APCLV(BUDLASTV))
+10 IF BUDHAS=1
QUIT "c"
+11 SET BUDHAS=$$OPI^BUDERPC2(DFN,$$VD^APCLV(BUDLASTV))
+12 IF BUDHAS=1
QUIT "c"
+13 SET BUDHAS=$$OPIC^BUDERPC2(DFN,$$VD^APCLV(BUDLASTV),"K")
+14 IF BUDHAS=1
QUIT "c"
+15 SET BUDHAS=$$MCD^BUDERPC2(DFN,$$VD^APCLV(BUDLASTV),"D")
+16 IF BUDHAS=1
QUIT "c"
+17 SET BUDHAS=$$MCD^BUDERPC2(DFN,$$VD^APCLV(BUDLASTV),"K")
+18 IF BUDHAS=1
QUIT "c"
+19 ;now check workman's comp and 3rd party liability
+20 SET BUDHAS=$$WC^BUDERPC2(DFN,BUDBD,BUDED)
+21 IF BUDHAS=1
QUIT "e"
+22 SET BUDHAS=$$TPL^BUDERPC2(DFN,BUDBD,BUDED)
+23 IF BUDHAS=1
QUIT "c"
+24 ;now check guarantor file
+25 ;S BUDHAS=$$GUAR(DFN,BUDBD,BUDED)
+26 ;I BUDHAS=1 D TINS(BUDAGE,"7") Q
+27 QUIT "b"
