- 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
