ABMDF1C ; IHS/ASDST/DMJ - Set UB82 Print Array - cont ;
;;2.6;IHS 3P BILLING SYSTEM;**6**;NOV 12, 2009
;Original;TMD;
;
S ABM("CNT")=0
S ABMP("B0")=^ABMDBILL(DUZ(2),ABMP("BDFN"),0)
S ABMP("GL")="^ABMDBILL(DUZ(2),"_ABMP("BDFN")_","
S ABMP("VDT")=$P(^ABMDBILL(DUZ(2),ABMP("BDFN"),7),U),$P(ABMP("B0"),U,2)=ABMP("VDT")
S ABMP("BTYP")=$P(ABMP("B0"),"^",12)
S ABMP("VTYP")=$P(ABMP("B0"),U,7)
D ^ABMDE2X1 S ABMP("EXP")=1
LOOP S ABM("IN")="",(ABMP("PAID"),ABMP("TW"))=0 F ABM("I")=41:1:43 S ABM("IN")=$O(^ABMDBILL(DUZ(2),ABMP("BDFN"),13,"C",ABM("IN"))) Q:'ABM("IN") S ABM("XIEN")=$O(^(ABM("IN"),0)) D
.S ABM("INSCO")=$P(^ABMDBILL(DUZ(2),ABMP("BDFN"),13,ABM("XIEN"),0),"^",1)
.D INS
.D INSRD
;S ABMP("PAID")=+$FN(ABMP("PAID")*ABM("RATIO"),"",2) ;IHS/SD/AML NOHEAT 2/15/2011
;S ABMP("TW")=+$FN(ABMP("TW")*ABM("RATIO"),"",2) ;IHS/SD/AML NOHEAT 2/15/2011
S ABMP("PAID")=+$FN(ABMP("PAID")*$G(ABM("RATIO")),"",2) ;IHS/SD/AML NOHEAT 2/15/2011
S ABMP("TW")=+$FN(ABMP("TW")*$G(ABM("RATIO")),"",2) ;IHS/SD/AML NOHEAT 2/15/2011
K ABM,ABME,ABMV
G ^ABMDF1D
;
MINUS S ABM("I")=ABM("I")-1
Q
;
INS G MINUS:'$D(^ABMDBILL(DUZ(2),ABMP("BDFN"),13,ABM("XIEN"),0)),MINUS:"U"[$P(^(0),U,3),MINUS:'$D(^AUTNINS(ABM("INSCO"),0))
S ABM("Z")=$S(ABM("I")=41:"A",ABM("I")=42:"B",1:"C")
I $P($G(^AUTNINS(ABM("INSCO"),2)),U)="R" S $P(ABMF(4),U,4)=$P(^AUTTLOC(ABMP("LDFN"),0),U,19)
PAYOR S Y=ABM("INSCO") S ABMP("GL")="^ABMDBILL(DUZ(2),"_ABMP("BDFN")_",",ABMP("VDT")=$P(^ABMDBILL(DUZ(2),ABMP("BDFN"),7),U) D SEL^ABMDE2X
I ABM("INSCO")=$P(ABMP("B0"),"^",8),$P(^ABMDBILL(DUZ(2),ABMP("BDFN"),13,ABM("XIEN"),0),"^",3)="I" D
.S ABMP("PAYOR")=ABM("I")
.I $P(ABMV("X1"),U,5)]"" S $P(ABMF(6),U)=$P(ABMV("X1"),U,5)
CONT S ABM("I0")=+ABMV("X1")
S (ABM("PD"),ABM("DEDCT"),ABM("COINS"))=0 D PREV
S ABM("RATIO")=+^ABMDBILL(DUZ(2),ABMP("BDFN"),2)/$S($P(^(2),U,3):$P(^(2),U,3),1:1)
S:ABM("RATIO")>1 ABM("RATIO")=1
S ABM("PD")=+$FN(ABM("PD")*ABM("RATIO"),"",2)
;
G NON:$P($G(^AUTNINS(ABM("I0"),2)),U)="N" S ABMF(ABM("I"))=$P(^(0),U)_U_$P($G(^ABMDBILL(DUZ(2),ABMP("BDFN"),7)),U,4)_U_$P($G(^(7)),U,5)
S:ABM("DEDCT") $P(ABMF(ABM("I")),U,4)=ABM("DEDCT")
S:ABM("COINS") $P(ABMF(ABM("I")),U,5)=ABM("COINS")
S:ABM("PD") $P(ABMF(ABM("I")),U,7)=ABM("PD")
Q
NON S $P(ABMF(44),U,2)=$S(ABM("PD")>0:ABM("PD"),1:"")
I $G(ABMP("PAYOR"))=ABM("I") S ABMP("PAYOR")=44
S ABM("I")=ABM("I")-1
Q
;
PREV S ABM("C")="" F S ABM("C")=$O(^ABMDBILL(DUZ(2),"AS",+^ABMDBILL(DUZ(2),ABMP("BDFN"),0),ABM("C"))) Q:ABM("C")="" D
.S ABM("B")=0 F S ABM("B")=$O(^ABMDBILL(DUZ(2),"AS",+^ABMDBILL(DUZ(2),ABMP("BDFN"),0),ABM("C"),ABM("B"))) Q:'ABM("B") D
..I $D(^ABMDBILL(DUZ(2),ABM("B"),0)),$P(^(0),U,8)=+ABM("I0"),$P(^(0),U,5)=ABMP("PDFN") D
...S ABM("J")=0 F S ABM("J")=$O(^ABMDBILL(DUZ(2),ABM("B"),3,ABM("J"))) Q:'ABM("J") D
....S ABM("PD")=$P(^ABMDBILL(DUZ(2),ABM("B"),3,ABM("J"),0),U,2)+ABM("PD"),ABM("DEDCT")=ABM("DEDCT")+$P(^(0),U,3),ABM("COINS")=ABM("COINS")+$P(^(0),U,4),ABMP("PAID")=ABMP("PAID")+$P(^(0),U,2),ABM("WO")=$P(^(0),U,6)
....I $P(^ABMDBILL(DUZ(2),ABM("B"),2),U,4)=0 S ABMP("TW")=ABMP("TW")+ABM("WO")
K ABM("B"),ABM("J")
Q
;
; Insured Section
INSRD Q:'$D(^ABMDBILL(DUZ(2),ABMP("BDFN"),13,ABM("XIEN"),0)) Q:"U"[$P(^(0),U,3)!'$D(^AUTNINS($P(^(0),"^",1),0))
I "NI"[$P($G(^AUTNINS(ABM("I0"),2)),U),$P(^(2),U)]"" Q
I $P($G(^AUTNINS(ABM("I0"),1)),U,7)=4 Q
S ABMF(ABM("I")+5)=$P($P(ABMV("X2"),U),";",2)_U_$S($P(ABMV("X2"),U,6)]"":$P(ABMV("X2"),U,6),1:"U")_U_$P($G(^AUTTRLSH(+$P(ABMV("X2"),U,2),0)),U,2)_U_$P(ABMV("X1"),U,4)_U_$P(ABMV("X3"),U,6,7)
I ABM("I0")=$P(ABMP("B0"),U,8),$P(^ABMDBILL(DUZ(2),ABMP("BDFN"),13,ABM("XIEN"),0),"^",3)="I",1'=+$P(ABMF(ABM("I")+5),U,3) D PRIHOLD
D EMPL
Q
;
PRIHOLD S $P(ABMF(12),U)=$P($P(ABMV("X2"),U),";",2)
S $P(ABMF(13),U)=$P(ABMV("X2"),U,3)
S $P(ABMF(14),U)=$P(ABMV("X2"),U,4)
S $P(ABMF(15),U)=$P(ABMV("X2"),U,5)
Q
;
EMPL ; Employment Info
Q:$P(ABMV("X3"),U)=""
S ABM("CNT")=ABM("CNT")+1 Q:ABM("CNT")>2
S ABMF(49+ABM("CNT"))=ABM("Z")_U_$P(ABMV("X3"),U,5)_U_$P(ABMV("X3"),U)_U_$P(ABMV("X3"),U,8)_U_$P(ABMV("X3"),U,2)_", "_$P(ABMV("X3"),U,3)
Q
ABMDF1C ; IHS/ASDST/DMJ - Set UB82 Print Array - cont ;
+1 ;;2.6;IHS 3P BILLING SYSTEM;**6**;NOV 12, 2009
+2 ;Original;TMD;
+3 ;
+4 SET ABM("CNT")=0
+5 SET ABMP("B0")=^ABMDBILL(DUZ(2),ABMP("BDFN"),0)
+6 SET ABMP("GL")="^ABMDBILL(DUZ(2),"_ABMP("BDFN")_","
+7 SET ABMP("VDT")=$PIECE(^ABMDBILL(DUZ(2),ABMP("BDFN"),7),U)
SET $PIECE(ABMP("B0"),U,2)=ABMP("VDT")
+8 SET ABMP("BTYP")=$PIECE(ABMP("B0"),"^",12)
+9 SET ABMP("VTYP")=$PIECE(ABMP("B0"),U,7)
+10 DO ^ABMDE2X1
SET ABMP("EXP")=1
LOOP SET ABM("IN")=""
SET (ABMP("PAID"),ABMP("TW"))=0
FOR ABM("I")=41:1:43
SET ABM("IN")=$ORDER(^ABMDBILL(DUZ(2),ABMP("BDFN"),13,"C",ABM("IN")))
IF 'ABM("IN")
QUIT
SET ABM("XIEN")=$ORDER(^(ABM("IN"),0))
Begin DoDot:1
+1 SET ABM("INSCO")=$PIECE(^ABMDBILL(DUZ(2),ABMP("BDFN"),13,ABM("XIEN"),0),"^",1)
+2 DO INS
+3 DO INSRD
End DoDot:1
+4 ;S ABMP("PAID")=+$FN(ABMP("PAID")*ABM("RATIO"),"",2) ;IHS/SD/AML NOHEAT 2/15/2011
+5 ;S ABMP("TW")=+$FN(ABMP("TW")*ABM("RATIO"),"",2) ;IHS/SD/AML NOHEAT 2/15/2011
+6 ;IHS/SD/AML NOHEAT 2/15/2011
SET ABMP("PAID")=+$FNUMBER(ABMP("PAID")*$GET(ABM("RATIO")),"",2)
+7 ;IHS/SD/AML NOHEAT 2/15/2011
SET ABMP("TW")=+$FNUMBER(ABMP("TW")*$GET(ABM("RATIO")),"",2)
+8 KILL ABM,ABME,ABMV
+9 GOTO ^ABMDF1D
+10 ;
MINUS SET ABM("I")=ABM("I")-1
+1 QUIT
+2 ;
INS IF '$DATA(^ABMDBILL(DUZ(2),ABMP("BDFN"),13,ABM("XIEN"),0))
GOTO MINUS
IF "U"[$PIECE(^(0),U,3)
GOTO MINUS
IF '$DATA(^AUTNINS(ABM("INSCO"),0))
GOTO MINUS
+1 SET ABM("Z")=$SELECT(ABM("I")=41:"A",ABM("I")=42:"B",1:"C")
+2 IF $PIECE($GET(^AUTNINS(ABM("INSCO"),2)),U)="R"
SET $PIECE(ABMF(4),U,4)=$PIECE(^AUTTLOC(ABMP("LDFN"),0),U,19)
PAYOR SET Y=ABM("INSCO")
SET ABMP("GL")="^ABMDBILL(DUZ(2),"_ABMP("BDFN")_","
SET ABMP("VDT")=$PIECE(^ABMDBILL(DUZ(2),ABMP("BDFN"),7),U)
DO SEL^ABMDE2X
+1 IF ABM("INSCO")=$PIECE(ABMP("B0"),"^",8)
IF $PIECE(^ABMDBILL(DUZ(2),ABMP("BDFN"),13,ABM("XIEN"),0),"^",3)="I"
Begin DoDot:1
+2 SET ABMP("PAYOR")=ABM("I")
+3 IF $PIECE(ABMV("X1"),U,5)]""
SET $PIECE(ABMF(6),U)=$PIECE(ABMV("X1"),U,5)
End DoDot:1
CONT SET ABM("I0")=+ABMV("X1")
+1 SET (ABM("PD"),ABM("DEDCT"),ABM("COINS"))=0
DO PREV
+2 SET ABM("RATIO")=+^ABMDBILL(DUZ(2),ABMP("BDFN"),2)/$SELECT($PIECE(^(2),U,3):$PIECE(^(2),U,3),1:1)
+3 IF ABM("RATIO")>1
SET ABM("RATIO")=1
+4 SET ABM("PD")=+$FNUMBER(ABM("PD")*ABM("RATIO"),"",2)
+5 ;
+6 IF $PIECE($GET(^AUTNINS(ABM("I0"),2)),U)="N"
GOTO NON
SET ABMF(ABM("I"))=$PIECE(^(0),U)_U_$PIECE($GET(^ABMDBILL(DUZ(2),ABMP("BDFN"),7)),U,4)_U_$PIECE($GET(^(7)),U,5)
+7 IF ABM("DEDCT")
SET $PIECE(ABMF(ABM("I")),U,4)=ABM("DEDCT")
+8 IF ABM("COINS")
SET $PIECE(ABMF(ABM("I")),U,5)=ABM("COINS")
+9 IF ABM("PD")
SET $PIECE(ABMF(ABM("I")),U,7)=ABM("PD")
+10 QUIT
NON SET $PIECE(ABMF(44),U,2)=$SELECT(ABM("PD")>0:ABM("PD"),1:"")
+1 IF $GET(ABMP("PAYOR"))=ABM("I")
SET ABMP("PAYOR")=44
+2 SET ABM("I")=ABM("I")-1
+3 QUIT
+4 ;
PREV SET ABM("C")=""
FOR
SET ABM("C")=$ORDER(^ABMDBILL(DUZ(2),"AS",+^ABMDBILL(DUZ(2),ABMP("BDFN"),0),ABM("C")))
IF ABM("C")=""
QUIT
Begin DoDot:1
+1 SET ABM("B")=0
FOR
SET ABM("B")=$ORDER(^ABMDBILL(DUZ(2),"AS",+^ABMDBILL(DUZ(2),ABMP("BDFN"),0),ABM("C"),ABM("B")))
IF 'ABM("B")
QUIT
Begin DoDot:2
+2 IF $DATA(^ABMDBILL(DUZ(2),ABM("B"),0))
IF $PIECE(^(0),U,8)=+ABM("I0")
IF $PIECE(^(0),U,5)=ABMP("PDFN")
Begin DoDot:3
+3 SET ABM("J")=0
FOR
SET ABM("J")=$ORDER(^ABMDBILL(DUZ(2),ABM("B"),3,ABM("J")))
IF 'ABM("J")
QUIT
Begin DoDot:4
+4 SET ABM("PD")=$PIECE(^ABMDBILL(DUZ(2),ABM("B"),3,ABM("J"),0),U,2)+ABM("PD")
SET ABM("DEDCT")=ABM("DEDCT")+$PIECE(^(0),U,3)
SET ABM("COINS")=ABM("COINS")+$PIECE(^(0),U,4)
SET ABMP("PAID")=ABMP("PAID")+$PIECE(^(0),U,2)
SET ABM("WO")=$PIECE(^(0),U,6)
+5 IF $PIECE(^ABMDBILL(DUZ(2),ABM("B"),2),U,4)=0
SET ABMP("TW")=ABMP("TW")+ABM("WO")
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+6 KILL ABM("B"),ABM("J")
+7 QUIT
+8 ;
+9 ; Insured Section
INSRD IF '$DATA(^ABMDBILL(DUZ(2),ABMP("BDFN"),13,ABM("XIEN"),0))
QUIT
IF "U"[$PIECE(^(0),U,3)!'$DATA(^AUTNINS($PIECE(^(0),"^",1),0))
QUIT
+1 IF "NI"[$PIECE($GET(^AUTNINS(ABM("I0"),2)),U)
IF $PIECE(^(2),U)]""
QUIT
+2 IF $PIECE($GET(^AUTNINS(ABM("I0"),1)),U,7)=4
QUIT
+3 SET ABMF(ABM("I")+5)=$PIECE($PIECE(ABMV("X2"),U),";",2)_U_$SELECT($PIECE(ABMV("X2"),U,6)]"":$PIECE(ABMV("X2"),U,6),1:"U")_U_$PIECE($GET(^AUTTRLSH(+$PIECE(ABMV("X2"),U,2),0)),U,2)_U_$PIECE(ABMV("X1"),U,4)_U_$PIECE(ABMV("X3"),U,6,7)
+4 IF ABM("I0")=$PIECE(ABMP("B0"),U,8)
IF $PIECE(^ABMDBILL(DUZ(2),ABMP("BDFN"),13,ABM("XIEN"),0),"^",3)="I"
IF 1'=+$PIECE(ABMF(ABM("I")+5),U,3)
DO PRIHOLD
+5 DO EMPL
+6 QUIT
+7 ;
PRIHOLD SET $PIECE(ABMF(12),U)=$PIECE($PIECE(ABMV("X2"),U),";",2)
+1 SET $PIECE(ABMF(13),U)=$PIECE(ABMV("X2"),U,3)
+2 SET $PIECE(ABMF(14),U)=$PIECE(ABMV("X2"),U,4)
+3 SET $PIECE(ABMF(15),U)=$PIECE(ABMV("X2"),U,5)
+4 QUIT
+5 ;
EMPL ; Employment Info
+1 IF $PIECE(ABMV("X3"),U)=""
QUIT
+2 SET ABM("CNT")=ABM("CNT")+1
IF ABM("CNT")>2
QUIT
+3 SET ABMF(49+ABM("CNT"))=ABM("Z")_U_$PIECE(ABMV("X3"),U,5)_U_$PIECE(ABMV("X3"),U)_U_$PIECE(ABMV("X3"),U,8)_U_$PIECE(ABMV("X3"),U,2)_", "_$PIECE(ABMV("X3"),U,3)
+4 QUIT
