- BUDHRPC4 ;IHS/CMI/LAB - UDS TABLE 1-6A;
- ;;13.0;IHS/RPMS UNIFORM DATA SYSTEM;;OCT 12, 2018;Build 90
- T9 ;EP
- ;TABLE 9D - TOTALS ONLY
- ;CODE ORIGINATED WITH SHONDA RENDER (BUDMUPV1)
- ;FIRST LOOP THROUGH BUDDBILL FOR THIS PATIENTS VISITS THAT ARE IN ^TMP
- S BUDDNT=0
- S BUDDUZ2=0
- S BUDFOUND=0
- S BUDLINE=""
- D GETPAR
- F S BUDDUZ2=$O(^ABMDBILL(BUDDUZ2)) Q:'BUDDUZ2 D
- .S BUDVDFN=0
- .F S BUDVDFN=$O(^TMP($J,"VISITSUDSPT",BUDVDFN)) Q:'BUDVDFN D
- ..S BUDDILLF=0 ;BUD*2.6*8 HEAT47191
- ..;Q:($G(^XTMP("BUD-PVP",$J,"VISITS",BUDVDFN))=1) ;already counted this visit on report
- ..Q:'$D(^ABMDBILL(BUDDUZ2,"AV",BUDVDFN)) ;visit not under this DUZ(2)
- ..S BUDP("BDFN")=0
- ..F S BUDP("BDFN")=$O(^ABMDBILL(BUDDUZ2,"AV",BUDVDFN,BUDP("BDFN"))) Q:'BUDP("BDFN") D Q:BUDDILLF ;BUD*2.6*8 HEAT47191
- ...I $P($G(^ABMDBILL(BUDDUZ2,BUDP("BDFN"),0)),U,4)="X" Q ;CANCELLED
- ...S BUDVLOC=$P($G(^ABMDBILL(BUDDUZ2,BUDP("BDFN"),0)),U,3)
- ...S BUDINS=$P($G(^ABMDBILL(BUDDUZ2,BUDP("BDFN"),0)),U,8)
- ...S BUDPT=$P($G(^ABMDBILL(BUDDUZ2,BUDP("BDFN"),0)),U,5)
- ...;determine insurer type and set LINE var
- ...S BUDLINE=""
- ...D GETITYPE
- ...I BUDLINE="" Q
- ...S (BUDDILLN,BUDSAV)=$P($G(^ABMDBILL(BUDDUZ2,BUDP("BDFN"),0)),U)
- ...;F S BUDDILLN=$O(^BARBL(BUDPAR,"B",BUDDILLN)) Q:$G(BUDDILLN)=""!(BUDDILLN'[BUDSAV) D ;BUD*2.6*8 HEAT47191
- ...F S BUDDILLN=$O(^BARBL(BUDPAR,"B",BUDDILLN)) Q:$G(BUDDILLN)=""!(BUDDILLN'[BUDSAV) D Q:BUDDILLF ;BUD*2.6*8 HEAT47191
- ....S BUDARIEN=0
- ....S BUDHOLD=DUZ(2)
- ....S DUZ(2)=BUDPAR
- ....F S BUDARIEN=$O(^BARBL(DUZ(2),"B",BUDDILLN,BUDARIEN)) Q:'BUDARIEN D Q:BUDDILLF ;BUD*2.6*8 HEAT47191
- .....S BUDARACT=$$GET1^DIQ(90050.01,BUDARIEN_",",3,"I") ;A/R BILL, A/R ACCOUNT
- .....S $P(BUDT9(BUDLINE),U,1)=$P($G(BUDT9(BUDLINE)),U,1)+$$VAL^XBDIQ1(90050.01,BUDARIEN,13)
- .....S $P(BUDT9(BUDLINE),U,3)=$P($G(BUDT9(BUDLINE)),U,3)+$$VAL^XBDIQ1(90050.01,BUDARIEN,25)
- .....;I BUDLINE=3 W !,DFN,":",BUDDILLN,":",BUDARIEN,":",$$VAL^XBDIQ1(90050.01,BUDARIEN,13)
- .....;S D0=BUDARACT
- .....;S BUDITYP=$$VALI^BARVPM(8) ;GET 'VIP INSURER TYPE' CODE
- .....;S BUDGRP=$S(BUDITYP="D":"MCD",BUDITYP="K":"CHIP",1:"OTHR")
- .....S BUDABILN=$P($G(^BARBL(DUZ(2),BUDARIEN,0)),U)
- .....S BUDTRIEN=0
- .....;F S BUDTRIEN=$O(^BARTR(DUZ(2),"AC",BUDARIEN,BUDTRIEN)) Q:'BUDTRIEN D ;BUD*2.6*8 HEAT47191
- .....F S BUDTRIEN=$O(^BARTR(DUZ(2),"AC",BUDARIEN,BUDTRIEN)) Q:'BUDTRIEN D Q:BUDDILLF ;BUD*2.6*8 HEAT47191
- ......S BUDTRTYP=$P($G(^BARTR(DUZ(2),BUDTRIEN,1)),U)
- ......S BUDADJT=$P($G(^BARTR(DUZ(2),BUDTRIEN,1)),U,3) ;abm*2.6*8
- ......;I "^40^113^114^121^132^137^138^139^"'[("^"_ABMTRTYP_"^") Q ;payment or payment credit ;abm*2.6*8
- ......I (BUDTRTYP'=40)&("^113^114^121^132^137^138^139^"'[("^"_BUDADJT_"^")) Q ;payment or payment credit ;abm*2.6*8
- ......I ($$GET1^DIQ(90050.03,BUDTRIEN,3.5))<(.01) Q ;don't count 0 pymts or reversals
- ......;CHECK DATES??
- ......Q:$P($P(^BARTR(DUZ(2),BUDTRIEN,0),U,1),".")>BUDED
- ......Q:$P($P(^BARTR(DUZ(2),BUDTRIEN,0),U,1),".")<BUDBD
- ......S $P(BUDT9(BUDLINE),U,2)=$P($G(BUDT9(BUDLINE)),U,2)+$$VAL^XBDIQ1(90050.03,BUDTRIEN,3.5)
- ....S DUZ(2)=BUDHOLD
- Q
- GETITYPE ;
- S BUDIT=$P($G(^ABMDBILL(BUDDUZ2,BUDP("BDFN"),2)),U,2)
- I BUDIT="D" S BUDLINE=3 Q
- I BUDIT="K" S BUDLINE=3 Q
- I BUDIT="R" S BUDLINE=6 Q
- I BUDIT="MD" S BUDLINE=6 Q
- I BUDIT="MH" S BUDLINE=6 Q
- I BUDIT="MC" S BUDLINE=6 Q
- I BUDIT="MMC" S BUDLINE=6 Q
- I BUDIT="I" S BUDLINE=9 Q
- I BUDIT="G" S BUDLINE=9 Q
- I BUDIT="SEP" S BUDLINE=9 Q
- I BUDIT="T" S BUDLINE=9 Q
- I BUDIT="C" S BUDLINE=12 Q
- I BUDIT="F" S BUDLINE=12 Q
- I BUDIT="FPL" S BUDLINE=12 Q
- I BUDIT="H" S BUDLINE=12 Q
- I BUDIT="M" S BUDLINE=12 Q
- I BUDIT="P" S BUDLINE=12 Q
- I BUDIT="W" S BUDLINE=12 Q
- I BUDIT="N" S BUDLINE=13 Q
- I BUDIT="TSI" S BUDLINE=13 Q
- ;I BUDIT="P" D
- ;.;IF INSURER HAS A K PUT IN 9
- ;.NEW X,Y,G
- ;.S G=0,X=0 F S X=$O(^ABMDBILL(BUDDUZ2,BUDP("BDFN"),13,X)) Q:X'=+X D
- ;..S Y=$P(^ABMDBILL(BUDDUZ2,BUDP("BDFN"),13,X,0),U)
- ;..I $P($G(^AUTNINS(Y,2)),U,1)="K" S G=1
- ;.I G S BUDLINE=9 Q
- ;.S BUDLINE=12
- Q
- GETPAR ;EP
- K BUDPSFLG,BUDFLIST
- S BUDPAR=0
- S BUDDNT=1
- F S BUDPAR=$O(^BAR(90052.05,BUDPAR)) Q:+BUDPAR=0 D Q:($G(BUDPSFLG)=1)
- .I $D(^BAR(90052.05,BUDPAR,DUZ(2))) D
- ..; Use A/R parent/sat is yes, but DUZ(2) is not the parent for this
- ..; visit location
- ..Q:$P($G(^BAR(90052.05,BUDPAR,DUZ(2),0)),U,3)'=BUDPAR
- ..Q:$P($G(^BAR(90052.05,BUDPAR,DUZ(2),0)),U,6)>DT
- ..Q:$P($G(^BAR(90052.05,BUDPAR,DUZ(2),0)),U,7)&($P(^(0),U,7)<DT)
- ..S BUDPSFLG=1
- Q ;
- BUDHRPC4 ;IHS/CMI/LAB - UDS TABLE 1-6A;
- +1 ;;13.0;IHS/RPMS UNIFORM DATA SYSTEM;;OCT 12, 2018;Build 90
- T9 ;EP
- +1 ;TABLE 9D - TOTALS ONLY
- +2 ;CODE ORIGINATED WITH SHONDA RENDER (BUDMUPV1)
- +3 ;FIRST LOOP THROUGH BUDDBILL FOR THIS PATIENTS VISITS THAT ARE IN ^TMP
- +4 SET BUDDNT=0
- +5 SET BUDDUZ2=0
- +6 SET BUDFOUND=0
- +7 SET BUDLINE=""
- +8 DO GETPAR
- +9 FOR
- SET BUDDUZ2=$ORDER(^ABMDBILL(BUDDUZ2))
- IF 'BUDDUZ2
- QUIT
- Begin DoDot:1
- +10 SET BUDVDFN=0
- +11 FOR
- SET BUDVDFN=$ORDER(^TMP($JOB,"VISITSUDSPT",BUDVDFN))
- IF 'BUDVDFN
- QUIT
- Begin DoDot:2
- +12 ;BUD*2.6*8 HEAT47191
- SET BUDDILLF=0
- +13 ;Q:($G(^XTMP("BUD-PVP",$J,"VISITS",BUDVDFN))=1) ;already counted this visit on report
- +14 ;visit not under this DUZ(2)
- IF '$DATA(^ABMDBILL(BUDDUZ2,"AV",BUDVDFN))
- QUIT
- +15 SET BUDP("BDFN")=0
- +16 ;BUD*2.6*8 HEAT47191
- FOR
- SET BUDP("BDFN")=$ORDER(^ABMDBILL(BUDDUZ2,"AV",BUDVDFN,BUDP("BDFN")))
- IF 'BUDP("BDFN")
- QUIT
- Begin DoDot:3
- +17 ;CANCELLED
- IF $PIECE($GET(^ABMDBILL(BUDDUZ2,BUDP("BDFN"),0)),U,4)="X"
- QUIT
- +18 SET BUDVLOC=$PIECE($GET(^ABMDBILL(BUDDUZ2,BUDP("BDFN"),0)),U,3)
- +19 SET BUDINS=$PIECE($GET(^ABMDBILL(BUDDUZ2,BUDP("BDFN"),0)),U,8)
- +20 SET BUDPT=$PIECE($GET(^ABMDBILL(BUDDUZ2,BUDP("BDFN"),0)),U,5)
- +21 ;determine insurer type and set LINE var
- +22 SET BUDLINE=""
- +23 DO GETITYPE
- +24 IF BUDLINE=""
- QUIT
- +25 SET (BUDDILLN,BUDSAV)=$PIECE($GET(^ABMDBILL(BUDDUZ2,BUDP("BDFN"),0)),U)
- +26 ;F S BUDDILLN=$O(^BARBL(BUDPAR,"B",BUDDILLN)) Q:$G(BUDDILLN)=""!(BUDDILLN'[BUDSAV) D ;BUD*2.6*8 HEAT47191
- +27 ;BUD*2.6*8 HEAT47191
- FOR
- SET BUDDILLN=$ORDER(^BARBL(BUDPAR,"B",BUDDILLN))
- IF $GET(BUDDILLN)=""!(BUDDILLN'[BUDSAV)
- QUIT
- Begin DoDot:4
- +28 SET BUDARIEN=0
- +29 SET BUDHOLD=DUZ(2)
- +30 SET DUZ(2)=BUDPAR
- +31 ;BUD*2.6*8 HEAT47191
- FOR
- SET BUDARIEN=$ORDER(^BARBL(DUZ(2),"B",BUDDILLN,BUDARIEN))
- IF 'BUDARIEN
- QUIT
- Begin DoDot:5
- +32 ;A/R BILL, A/R ACCOUNT
- SET BUDARACT=$$GET1^DIQ(90050.01,BUDARIEN_",",3,"I")
- +33 SET $PIECE(BUDT9(BUDLINE),U,1)=$PIECE($GET(BUDT9(BUDLINE)),U,1)+$$VAL^XBDIQ1(90050.01,BUDARIEN,13)
- +34 SET $PIECE(BUDT9(BUDLINE),U,3)=$PIECE($GET(BUDT9(BUDLINE)),U,3)+$$VAL^XBDIQ1(90050.01,BUDARIEN,25)
- +35 ;I BUDLINE=3 W !,DFN,":",BUDDILLN,":",BUDARIEN,":",$$VAL^XBDIQ1(90050.01,BUDARIEN,13)
- +36 ;S D0=BUDARACT
- +37 ;S BUDITYP=$$VALI^BARVPM(8) ;GET 'VIP INSURER TYPE' CODE
- +38 ;S BUDGRP=$S(BUDITYP="D":"MCD",BUDITYP="K":"CHIP",1:"OTHR")
- +39 SET BUDABILN=$PIECE($GET(^BARBL(DUZ(2),BUDARIEN,0)),U)
- +40 SET BUDTRIEN=0
- +41 ;F S BUDTRIEN=$O(^BARTR(DUZ(2),"AC",BUDARIEN,BUDTRIEN)) Q:'BUDTRIEN D ;BUD*2.6*8 HEAT47191
- +42 ;BUD*2.6*8 HEAT47191
- FOR
- SET BUDTRIEN=$ORDER(^BARTR(DUZ(2),"AC",BUDARIEN,BUDTRIEN))
- IF 'BUDTRIEN
- QUIT
- Begin DoDot:6
- +43 SET BUDTRTYP=$PIECE($GET(^BARTR(DUZ(2),BUDTRIEN,1)),U)
- +44 ;abm*2.6*8
- SET BUDADJT=$PIECE($GET(^BARTR(DUZ(2),BUDTRIEN,1)),U,3)
- +45 ;I "^40^113^114^121^132^137^138^139^"'[("^"_ABMTRTYP_"^") Q ;payment or payment credit ;abm*2.6*8
- +46 ;payment or payment credit ;abm*2.6*8
- IF (BUDTRTYP'=40)&("^113^114^121^132^137^138^139^"'[("^"_BUDADJT_"^"))
- QUIT
- +47 ;don't count 0 pymts or reversals
- IF ($$GET1^DIQ(90050.03,BUDTRIEN,3.5))<(.01)
- QUIT
- +48 ;CHECK DATES??
- +49 IF $PIECE($PIECE(^BARTR(DUZ(2),BUDTRIEN,0),U,1),".")>BUDED
- QUIT
- +50 IF $PIECE($PIECE(^BARTR(DUZ(2),BUDTRIEN,0),U,1),".")<BUDBD
- QUIT
- +51 SET $PIECE(BUDT9(BUDLINE),U,2)=$PIECE($GET(BUDT9(BUDLINE)),U,2)+$$VAL^XBDIQ1(90050.03,BUDTRIEN,3.5)
- End DoDot:6
- IF BUDDILLF
- QUIT
- End DoDot:5
- IF BUDDILLF
- QUIT
- +52 SET DUZ(2)=BUDHOLD
- End DoDot:4
- IF BUDDILLF
- QUIT
- End DoDot:3
- IF BUDDILLF
- QUIT
- End DoDot:2
- End DoDot:1
- +53 QUIT
- GETITYPE ;
- +1 SET BUDIT=$PIECE($GET(^ABMDBILL(BUDDUZ2,BUDP("BDFN"),2)),U,2)
- +2 IF BUDIT="D"
- SET BUDLINE=3
- QUIT
- +3 IF BUDIT="K"
- SET BUDLINE=3
- QUIT
- +4 IF BUDIT="R"
- SET BUDLINE=6
- QUIT
- +5 IF BUDIT="MD"
- SET BUDLINE=6
- QUIT
- +6 IF BUDIT="MH"
- SET BUDLINE=6
- QUIT
- +7 IF BUDIT="MC"
- SET BUDLINE=6
- QUIT
- +8 IF BUDIT="MMC"
- SET BUDLINE=6
- QUIT
- +9 IF BUDIT="I"
- SET BUDLINE=9
- QUIT
- +10 IF BUDIT="G"
- SET BUDLINE=9
- QUIT
- +11 IF BUDIT="SEP"
- SET BUDLINE=9
- QUIT
- +12 IF BUDIT="T"
- SET BUDLINE=9
- QUIT
- +13 IF BUDIT="C"
- SET BUDLINE=12
- QUIT
- +14 IF BUDIT="F"
- SET BUDLINE=12
- QUIT
- +15 IF BUDIT="FPL"
- SET BUDLINE=12
- QUIT
- +16 IF BUDIT="H"
- SET BUDLINE=12
- QUIT
- +17 IF BUDIT="M"
- SET BUDLINE=12
- QUIT
- +18 IF BUDIT="P"
- SET BUDLINE=12
- QUIT
- +19 IF BUDIT="W"
- SET BUDLINE=12
- QUIT
- +20 IF BUDIT="N"
- SET BUDLINE=13
- QUIT
- +21 IF BUDIT="TSI"
- SET BUDLINE=13
- QUIT
- +22 ;I BUDIT="P" D
- +23 ;.;IF INSURER HAS A K PUT IN 9
- +24 ;.NEW X,Y,G
- +25 ;.S G=0,X=0 F S X=$O(^ABMDBILL(BUDDUZ2,BUDP("BDFN"),13,X)) Q:X'=+X D
- +26 ;..S Y=$P(^ABMDBILL(BUDDUZ2,BUDP("BDFN"),13,X,0),U)
- +27 ;..I $P($G(^AUTNINS(Y,2)),U,1)="K" S G=1
- +28 ;.I G S BUDLINE=9 Q
- +29 ;.S BUDLINE=12
- +30 QUIT
- GETPAR ;EP
- +1 KILL BUDPSFLG,BUDFLIST
- +2 SET BUDPAR=0
- +3 SET BUDDNT=1
- +4 FOR
- SET BUDPAR=$ORDER(^BAR(90052.05,BUDPAR))
- IF +BUDPAR=0
- QUIT
- Begin DoDot:1
- +5 IF $DATA(^BAR(90052.05,BUDPAR,DUZ(2)))
- Begin DoDot:2
- +6 ; Use A/R parent/sat is yes, but DUZ(2) is not the parent for this
- +7 ; visit location
- +8 IF $PIECE($GET(^BAR(90052.05,BUDPAR,DUZ(2),0)),U,3)'=BUDPAR
- QUIT
- +9 IF $PIECE($GET(^BAR(90052.05,BUDPAR,DUZ(2),0)),U,6)>DT
- QUIT
- +10 IF $PIECE($GET(^BAR(90052.05,BUDPAR,DUZ(2),0)),U,7)&($PIECE(^(0),U,7)<DT)
- QUIT
- +11 SET BUDPSFLG=1
- End DoDot:2
- End DoDot:1
- IF ($GET(BUDPSFLG)=1)
- QUIT
- +12 ;
- QUIT
