BUD1RPC3.m

BUD1RPC3 ; 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("BUD1RP9DEL",BUDJ,BUDH,BUDDATE,BUDT9C)=BUDREC

 Q

BUD1RPC3  ; 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("BUD1RP9DEL",BUDJ,BUDH,BUDDATE,BUDT9C)=BUDREC

 +3        QUIT