BUD2RPC3 ; IHS/CMI/LAB - UDS TABLE 6 11 Dec 2007 12:15 PM ;
;;10.0;IHS/RPMS UNIFORM DATA SYSTEM;;FEB 04, 2016;Build 50
T9D ;EP
NEW BUDAIEN,BUDDATE,BUD0,BUDREC,BUDBILL,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))
.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 BUDBILL=$$VALI^XBDIQ1(90050.03,BUDAIEN,4)
.I BUDBILL S Z=$$VAL^XBDIQ1(90050.01,BUDBILL,108)
.S BUDPIEC=BUDPIEC+1
.S $P(BUDREC,U,BUDPIEC)=Z
.;CLINIC TYPE
.I BUDBILL S Z=$$VAL^XBDIQ1(90050.01,BUDBILL,112)
.S BUDPIEC=BUDPIEC+1
.S $P(BUDREC,U,BUDPIEC)=Z
.;DOS BEGIN
.I BUDBILL S Z=$$VAL^XBDIQ1(90050.01,BUDBILL,102)
.S BUDPIEC=BUDPIEC+1
.S $P(BUDREC,U,BUDPIEC)=Z
.;BILL TYPE
.I BUDBILL S Z=$$VAL^XBDIQ1(90050.01,BUDBILL,4)
.S BUDPIEC=BUDPIEC+1
.S $P(BUDREC,U,BUDPIEC)=Z
.;PRIMARY PROVIDER
.I BUDBILL S Z=$$VAL^XBDIQ1(90050.01,BUDBILL,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("BUD2RP9DEL",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 $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 $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
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
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=""
. 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 ;
Q Y
BUD2RPC3 ; IHS/CMI/LAB - UDS TABLE 6 11 Dec 2007 12:15 PM ;
+1 ;;10.0;IHS/RPMS UNIFORM DATA SYSTEM;;FEB 04, 2016;Build 50
T9D ;EP
+1 NEW BUDAIEN,BUDDATE,BUD0,BUDREC,BUDBILL,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 SET BUD0=^BARTR(DUZ(2),BUDAIEN,0)
+6 SET BUDDATE=$PIECE(BUD0,U,12)
+7 ;ONLY UDS DATE RANGE
IF $PIECE(BUDDATE,".")<BUDBD
QUIT
+8 IF $PIECE(BUDDATE,".")>BUDED
QUIT
+9 SET BUDREC=""
SET BUDPIEC=0
+10 ;DATE
+11 SET BUDPIEC=BUDPIEC+1
+12 SET $PIECE(BUDREC,U,BUDPIEC)=$$FMTE^XLFDT(BUDDATE)
+13 ;BILL NUMBER
+14 SET BUDPIEC=BUDPIEC+1
+15 SET $PIECE(BUDREC,U,BUDPIEC)=$$VAL^XBDIQ1(90050.03,BUDAIEN,4)
+16 ;TRANSACTION TYPE
+17 SET BUDPIEC=BUDPIEC+1
+18 SET $PIECE(BUDREC,U,BUDPIEC)=$$VAL^XBDIQ1(90050.03,BUDAIEN,101)
+19 ;CREDIT 2 A/R TRANSACTION FILE
+20 SET BUDPIEC=BUDPIEC+1
+21 SET $PIECE(BUDREC,U,BUDPIEC)=$PIECE(BUD0,U,2)
+22 ;DEBIT 3 A/R TRANSACTION FILE
+23 SET BUDPIEC=BUDPIEC+1
+24 SET $PIECE(BUDREC,U,BUDPIEC)=$PIECE(BUD0,U,3)
+25 ;PRIME BILL AMOUNT
+26 SET BUDPIEC=BUDPIEC+1
+27 SET $PIECE(BUDREC,U,BUDPIEC)=$$VAL^XBDIQ1(90050.03,BUDAIEN,3.2)
+28 ;PAYMENT
+29 SET BUDPIEC=BUDPIEC+1
+30 SET $PIECE(BUDREC,U,BUDPIEC)=$$VAL^XBDIQ1(90050.03,BUDAIEN,3.6)
+31 ;ADJUSTMENT
+32 SET BUDPIEC=BUDPIEC+1
+33 SET $PIECE(BUDREC,U,BUDPIEC)=$$VAL^XBDIQ1(90050.03,BUDAIEN,3.7)
+34 ;ADJUSTMENT CATEGORY
+35 SET BUDPIEC=BUDPIEC+1
+36 SET $PIECE(BUDREC,U,BUDPIEC)=$$VAL^XBDIQ1(90050.03,BUDAIEN,102)
+37 ;ADJUSTMENT TYPE
+38 SET BUDPIEC=BUDPIEC+1
+39 SET $PIECE(BUDREC,U,BUDPIEC)=$$VAL^XBDIQ1(90050.03,BUDAIEN,103)
+40 ;A/R ACCOUNT
+41 SET BUDPIEC=BUDPIEC+1
+42 SET $PIECE(BUDREC,U,BUDPIEC)=$$VAL^XBDIQ1(90050.03,BUDAIEN,6)
+43 ;PATIENT
+44 SET BUDPIEC=BUDPIEC+1
+45 SET $PIECE(BUDREC,U,BUDPIEC)=$$VAL^XBDIQ1(90050.03,BUDAIEN,5)
+46 ;VISIT LOCATION
+47 SET BUDBILL=$$VALI^XBDIQ1(90050.03,BUDAIEN,4)
+48 IF BUDBILL
SET Z=$$VAL^XBDIQ1(90050.01,BUDBILL,108)
+49 SET BUDPIEC=BUDPIEC+1
+50 SET $PIECE(BUDREC,U,BUDPIEC)=Z
+51 ;CLINIC TYPE
+52 IF BUDBILL
SET Z=$$VAL^XBDIQ1(90050.01,BUDBILL,112)
+53 SET BUDPIEC=BUDPIEC+1
+54 SET $PIECE(BUDREC,U,BUDPIEC)=Z
+55 ;DOS BEGIN
+56 IF BUDBILL
SET Z=$$VAL^XBDIQ1(90050.01,BUDBILL,102)
+57 SET BUDPIEC=BUDPIEC+1
+58 SET $PIECE(BUDREC,U,BUDPIEC)=Z
+59 ;BILL TYPE
+60 IF BUDBILL
SET Z=$$VAL^XBDIQ1(90050.01,BUDBILL,4)
+61 SET BUDPIEC=BUDPIEC+1
+62 SET $PIECE(BUDREC,U,BUDPIEC)=Z
+63 ;PRIMARY PROVIDER
+64 IF BUDBILL
SET Z=$$VAL^XBDIQ1(90050.01,BUDBILL,113)
+65 SET BUDPIEC=BUDPIEC+1
+66 SET $PIECE(BUDREC,U,BUDPIEC)=Z
+67 ;HRN
+68 SET BUDPIEC=BUDPIEC+1
+69 SET $PIECE(BUDREC,U,BUDPIEC)=$$HRN^AUPNPAT(DFN,DUZ(2))
+70 ;DOB
+71 SET BUDPIEC=BUDPIEC+1
+72 SET $PIECE(BUDREC,U,BUDPIEC)=$$FMTE^XLFDT($$DOB^AUPNPAT(DFN))
+73 ;COMMUNITY
+74 SET BUDPIEC=BUDPIEC+1
+75 SET $PIECE(BUDREC,U,BUDPIEC)=$$COMMRES^AUPNPAT(DFN,"E")
+76 DO SET
+77 QUIT
End DoDot:1
+78 QUIT
SET ;
+1 SET BUDT9C=BUDT9C+1
+2 SET ^XTMP("BUD2RP9DEL",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 $PIECE($GET(^AUTNINS(X,2)),U,1)=T
SET G=1
+19 IF 'G
QUIT
+20 IF $PIECE(^AUPNPRVT(P,11,I,0),U,6)>D
QUIT
+21 IF $PIECE(^AUPNPRVT(P,11,I,0),U,7)]""
IF $PIECE(^(0),U,7)<D
QUIT
+22 SET Y=1
+23 QUIT
End DoDot:1
+24 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 ;I $P($G(^AUTNINS(X,2)),U,1)="G" S G=1
+19 IF $PIECE($GET(^AUTNINS(X,2)),U,1)="I"
SET G=1
+20 IF $PIECE($GET(^AUTNINS(X,2)),U,1)="SEP"
SET G=1
+21 IF $PIECE($GET(^AUTNINS(X,2)),U,1)="T"
SET G=1
+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
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
+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
+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 $PIECE(^AUTNINS(X,0),U)["AHCCCS"
QUIT
+18 SET G=0
+19 IF $PIECE($GET(^AUTNINS(X,2)),U,1)="C"
SET G=1
+20 IF $PIECE($GET(^AUTNINS(X,2)),U,1)="F"
SET G=1
+21 IF $PIECE($GET(^AUTNINS(X,2)),U,1)="H"
SET G=1
+22 IF $PIECE($GET(^AUTNINS(X,2)),U,1)="M"
SET G=1
+23 IF $PIECE($GET(^AUTNINS(X,2)),U,1)="P"
SET G=1
+24 IF $PIECE($GET(^AUTNINS(X,2)),U,1)="W"
SET G=1
+25 IF 'G
QUIT
+26 IF $PIECE(^AUPNPRVT(P,11,I,0),U,6)>D
QUIT
+27 IF $PIECE(^AUPNPRVT(P,11,I,0),U,7)]""
IF $PIECE(^(0),U,7)<D
QUIT
+28 SET Y=1
+29 QUIT
End DoDot:1
PIX ;
+1 QUIT Y
