Routine: ABMDF3B

ABMDF3B ; 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

 ;    Ambulance origin zip

 ; IHS/SD/SDR - v2.5 p9 - IM19291

 ;    Added supervising provider UPIN to block 19

 ; IHS/SD/SDR - v2.5 p10 - IM21068

 ;   Added CLIA number to code

 ; IHS/SD/SDR - v2.5 p10 - IM21468

 ;   Made change so it won't error if there is an outside lab

 ;   charge and the ref lab CLIA is missing

 ; *********************************************************************

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),U)=$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

ABMDF3B   ; 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      ;    Ambulance origin zip

 +13      ;

 +14      ; IHS/SD/SDR - v2.5 p9 - IM19291

 +15      ;    Added supervising provider UPIN to block 19

 +16      ;

 +17      ; IHS/SD/SDR - v2.5 p10 - IM21068

 +18      ;   Added CLIA number to code

 +19      ;

 +20      ; IHS/SD/SDR - v2.5 p10 - IM21468

 +21      ;   Made change so it won't error if there is an outside lab

 +22      ;   charge and the ref lab CLIA is missing

 +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),U)=$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

ABMDF3B.m