ABMDF27B ; IHS/ASDST/DMJ - Set HCFA1500 (08/05) Print Array PART 2 ;
;;2.6;IHS 3P BILLING SYSTEM;**4,10,11,21**;NOV 12, 2009;Build 379
; IHS/SD/SDR - abm*2.6*4 - HEAT12115 - Moved box 23 over 2 to allow for "extra" dx codes
;IHS/SD/SDR - 2.6*21 - VMBP - Updated p11 changes to include Serena ref#s
;
; *********************************************************************
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))
;start old code abm*2.6*4 HEAT12115
;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
;end old code start new code HEAT12115
I $P(ABM("B5"),U,12)]"" S $P(ABMF(33),U,5)=$P(ABM("B5"),U,12)
I $P($G(^DIC(40.7,ABMP("CLN"),0)),U)="AMBULANCE" S $P(ABMF(33),U,5)=$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,5)=$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,5)=$P($G(^ABMDBILL(DUZ(2),ABMP("BDFN"),9)),U,22) ;default in-house
;end new code HEAT12115
;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)
;
;I (ABMP("ITYPE")="V")&($P($G(^ABMDPARM(ABMP("LDFN"),1,3)),U,12)'="") S $P(ABMF(33),U,5)=$P($G(^ABMDPARM(ABMP("LDFN"),1,3)),U,12) ;abm*2.6*11 VMBP RQMT_108 ;abm*2.6*14 VMBP change
I ((ABMP("ITYPE")="V")!($$GET1^DIQ(9999999.18,ABMP("INS"),".01","E")["VMBP"))&($P($G(^ABMDPARM(ABMP("LDFN"),1,3)),U,12)'="") S $P(ABMF(33),U,5)=$P($G(^ABMDPARM(ABMP("LDFN"),1,3)),U,12) ;abm*2.6*11 VMBP RQMT_108 ;abm*2.6*14 VMBP change
;
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)
S $P(ABMF(26),U)=$P(ABM("B8"),U,18)_$P(ABM("B8"),U,11) ;ref QUALIFIER/ID
S $P(ABMF(27),U,2)=$P(ABM("B8"),U,17) ;ref NPI
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),U)=$E(ABMBLK19,1,48)
I (ABMP("ITYPE")="V")&($P($G(^ABMDPARM(ABMP("LDFN"),1,3)),U,13)'="") S $P(ABMF(29),U)=$P($G(^ABMDPARM(ABMP("LDFN"),1,3)),U,13) ;abm*2.6*11 VMBP VMBP RQMT_108
I ((ABMP("ITYPE")="V")!($$GET1^DIQ(9999999.18,ABMP("INS"),".01","E")["VMBP"))&($P($G(^ABMDPARM(ABMP("LDFN"),1,3)),U,13)'="") S $P(ABMF(29),U)=$P($G(^ABMDPARM(ABMP("LDFN"),1,3)),U,13) ;abm*2.6*11 VMBP RQMT_108 ;abm*2.6*14 VMBP
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 ;abm*2.6*10 HEAT78335
;I $P(ABM("B7"),U,4)="Y" S ABMF("23")="SIGNATURE ON FILE"_U_$P($G(^ABMDBILL(DUZ(2),ABMP("BDFN"),7)),U,12) ;abm*2.6*10 HEAT78335 ;abm*2.6*11 IHS/SD/AML 3/31/2011 HEAT30524- ALLOW ROI DATE TO PRINT
I $P(ABM("B7"),U,4)="Y" S ABMF("23")="SIGNATURE ON FILE"_U_$P(ABM("B7"),U,11) ;abm*2.6*11 IHS/SD/AML 3/31/2011 HEAT30524- ALLOW ROI DATE TO PRINT
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
ABMDF27B ; IHS/ASDST/DMJ - Set HCFA1500 (08/05) Print Array PART 2 ;
+1 ;;2.6;IHS 3P BILLING SYSTEM;**4,10,11,21**;NOV 12, 2009;Build 379
+2 ; IHS/SD/SDR - abm*2.6*4 - HEAT12115 - Moved box 23 over 2 to allow for "extra" dx codes
+3 ;IHS/SD/SDR - 2.6*21 - VMBP - Updated p11 changes to include Serena ref#s
+4 ;
+5 ; *********************************************************************
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 ;start old code abm*2.6*4 HEAT12115
+2 ;I $P(ABM("B5"),U,12)]"" S $P(ABMF(33),U,3)=$P(ABM("B5"),U,12)
+3 ;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)
+4 ;I +$O(^ABMDBILL(DUZ(2),ABMP("BDFN"),37,0))'=0 D
+5 ;.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)
+6 ;.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
+7 ;end old code start new code HEAT12115
+8 IF $PIECE(ABM("B5"),U,12)]""
SET $PIECE(ABMF(33),U,5)=$PIECE(ABM("B5"),U,12)
+9 IF $PIECE($GET(^DIC(40.7,ABMP("CLN"),0)),U)="AMBULANCE"
SET $PIECE(ABMF(33),U,5)=$EXTRACT($PIECE($GET(^ABMDBILL(DUZ(2),ABMP("BDFN"),12)),U,6),1,5)
+10 IF +$ORDER(^ABMDBILL(DUZ(2),ABMP("BDFN"),37,0))'=0
Begin DoDot:1
+11 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,5)=$PIECE($GET(^ABMRLABS($PIECE($GET(^ABMDBILL(DUZ(2),ABMP("BDFN"),9)),U,23),0)),U,2)
+12 ;default in-house
IF +$PIECE($GET(^ABMDBILL(DUZ(2),ABMP("BDFN"),8)),U)=0
SET $PIECE(ABMF(33),U,5)=$PIECE($GET(^ABMDBILL(DUZ(2),ABMP("BDFN"),9)),U,22)
End DoDot:1
+13 ;end new code HEAT12115
+14 ;no labs but CLIA wanted on form
+15 IF +$ORDER(^ABMDBILL(DUZ(2),ABMP("BDFN"),37,0))=0
Begin DoDot:1
+16 IF $PIECE($GET(^ABMNINS(DUZ(2),ABMP("INS"),1,ABMP("VTYP"),1)),U,6)="R"
Begin DoDot:2
+17 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
+18 IF $PIECE($GET(^ABMNINS(DUZ(2),ABMP("INS"),1,ABMP("VTYP"),1)),U,6)="I"
Begin DoDot:2
+19 SET $PIECE(ABMF(33),U,3)=$PIECE($GET(^ABMDBILL(DUZ(2),ABMP("BDFN"),9)),U,22)
End DoDot:2
End DoDot:1
+20 ;
+21 ;I (ABMP("ITYPE")="V")&($P($G(^ABMDPARM(ABMP("LDFN"),1,3)),U,12)'="") S $P(ABMF(33),U,5)=$P($G(^ABMDPARM(ABMP("LDFN"),1,3)),U,12) ;abm*2.6*11 VMBP RQMT_108 ;abm*2.6*14 VMBP change
+22 ;abm*2.6*11 VMBP RQMT_108 ;abm*2.6*14 VMBP change
IF ((ABMP("ITYPE")="V")!($$GET1^DIQ(9999999.18,ABMP("INS"),".01","E")["VMBP"))&($PIECE($GET(^ABMDPARM(ABMP("LDFN"),1,3)),U,12)'="")
SET $PIECE(ABMF(33),U,5)=$PIECE($GET(^ABMDPARM(ABMP("LDFN"),1,3)),U,12)
+23 ;
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)
+1 ;ref QUALIFIER/ID
SET $PIECE(ABMF(26),U)=$PIECE(ABM("B8"),U,18)_$PIECE(ABM("B8"),U,11)
+2 ;ref NPI
SET $PIECE(ABMF(27),U,2)=$PIECE(ABM("B8"),U,17)
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),U)=$EXTRACT(ABMBLK19,1,48)
+9 ;abm*2.6*11 VMBP VMBP RQMT_108
IF (ABMP("ITYPE")="V")&($PIECE($GET(^ABMDPARM(ABMP("LDFN"),1,3)),U,13)'="")
SET $PIECE(ABMF(29),U)=$PIECE($GET(^ABMDPARM(ABMP("LDFN"),1,3)),U,13)
+10 ;abm*2.6*11 VMBP RQMT_108 ;abm*2.6*14 VMBP
IF ((ABMP("ITYPE")="V")!($$GET1^DIQ(9999999.18,ABMP("INS"),".01","E")["VMBP"))&($PIECE($GET(^ABMDPARM(ABMP("LDFN"),1,3)),U,13)'="")
SET $PIECE(ABMF(29),U)=$PIECE($GET(^ABMDPARM(ABMP("LDFN"),1,3)),U,13)
+11 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 ;I $P(ABM("B7"),U,4)="Y" S ABMF("23")="SIGNATURE ON FILE"_U_DT ;abm*2.6*10 HEAT78335
+3 ;I $P(ABM("B7"),U,4)="Y" S ABMF("23")="SIGNATURE ON FILE"_U_$P($G(^ABMDBILL(DUZ(2),ABMP("BDFN"),7)),U,12) ;abm*2.6*10 HEAT78335 ;abm*2.6*11 IHS/SD/AML 3/31/2011 HEAT30524- ALLOW ROI DATE TO PRINT
+4 ;abm*2.6*11 IHS/SD/AML 3/31/2011 HEAT30524- ALLOW ROI DATE TO PRINT
IF $PIECE(ABM("B7"),U,4)="Y"
SET ABMF("23")="SIGNATURE ON FILE"_U_$PIECE(ABM("B7"),U,11)
+5 IF $PIECE(ABM("B7"),U,5)="Y"
SET $PIECE(ABMF("23"),U,3)="SIGNATURE ON FILE"
+6 ;
+7 IF $PIECE(ABMP("B0"),U,7)'=111
IF ($PIECE(ABMP("B0"),U,7)'=999)
IF ($PIECE(ABMP("B0"),U,7)'=141)
GOTO XIT
+8 ;
+9 ; 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
