ABMDF35C ; IHS/SD/SDR - Set HCFA1500 (02/12) Print Array ;
;;2.6;IHS 3P BILLING SYSTEM;**13,21**;NOV 12, 2009;Build 379
;IHS/SD/SDR 2.6*21 HEAT298958 PROPERTY/CASUALTY PATIENT NUMBER prints in box 1A. PROPERTY/CASUALTY CLAIM NUMBER should print in box 11B.
; If no PROPERTY/CASUALTY CLAIM NUMBER, print the CASE NUMBER in box 11B.
;
; *********************************************************************
;
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")=35
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"'[$$GET1^DIQ(9999999.181,$$GET1^DIQ(9999999.18,ABM("I0"),".211","I"),1,"I") D
.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) ;abm*2.6*13 remove box 9B
.;I $P(ABMV("X2"),U,6)]"" S $P(ABMF(15),U,$S($P(ABMV("X2"),U,6)="F":3,1:2))="X" ;abm*2.6*13 remove box 9B
.S $P(ABMF(13),U)=$P(ABMV("X1"),U,4)_" "_$P(ABMV("X3"),U,7)
.;S $P(ABMF(17),U)=$P(ABMV("X3"),U) ;abm*2.6*13 remove box 9C
.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" ;abm*2.6*13 remove box 8
.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))
.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 ;abm*2.6*13 box 11B
..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) ;abm*2.6*21 IHS/SD/SDR HEAT298958
.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) ;abm*2.6*13 remove box 9B
.;S $P(ABMF(17),U,4)=$P($P(ABMV("X1"),U),";",2) ;abm*2.6*13 remove box 9C
.S $P(ABMF(17),U,3)=$P($P(ABMV("X1"),U),";",2) ;abm*2.6*13 remove box 9C
.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) ;abm*2.6*13 exp mode 35
.I $P(ABMF(11),U,2)="",($P(ABMV("X3"),U,7)]""!$P(ABMV("X3"),U,6)]"") S $P(ABMF(11),U,2)=$S($P(ABMV("X3"),U,7)]"":$P(ABMV("X3"),U,7)_"/",1:"")_$P(ABMV("X3"),U,6) ;abm*2.6*13 exp mode 35
.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)
.;start old code abm*2.6*13 remove box 8
.;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)
.;end old code start new code box 8
.S $P(ABMF(7),U,3)=$P($P(ABMV("X2"),U,4),", ")
.S $P(ABMF(7),U,4)=$P($P($P(ABMV("X2"),U,4),", ",2)," ")
.S $P(ABMF(9),U,3)=$P($P($P(ABMV("X2"),U,4),", ",2)," ",2)
.S $P(ABMF(9),U,4)=$S($E($P(ABMV("X2"),U,5))="(":"",1:" ")_$P(ABMV("X2"),U,5)
.;end new code box 8
.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"
I $P($G(^ABMDBILL(DUZ(2),ABMP("BDFN"),7)),U,13)'="" S $P(ABMF(15),U,4)="Y4 "_$P($G(^ABMDBILL(DUZ(2),ABMP("BDFN"),7)),U,13) ;abm*2.6*13 box 11B
I ($P($G(^ABMDBILL(DUZ(2),ABMP("BDFN"),4)),U,8)'="")&($P(ABMF(1),U,8)="") S $P(ABMF(1),U,8)=$P($G(^ABMDBILL(DUZ(2),ABMP("BDFN"),4)),U,8) ;abm*2.6*21 IHS/SD/SDR HEAT298958
Q
ABMDF35C ; IHS/SD/SDR - Set HCFA1500 (02/12) Print Array ;
+1 ;;2.6;IHS 3P BILLING SYSTEM;**13,21**;NOV 12, 2009;Build 379
+2 ;IHS/SD/SDR 2.6*21 HEAT298958 PROPERTY/CASUALTY PATIENT NUMBER prints in box 1A. PROPERTY/CASUALTY CLAIM NUMBER should print in box 11B.
+3 ; If no PROPERTY/CASUALTY CLAIM NUMBER, print the CASE NUMBER in box 11B.
+4 ;
+5 ; *********************************************************************
+6 ;
+7 DO VAR
+8 DO LOOP
+9 DO VAR
+10 DO XIT
+11 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")=35
End DoDot:1
PAYOR SET Y=ABM("INSCO")
DO SEL^ABMDE2X
+1 SET ABM("I0")=+ABMV("X1")
+2 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
+3 IF $PIECE($GET(^ABMDBILL(DUZ(2),ABMP("BDFN"),13,ABM("XIEN"),0)),U,11)=$PIECE(ABMP("B0"),U,8)
QUIT
+4 SET $PIECE(ABMF(19),U,3)="X"
SET $PIECE(ABMF(19),U,4)=""
+5 SET $PIECE(ABMF(19),U)=$PIECE(^AUTNINS(ABM("I0"),0),U)
+6 SET $PIECE(ABMF(11),U)=$PIECE($PIECE(ABMV("X2"),U),";",2)
+7 ;S $P(ABMF(15),U)=$P(ABMV("X2"),U,7) ;abm*2.6*13 remove box 9B
+8 ;I $P(ABMV("X2"),U,6)]"" S $P(ABMF(15),U,$S($P(ABMV("X2"),U,6)="F":3,1:2))="X" ;abm*2.6*13 remove box 9B
+9 SET $PIECE(ABMF(13),U)=$PIECE(ABMV("X1"),U,4)_" "_$PIECE(ABMV("X3"),U,7)
+10 ;S $P(ABMF(17),U)=$P(ABMV("X3"),U) ;abm*2.6*13 remove box 9C
+11 SET ABM("CNT")=ABM("CNT")+1
End DoDot:1
PRIM ;
+1 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
+2 SET ABM("SPOUSE")=0
+3 IF $PIECE(^AUPNPAT(ABMP("PDFN"),0),U,22)
SET ABM("SPOUSE")=1
+4 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
+5 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
+6 IF $PIECE(ABMV("X2"),U,2)
IF $PIECE($GET(^AUTTRLSH(+$PIECE(ABMV("X2"),U,2),0)),U,3)="02"
SET ABM("SPOUSE")=1
+7 SET ABMPIECE=3
+8 IF ABM("SPOUSE")
SET ABMPIECE=4
+9 SET ABMMSTAT=$PIECE(^DPT(ABMP("PDFN"),0),"^",5)
+10 IF ABMMSTAT
Begin DoDot:2
+11 SET ABMPIECE=5
+12 IF ABMMSTAT=8
SET ABMPIECE=3
+13 IF ABMMSTAT=2
SET ABMPIECE=4
End DoDot:2
+14 ;S $P(ABMF(7),"^",ABMPIECE)="X" ;abm*2.6*13 remove box 8
+15 IF $PIECE($GET(ABMF(19)),U,3)=""
SET $PIECE(ABMF(19),U,4)="X"
+16 SET $PIECE(ABMF(3),U,5)=$PIECE($PIECE(ABMV("X2"),U),";",2)
+17 IF $PIECE(ABMV("X3"),U,1)]""
IF $PIECE(ABMV("X3"),U,6)]""
SET ABMF(1)=""
SET $PIECE(ABMF(1),U,5)="X"
+18 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))
+19 IF ("^T^W^"[(ABMP("ITYPE")))
Begin DoDot:2
+20 ;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 ;abm*2.6*13 box 11B
+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 ;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) ;abm*2.6*21 IHS/SD/SDR HEAT298958
End DoDot:2
+23 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),"-","")
+24 ;S $P(ABMF(15),U,7)=$P(ABMV("X3"),U,1) ;abm*2.6*13 remove box 9B
+25 ;S $P(ABMF(17),U,4)=$P($P(ABMV("X1"),U),";",2) ;abm*2.6*13 remove box 9C
+26 ;abm*2.6*13 remove box 9C
SET $PIECE(ABMF(17),U,3)=$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 ;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) ;abm*2.6*13 exp mode 35
+29 ;abm*2.6*13 exp mode 35
IF $PIECE(ABMF(11),U,2)=""
IF ($PIECE(ABMV("X3"),U,7)]""!$PIECE(ABMV("X3"),U,6)]"")
SET $PIECE(ABMF(11),U,2)=$SELECT($PIECE(ABMV("X3"),U,7)]"":$PIECE(ABMV("X3"),U,7)_"/",1:"")_$PIECE(ABMV("X3"),U,6)
+30 SET $PIECE(ABMF(13),U,4)=$PIECE(ABMV("X2"),U,7)
+31 IF $PIECE(ABMV("X2"),U,6)]""
SET $PIECE(ABMF(13),U,$SELECT($PIECE(ABMV("X2"),U,6)="F":6,1:5))="X"
+32 SET $PIECE(ABMF(5),U,6)=$PIECE(ABMV("X2"),U,3)
+33 ;start old code abm*2.6*13 remove box 8
+34 ;S $P(ABMF(7),U,6)=$P($P(ABMV("X2"),U,4),", ")
+35 ;S $P(ABMF(7),U,7)=$P($P($P(ABMV("X2"),U,4),", ",2)," ")
+36 ;S $P(ABMF(9),U,6)=$P($P($P(ABMV("X2"),U,4),", ",2)," ",2)
+37 ;S $P(ABMF(9),U,7)=$S($E($P(ABMV("X2"),U,5))="(":"",1:" ")_$P(ABMV("X2"),U,5)
+38 ;end old code start new code box 8
+39 SET $PIECE(ABMF(7),U,3)=$PIECE($PIECE(ABMV("X2"),U,4),", ")
+40 SET $PIECE(ABMF(7),U,4)=$PIECE($PIECE($PIECE(ABMV("X2"),U,4),", ",2)," ")
+41 SET $PIECE(ABMF(9),U,3)=$PIECE($PIECE($PIECE(ABMV("X2"),U,4),", ",2)," ",2)
+42 SET $PIECE(ABMF(9),U,4)=$SELECT($EXTRACT($PIECE(ABMV("X2"),U,5))="(":"",1:" ")_$PIECE(ABMV("X2"),U,5)
+43 ;end new code box 8
+44 SET ABM("RLSH")=$SELECT($PIECE(ABMV("X2"),U,2)]"":+$PIECE($GET(^AUTTRLSH(+$PIECE(ABMV("X2"),U,2),0)),U,2),1:"")
+45 IF ABM("RLSH")>0&(ABM("RLSH")<4)
SET ABM("RLSH")=ABM("RLSH")+1
+46 IF '$TEST
SET ABM("RLSH")=$SELECT(ABM("RLSH")=5:4,1:5)
+47 SET $PIECE(ABMF(5),U,ABM("RLSH"))="X"
End DoDot:1
+48 ;abm*2.6*13 box 11B
IF $PIECE($GET(^ABMDBILL(DUZ(2),ABMP("BDFN"),7)),U,13)'=""
SET $PIECE(ABMF(15),U,4)="Y4 "_$PIECE($GET(^ABMDBILL(DUZ(2),ABMP("BDFN"),7)),U,13)
+49 ;abm*2.6*21 IHS/SD/SDR HEAT298958
IF ($PIECE($GET(^ABMDBILL(DUZ(2),ABMP("BDFN"),4)),U,8)'="")&($PIECE(ABMF(1),U,8)="")
SET $PIECE(ABMF(1),U,8)=$PIECE($GET(^ABMDBILL(DUZ(2),ABMP("BDFN"),4)),U,8)
+50 QUIT
