Routine: ABMDF2A

ABMDF2A ; IHS/SD/SDR - Set HCFA-1500 Print Array ;

 ;;2.6;IHS 3P BILLING SYSTEM;**10,21**;NOV 12, 2009;Build 379

 ;Original;TMD;

 ;IHS/SD/SDR - 2.6*21 - HEAT135805 - Added code to define ABMP("VTYP") to stop <UNDEF>SITE+26^ABMDE1X1.

ENT K ABMF,ABM,ABMU,ABMR,ABMS

 S ABMP("B0")=^ABMDBILL(DUZ(2),ABMP("BDFN"),0),ABMP("INS")=$P(ABMP("B0"),U,8) Q:'ABMP("INS")

 S ABMP("PDFN")=$P(ABMP("B0"),U,5),ABMP("LDFN")=$P(ABMP("B0"),U,3) Q:'ABMP("PDFN")!('+ABMP("LDFN"))

 S ABMP("VDT")=$P(^ABMDBILL(DUZ(2),ABMP("BDFN"),7),U)

 S ABMP("VTYP")=$P(ABMP("B0"),U,7)  ;Visit Type  ;abm*2.6*21 IHS/SD/SDR HEAT135805

 S ABMP("BTYP")=$P(ABMP("B0"),"^",12)

 S (ABMV("X1"),ABMV("X2"),ABMV("X3"))=""

 D PAT^ABMDE1X,REMPL^ABMDE1X1,LOC^ABMDE1X1 K ABME

LOC S $P(ABMF(52),U,2)=$P($P(ABMV("X1"),U),";",2),$P(ABMF(29),U)=$P($P(ABMV("X1"),U),";",2)_"    (see Block 31)"

 I $P(ABMV("X1"),U,2)]"" S $P(ABMF(53),U,3)=$P(ABMV("X1"),U,2),$P(ABMF(54),U,2)=$P(ABMV("X1"),U,3),ABMF(55)=$P(ABMV("X1"),U,4)

 E  S $P(ABMF(53),U,3)=$P(ABMV("X1"),U,3),$P(ABMF(54),U,2)=$P(ABMV("X1"),U,4),$P(ABMF(55),U)=$P(ABMV("X1"),U,5)

BNUM S $P(ABMF(56),U)=$P(ABMP("B0"),U)_$S($P($G(^ABMDPARM(DUZ(2),1,2)),U,4)]"":"-"_$P(^(2),U,4),1:"") I $P($G(^(3)),U,3),$P($G(^AUPNPAT(ABMP("PDFN"),41,ABMP("LDFN"),0)),U,2) S $P(ABMF(56),U)=$P(ABMF(56),U)_" "_$P(^(0),U,2)

INSNUM S ABM("I")=$P($G(^ABMNINS(DUZ(2),ABMP("INS"),1,$P(ABMP("B0"),U,7),0)),U,6)

 S ABM("INUM")=$P($G(^ABMNINS(DUZ(2),ABMP("INS"),1,$S(ABM("I")="Y":999,1:$P(ABMP("B0"),U,7)),0)),U,8)

 S:ABM("INUM")="" ABM("INUM")=$P($G(^AUTNINS(ABMP("INS"),15,ABMP("LDFN"),0)),U,2)

 S $P(ABMF(56),U,3)=ABM("INUM")

 ;I $P($G(^AUTNINS(ABMP("INS"),2)),U)="R" S $P(ABMF(56),U,3)=$P(^AUTTLOC(ABMP("LDFN"),0),U,19)  ;abm*2.6*10 HEAT73780

 I $$GET1^DIQ(9999999.181,$$GET1^DIQ(9999999.18,ABMP("INS"),".211","I"),1,"I")="R" S $P(ABMF(56),U,3)=$P(^AUTTLOC(ABMP("LDFN"),0),U,19)  ;abm*2.6*10 HEAT73780

 ;S ABM("ITYP")=$P($G(^AUTNINS(ABMP("INS"),2)),U),ABM("ITYP")=$S(ABM("ITYP")="R":1,ABM("ITYP")="D":2,ABM("ITYP")="C":3,1:6),$P(ABMF(1),U,ABM("ITYP"))="X"  ;abm*2.6*10 HEAT73780

 S ABM("ITYP")=$$GET1^DIQ(9999999.181,$$GET1^DIQ(9999999.18,ABMP("INS"),".211","I"),1,"I"),ABM("ITYP")=$S(ABM("ITYP")="R":1,ABM("ITYP")="D":2,ABM("ITYP")="C":3,1:6),$P(ABMF(1),U,ABM("ITYP"))="X"  ;abm*2.6*10 HEAT73780

TAX S $P(ABMF(56),U,2)=$P(ABMV("X1"),U,6)

PNODES S ABM("P0")=^DPT(ABMP("PDFN"),0)

NAME S ABMF(4)=$P(ABM("P0"),U)

ADDRESS S $P(ABMF(7),U)=$P(ABMV("X2"),U,3)

 S $P(ABMF(8),U)=$P(ABMV("X2"),U,4)

 S $P(ABMF(10),U)=$P(ABMV("X2"),U,5)

DOB S $P(ABMF(4),U,2)=$P($P(ABMV("X2"),U,6),"-")

 S $P(ABMF(4),U,3)=$P($P(ABMV("X2"),U,6),"-",2)

 S $P(ABMF(4),U,4)=$P($P(ABMV("X2"),U,6),"-",3)

SEX I $P(ABMV("X2"),U,2)="M" S $P(ABMF(6),U,2)="X"

 E  S $P(ABMF(6),U,3)="X"

 K ABM("P0")

XIT K ABM,ABMX,ABMV

ABMDF2A   ; IHS/SD/SDR - Set HCFA-1500 Print Array ;

 +1       ;;2.6;IHS 3P BILLING SYSTEM;**10,21**;NOV 12, 2009;Build 379

 +2       ;Original;TMD;

 +3       ;IHS/SD/SDR - 2.6*21 - HEAT135805 - Added code to define ABMP("VTYP") to stop <UNDEF>SITE+26^ABMDE1X1.

 +4       ;

ENT        KILL ABMF,ABM,ABMU,ABMR,ABMS

 +1        SET ABMP("B0")=^ABMDBILL(DUZ(2),ABMP("BDFN"),0)

           SET ABMP("INS")=$PIECE(ABMP("B0"),U,8)

           IF 'ABMP("INS")

               QUIT

 +2        SET ABMP("PDFN")=$PIECE(ABMP("B0"),U,5)

           SET ABMP("LDFN")=$PIECE(ABMP("B0"),U,3)

           IF 'ABMP("PDFN")!('+ABMP("LDFN"))

               QUIT

 +3        SET ABMP("VDT")=$PIECE(^ABMDBILL(DUZ(2),ABMP("BDFN"),7),U)

 +4       ;Visit Type  ;abm*2.6*21 IHS/SD/SDR HEAT135805

           SET ABMP("VTYP")=$PIECE(ABMP("B0"),U,7)

 +5        SET ABMP("BTYP")=$PIECE(ABMP("B0"),"^",12)

 +6        SET (ABMV("X1"),ABMV("X2"),ABMV("X3"))=""

 +7        DO PAT^ABMDE1X

           DO REMPL^ABMDE1X1

           DO LOC^ABMDE1X1

           KILL ABME

 +8       ;

LOC        SET $PIECE(ABMF(52),U,2)=$PIECE($PIECE(ABMV("X1"),U),";",2)

           SET $PIECE(ABMF(29),U)=$PIECE($PIECE(ABMV("X1"),U),";",2)_"    (see Block 31)"

 +1        IF $PIECE(ABMV("X1"),U,2)]""

               SET $PIECE(ABMF(53),U,3)=$PIECE(ABMV("X1"),U,2)

               SET $PIECE(ABMF(54),U,2)=$PIECE(ABMV("X1"),U,3)

               SET ABMF(55)=$PIECE(ABMV("X1"),U,4)

 +2       IF '$TEST

               SET $PIECE(ABMF(53),U,3)=$PIECE(ABMV("X1"),U,3)

               SET $PIECE(ABMF(54),U,2)=$PIECE(ABMV("X1"),U,4)

               SET $PIECE(ABMF(55),U)=$PIECE(ABMV("X1"),U,5)

BNUM       SET $PIECE(ABMF(56),U)=$PIECE(ABMP("B0"),U)_$SELECT($PIECE($GET(^ABMDPARM(DUZ(2),1,2)),U,4)]"":"-"_$PIECE(^(2),U,4),1:"")

           IF $PIECE($GET(^(3)),U,3)

               IF $PIECE($GET(^AUPNPAT(ABMP("PDFN"),41,ABMP("LDFN"),0)),U,2)

                   SET $PIECE(ABMF(56),U)=$PIECE(ABMF(56),U)_" "_$PIECE(^(0),U,2)

INSNUM     SET ABM("I")=$PIECE($GET(^ABMNINS(DUZ(2),ABMP("INS"),1,$PIECE(ABMP("B0"),U,7),0)),U,6)

 +1        SET ABM("INUM")=$PIECE($GET(^ABMNINS(DUZ(2),ABMP("INS"),1,$SELECT(ABM("I")="Y":999,1:$PIECE(ABMP("B0"),U,7)),0)),U,8)

 +2        IF ABM("INUM")=""

               SET ABM("INUM")=$PIECE($GET(^AUTNINS(ABMP("INS"),15,ABMP("LDFN"),0)),U,2)

 +3        SET $PIECE(ABMF(56),U,3)=ABM("INUM")

 +4       ;I $P($G(^AUTNINS(ABMP("INS"),2)),U)="R" S $P(ABMF(56),U,3)=$P(^AUTTLOC(ABMP("LDFN"),0),U,19)  ;abm*2.6*10 HEAT73780

 +5       ;abm*2.6*10 HEAT73780

           IF $$GET1^DIQ(9999999.181,$$GET1^DIQ(9999999.18,ABMP("INS"),".211","I"),1,"I")="R"

               SET $PIECE(ABMF(56),U,3)=$PIECE(^AUTTLOC(ABMP("LDFN"),0),U,19)

 +6       ;S ABM("ITYP")=$P($G(^AUTNINS(ABMP("INS"),2)),U),ABM("ITYP")=$S(ABM("ITYP")="R":1,ABM("ITYP")="D":2,ABM("ITYP")="C":3,1:6),$P(ABMF(1),U,ABM("ITYP"))="X"  ;abm*2.6*10 HEAT73780

 +7       ;abm*2.6*10 HEAT73780

           SET ABM("ITYP")=$$GET1^DIQ(9999999.181,$$GET1^DIQ(9999999.18,ABMP("INS"),".211","I"),1,"I")

           SET ABM("ITYP")=$SELECT(ABM("ITYP")="R":1,ABM("ITYP")="D":2,ABM("ITYP")="C":3,1:6)

           SET $PIECE(ABMF(1),U,ABM("ITYP"))="X"

TAX        SET $PIECE(ABMF(56),U,2)=$PIECE(ABMV("X1"),U,6)

 +1       ;

PNODES     SET ABM("P0")=^DPT(ABMP("PDFN"),0)

NAME       SET ABMF(4)=$PIECE(ABM("P0"),U)

ADDRESS    SET $PIECE(ABMF(7),U)=$PIECE(ABMV("X2"),U,3)

 +1        SET $PIECE(ABMF(8),U)=$PIECE(ABMV("X2"),U,4)

 +2        SET $PIECE(ABMF(10),U)=$PIECE(ABMV("X2"),U,5)

 +3       ;

DOB        SET $PIECE(ABMF(4),U,2)=$PIECE($PIECE(ABMV("X2"),U,6),"-")

 +1        SET $PIECE(ABMF(4),U,3)=$PIECE($PIECE(ABMV("X2"),U,6),"-",2)

 +2        SET $PIECE(ABMF(4),U,4)=$PIECE($PIECE(ABMV("X2"),U,6),"-",3)

SEX        IF $PIECE(ABMV("X2"),U,2)="M"

               SET $PIECE(ABMF(6),U,2)="X"

 +1       IF '$TEST

               SET $PIECE(ABMF(6),U,3)="X"

 +2        KILL ABM("P0")

 +3       ;

XIT        KILL ABM,ABMX,ABMV

 +1        QUIT

ABMDF2A.m