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

BUDCRPC3.m

Go to the documentation of this file.
BUDCRPC3 ; IHS/CMI/LAB - UDS TABLE 6 ; 11 Dec 2015  10:13 AM
 ;;10.0;IHS/RPMS UNIFORM DATA SYSTEM;;FEB 04, 2016;Build 50
T9D ;EP
 NEW BUDAIEN,BUDDATE,BUD0,BUDREC,BUDCILL,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 BUDCILL=$$VALI^XBDIQ1(90050.03,BUDAIEN,4)
 .I BUDCILL S Z=$$VAL^XBDIQ1(90050.01,BUDCILL,108)
 .S BUDPIEC=BUDPIEC+1
 .S $P(BUDREC,U,BUDPIEC)=Z
 .;CLINIC TYPE
 .I BUDCILL S Z=$$VAL^XBDIQ1(90050.01,BUDCILL,112)
 .S BUDPIEC=BUDPIEC+1
 .S $P(BUDREC,U,BUDPIEC)=Z
 .;DOS BEGIN
 .I BUDCILL S Z=$$VAL^XBDIQ1(90050.01,BUDCILL,102)
 .S BUDPIEC=BUDPIEC+1
 .S $P(BUDREC,U,BUDPIEC)=Z
 .;BILL TYPE
 .I BUDCILL S Z=$$VAL^XBDIQ1(90050.01,BUDCILL,4)
 .S BUDPIEC=BUDPIEC+1
 .S $P(BUDREC,U,BUDPIEC)=Z
 .;PRIMARY PROVIDER
 .I BUDCILL S Z=$$VAL^XBDIQ1(90050.01,BUDCILL,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 $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
ZIPINS(DFN,BUDLASTV) ;EP - ZIP INSURANCE
 NEW BUDHAS
 S BUDHAS=0
 S BUDHAS=$$PI^BUDCRPC2(DFN,$$VD^APCLV(BUDLASTV))
 I BUDHAS=1 Q "e"
 S BUDHAS=$$MCR^BUDCRPC2(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^BUDCRPC2(DFN,$$VD^APCLV(BUDLASTV))
 I BUDHAS=1 Q "c"
 S BUDHAS=$$OPIC^BUDCRPC2(DFN,$$VD^APCLV(BUDLASTV),"K")
 I BUDHAS=1 Q "c"
 S BUDHAS=$$MCD^BUDCRPC2(DFN,$$VD^APCLV(BUDLASTV),"D")
 I BUDHAS=1 Q "c"
 S BUDHAS=$$MCD^BUDCRPC2(DFN,$$VD^APCLV(BUDLASTV),"K")
 I BUDHAS=1 Q "c"
 ;now check workman's comp and 3rd party liability
 S BUDHAS=$$WC^BUDCRPC2(DFN,BUDBD,BUDED)
 I BUDHAS=1 Q "c"
 S BUDHAS=$$TPL^BUDCRPC2(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"