ABMDF14B ; IHS/ASDST/DMJ - Set HCFA1500 Print Array PART 2 ;
;;2.6;IHS 3P BILLING SYSTEM;;NOV 12, 2009
;Original;TMD;
;
; IHS/ASDS/SDH - 04/10/01 - V2.4 Patch 9 - NOIS NFA-0600-180065
; Allow FL 18 to display when inpatient with more than one
; provider that was split for billing purposes.
;
; IHS/SD/SDR - v2.5 p3 - 2/26/2003 - NDA-0402-180192
; Added new block 19 stuff
;
; IHS/SD/SDR - v2.5 p8 - task 6
; origin zip when ambulance
;
; IHS/SD/SDR - v2.5 p9 - IM19291
; Added Supervising Provider to block 19
;
; IHS/SD/SDR - v2.5 p10 - IM20462
; Fix check for outside lab charges
;
; IHS/SD/SDR - v2.5 p10 - IM21468
; Made change so it won't error if ref lab CLIA is missing
; and there are outside lab charges
;
; *********************************************************************
;
BNODES S ABM("B5")=$G(^ABMDBILL(DUZ(2),ABMP("BDFN"),5)),ABM("B6")=$G(^(6)),ABM("B7")=$G(^(7)),ABM("B8")=$G(^(8)),ABM("B9")=$G(^(9)),ABM("B10")=$G(^(10))
I $P(ABM("B5"),U,12)]"" S $P(ABMF(33),U,3)=$P(ABM("B5"),U,12)
I $P($G(^DIC(40.7,ABMP("CLN"),0)),U)="AMBULANCE" S $P(ABMF(33),U,3)=$E($P($G(^ABMDBILL(DUZ(2),ABMP("BDFN"),12)),U,6),1,5)
I +$O(^ABMDBILL(DUZ(2),ABMP("BDFN"),37,0))'=0 D
.I +$P($G(^ABMDBILL(DUZ(2),ABMP("BDFN"),8)),U)'=0,($P($G(^ABMDBILL(DUZ(2),ABMP("BDFN"),9)),U,23)'="") S $P(ABMF(33),U,3)=$P($G(^ABMRLABS($P($G(^ABMDBILL(DUZ(2),ABMP("BDFN"),9)),U,23),0)),U,2)
.I +$P($G(^ABMDBILL(DUZ(2),ABMP("BDFN"),8)),U)=0 S $P(ABMF(33),U,3)=$P($G(^ABMDBILL(DUZ(2),ABMP("BDFN"),9)),U,22) ;default in-house
;no labs but CLIA wanted on form
I +$O(^ABMDBILL(DUZ(2),ABMP("BDFN"),37,0))=0 D
.I $P($G(^ABMNINS(DUZ(2),ABMP("INS"),1,ABMP("VTYP"),1)),U,6)="R" D
..S $P(ABMF(33),U,3)=$P($G(^ABMRLABS($P($G(^ABMDBILL(DUZ(2),ABMP("BDFN"),9)),U,23),0)),U,2)
.I $P($G(^ABMNINS(DUZ(2),ABMP("INS"),1,ABMP("VTYP"),1)),U,6)="I" D
..S $P(ABMF(33),U,3)=$P($G(^ABMDBILL(DUZ(2),ABMP("BDFN"),9)),U,22)
EMPL I $P(ABM("B9"),U)]"" S $P(ABMF(13),U,2)="X"
E S $P(ABMF(13),U,3)="X" G ACCD
I $P(ABM("B9"),U,3)]"" S $P(ABMF(25),U,3)=$P(ABM("B9"),U,3)
I $P(ABM("B9"),U,4)]"" S $P(ABMF(25),U,4)=$P(ABM("B9"),U,4)
;
ACCD S $P(ABMF(15),U,$S('$P(ABM("B8"),U,3):5,"12"[$P(ABM("B8"),U,3):4,1:5))="X"
S $P(ABMF(17),U,$S("12"[$P(ABM("B8"),U,3):3,1:2))="X"
FSYM S $P(ABMF(25),U)=$P(ABM("B8"),U,6)
SIML S $P(ABMF(25),U,2)=$P(ABM("B8"),U,9)
REFR S $P(ABMF(27),U)=$P(ABM("B8"),U,8),$P(ABMF(27),U,2)=$P(ABM("B8"),U,11)
BLK19 ;
S ABMBLK19=$$SDT^ABMDUTL($P(ABM("B9"),U,11)) ;date last seen
S ABMBLK19=ABMBLK19_" "_$P(ABM("B9"),U,24) ;supervising prov UPIN
S ABMBLK19=ABMBLK19_" "_$P(ABM("B9"),U,12) ;supervising prov
S ABMBLK19=ABMBLK19_" "_$$SDT^ABMDUTL($P(ABM("B9"),U,13)) ;last x-ray
S ABMBLK19=ABMBLK19_" "_$S($P(ABM("B9"),U,14)="Y":"HOMEBOUND",1:"")
S ABMBLK19=ABMBLK19_" "_$S($P(ABM("B9"),U,15)="Y":"HOSPICE EMP. PROV",1:"")
S ABMBLK19=ABMBLK19_" "_$P(ABM("B10"),U,1)
S $P(ABMF(29),"^",1)=$E(ABMBLK19,1,48)
K ABMBLK19
LAB I '$P(ABM("B8"),U) S $P(ABMF(29),U,3)="X"
E S $P(ABMF(29),U,2)="X",$P(ABMF(29),U,4)=$P(ABM("B8"),U)
I $P(ABM("B7"),U,4)="Y" S ABMF("23")="SIGNATURE ON FILE"_U_DT
I $P(ABM("B7"),U,5)="Y" S $P(ABMF("23"),U,3)="SIGNATURE ON FILE"
;
I $P(ABMP("B0"),U,7)'=111,($P(ABMP("B0"),U,7)'=999),($P(ABMP("B0"),U,7)'=141) G XIT
;
; Hosp Info
ADMIT I $P(ABM("B6"),U,1)]"" S $P(ABMF(27),U,3)=$P(ABM("B6"),U,1)
DISCH I $P(ABM("B6"),U,3)]"" S $P(ABMF(27),U,4)=$P(ABM("B6"),U,3)
;
XIT K ABM,ABMV,ABMX
Q
ABMDF14B ; IHS/ASDST/DMJ - Set HCFA1500 Print Array PART 2 ;
+1 ;;2.6;IHS 3P BILLING SYSTEM;;NOV 12, 2009
+2 ;Original;TMD;
+3 ;
+4 ; IHS/ASDS/SDH - 04/10/01 - V2.4 Patch 9 - NOIS NFA-0600-180065
+5 ; Allow FL 18 to display when inpatient with more than one
+6 ; provider that was split for billing purposes.
+7 ;
+8 ; IHS/SD/SDR - v2.5 p3 - 2/26/2003 - NDA-0402-180192
+9 ; Added new block 19 stuff
+10 ;
+11 ; IHS/SD/SDR - v2.5 p8 - task 6
+12 ; origin zip when ambulance
+13 ;
+14 ; IHS/SD/SDR - v2.5 p9 - IM19291
+15 ; Added Supervising Provider to block 19
+16 ;
+17 ; IHS/SD/SDR - v2.5 p10 - IM20462
+18 ; Fix check for outside lab charges
+19 ;
+20 ; IHS/SD/SDR - v2.5 p10 - IM21468
+21 ; Made change so it won't error if ref lab CLIA is missing
+22 ; and there are outside lab charges
+23 ;
+24 ; *********************************************************************
+25 ;
BNODES SET ABM("B5")=$GET(^ABMDBILL(DUZ(2),ABMP("BDFN"),5))
SET ABM("B6")=$GET(^(6))
SET ABM("B7")=$GET(^(7))
SET ABM("B8")=$GET(^(8))
SET ABM("B9")=$GET(^(9))
SET ABM("B10")=$GET(^(10))
+1 IF $PIECE(ABM("B5"),U,12)]""
SET $PIECE(ABMF(33),U,3)=$PIECE(ABM("B5"),U,12)
+2 IF $PIECE($GET(^DIC(40.7,ABMP("CLN"),0)),U)="AMBULANCE"
SET $PIECE(ABMF(33),U,3)=$EXTRACT($PIECE($GET(^ABMDBILL(DUZ(2),ABMP("BDFN"),12)),U,6),1,5)
+3 IF +$ORDER(^ABMDBILL(DUZ(2),ABMP("BDFN"),37,0))'=0
Begin DoDot:1
+4 IF +$PIECE($GET(^ABMDBILL(DUZ(2),ABMP("BDFN"),8)),U)'=0
IF ($PIECE($GET(^ABMDBILL(DUZ(2),ABMP("BDFN"),9)),U,23)'="")
SET $PIECE(ABMF(33),U,3)=$PIECE($GET(^ABMRLABS($PIECE($GET(^ABMDBILL(DUZ(2),ABMP("BDFN"),9)),U,23),0)),U,2)
+5 ;default in-house
IF +$PIECE($GET(^ABMDBILL(DUZ(2),ABMP("BDFN"),8)),U)=0
SET $PIECE(ABMF(33),U,3)=$PIECE($GET(^ABMDBILL(DUZ(2),ABMP("BDFN"),9)),U,22)
End DoDot:1
+6 ;no labs but CLIA wanted on form
+7 IF +$ORDER(^ABMDBILL(DUZ(2),ABMP("BDFN"),37,0))=0
Begin DoDot:1
+8 IF $PIECE($GET(^ABMNINS(DUZ(2),ABMP("INS"),1,ABMP("VTYP"),1)),U,6)="R"
Begin DoDot:2
+9 SET $PIECE(ABMF(33),U,3)=$PIECE($GET(^ABMRLABS($PIECE($GET(^ABMDBILL(DUZ(2),ABMP("BDFN"),9)),U,23),0)),U,2)
End DoDot:2
+10 IF $PIECE($GET(^ABMNINS(DUZ(2),ABMP("INS"),1,ABMP("VTYP"),1)),U,6)="I"
Begin DoDot:2
+11 SET $PIECE(ABMF(33),U,3)=$PIECE($GET(^ABMDBILL(DUZ(2),ABMP("BDFN"),9)),U,22)
End DoDot:2
End DoDot:1
EMPL IF $PIECE(ABM("B9"),U)]""
SET $PIECE(ABMF(13),U,2)="X"
+1 IF '$TEST
SET $PIECE(ABMF(13),U,3)="X"
GOTO ACCD
+2 IF $PIECE(ABM("B9"),U,3)]""
SET $PIECE(ABMF(25),U,3)=$PIECE(ABM("B9"),U,3)
+3 IF $PIECE(ABM("B9"),U,4)]""
SET $PIECE(ABMF(25),U,4)=$PIECE(ABM("B9"),U,4)
+4 ;
ACCD SET $PIECE(ABMF(15),U,$SELECT('$PIECE(ABM("B8"),U,3):5,"12"[$PIECE(ABM("B8"),U,3):4,1:5))="X"
+1 SET $PIECE(ABMF(17),U,$SELECT("12"[$PIECE(ABM("B8"),U,3):3,1:2))="X"
FSYM SET $PIECE(ABMF(25),U)=$PIECE(ABM("B8"),U,6)
SIML SET $PIECE(ABMF(25),U,2)=$PIECE(ABM("B8"),U,9)
REFR SET $PIECE(ABMF(27),U)=$PIECE(ABM("B8"),U,8)
SET $PIECE(ABMF(27),U,2)=$PIECE(ABM("B8"),U,11)
BLK19 ;
+1 ;date last seen
SET ABMBLK19=$$SDT^ABMDUTL($PIECE(ABM("B9"),U,11))
+2 ;supervising prov UPIN
SET ABMBLK19=ABMBLK19_" "_$PIECE(ABM("B9"),U,24)
+3 ;supervising prov
SET ABMBLK19=ABMBLK19_" "_$PIECE(ABM("B9"),U,12)
+4 ;last x-ray
SET ABMBLK19=ABMBLK19_" "_$$SDT^ABMDUTL($PIECE(ABM("B9"),U,13))
+5 SET ABMBLK19=ABMBLK19_" "_$SELECT($PIECE(ABM("B9"),U,14)="Y":"HOMEBOUND",1:"")
+6 SET ABMBLK19=ABMBLK19_" "_$SELECT($PIECE(ABM("B9"),U,15)="Y":"HOSPICE EMP. PROV",1:"")
+7 SET ABMBLK19=ABMBLK19_" "_$PIECE(ABM("B10"),U,1)
+8 SET $PIECE(ABMF(29),"^",1)=$EXTRACT(ABMBLK19,1,48)
+9 KILL ABMBLK19
LAB IF '$PIECE(ABM("B8"),U)
SET $PIECE(ABMF(29),U,3)="X"
+1 IF '$TEST
SET $PIECE(ABMF(29),U,2)="X"
SET $PIECE(ABMF(29),U,4)=$PIECE(ABM("B8"),U)
+2 IF $PIECE(ABM("B7"),U,4)="Y"
SET ABMF("23")="SIGNATURE ON FILE"_U_DT
+3 IF $PIECE(ABM("B7"),U,5)="Y"
SET $PIECE(ABMF("23"),U,3)="SIGNATURE ON FILE"
+4 ;
+5 IF $PIECE(ABMP("B0"),U,7)'=111
IF ($PIECE(ABMP("B0"),U,7)'=999)
IF ($PIECE(ABMP("B0"),U,7)'=141)
GOTO XIT
+6 ;
+7 ; Hosp Info
ADMIT IF $PIECE(ABM("B6"),U,1)]""
SET $PIECE(ABMF(27),U,3)=$PIECE(ABM("B6"),U,1)
DISCH IF $PIECE(ABM("B6"),U,3)]""
SET $PIECE(ABMF(27),U,4)=$PIECE(ABM("B6"),U,3)
+1 ;
XIT KILL ABM,ABMV,ABMX
+1 QUIT
