ABMDF27C ; IHS/SD/SDR - Set HCFA1500 (08/05) Print Array ;
;;2.6;IHS 3P BILLING SYSTEM;**10,11**;NOV 12, 2009;Build 133
;
; *********************************************************************
;
D VAR
D LOOP
D VAR
D XIT
Q
VAR S ABM("CNT")=0
S ABMP("C0")=^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("C0"),U,2)=ABMP("VDT")
S ABMP("VTYP")=$P(ABMP("C0"),U,7)
Q
LOOP S ABM("IN")="" 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"),"")) S ABM("Z")=$S(ABM("I")=41:"A",ABM("I")=42:"B",1:"C") D INS
Q
;
XIT K ABM,ABME,ABMV
Q
;
INS Q:'$D(^ABMDBILL(DUZ(2),ABMP("BDFN"),13,ABM("XIEN"),0)) S ABM("INSCO")=$P(^(0),U)
Q:$P(^ABMDBILL(DUZ(2),ABMP("BDFN"),13,ABM("XIEN"),0),U,3)="U"
I ABM("INSCO")=$P(ABMP("B0"),U,8),$P(^ABMDBILL(DUZ(2),ABMP("BDFN"),13,ABM("XIEN"),0),"^",3)="I" D
.D ^ABMDE2X1
.I $D(ABMP("FLAT")) D
..S $P(ABMP("FLAT"),U)=+$P($G(^ABMDBILL(DUZ(2),ABMP("BDFN"),2)),U) ;bill amt
..S:ABMP("VTYP")=111 $P(ABMP("FLAT"),U)=$P(ABMP("FLAT"),U)/$P(ABMP("FLAT"),U,3)
.S ABMP("EXP")=27
PAYOR S Y=ABM("INSCO") D SEL^ABMDE2X
S ABM("I0")=+ABMV("X1")
;I ABM("INSCO")'=$P(ABMP("B0"),U,8),ABM("CNT")=0,"IN"'[$P($G(^AUTNINS(ABM("I0"),2)),U) D ;abm*2.6*10 HEAT73780
I ABM("INSCO")'=$P(ABMP("B0"),U,8),ABM("CNT")=0,"IN"'[$$GET1^DIQ(9999999.181,$$GET1^DIQ(9999999.18,ABM("I0"),".211","I"),1,"I") D ;abm*2.6*10 HEAT73780
.Q:$P($G(^ABMDBILL(DUZ(2),ABMP("BDFN"),13,ABM("XIEN"),0)),U,11)=$P(ABMP("B0"),U,8)
.S $P(ABMF(19),U,3)="X",$P(ABMF(19),U,4)=""
.S $P(ABMF(19),U)=$P(^AUTNINS(ABM("I0"),0),U)
.S $P(ABMF(11),U)=$P($P(ABMV("X2"),U),";",2)
.S $P(ABMF(15),U)=$P(ABMV("X2"),U,7)
.I $P(ABMV("X2"),U,6)]"" S $P(ABMF(15),U,$S($P(ABMV("X2"),U,6)="F":3,1:2))="X"
.S $P(ABMF(13),U)=$P(ABMV("X1"),U,4)_" "_$P(ABMV("X3"),U,7)
.S $P(ABMF(17),U)=$P(ABMV("X3"),U)
.S ABM("CNT")=ABM("CNT")+1
PRIM I ((ABM("INSCO")=$P(ABMP("B0"),U,8))!($P($G(^ABMDBILL(DUZ(2),ABMP("BDFN"),13,ABM("XIEN"),0)),U,11)=$P(ABMP("B0"),U,8))),($P(^ABMDBILL(DUZ(2),ABMP("BDFN"),13,ABM("XIEN"),0),"^",3)="I") D
.S ABM("SPOUSE")=0
.I $P(^AUPNPAT(ABMP("PDFN"),0),U,22) S ABM("SPOUSE")=1
.I $P($G(^AUPNPAT(ABMP("PDFN"),28)),U,2),$P($G(^AUTTRLSH($P(^(28),U,2),0)),U,3)="02" S ABM("SPOUSE")=1
.I $P($G(^AUPNPAT(ABMP("PDFN"),31)),U,2),$P($G(^AUTTRLSH($P(^(31),U,2),0)),U,3)="02" S ABM("SPOUSE")=1
.I $P(ABMV("X2"),U,2),$P($G(^AUTTRLSH(+$P(ABMV("X2"),U,2),0)),U,3)="02" S ABM("SPOUSE")=1
.S ABMPIECE=3
.S:ABM("SPOUSE") ABMPIECE=4
.S ABMMSTAT=$P(^DPT(ABMP("PDFN"),0),"^",5)
.I ABMMSTAT D
..S ABMPIECE=5
..S:ABMMSTAT=8 ABMPIECE=3
..S:ABMMSTAT=2 ABMPIECE=4
.S $P(ABMF(7),"^",ABMPIECE)="X"
.S:$P($G(ABMF(19)),U,3)="" $P(ABMF(19),U,4)="X"
.S $P(ABMF(3),U,5)=$P($P(ABMV("X2"),U),";",2)
.I $P(ABMV("X3"),U,1)]"",$P(ABMV("X3"),U,6)]"" S ABMF(1)="",$P(ABMF(1),U,5)="X"
.S $P(ABMF(1),U,8)=$S($P($G(^ABMDBILL(DUZ(2),ABMP("BDFN"),4)),U,8)'="":$P(^(4),U,8),$P($G(ABMV("X1")),U,12)'="":$P(ABMV("X1"),U,12),1:$P(ABMV("X1"),U,4))
.;start new code abm*2.6*11 HEAT86014
.I ("^T^W^"[(ABMP("ITYPE"))) D
..I $P($G(^ABMDBILL(DUZ(2),ABMP("BDFN"),7)),U,13)'="" S $P(ABMF(1),U,8)=$P($G(^ABMDBILL(DUZ(2),ABMP("BDFN"),7)),U,13) Q
..I $P($G(^ABMDBILL(DUZ(2),ABMP("BDFN"),7)),U,26)'="" S $P(ABMF(1),U,8)=$P($G(^ABMDBILL(DUZ(2),ABMP("BDFN"),7)),U,26) Q
..I $P($G(^ABMDBILL(DUZ(2),ABMP("BDFN"),4)),U,8)'="" S $P(ABMF(1),U,8)=$P($G(^ABMDBILL(DUZ(2),ABMP("BDFN"),4)),U,8)
.;end new code HEAT86014
.I $P($G(^ABMNINS(DUZ(2),ABMP("INS"),1,ABMP("VTYP"),1)),U,7)="N" S $P(ABMF(1),U,8)=$TR($P(ABMF(1),U,8),"-","")
.S $P(ABMF(15),U,7)=$P(ABMV("X3"),U,1)
.S $P(ABMF(17),U,4)=$P($P(ABMV("X1"),U),";",2)
.S $P(ABMF(11),U,2)=$P($G(^ABMNINS(DUZ(2),ABMP("INS"),1,ABMP("VTYP"),1)),U,3) ;group name/number
.I $P(ABMF(11),U,2)="",($P(ABMV("X3"),U,7)]"") S $P(ABMF(11),U,2)=$P(ABMV("X3"),U,7)_"/"_$P(ABMV("X3"),U,6)
.S $P(ABMF(13),U,4)=$P(ABMV("X2"),U,7)
.I $P(ABMV("X2"),U,6)]"" S $P(ABMF(13),U,$S($P(ABMV("X2"),U,6)="F":6,1:5))="X"
.S $P(ABMF(5),U,6)=$P(ABMV("X2"),U,3)
.S $P(ABMF(7),U,6)=$P($P(ABMV("X2"),U,4),", ")
.S $P(ABMF(7),U,7)=$P($P($P(ABMV("X2"),U,4),", ",2)," ")
.S $P(ABMF(9),U,6)=$P($P($P(ABMV("X2"),U,4),", ",2)," ",2)
.S $P(ABMF(9),U,7)=$S($E($P(ABMV("X2"),U,5))="(":"",1:" ")_$P(ABMV("X2"),U,5)
.S ABM("RLSH")=$S($P(ABMV("X2"),U,2)]"":+$P($G(^AUTTRLSH(+$P(ABMV("X2"),U,2),0)),U,2),1:"")
.I ABM("RLSH")>0&(ABM("RLSH")<4) S ABM("RLSH")=ABM("RLSH")+1
.E S ABM("RLSH")=$S(ABM("RLSH")=5:4,1:5)
.S $P(ABMF(5),U,ABM("RLSH"))="X"
Q
ABMDF27C ; IHS/SD/SDR - Set HCFA1500 (08/05) Print Array ;
+1 ;;2.6;IHS 3P BILLING SYSTEM;**10,11**;NOV 12, 2009;Build 133
+2 ;
+3 ; *********************************************************************
+4 ;
+5 DO VAR
+6 DO LOOP
+7 DO VAR
+8 DO XIT
+9 QUIT
VAR SET ABM("CNT")=0
+1 SET ABMP("C0")=^ABMDBILL(DUZ(2),ABMP("BDFN"),0)
+2 SET ABMP("GL")="^ABMDBILL(DUZ(2),"_ABMP("BDFN")_","
+3 SET ABMP("VDT")=$PIECE(^ABMDBILL(DUZ(2),ABMP("BDFN"),7),U)
SET $PIECE(ABMP("C0"),U,2)=ABMP("VDT")
+4 SET ABMP("VTYP")=$PIECE(ABMP("C0"),U,7)
+5 QUIT
LOOP SET ABM("IN")=""
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"),""))
SET ABM("Z")=$SELECT(ABM("I")=41:"A",ABM("I")=42:"B",1:"C")
DO INS
+1 QUIT
+2 ;
XIT KILL ABM,ABME,ABMV
+1 QUIT
+2 ;
INS IF '$DATA(^ABMDBILL(DUZ(2),ABMP("BDFN"),13,ABM("XIEN"),0))
QUIT
SET ABM("INSCO")=$PIECE(^(0),U)
+1 IF $PIECE(^ABMDBILL(DUZ(2),ABMP("BDFN"),13,ABM("XIEN"),0),U,3)="U"
QUIT
+2 IF ABM("INSCO")=$PIECE(ABMP("B0"),U,8)
IF $PIECE(^ABMDBILL(DUZ(2),ABMP("BDFN"),13,ABM("XIEN"),0),"^",3)="I"
Begin DoDot:1
+3 DO ^ABMDE2X1
+4 IF $DATA(ABMP("FLAT"))
Begin DoDot:2
+5 ;bill amt
SET $PIECE(ABMP("FLAT"),U)=+$PIECE($GET(^ABMDBILL(DUZ(2),ABMP("BDFN"),2)),U)
+6 IF ABMP("VTYP")=111
SET $PIECE(ABMP("FLAT"),U)=$PIECE(ABMP("FLAT"),U)/$PIECE(ABMP("FLAT"),U,3)
End DoDot:2
+7 SET ABMP("EXP")=27
End DoDot:1
PAYOR SET Y=ABM("INSCO")
DO SEL^ABMDE2X
+1 SET ABM("I0")=+ABMV("X1")
+2 ;I ABM("INSCO")'=$P(ABMP("B0"),U,8),ABM("CNT")=0,"IN"'[$P($G(^AUTNINS(ABM("I0"),2)),U) D ;abm*2.6*10 HEAT73780
+3 ;abm*2.6*10 HEAT73780
IF ABM("INSCO")'=$PIECE(ABMP("B0"),U,8)
IF ABM("CNT")=0
IF "IN"'[$$GET1^DIQ(9999999.181,$$GET1^DIQ(9999999.18,ABM("I0"),".211","I"),1,"I")
Begin DoDot:1
+4 IF $PIECE($GET(^ABMDBILL(DUZ(2),ABMP("BDFN"),13,ABM("XIEN"),0)),U,11)=$PIECE(ABMP("B0"),U,8)
QUIT
+5 SET $PIECE(ABMF(19),U,3)="X"
SET $PIECE(ABMF(19),U,4)=""
+6 SET $PIECE(ABMF(19),U)=$PIECE(^AUTNINS(ABM("I0"),0),U)
+7 SET $PIECE(ABMF(11),U)=$PIECE($PIECE(ABMV("X2"),U),";",2)
+8 SET $PIECE(ABMF(15),U)=$PIECE(ABMV("X2"),U,7)
+9 IF $PIECE(ABMV("X2"),U,6)]""
SET $PIECE(ABMF(15),U,$SELECT($PIECE(ABMV("X2"),U,6)="F":3,1:2))="X"
+10 SET $PIECE(ABMF(13),U)=$PIECE(ABMV("X1"),U,4)_" "_$PIECE(ABMV("X3"),U,7)
+11 SET $PIECE(ABMF(17),U)=$PIECE(ABMV("X3"),U)
+12 SET ABM("CNT")=ABM("CNT")+1
End DoDot:1
PRIM IF ((ABM("INSCO")=$PIECE(ABMP("B0"),U,8))!($PIECE($GET(^ABMDBILL(DUZ(2),ABMP("BDFN"),13,ABM("XIEN"),0)),U,11)=$PIECE(ABMP("B0"),U,8)))
IF ($PIECE(^ABMDBILL(DUZ(2),ABMP("BDFN"),13,ABM("XIEN"),0),"^",3)="I")
Begin DoDot:1
+1 SET ABM("SPOUSE")=0
+2 IF $PIECE(^AUPNPAT(ABMP("PDFN"),0),U,22)
SET ABM("SPOUSE")=1
+3 IF $PIECE($GET(^AUPNPAT(ABMP("PDFN"),28)),U,2)
IF $PIECE($GET(^AUTTRLSH($PIECE(^(28),U,2),0)),U,3)="02"
SET ABM("SPOUSE")=1
+4 IF $PIECE($GET(^AUPNPAT(ABMP("PDFN"),31)),U,2)
IF $PIECE($GET(^AUTTRLSH($PIECE(^(31),U,2),0)),U,3)="02"
SET ABM("SPOUSE")=1
+5 IF $PIECE(ABMV("X2"),U,2)
IF $PIECE($GET(^AUTTRLSH(+$PIECE(ABMV("X2"),U,2),0)),U,3)="02"
SET ABM("SPOUSE")=1
+6 SET ABMPIECE=3
+7 IF ABM("SPOUSE")
SET ABMPIECE=4
+8 SET ABMMSTAT=$PIECE(^DPT(ABMP("PDFN"),0),"^",5)
+9 IF ABMMSTAT
Begin DoDot:2
+10 SET ABMPIECE=5
+11 IF ABMMSTAT=8
SET ABMPIECE=3
+12 IF ABMMSTAT=2
SET ABMPIECE=4
End DoDot:2
+13 SET $PIECE(ABMF(7),"^",ABMPIECE)="X"
+14 IF $PIECE($GET(ABMF(19)),U,3)=""
SET $PIECE(ABMF(19),U,4)="X"
+15 SET $PIECE(ABMF(3),U,5)=$PIECE($PIECE(ABMV("X2"),U),";",2)
+16 IF $PIECE(ABMV("X3"),U,1)]""
IF $PIECE(ABMV("X3"),U,6)]""
SET ABMF(1)=""
SET $PIECE(ABMF(1),U,5)="X"
+17 SET $PIECE(ABMF(1),U,8)=$SELECT($PIECE($GET(^ABMDBILL(DUZ(2),ABMP("BDFN"),4)),U,8)'="":$PIECE(^(4),U,8),$PIECE($GET(ABMV("X1")),U,12)'="":$PIECE(ABMV("X1"),U,12),1:$PIECE(ABMV("X1"),U,4))
+18 ;start new code abm*2.6*11 HEAT86014
+19 IF ("^T^W^"[(ABMP("ITYPE")))
Begin DoDot:2
+20 IF $PIECE($GET(^ABMDBILL(DUZ(2),ABMP("BDFN"),7)),U,13)'=""
SET $PIECE(ABMF(1),U,8)=$PIECE($GET(^ABMDBILL(DUZ(2),ABMP("BDFN"),7)),U,13)
QUIT
+21 IF $PIECE($GET(^ABMDBILL(DUZ(2),ABMP("BDFN"),7)),U,26)'=""
SET $PIECE(ABMF(1),U,8)=$PIECE($GET(^ABMDBILL(DUZ(2),ABMP("BDFN"),7)),U,26)
QUIT
+22 IF $PIECE($GET(^ABMDBILL(DUZ(2),ABMP("BDFN"),4)),U,8)'=""
SET $PIECE(ABMF(1),U,8)=$PIECE($GET(^ABMDBILL(DUZ(2),ABMP("BDFN"),4)),U,8)
End DoDot:2
+23 ;end new code HEAT86014
+24 IF $PIECE($GET(^ABMNINS(DUZ(2),ABMP("INS"),1,ABMP("VTYP"),1)),U,7)="N"
SET $PIECE(ABMF(1),U,8)=$TRANSLATE($PIECE(ABMF(1),U,8),"-","")
+25 SET $PIECE(ABMF(15),U,7)=$PIECE(ABMV("X3"),U,1)
+26 SET $PIECE(ABMF(17),U,4)=$PIECE($PIECE(ABMV("X1"),U),";",2)
+27 ;group name/number
SET $PIECE(ABMF(11),U,2)=$PIECE($GET(^ABMNINS(DUZ(2),ABMP("INS"),1,ABMP("VTYP"),1)),U,3)
+28 IF $PIECE(ABMF(11),U,2)=""
IF ($PIECE(ABMV("X3"),U,7)]"")
SET $PIECE(ABMF(11),U,2)=$PIECE(ABMV("X3"),U,7)_"/"_$PIECE(ABMV("X3"),U,6)
+29 SET $PIECE(ABMF(13),U,4)=$PIECE(ABMV("X2"),U,7)
+30 IF $PIECE(ABMV("X2"),U,6)]""
SET $PIECE(ABMF(13),U,$SELECT($PIECE(ABMV("X2"),U,6)="F":6,1:5))="X"
+31 SET $PIECE(ABMF(5),U,6)=$PIECE(ABMV("X2"),U,3)
+32 SET $PIECE(ABMF(7),U,6)=$PIECE($PIECE(ABMV("X2"),U,4),", ")
+33 SET $PIECE(ABMF(7),U,7)=$PIECE($PIECE($PIECE(ABMV("X2"),U,4),", ",2)," ")
+34 SET $PIECE(ABMF(9),U,6)=$PIECE($PIECE($PIECE(ABMV("X2"),U,4),", ",2)," ",2)
+35 SET $PIECE(ABMF(9),U,7)=$SELECT($EXTRACT($PIECE(ABMV("X2"),U,5))="(":"",1:" ")_$PIECE(ABMV("X2"),U,5)
+36 SET ABM("RLSH")=$SELECT($PIECE(ABMV("X2"),U,2)]"":+$PIECE($GET(^AUTTRLSH(+$PIECE(ABMV("X2"),U,2),0)),U,2),1:"")
+37 IF ABM("RLSH")>0&(ABM("RLSH")<4)
SET ABM("RLSH")=ABM("RLSH")+1
+38 IF '$TEST
SET ABM("RLSH")=$SELECT(ABM("RLSH")=5:4,1:5)
+39 SET $PIECE(ABMF(5),U,ABM("RLSH"))="X"
End DoDot:1
+40 QUIT
